# $Id$
$VERSION{''.__FILE__} = '$Revision$';
#
# >>Title:: Table Processing Library
#
# >>Copyright::
# Copyright (c) 1992-1996, Ian Clatworthy (ianc@mincom.com).
# You may distribute under the terms specified in the LICENSE file.
#
# >>History::
# -----------------------------------------------------------------------
# Date Who Change
# 29-Feb-96 ianc SDF 2.000
# -----------------------------------------------------------------------
#
# >>Purpose::
# This library provides routines for reading, processing and
# writing {{FMT:TBL}} files.
#
# >>Description::
# Tables are stored in arrays.
# The first element in the array is the {{input format specification}}.
# Remaining elements are data, one record per element.
#
# The routines are often used together as follows:
#
# !block verbatim
# # Read in the table (using the default format)
# ($ok, @table) = &TableFetch($table_name);
#
# # Process the data records
# $format = shift @table;
# @flds = &TableFields($format);
# for $rec (@table) {
# %value = &TableRecSplit(*flds, $rec);
# $value{'Age'}++; # say ...
# $rec = &TableRecJoin(*flds, %value);
# }
# unshift(@table, $format);
#
# # Ouptut the new table (using the default flags)
# &TablePrint(STDOUT, *table);
# !endblock
#
# Note: Multi-line fields are stored with a newline as the first character
# so be sure to allow for this when processing them.
#
# >>Limitations::
# When validating field-names, the line number and context should be
# set to something meaningful. To achieve this, the line number of
# the format string in the file (if it's in the file, that is!) needs
# to be saved as part of the table.
#
# >>Resources::
#
# >>Implementation::
#
require "sdf/misc.pl";
######### Constants #########
# Tab size used in expanding fixed-width TBL data
$_TABLE_TAB_SIZE = 8;
#
# >>Description::
# {{Y:TABLE_MODEL_MODEL}} is the model for model files.
#
@TABLE_MODEL_MODEL = &TableParse (
'Field,Category,Rule,AuxRule',
'Field,key,<\w+>',
'Category,mandatory,<key|partkey|mandatory|expected|optional|routine>',
'Rule,optional',
'AuxRule,optional',
'_ENTRY_,routine,-,&_TableValRules("ENTRY")',
'_RECORD_,routine,-,&_TableValRules("RECORD")',
'_EXIT_,routine ,-,&_TableValRules("EXIT")',
);
# These are the tables of custom read/write routines indexed on type
%_TABLE_CUSTOM_READ = (
);
%_TABLE_CUSTOM_WRITE = (
);
######### Variables #########
# Counter used to ensure {{Y:TableFetch}} is re-entrant
$_table_cnt = 0;
# Counters used by TableValRules()
$_table_keys = 0;
$_table_partkeys = 0;
######### Routines #########
#
# >>Description::
# {{Y:TableFetch}} reads {{file}} as a table defined in {{TBL}} format.
# If the first data line of the file is not an input format specification,
# it can be specified using {{format}}.
# {{success}} is 1 if the file is opened successfully.
# {{records}} is an array of records,
# the first of which is the format specification.
#
sub TableFetch {
local($file, $format) = @_;
local($success, @records);
local($strm);
# Open the file (ensuring stream_id is unique)
$strm = sprintf("tbl_s%d", $_table_cnt++);
open($strm, $file) || return (0);
# Input the records
@records = &TableParse($format, <$strm>);
# close the output
close($strm);
# return results
return (1, @records);
}
#
# >>Description::
# {{Y:TableParse}} converts a list of strings into a table.
#
sub TableParse {
local(@strings) = @_;
local(@records);
# Read in the data
&_TableReadText(*strings, *records);
# Return result
return @records;
}
#
# >>Description::
# {{Y:TableParseUsingParams}} converts a list of strings into a table
# using the nominated parameters. No parameters are supported yet.
#
sub TableParseUsingParams {
local($ref_to_strings, %params) = @_;
local(@records);
local(@strings);
# Read in the data
@strings = @$ref_to_strings;
&_TableReadText(*strings, *records, %params);
#printf STDERR "records are:\n%s<\n", join("<\n", @records);
# Return result
return @records;
}
#
# >>Description::
# {{Y:TableValidate}} validates {{@table}} against {{@rules}}.
#
sub TableValidate {
local(*table, *rules) = @_;
# local();
local($i);
local(@partkeys, $rulesep, @ruleflds, %rule);
local($fld, %fldcat, %fldrule, %fldauxrule);
local(@flds, %keylist);
# Build the validation lookup tables
@partkeys = ();
@ruleflds = &TableFields($rules[0]);
for ($i = 1; $i <= $#rules; $i++) {
%rule = &TableRecSplit(*ruleflds, $rules[$i]);
$fld = $rule{"Field"};
$fldcat{$fld} = $rule{"Category"};
push(@partkeys, $fld) if $fldcat{$fld} eq 'partkey';
$fldrule{$fld} = $rule{"Rule"};
$fldrule{$fld} =~ s#^\<(.*)\>$#/^($1)\$/#;
$fldauxrule{$fld} = $rule{"AuxRule"};
$fldauxrule{$fld} =~ s#^\<(.*)\>$#/^($1)\$/#;
}
# Check the data
@flds = &TableFieldsCheck($table[0], "error", %fldcat);
&MiscDoAction($fldauxrule{"_ENTRY_"}, "_ENTRY_ routine");
%keylist = ();
for ($i = 1; $i <= $#table; $i++) {
next if $table[$i] =~ /^!/;
&_TableRecordCheck($table[$i], *flds,
*fldcat, *fldrule, *fldauxrule, *keylist, @partkeys);
}
&MiscDoAction($fldauxrule{"_EXIT_"}, "_EXIT_ routine");
}
#
# >>Description::
# {{Y:TablePrint}} outputs {{@table}} to {{strm}}.
# The {{flags}} supported are outlined below.
#
# !block table
# Flag Description
# TBL format:
# behead column headings are not included at the top of the output
# delimited use delimited format - delimiter is the argument (default is tab)
# !endblock
#
sub TablePrint {
local($strm, *table, %flags) = @_;
# local();
local($format, $i);
# Get the format and output it, unless explicitly asked not to
$format = $table[0];
if ($format eq '' || $format =~ /^\w/) {
&_TableWriteText(*table, $strm, '', %flags);
}
else {
&_TableWriteCustom(*table, $strm, '', %flags);
}
}
#
# >>Description::
# {{Y:TableFormat}} formats {{@table}} using {{flags}} and
# returns a set of strings. See {{Y:TablePrint}} for a list
# of the flags supported.
#
sub TableFormat {
local(*table, %flags) = @_;
local(@strings);
&_TableWriteText(*table, '', *strings, %flags);
# Return results
return @strings;
}
#
# >>Description::
# {{Y:TableFields}} returns the list of fields in {{format}}.
# Behaviour for custom formats is currently undefined.
#
sub TableFields {
local($format) = @_;
local(@fields);
local($sep);
($sep, @fields) = &_TableFormatSplit($format);
return @fields;
}
#
# >>_Description::
# {{Y:_TableFormatSplit}} converts a format string into a separator
# and a list of fields.
#
sub _TableFormatSplit {
local($format) = @_;
local($sep, @fields);
local($sep_regexp);
# Trim leading whitespace
$format =~ s/^\s+//;
# find the field separator
($sep) = $format =~ /(\W)/;
# for custom formats, handling is currently undecided
if ($format !~ /^\w/) {
&AppMsg("failure", "TableFields() does not support custom formats yet");
}
# for single column tables, the field is the format
elsif ($sep eq '') {
@fields = ($format);
}
# for fixed-width fields, split on whitespace
elsif ($sep =~ /\s/) {
@fields = split(/\s+/, $format);
}
# for delimited fields, split on the delimiter
else {
# escape any regular expression characters
$sep_regexp = $sep;
$sep_regexp =~ s/(\W)/\\$1/g;
@fields = split(/$sep_regexp/, $format);
}
# return results
return ($sep, @fields);
}
#
# >>_Description::
# {{Y:_TableFormatJoin}} converts a separator and a list of fields
# into a format string.
#
sub _TableFormatJoin {
local($sep, @fields) = @_;
local($format);
# return results
return join($sep, @fields);
}
#
# >>Description::
# {{Y:TableRecSplit}} converts a record into a set of name-value pairs
# using a set of fields (typically returned from {{Y:TableFields}}).
#
sub TableRecSplit {
local(*fields, $record) = @_;
local(%values);
# store the field values into an associative array, after
# splitting the record into an (ordinary) array of field values,
# remembering that the .line pseudo-field always exists
@values{".line", @fields} = split(/\000/, $record, scalar(@fields) + 1);
# return results
%values;
}
#
# >>Description::
# {{Y:TableRecJoin}} converts a set of name-value pairs into a record
# using a set of fields (typically returned from {{Y:TableFields}}).
#
sub TableRecJoin {
local(*fields, %values) = @_;
local($record);
# return results
return join("\000", @values{".line", @fields});
}
#
# >>Description::
# {{Y:TableRecFormat}} formats a set of name-value pairs into a string
# using a format string.
# Behaviour for custom formats is currently undefined.
#
sub TableRecFormat {
local($format, %values) = @_;
local($string);
local(@values, @fields, $sep, $packfmt);
# Get the format-related stuff
@fields = &TableFields($format);
($sep) = $format =~ /(\W)/;
if ($sep =~ /^\s/) {
$packfmt = &_TablePackStr($format);
}
# Get the list of values
@values = @values{@fields};
# return results
return &_TableFmtText(*values, *fields, $sep, $packfmt);
}
#
# >>Description::
# {{Y:TableFilter}} filters a table using an expression.
#
sub TableFilter {
local(*table, $where, *var) = @_;
local(@result);
local($format, @data);
local(@fields);
local($_, %o);
# Split the table into its components
($format, @data) = @table;
@fields = &TableFields($format);
# Filter the data
@result = ($format);
for $_ (@data) {
next if /^\!/;
%o = &TableRecSplit(*fields, $_);
push(@result, $_) if eval $where;
if ($@) {
&AppMsg("warning", "table filter '$where' failed: $@");
}
}
# Return result
return @result;
}
#
# >>Description::
# {{Y:TableDeleteFields}} deletes a list of fields from a table.
#
sub TableDeleteFields {
local(*table, @junk) = @_;
local(@result);
local($format, @data);
local(%junk);
local($sep, @fields, @new_fields);
local($_, %o);
# Split the table into its components
($format, @data) = @table;
($sep, @fields) = &_TableFormatSplit($format);
# Build the new format
grep($junk{$_}++, @junk);
@new_fields = ();
for $_ (@fields) {
push(@new_fields, $_) unless $junk{$_};
}
$format = &_TableFormatJoin($sep, @new_fields);
# Build the new data records
@result = ($format);
for $_ (@data) {
next if /^\!/;
%o = &TableRecSplit(*fields, $_);
push(@result, &TableRecJoin(*new_fields, %o));
}
# Return result
return @result;
}
#
# >>Description::
# {{Y:TableSelectFields}} selects a list of fields from a table.
#
sub TableSelectFields {
local(*table, @new_fields) = @_;
local(@result);
local($format, @data);
local($sep, @fields);
local($_, %o);
# Split the table into its components
($format, @data) = @table;
($sep, @fields) = &_TableFormatSplit($format);
# Build the new format
$format = &_TableFormatJoin($sep, @new_fields);
# Build the new data records
@result = ($format);
for $_ (@data) {
next if /^\!/;
%o = &TableRecSplit(*fields, $_);
push(@result, &TableRecJoin(*new_fields, %o));
}
# Return result
return @result;
}
#
# >>Description::
# {{Y:TableSort}} sorts a table by one of more fields.
# The fields to use are passed in {{by}}.
# If no fields are specified, all fields are used in the order
# they appear in the table.
#
sub TableSort {
local(*table, @by) = @_;
local(@result);
local($format, @data);
local(@fields);
# Split the table into its components
($format, @data) = @table;
@fields = &TableFields($format);
# Sort the data
if (@by && $by[0] ne '-') {
@data = sort _TableSortFn @data;
}
else {
@data = sort @data;
}
# Return result
return ($format, @data);
}
#
# >>_Description::
# {{Y:_TableSortFn}} is used by {{Y:TableSort}} as the sorting function.
# This routine compares two records ($a and $b) and return -1, 0 or 1
# depending on whether the first record is greater than, equal to or
# less than the second record respectively.
# {{@by}}, {{$sep}} and {{@fields}} are dynamically scoped within
# {{Y:TableSort}} and are used by this routine.
#
sub _TableSortFn {
local(%data1, %data2);
%data1 = &TableRecSplit(*fields, $a);
%data2 = &TableRecSplit(*fields, $b);
return join("\000", @data1{@by}) cmp join("\000", @data2{@by});
}
#
# >>Description::
# {{Y:TableIndex}} indexes a table by one of more fields.
# The fields to use are passed in {{by}}.
# If no fields are specified, all fields are used in the order
# they appear in the table. {{index}} is an associative array where:
#
# * the key is the value of the {{by}} fields
# * the data is the index in {{table}} of the matching record
#
# For multiple-field keys, values are separated by a null character (\000).
# The index of the first data record is 1 (the field specification
# record has an index of 0).
# {{@duplicates}} is the list of indices which do not appear in {{%index}}.
# If duplicate keys are found, the highest index is stored in {{%index}}
# for each key.
#
sub TableIndex {
local(*table, *duplicates, @by) = @_;
local(%index);
local(@fields, %values);
local($index);
# Get the fields
@fields = &TableFields($table[0]);
# Use all fields if none specified
@by = @fields unless @by;
# Build the index
@duplicates = ();
for ($index = 1; $index <= $#table; $index++) {
%values = &TableRecSplit(*fields, $table[$index]);
$key = join("\000", @values{@by});
if ($index{$key}) {
push(@duplicates, $index{$key});
}
$index{$key} = $index;
}
# Return result
return %index;
}
#
# >>Description::
# {{Y:TableLookup}} returns the name-value pairs for a given key.
# {{@table}} is the data table. {{%index}} is an index created
# using {{Y:TableIndex}}. An empty associative array is returned
# if no matching record is found.
#
sub TableLookup {
local(*table, *index, @key_values) = @_;
local(%values);
local(@fields);
local($idx);
$idx = $index{join("\000", @key_values)};
if ($idx) {
@fields = &TableFields($table[0]);
%values = &TableRecSplit(*fields, $table[$idx]);
}
# Return result
return %values;
}
#
# >>Description::
# {{Y:TableFieldsCheck}} is a wrapper around {{Y:TableFields}}
# which checks that the fields contains no duplicates. If {{known}} is
# defined, its keys are used to find unknown fields, if any.
# Any errors encountered are output as such using {{Y:AppMsg}}.
# {{msg_type}} can be used to control the message type - {{error}}
# is the default.
#
sub TableFieldsCheck {
local($format, $msg_type, %known) = @_;
local(@flds);
local(%fldcnt, $fld);
local(@unknown);
# The default message type is error
$msg_type = "error" unless $msg_type;
# Check that each field only exists once
%fldcnt = ();
@flds = &TableFields($format);
for $fld (@flds) {
if ($fldcnt{$fld}++) {
&AppMsg($msg_type, "field '$fld' is duplicated");
}
}
# Check for unknown fields
if (%known) {
@unknown = grep(!$known{$_}, @flds);
if (@unknown) {
&AppMsg($msg_type, sprintf("unknown field(s): %s",
join(", ", @unknown)));
}
}
# Return result
return @flds;
}
#
# >>_Description::
# {{Y:_TableValRules}} is used by {{Y:TABLE_MODEL_MODEL}} to check
# table-wide semantics for validation files. The rules are:
#
# * a key of some form is expected
# * a single partkey is an error
#
# Note that this logic is not directly embedded within
# {{Y:TABLE_MODEL_MODEL}} as doing so greatly reduces readability.
#
sub _TableValRules {
local($state) = @_;
# local();
if ($state eq 'ENTRY') {
$_table_keys = 0;
$_table_partkeys = 0;
}
elsif ($state eq 'RECORD') {
$_table_keys++ if $o{"Category"} eq "key";
$_table_partkeys++ if $o{"Category"} eq "partkey";
}
elsif ($state eq 'EXIT') {
if ($_table_partkeys == 0) {
&AppMsg("warning", "no keys defined") unless $_table_keys;
}
elsif ($_table_partkeys == 1) {
&AppMsg("error", "bad key definition - only 1 'partkey' field");
}
}
else {
&AppExit("failure", "unknown state '$state' in _TableValRules()");
}
}
#
# >>_Description::
# {{Y:_TableRecordCheck}} validates a table record ({{record}})
# against the validation rules defined by {{%fldcat}}, {{%fldrule}}
# and {{%fldauxrule}}. These lookup tables are indexed on field name.
# {{@flds}} is the list of fields in the table.
# {{%keylist}} is an associative array which this routine
# needs for key checking. i.e. checking keys in this record are unique
# and storing the key values from this record for checking by subsequent
# calls. Before this routine is called for the first
# record in a table, it should be cleared by the caller. {{@partkeys}}
# is the list of fields in the key.
#
sub _TableRecordCheck {
local($record, *flds, *fldcat, *fldrule, *fldauxrule, *keylist, @partkeys) = @_;
# local();
local(%o, $fld, $fld_cat, $key_value);
local($orig_lineno, $orig_context);
# Setup message parameters
%o = &TableRecSplit(*flds, $record);
$orig_lineno = $app_lineno;
$orig_context = $app_context;
$app_lineno = $o{'.line'};
$app_context = 'line ';
# Check the fields
for $fld (@flds) {
# Get the field value
$_ = $o{$fld};
# Check the category - for performance, we only check the first letter
$fld_cat = $fldcat{$fld};
if ($fld_cat =~ /^k/) { # key
$key_value = "$fld:$_";
&AppMsg("error", "duplicate key on field '$fld', value '$_'") if
$keylist{$key_value}++;
}
elsif ($fld_cat =~ /^m/) { # mandatory
&AppMsg("error", "field '$fld' is missing") if $_ eq '';
}
elsif ($fld_cat =~ /^e/) { # expected
&AppMsg("warning", "field '$fld' is missing") if $_ eq '';
}
# If there is a value, check the rules, if any.
if ($_ ne '') {
# "Rule" validation
unless (&MiscDoAction($fldrule{$fld}, "rule")) {
&AppMsg("error", "bad value '$_' for field '$fld'");
}
else {
# "AuxRule" validation
unless (&MiscDoAction($fldauxrule{$fld}, "rule")) {
&AppMsg("warning", "unexpected value '$_' for field '$fld'");
}
}
}
}
# Check uniqueness of multi-part keys
if (@partkeys) {
$key_value = join("\000", ":", @o{@partkeys});
&AppMsg("error", sprintf("duplicate key on fields (%s)",
join(", ", @partkeys))) if $keylist{$key_value}++;
}
# If a 'record' rule routine is defined, do it.
&MiscDoAction($fldauxrule{"_RECORD_"}, "_RECORD_ routine");
# Restore the original message parameters
$app_lineno = $orig_lineno;
$app_context = $orig_context;
}
#
# >>_Description::
# {{Y:_TableReadText}} parses {{@strings}} as {{TBL}} format data using
# the nominated parameters.
# The table is returned in {{@table}}.
# See TableParseUsingParams() for details on the supported parameters.
#
sub _TableReadText {
local(*strings, *table, %params) = @_;
# local();
local($i, $linenum, $_);
local($format);
local($sep);
local($unpackfmt);
local(@fields, $field_count, $sep_re);
local($record, $field);
local($leading_indent_size);
# Preprocess text:
# * expand tabs
# * remove comments and blank lines
# * convert multi-line records into a single record
# * record line numbers (needed for meaningful validation messages)
@table = ();
for ($i = 0; $i <= $#strings; $i++) {
$_ = $strings[$i];
# Trim control-Ms (in case this file came from DOS), the newline
# and trailing whitespace & expand tabs
s/\r$//;
s/\s+$//;
1 while s/\t+/' ' x (length($&) * $_TABLE_TAB_SIZE - length($`) % $_TABLE_TAB_SIZE)/e;
unless ($field) {
# Skip comments and blank lines
next if /^\s*#/ || /^$/;
# Get the line number
$linenum = $i + 1;
# Lines ending in \ are continued onto the next line,
# unless there are exactly 2 backslashes at the end of the line
if (/[^\\]\\\\$/) {
s/\\$//;
}
elsif (s/\\$//) {
$line = $_;
for ($i++; $i <= $#strings; $i++) {
$_ = $strings[$i];
# Trim trailing whitespace, expand tabs & trim leading
# whitespace
s/\r$//;
s/\s+$//;
1 while s/\t+/' ' x (length($&) * $_TABLE_TAB_SIZE - length($`) % $_TABLE_TAB_SIZE)/e;
s/^\s+//;
# Build the logical line
$last = ($_ !~ /\\$/ || /[^\\]\\\\$/);
s/\\$//;
$line .= $_;
last if $last;
}
$_ = $line;
}
# Copy macros into the output
if (/^\s*\!/) {
push(@table, $_);
next;
}
}
# get the format specification, if we haven't already
if ($format eq '') {
$_ =~ s/^(\s*)//;
$leading_indent_size = length($1);
$format = $_;
push(@table, $format);
($sep) = $format =~ /(\W)/;
if ($sep =~ /\s/) {
$unpackfmt = &_TablePackStr($format);
}
elsif ($sep ne '') {
$sep_re = $sep;
$sep_re =~ s/(\W)/\\$1/g;
@fields = &TableFields($format);
$field_count = scalar(@fields);
}
next;
}
# get records, including those with multi-line cells
if ($field) {
if (s/^\>\>//) {
# Finalise this field
chop($field);
$field =~ s/$sep_re/\000/g if $sep_re;
$record .= $field;
if (/\<\<$/) {
$record .= $`;
$field = "\n";
next;
}
else {
$record .= $_;
$field = '';
}
}
else {
$field .= "$_\n";
next;
}
}
elsif (/\<\<$/) {
$record = $`;
$field = "\n";
next;
}
else {
$record = $_;
}
# If we reach here, the record can be saved
$record = substr($record, $leading_indent_size) if $leading_indent_size;
push(@table, &_TableBuildRec($record, $sep, $linenum, $unpackfmt,
$sep_re, $field_count));
}
# If a multi-line field was not explicitly terminated,
# the EOF terminates it
if ($field) {
chop($field);
$field =~ s/$sep_re/\000/g if $sep_re;
$record .= $field;
push(@table, &_TableBuildRec($record, $sep, $linenum, $unpackfmt,
$sep_re, $field_count));
}
}
sub _TableBuildRec {
local($rec, $sep, $linenum, $unpackfmt, $sep_re, $field_count) = @_;
local($result);
local(@values);
local($str);
local($val);
# Handle single field tables
if ($sep eq '') {
@values = ($rec);
}
# For fixed-width fields, trim whitespace at the end of each field
elsif ($sep =~ /\s/) {
@values = unpack($unpackfmt, $rec);
}
# For delimited fields:
# * split on the delimiter (unless its inside double-quotes), and
# * process double-quotes, if any
else {
$rec =~ s/("[^"]*")/do{$a=$1; $a=~s"$sep_re"\000"g; $a}/eg;
@values = split(/$sep_re/, $rec, $field_count);
for $val (@values) {
$val =~ s/\000/$sep/g;
if ($val =~ /^"(.*)"$/) {
$val = $1;
$val =~ s/""/"/g;
}
}
}
# Return result
return join("\000", $linenum, @values);
}
#
# >>_Description::
# {{Y:_TablePackStr}} builds a Perl pack/unpack string for
# a fixed-width format specification.
#
sub _TablePackStr {
local($format) = @_;
local($packfmt);
$packfmt = '';
while ($format =~ s/\w+\s+//e) {
$packfmt .= 'A' . length($&);
}
$packfmt .= 'A*';
return $packfmt;
}
#
# >>_Description::
# {{Y:_TableReadCustom}} parses {{@strings}} as custom format data.
# {{format}} is the format specification.
# The list of data records is returned in {{@data}}.
#
sub _TableReadCustom {
local($format, *strings, *table) = @_;
# local();
local($type, $spec, $fn);
# Get the format type and specification
@table = ();
if ($format =~ /^\!(\w+):?/) {
$type = $1;
$spec = $';
$fn = $_TABLE_CUSTOM_READ{$type};
if ($fn) {
eval {&$fn(*strings, *table, $type, $spec)};
&AppExit('failed', $@) if $@;
}
else {
&AppMsg("error", "unsupported custom table type '$type'");
}
}
else {
&AppMsg("error", "bad table format '$format'");
}
}
#
# >>_Description::
# {{Y:_TableWriteText}} outputs a table into {{TBL}} format.
# If {{strm}} is true, the table is output to that stream.
# Otherwise, the strings are appended to {{@strings}}.
#
sub _TableWriteText {
local(*table, $strm, *strings, %flags) = @_;
# local();
local($format);
local(@values, @fields, $sep, $packfmt);
local($fmtsep, $fmtsep_re);
local($i);
local($string);
# Get the formatting parameters
$format = $table[0];
@fields = &TableFields($format);
($sep) = $format =~ /(\W)/;
if ($sep eq '') {
# do nothing
}
elsif ($flags{'delimited'}) {
$fmtsep = $sep;
$fmtsep_re = $fmtsep;
$fmtsep_re =~ s/(\W)/\\$1/g;
$sep = $flags{'delimited'};
if ($sep == 1) {
$sep = "\t";
if ($fmtsep =~ /\s/) {
$format =~ s/\s+/\t/g;
}
else {
$format =~ s/$fmtsep_re/\t/g;
}
}
else {
$format =~ s/$fmtsep_re/$sep/g;
}
}
elsif ($sep =~ /^\s/) {
$sep = ' ';
$packfmt = &_TablePackStr($format);
}
# Output the header, unless asked not to
unless ($flags{'behead'}) {
if ($strm) {
print $strm $format, "\n";
}
else {
push(@strings, $format);
}
}
# Output the data
for ($i = 1; $i <= $#table; $i++) {
@values = split(/\000/, $table[$i]);
shift(@values); # skip the .line field
$string = &_TableFmtText(*values, *fields, $sep, $packfmt);
if ($strm) {
print $strm $string, "\n";
}
else {
push(@strings, $string);
}
}
}
#
# >>_Description::
# {{Y:_TableFmtText}} formats a text record.
# {{sep}} should be one of the following:
#
# * a space - format is fixed width columns using {{packfmt}}
# * a tab - format is tab-delimited output
# * another character - format is delimited by that character
#
sub _TableFmtText {
local(*values, *fields, $sep, $packfmt) = @_;
local($string);
local($multiline);
local($sep_re);
local($i);
if ($tjhdebug) {
print STDERR "1-------------------------------------------------\n";
for $igc (@values) {
print STDERR "value: $igc<\n";
}
for $igc (@fields) {
print STDERR "field: $igc<\n";
}
print STDERR "2-------------------------------------------------\n";
}
# Get the list of values, reformatting the last if its multi-line
# if (substr($values[$#fields], 0, 1) eq "\n") {
# $values[$#fields] = "<<" . $values[$#fields] . "\n>>";
# $multiline = $values[$#fields];
# }
# else {
# $multiline = '';
# }
# handle single column tables
if ($sep eq '') {
$string = $values[0];
}
# handle fixed width format
elsif ($sep eq ' ') {
$string = pack($packfmt, @values);
}
# handle tab-delimited format (skip double quote handling)
elsif ($sep eq "\t") {
# remove trailing empty elements
while (@values && $values[$#values] eq '') {
pop(@values);
}
# TJH
for $val (@values) {
if (substr($val,0,1) eq "\n") {
print STDERR "\nHACK $val\n" if ($tjhdebug);
$val = "<<" . $val . ">>";
}
}
$string = join($sep, @values);
}
# handle delimited format
else {
# remove trailing empty elements
while (@values && $values[$#values] eq '') {
pop(@values);
}
# Double quote handling - enclose in double quotes if
# the value contains double quotes or the separator
$sep_re = $sep;
$sep_re =~ s/(\W)/\\$1/g;
# pop(@values) if $multiline;
for $val (@values) {
if (substr($val,0,1) eq "\n") {
print STDERR "\nHACK $val\n" if ($tjhdebug);
$val = "<<" . $val . ">>";
} else {
if ($val =~ s/"/""/g || $val =~ /$sep_re/) {
$val = '"' . $val . '"';
}
}
$i++;
}
# push(@values, $multiline) if $multiline;
$string = join($sep, @values);
}
# Return result
return $string;
}
#
# >>_Description::
# {{Y:_TableWriteCustom}} formats a table into a custom format.
#
sub _TableWriteCustom {
local(*table, $strm, *strings, %flags) = @_;
# local();
&AppMsg("failure", "TableWriteCustom() not implemented yet");
}
# package return value
1;