home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _eb3f612b79207aa8d49b1609239ca2e8 < prev    next >
Encoding:
Text File  |  2004-06-01  |  56.5 KB  |  1,863 lines
  1. package Text::Reform;
  2.  
  3. use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); use Carp;
  4. use 5.005;
  5. $VERSION = '1.11';
  6.  
  7. require Exporter;
  8.  
  9. @ISA = qw(Exporter);
  10. @EXPORT = qw( form );
  11. @EXPORT_OK = qw( tag break_with break_at break_wrap break_TeX debug );
  12.  
  13. my @bspecials = qw( [ | ] );
  14. my @lspecials = qw( < ^ > );
  15. my $ljustified = '[<]{2,}[>]{2,}';
  16. my $bjustified = '[[]{2,}[]]{2,}';
  17. my $bsingle    = '~+';
  18. my @specials = (@bspecials, @lspecials);
  19. my $fixed_fieldpat = join('|', ($ljustified, $bjustified,
  20.                 $bsingle,
  21.                 map { "\\$_\{2,}" } @specials));
  22. my ($lfieldmark, $bfieldmark, $fieldmark, $fieldpat, $decimal);
  23. my $emptyref = '';
  24.  
  25. sub import
  26. {
  27.     use POSIX qw( localeconv );
  28.     $decimal = localeconv()->{decimal_point} || '.';
  29.  
  30.     my $lnumerical = '[>]+(?:'.quotemeta($decimal).'[<]{1,})';
  31.     my $bnumerical = '[]]+(?:'.quotemeta($decimal).'[[]{1,})';
  32.  
  33.     $fieldpat = join('|', ($lnumerical, $bnumerical,$fixed_fieldpat));
  34.  
  35.     $lfieldmark = join '|', ($lnumerical, $ljustified, map { "\\$_\{2}" } @lspecials);
  36.     $bfieldmark = join '|', ($bnumerical, $bjustified, $bsingle, map { "\\$_\{2}" } @bspecials);
  37.     $fieldmark  = join '|', ($lnumerical, $bnumerical,
  38.                  $bsingle,
  39.                  $ljustified, $bjustified,
  40.                  $lfieldmark, $bfieldmark);
  41.  
  42.     Text::Reform->export_to_level(1, @_);
  43. }
  44.  
  45. sub carpfirst {
  46.     our %carped;
  47.     my ($msg) = @_;
  48.     return if $carped{$msg}++;
  49.     carp $msg;
  50. }
  51.  
  52. ###### USEFUL TOOLS ######################################
  53.  
  54. #===== form =============================================#
  55.  
  56. sub BAD_CONFIG { 'Configuration hash not allowed between format and data' }
  57.  
  58. sub break_with
  59. {
  60.     my $hyphen = $_[0];
  61.     my $hylen = length($hyphen);
  62.     my @ret;
  63.     sub
  64.     {
  65.         if ($_[2]<=$hylen)
  66.         {
  67.             @ret = (substr($_[0],0,1), substr($_[0],1))
  68.         }
  69.         else
  70.         {
  71.             @ret = (substr($_[0],0,$_[1]-$hylen),
  72.                 substr($_[0],$_[1]-$hylen))
  73.         }
  74.         if ($ret[0] =~ /\A\s*\Z/) { return ("",$_[0]); }
  75.         else { return ($ret[0].$hyphen,$ret[1]); }
  76.     }
  77.  
  78. }
  79.  
  80. sub break_at {
  81.     my $hyphen = $_[0];
  82.     my $hylen = length($hyphen);
  83.     my @ret;
  84.     sub
  85.     {
  86.         my $max = $_[2]-$hylen;
  87.         if ($max <= 0) {
  88.             @ret = (substr($_[0],0,1), substr($_[0],1))
  89.         }
  90.         elsif ($_[0] =~ /(.{1,$max}$hyphen)(.*)/s) {
  91.             @ret = ($1,$2);
  92.         }
  93.         elsif (length($_[0])>$_[2]) {
  94.             @ret = (substr($_[0],0,$_[1]-$hylen).$hyphen,
  95.                 substr($_[0],$_[1]-$hylen))
  96.         }
  97.         else {
  98.             @ret = ("",$_[0]);
  99.         }
  100.         if ($ret[0] =~ /\A\s*\Z/) { return ("",$_[0]); }
  101.         else { return @ret; }
  102.     }
  103.  
  104. }
  105.  
  106. sub break_wrap
  107. {
  108.     return \&break_wrap unless @_;
  109.     my ($text, $reqlen, $fldlen) = @_;
  110.     if ($reqlen==$fldlen) { $text =~ m/\A(\s*\S*)(.*)/s }
  111.     else                  { ("", $text) }
  112. }
  113.  
  114. my %hyp;
  115. sub break_TeX
  116. {
  117.     my $file = $_[0] || "";
  118.  
  119.     croak "Can't find TeX::Hypen module"
  120.         unless require "TeX/Hyphen.pm";
  121.  
  122.     $hyp{$file} = TeX::Hyphen->new($file||undef)
  123.             || croak "Can't open hyphenation file $file"
  124.         unless $hyp{$file};
  125.  
  126.     return sub {
  127.         for (reverse $hyp{$file}->hyphenate($_[0])) {
  128.             if ($_ < $_[1]) {
  129.                 return (substr($_[0],0,$_).'-',
  130.                     substr($_[0],$_) );
  131.             }
  132.         }
  133.         return ("",$_[0]);
  134.     }
  135. }
  136.  
  137. my $debug = 0;
  138. sub _debug { print STDERR @_, "\n" if $debug }
  139. sub debug { $debug = 1; }
  140.  
  141. sub notempty
  142. {
  143.     my $ne = ${$_[0]} =~ /\S/;
  144.     _debug("\tnotempty('${$_[0]}') = $ne\n");
  145.     return $ne;
  146. }
  147.  
  148. sub replace($$$$)   # ($fmt, $len, $argref, $config)
  149. {
  150.     my $ref = $_[2];
  151.     my $text = '';
  152.     my $rem = $_[1];
  153.     my $config = $_[3];
  154.     my $filled = 0;
  155.  
  156.     if ($config->{fill}) { $$ref =~ s/\A\s*// }
  157.     else             { $$ref =~ s/\A[ \t]*// }
  158.  
  159.     my $fmtnum = length $_[0];
  160.  
  161.     if ($$ref =~ /\S/ && $fmtnum>2)
  162.     {
  163.     NUMERICAL:{
  164.         use POSIX qw( strtod );
  165.         my ($ilen,$dlen) = map {length} $_[0] =~ m/([]>]+)\Q$decimal\E([[<]+)/;
  166.         my ($num,$unconsumed) = strtod($$ref);
  167.         if ($unconsumed == length $$ref)
  168.         {
  169.             $$ref =~ s/\s*\S*//;
  170.             redo NUMERICAL if $config->{numeric} =~ m/\bSkipNaN\b/i
  171.                        && $$ref =~ m/\S/;
  172.             $text = '?' x $ilen . $decimal . '?' x $dlen;
  173.             $rem = 0;
  174.             return $text;
  175.         }
  176.         my $formatted = sprintf "%$fmtnum.${dlen}f", $num;
  177.         $text = (length $formatted > $fmtnum)
  178.             ? '#' x $ilen . $decimal . '#' x $dlen
  179.             : $formatted;
  180.         $text =~ s/(\Q$decimal\E\d+?)(0+)$/$1 . " " x length $2/e
  181.             unless $config->{numeric} =~ m/\bAllPlaces\b/i
  182.                 || $num =~ /\Q$decimal\E\d\d{$dlen,}$/;
  183.         if ($unconsumed)
  184.         {
  185.             if ($unconsumed == length $$ref)
  186.                 { $$ref =~ s/\A.[^0-9.+-]*// }
  187.             else
  188.                 { substr($$ref,0,-$unconsumed) = ""}
  189.         }
  190.         else            { $$ref = "" }
  191.         $rem = 0;
  192.         }
  193.     }
  194.     else
  195.     {
  196.         while ($$ref =~ /\S/)
  197.         {
  198.             if (!$config->{fill} && $$ref=~s/\A[ \t]*\n//)
  199.                 { $filled = 2; last }
  200.             last unless $$ref =~ /\A(\s*)(\S+)(.*)\z/s;
  201.             my ($ws, $word, $extra) = ($1,$2,$3);
  202.             my $nonnl = $ws =~ /[^\n]/;
  203.             $ws =~ s/\n/$nonnl? "" : " "/ge if $config->{fill};
  204.             my $lead = ($config->{squeeze} ? ($ws ? " " : "") : $ws);
  205.             my $match = $lead . $word;
  206.             _debug "Extracted [$match]";
  207.             last if $text && $match =~ /\n/;
  208.             my $len1 = length($match);
  209.             if ($len1 <= $rem)
  210.             {
  211.                 _debug "Accepted [$match]";
  212.                 $text .= $match;
  213.                 $rem  -= $len1;
  214.                 $$ref = $extra;
  215.             }
  216.             else
  217.             {
  218.                 _debug "Need to break [$match]";
  219.                 # was: if ($len1 > $_[1] and $rem-length($lead)>$config->{minbreak})
  220.                 if ($rem-length($lead)>$config->{minbreak})
  221.                 {
  222.                     _debug "Trying to break '$match'";
  223.                     my ($broken,$left) =
  224.                         $config->{break}->($match,$rem,$_[1]);    
  225.                     $text .= $broken;
  226.                     _debug "Broke as: [$broken][$left]";
  227.                     $$ref = $left.$extra;
  228.                     $rem -= length $broken;
  229.                 }
  230.                 last;
  231.             }
  232.         }
  233.         continue { $filled=1 }
  234.     }
  235.  
  236.     if (!$filled && $rem>0 && $$ref=~/\S/ && length $text == 0)
  237.     {
  238.         $$ref =~ s/^\s*(.{1,$rem})//;
  239.         $text = $1;
  240.         $rem -= length $text;
  241.     }
  242.  
  243.     if ( $text=~/ / && $_[0] eq 'J' && $$ref=~/\S/ && $filled!=2 ) {
  244.                             # FULLY JUSTIFIED
  245.         $text = reverse $text;
  246.         $text =~ s/( +)/($rem-->0?" ":"").$1/ge while $rem>0;
  247.         $text = reverse $text;
  248.     }
  249.     elsif ( $_[0] =~ /\>|\]/ ) {            # RIGHT JUSTIFIED
  250.         substr($text,0,0) =
  251.             substr($config->{filler}{left} x $rem, -$rem)
  252.                 if $rem > 0;
  253.     }
  254.     elsif ( $_[0] =~ /\^|\|/ ) {            # CENTRE JUSTIFIED
  255.         if ($rem>0) {
  256.         my $halfrem = int($rem/2);
  257.         substr($text,0,0) =
  258.             substr($config->{filler}{left}x$halfrem, -$halfrem);
  259.         $halfrem = $rem-$halfrem;
  260.         $text .= substr($config->{filler}{right}x$halfrem, 0, $halfrem);
  261.         }
  262.     }
  263.     else {                        # LEFT JUSTIFIED
  264.         $text .= substr($config->{filler}{right}x$rem, 0, $rem)
  265.             if $rem > 0;
  266.     }
  267.  
  268.     return $text;
  269. }
  270.  
  271. my %std_config =
  272. (
  273.     header       => sub{""},
  274.     footer       => sub{""},
  275.     pagefeed   => sub{""},
  276.     pagelen       => 0,
  277.     pagenum       => undef,
  278.     pagewidth  => 72,
  279.     break       => break_with('-'),
  280.     minbreak   => 2,
  281.     squeeze       => 0,
  282.     filler     => {left=>' ', right=>' '},
  283.     interleave => 0,
  284.     numeric       => "",
  285.     _used      => 1,
  286. );
  287.  
  288. sub lcr {
  289.     my ($data, $pagewidth, $header) = @_;
  290.     $data->{width}  ||= $pagewidth;
  291.     $data->{left}   ||= "";
  292.     $data->{centre} ||= $data->{center}||"";
  293.     $data->{right}  ||= "";
  294.     return sub {
  295.         my @l = split "\n", (ref $data->{left} eq 'CODE'
  296.                 ? $data->{left}->(@_) : $data->{left}), -1;
  297.         my @c = split "\n", (ref $data->{centre} eq 'CODE'
  298.                 ? $data->{centre}->(@_) : $data->{centre}), -1;
  299.         my @r = split "\n", (ref $data->{right} eq 'CODE'
  300.                 ? $data->{right}->(@_) : $data->{right}), -1;
  301.         my $text = "";
  302.         while (@l||@c||@r) {
  303.             my $l = @l ? shift(@l) : "";
  304.             my $c = @c ? shift(@c) : "";
  305.             my $r = @r ? shift(@r) : "";
  306.             my $gap = int(($data->{width}-length($c))/2-length($l));
  307.             if ($gap < 0) {
  308.                 $gap = 0;
  309.                 carpfirst "\nWarning: $header is wider than specified page width ($data->{width} chars)" if $^W;
  310.             }
  311.             $text .= $l . " " x $gap
  312.                    . $c . " " x ($data->{width}-length($l)-length($c)-$gap-length($r))
  313.                    . $r
  314.                    . "\n";
  315.         }
  316.         return $text;
  317.     }
  318. }
  319.  
  320. sub fix_config(\%)
  321. {
  322.     my ($config) = @_;
  323.     if (ref $config->{header} eq 'HASH') {
  324.         $config->{header} =
  325.             lcr $config->{header}, $config->{pagewidth}, 'header';
  326.     }
  327.     elsif (ref $config->{header} eq 'CODE') {
  328.         my $tmp = $config->{header};
  329.         $config->{header} = sub {
  330.             my $header = &$tmp;
  331.             return (ref $header eq 'HASH')
  332.                 ? lcr($header,$config->{pagewidth},'header')->()
  333.                 : $header;
  334.         }
  335.     }
  336.     else {
  337.         my $tmp = $config->{header};
  338.         $config->{header} = sub { $tmp }
  339.     }
  340.     if (ref $config->{footer} eq 'HASH') {
  341.         $config->{footer} =
  342.             lcr $config->{footer}, $config->{pagewidth}, 'footer';
  343.     }
  344.     elsif (ref $config->{footer} eq 'CODE') {
  345.         my $tmp = $config->{footer};
  346.         $config->{footer} = sub {
  347.             my $footer = &$tmp;
  348.             return (ref $footer eq 'HASH')
  349.                 ? lcr($footer,$config->{pagewidth},'footer')->()
  350.                 : $footer;
  351.         }
  352.     }
  353.     else {
  354.         my $tmp = $config->{footer};
  355.         $config->{footer} = sub { $tmp }
  356.     }
  357.     unless (ref $config->{pagefeed} eq 'CODE')
  358.         { my $tmp = $config->{pagefeed}; $config->{pagefeed} = sub { $tmp } }
  359.     unless (ref $config->{break} eq 'CODE')
  360.         { $config->{break} = break_at($config->{break}) }
  361.     if (defined $config->{pagenum} && ref $config->{pagenum} ne 'SCALAR') 
  362.         { my $tmp = $config->{pagenum}+0; $config->{pagenum} = \$tmp }
  363.     unless (ref $config->{filler} eq 'HASH') {
  364.         $config->{filler} = { left  => "$config->{filler}",
  365.                         right => "$config->{filler}" }
  366.     }
  367. }
  368.  
  369. sub FormOpt::DESTROY
  370. {
  371.     print STDERR "\nWarning: lexical &form configuration at $std_config{_line} was never used.\n"
  372.         if $^W && !$std_config{_used};
  373.     %std_config = %{$std_config{_prev}};
  374. }
  375.  
  376. sub form
  377. {
  378.     our %carped;
  379.     local %carped;
  380.     my $config = {%std_config};
  381.     my $startidx = 0;
  382.     if (@_ && ref($_[0]) eq 'HASH')        # RESETTING CONFIG
  383.     {
  384.         if (@_ > 1)            # TEMPORARY RESET
  385.         {
  386.             $config = {%$config, %{$_[$startidx++]}};
  387.             fix_config(%$config);
  388.             $startidx = 1;
  389.         }
  390.         elsif (defined wantarray)    # CONTEXT BEING CAPTURED
  391.         {
  392.             $_[0]->{_prev} = { %std_config };
  393.             $_[0]->{_used} = 0;
  394.             $_[0]->{_line} = join " line ", (caller)[1..2];;
  395.             %{$_[0]} = %std_config = (%std_config, %{$_[0]});
  396.             fix_config(%std_config);
  397.             return bless $_[0], 'FormOpt';
  398.         }
  399.         else                # PERMANENT RESET
  400.         {
  401.             $_[0]->{_used} = 1;
  402.             $_[0]->{_line} = join " line ", (caller)[1..2];;
  403.             %std_config = (%std_config, %{$_[0]});
  404.             fix_config(%std_config);
  405.             return;
  406.         }
  407.     }
  408.     $config->{pagenum} = do{\(my $tmp=1)}
  409.         unless defined $config->{pagenum};
  410.  
  411.     $std_config{_used}++;
  412.     my @ref = map { ref } @_;
  413.     my @orig = @_;
  414.     my $caller = caller;
  415.     no strict;
  416.  
  417.     for (my $nextarg=0; $nextarg<@_; $nextarg++)
  418.     {
  419.         my $next = $_[$nextarg];
  420.         if (!defined $next) {
  421.             my $tmp = "";
  422.             splice @_, $nextarg, 1, \$tmp;
  423.         }
  424.         elsif ($ref[$nextarg] eq 'ARRAY') {
  425.             splice @_, $nextarg, 1, \join("\n", @$next)
  426.         }
  427.         elsif ($ref[$nextarg] eq 'HASH' && $next->{cols} ) {
  428.             croak "Missing 'from' data for 'cols' option"
  429.                 unless $next->{from};
  430.             croak "Can't mix other options with 'cols' option"
  431.                 if keys %$next > 2;
  432.             my ($cols, $data) = @{$next}{'cols','from'};
  433.             croak "Invalid 'cols' option.\nExpected reference to array of column specifiers but found " . (ref($cols)||"'$cols'")
  434.                 unless ref $cols eq 'ARRAY';
  435.             croak "Invalid 'from' data for 'cols' option.\nExpected reference to array of hashes or arrays but found " . (ref($data)||"'$data'")
  436.                 unless ref $data eq 'ARRAY';
  437.             splice @_, $nextarg, 2, columns(@$cols,@$data);
  438.             splice @ref, $nextarg, 2, ('ARRAY')x@$cols;
  439.             $nextarg--;
  440.         }
  441.         elsif (!defined eval { local $SIG{__DIE__};
  442.                        $_[$nextarg] = $next;
  443.                        _debug "writeable: [$_[$nextarg]]";
  444.                        1})
  445.         {
  446.                 _debug "unwriteable: [$_[$nextarg]]";
  447.             my $arg = $_[$nextarg];
  448.             splice @_, $nextarg, 1, \$arg;
  449.         }
  450.         elsif (!$ref[$nextarg]) {
  451.             splice @_, $nextarg, 1, \$_[$nextarg];
  452.         }
  453.                 elsif ($ref[$nextarg] ne 'HASH' and $ref[$nextarg] ne 'SCALAR')
  454.                 {
  455.             splice @_, $nextarg, 1, \"$next";
  456.                 }
  457.     }
  458.  
  459.     my $header = $config->{header}->(${$config->{pagenum}});
  460.     $header.="\n" if $header && substr($header,-1,1) ne "\n";
  461.  
  462.     my $footer = $config->{footer}->(${$config->{pagenum}});
  463.     $footer.="\n" if $footer && substr($footer,-1,1) ne "\n";
  464.  
  465.     my $prevfooter = $footer;
  466.  
  467.     my $linecount = $header=~tr/\n/\n/ + $footer=~tr/\n/\n/;
  468.     my $hfcount = $linecount;
  469.  
  470.     my $text = $header;
  471.     my @format_stack;
  472.  
  473.     LINE: while ($startidx < @_ || @format_stack)
  474.     {
  475.         if (($ref[$startidx]||'') eq 'HASH')
  476.         {
  477.             $config = {%$config, %{$_[$startidx++]}};
  478.             fix_config(%$config);
  479.             next;
  480.         }
  481.         unless (@format_stack) {
  482.             @format_stack = $config->{interleave}
  483.                 ? map "$_\n", split /\n/, ${$_[$startidx++]}||""
  484.                 : ${$_[$startidx++]}||"";
  485.         }
  486.         my $format = shift @format_stack;
  487.         _debug("format: [$format]");
  488.     
  489.         my @parts = split /(\n|(?:\\.)+|$fieldpat)/, $format;
  490.         push @parts, "\n" unless @parts && $parts[-1] eq "\n";
  491.         my $fieldcount = 0;
  492.         my $filled = 0;
  493.         my $firstline = 1;
  494.         while (!$filled)
  495.         {
  496.             my $nextarg = $startidx;
  497.             my @data;
  498.             foreach my $part ( @parts )
  499.             {
  500.                 if ($part =~ /\A(?:\\.)+/)
  501.                 {
  502.                     _debug("esc literal: [$part]");
  503.                     my $tmp = $part;
  504.                     $tmp =~ s/\\(.)/$1/g;
  505.                     $text .= $tmp;
  506.                 }
  507.                 elsif ($part =~ /($lfieldmark)/)
  508.                 {
  509.                     if ($firstline)
  510.                     {
  511.                         $fieldcount++;
  512.                         if ($nextarg > $#_)
  513.                             { push @_,\$emptyref; push @ref, '' }
  514.                         my $type = $1;
  515.                         $type = 'J' if $part =~ /$ljustified/;
  516.                         croak BAD_CONFIG if ($ref[$startidx] eq 'HASH');
  517.                         _debug("once field: [$part]");
  518.                         _debug("data was: [${$_[$nextarg]}]");
  519.                         $text .= replace($type,length($part),$_[$nextarg],$config);
  520.                         _debug("data now: [${$_[$nextarg]}]");
  521.                     }
  522.                     else
  523.                     {
  524.                         $text .= substr($config->{filler}{left} x length($part), -length($part));
  525.                         _debug("missing once field: [$part]");
  526.                     }
  527.                     $nextarg++;
  528.                 }
  529.                 elsif ($part =~ /($fieldmark)/ and substr($part,0,2) ne '~~')
  530.                 {
  531.                     $fieldcount++ if $firstline;
  532.                     if ($nextarg > $#_)
  533.                         { push @_,\$emptyref; push @ref, '' }
  534.                     my $type = $1;
  535.                     $type = 'J' if $part =~ /$bjustified/;
  536.                     croak BAD_CONFIG if ($ref[$startidx] eq 'HASH');
  537.                     _debug("multi field: [$part]");
  538.                     _debug("data was: [${$_[$nextarg]}]");
  539.                     $text .= replace($type,length($part),$_[$nextarg],$config);
  540.                     _debug("data now: [${$_[$nextarg]}]");
  541.                     push @data, $_[$nextarg];
  542.                     $nextarg++;
  543.                 }
  544.                 else
  545.                 {
  546.                     _debug("literal: [$part]");
  547.                     my $tmp = $part;
  548.                     $tmp =~ s/\0(\0*)/$1/g;
  549.                     $text .= $tmp;
  550.                     if ($part eq "\n")
  551.                     {
  552.                         $linecount++;
  553.                         if ($config->{pagelen} && $linecount>=$config->{pagelen})
  554.                         {
  555.                             _debug("\tejecting page:  $config->{pagenum}");
  556.                             carpfirst "\nWarning: could not format page ${$config->{pagenum}} within specified page length"
  557.                                 if $^W && $config->{pagelen} && $linecount > $config->{pagelen};
  558.                             ${$config->{pagenum}}++;
  559.                             my $pagefeed = $config->{pagefeed}->(${$config->{pagenum}});
  560.                             $header = $config->{header}->(${$config->{pagenum}});
  561.                             $header.="\n" if $header && substr($header,-1,1) ne "\n";
  562.                             $text .= $footer
  563.                                    . $pagefeed
  564.                                    . $header;
  565.                             $prevfooter = $footer;
  566.                             $footer = $config->{footer}->(${$config->{pagenum}});
  567.                             $footer.="\n" if $footer && substr($footer,-1,1) ne "\n";
  568.                             $linecount = $hfcount =
  569.                                 $header=~tr/\n/\n/ + $footer=~tr/\n/\n/;
  570.                             $header = $pagefeed
  571.                                 . $header;
  572.                         }
  573.                     }
  574.                 }
  575.                 _debug("\tnextarg now:  $nextarg");
  576.                 _debug("\tstartidx now: $startidx");
  577.             }
  578.             $firstline = 0;
  579.             $filled = ! grep { notempty $_ } @data;
  580.         }
  581.         $startidx += $fieldcount;
  582.     }
  583.  
  584.     # ADJUST FINAL PAGE HEADER OR FOOTER AS REQUIRED
  585.     if ($hfcount && $linecount == $hfcount)        # UNNEEDED HEADER
  586.     {
  587.         $text =~ s/\Q$header\E\Z//;
  588.     }
  589.     elsif ($linecount && $config->{pagelen})    # MISSING FOOTER
  590.     {
  591.         $text .= "\n" x ($config->{pagelen}-$linecount)
  592.                . $footer;
  593.         $prevfooter = $footer;
  594.     }
  595.  
  596.     # REPLACE LAST FOOTER
  597.     
  598.     if ($prevfooter) {
  599.         my $lastfooter = $config->{footer}->(${$config->{pagenum}},1);
  600.         $lastfooter.="\n"
  601.             if $lastfooter && substr($lastfooter,-1,1) ne "\n";
  602.         my $footerdiff = ($lastfooter =~ tr/\n/\n/)
  603.                    - ($prevfooter =~ tr/\n/\n/);
  604.         # Enough space to squeeze longer final footer in?
  605.         my $tail = '^[^\S\n]*\n' x $footerdiff;
  606.         if ($footerdiff > 0 && $text =~ /($tail\Q$prevfooter\E)\Z/m) {
  607.             $prevfooter = $1;
  608.             $footerdiff = 0;
  609.         }
  610.         # Apparently, not, so create an extra (empty) page for it
  611.         if ($footerdiff > 0) {
  612.             ${$config->{pagenum}}++;
  613.             my $lastheader = $config->{header}->(${$config->{pagenum}});
  614.             $lastheader.="\n"
  615.                 if $lastheader && substr($lastheader,-1,1) ne "\n";
  616.             $lastfooter = $config->{footer}->(${$config->{pagenum}},1);
  617.             $lastfooter.="\n"
  618.                 if $lastfooter && substr($lastfooter,-1,1) ne "\n";
  619.  
  620.             $text .= $lastheader
  621.                    . ("\n" x ( $config->{pagelen}
  622.                     - ($lastheader =~ tr/\n/\n/)
  623.                         - ($lastfooter =~ tr/\n/\n/)
  624.                     )
  625.                  )
  626.                    . $lastfooter;
  627.         }
  628.         else {
  629.                         $lastfooter = ("\n"x-$footerdiff).$lastfooter;
  630.                         substr($text, -length($prevfooter)) = $lastfooter;
  631.         }
  632.     }
  633.  
  634.         # RESTORE ARG LIST
  635.         for my $i (0..$#orig)
  636.         {
  637.                 if ($ref[$i] eq 'ARRAY')
  638.                         { eval { @{$orig[$i]} = map "$_\n", split /\n/, ${$_[$i]} } }
  639.                 elsif (!$ref[$i])
  640.                         { eval { _debug("restoring $i (".$_[$i].") to " .
  641.                                  defined($orig[$i]) ? $orig[$i] : "<undef>");
  642.                                  ${$_[$i]} = $orig[$i] } }
  643.         }
  644.  
  645.         ${$config->{pagenum}}++;
  646.         $text =~ s/[ ]+$//gm if $config->{trim};
  647.         return $text unless wantarray;
  648.         return map "$_\n", split /\n/, $text;
  649. }
  650.  
  651.  
  652. #==== columns ========================================#
  653.  
  654. sub columns {
  655.         my @cols;
  656.         my (@fullres, @res);
  657.         while (@_) {
  658.                 my $arg = shift @_;
  659.                 my $type = ref $arg;
  660.                 if ($type eq 'HASH') {
  661.                         push @{$res[$_]}, $arg->{$cols[$_]} for 0..$#cols;
  662.                 }
  663.                 elsif ($type eq 'ARRAY') {
  664.                         push @{$res[$_]}, $arg->[$cols[$_]] for 0..$#cols;
  665.                 }
  666.                 else {
  667.                         if (@res) {
  668.                                 push @fullres, @res;
  669.                                 @res = @cols = ();
  670.                         }
  671.                         push @cols, $arg;
  672.                 }
  673.         }
  674.         return @fullres, @res;
  675. }
  676.  
  677.  
  678. #==== tag ============================================#
  679.  
  680. sub invert($)
  681. {
  682.         my $inversion = reverse $_[0];
  683.         $inversion =~ tr/{[<(/}]>)/;
  684.         return $inversion;
  685. }
  686.  
  687. sub tag         # ($tag, $text; $opt_endtag)
  688. {
  689.         my ($tagleader,$tagindent,$ldelim,$tag,$tagargs,$tagtrailer) = 
  690.                 ( $_[0] =~ /\A((?:[ \t]*\n)*)([ \t]*)(\W*)(\w+)(.*?)(\s*)\Z/ );
  691.  
  692.         $ldelim = '<' unless $ldelim;
  693.         $tagtrailer =~ s/([ \t]*)\Z//;
  694.         my $textindent = $1||"";
  695.  
  696.         my $rdelim = invert $ldelim;
  697.  
  698.         my $i;
  699.         for ($i = -1; -1-$i < length $rdelim && -1-$i < length $tagargs; $i--)
  700.         {
  701.                 last unless substr($tagargs,$i,1) eq substr($rdelim,$i,1);
  702.         }
  703.         if ($i < -1)
  704.         {
  705.                 $i++;
  706.                 $tagargs = substr($tagargs,0,$i);
  707.                 $rdelim = substr($rdelim,$i);
  708.         }
  709.  
  710.         my $endtag = $_[2] || "$ldelim/$tag$rdelim";
  711.  
  712.         return "$tagleader$tagindent$ldelim$tag$tagargs$rdelim$tagtrailer".
  713.                 join("\n",map { "$tagindent$textindent$_" } split /\n/, $_[1]).
  714.                 "$tagtrailer$tagindent$endtag$tagleader";
  715.  
  716. }
  717.  
  718.  
  719. 1;
  720.  
  721. __END__
  722.  
  723. =head1 NAME
  724.  
  725. Text::Reform - Manual text wrapping and reformatting
  726.  
  727. =head1 VERSION
  728.  
  729. This document describes version 1.11 of Text::Reform,
  730. released May  7, 2003.
  731.  
  732. =head1 SYNOPSIS
  733.  
  734.         use Text::Reform;
  735.  
  736.         print form $template,
  737.                    $data, $to, $fill, $it, $with;
  738.  
  739.  
  740.         use Text::Reform qw( tag );
  741.  
  742.         print tag 'B', $enboldened_text;
  743.  
  744.  
  745. =head1 DESCRIPTION
  746.  
  747. =head2 The C<form> sub
  748.  
  749. The C<form()> subroutine may be exported from the module.
  750. It takes a series of format (or "picture") strings followed by
  751. replacement values, interpolates those values into each picture string,
  752. and returns the result. The effect is similar to the inbuilt perl
  753. C<format> mechanism, although the field specification syntax is
  754. simpler and some of the formatting behaviour is more sophisticated.
  755.  
  756. A picture string consists of sequences of the following characters:
  757.  
  758. =over 8
  759.  
  760. =item <
  761.  
  762. Left-justified field indicator.
  763. A series of two or more sequential <'s specify
  764. a left-justified field to be filled by a subsequent value.
  765. A single < is formatted as the literal character '<'
  766.  
  767. =item >
  768.  
  769. Right-justified field indicator.
  770. A series of two or more sequential >'s specify
  771. a right-justified field to be filled by a subsequent value.
  772. A single < is formatted as the literal character '<'
  773.  
  774. =item <<<>>>
  775.  
  776. Fully-justified field indicator.
  777. Field may be of any width, and brackets need not balance, but there
  778. must be at least 2 '<' and 2 '>'.
  779.  
  780. =item ^
  781.  
  782. Centre-justified field indicator.
  783. A series of two or more sequential ^'s specify
  784. a centred field to be filled by a subsequent value.
  785. A single ^ is formatted as the literal character '<'
  786.  
  787. =item >>>.<<<<
  788.  
  789. A numerically formatted field with the specified number of digits to
  790. either side of the decimal place. See L<Numerical formatting> below.
  791.  
  792.  
  793. =item [
  794.  
  795. Left-justified block field indicator.
  796. Just like a < field, except it repeats as required on subsequent lines. See
  797. below.
  798. A single [ is formatted as the literal character '['
  799.  
  800. =item ]
  801.  
  802. Right-justified block field indicator.
  803. Just like a > field, except it repeats as required on subsequent lines. See
  804. below.
  805. A single ] is formatted as the literal character ']'
  806.  
  807. =item [[[]]]
  808.  
  809. Fully-justified block field indicator.
  810. Just like a <<<>>> field, except it repeats as required on subsequent lines. See
  811. below.
  812. Field may be of any width, and brackets need not balance, but there
  813. must be at least 2 '[' and 2 ']'.
  814.  
  815. =item |
  816.  
  817. Centre-justified block field indicator.
  818. Just like a ^ field, except it repeats as required on subsequent lines. See
  819. below.
  820. A single | is formatted as the literal character '|'
  821.  
  822. =item ]]].[[[[
  823.  
  824. A numerically formatted block field with the specified number of digits to
  825. either side of the decimal place.
  826. Just like a >>>.<<<< field, except it repeats as required on
  827. subsequent lines. See below.
  828.  
  829.  
  830. =item ~
  831.  
  832. A one-character wide block field.
  833.  
  834. =item \
  835.  
  836. Literal escape of next character (e.g. C<\~> is formatted as '~', not a one
  837. character wide block field).
  838.  
  839. =item Any other character
  840.  
  841. That literal character.
  842.  
  843. =back
  844.  
  845. Any substitution value which is C<undef> (either explicitly so, or because it
  846. is missing) is replaced by an empty string.
  847.  
  848.  
  849.  
  850. =head2 Controlling line filling.
  851.  
  852. Note that, unlike the a perl C<format>, C<form> preserves whitespace
  853. (including newlines) unless called with certain options.
  854.  
  855. The "squeeze" option (when specified with a true value) causes any sequence
  856. of spaces and/or tabs (but not newlines) in an interpolated string to be
  857. replaced with a single space.
  858.  
  859. A true value for the "fill" option causes (only) newlines to be squeezed.
  860.  
  861. To minimize all whitespace, you need to specify both options. Hence:
  862.  
  863.         $format = "EG> [[[[[[[[[[[[[[[[[[[[[";
  864.         $data   = "h  e\t l lo\nworld\t\t\t\t\t";
  865.  
  866.         print form $format, $data;              # all whitespace preserved:
  867.                                                 #
  868.                                                 # EG> h  e            l lo
  869.                                                 # EG> world
  870.  
  871.  
  872.         print form {squeeze=>1},                # only newlines preserved:
  873.                    $format, $data;              #
  874.                                                 # EG> h e l lo
  875.                                                 # EG> world
  876.  
  877.  
  878.         print form {fill=>1},                   # only spaces/tabs preserved:
  879.                     $format, $data;             #
  880.                                                 # EG> h  e        l lo world
  881.  
  882.  
  883.         print form {squeeze=>1, fill=>1},       # no whitespace preserved:
  884.                    $format, $data;              #
  885.                                                 # EG> h e l lo world
  886.  
  887.  
  888. Whether or not filling or squeezing is in effect, C<form> can also be
  889. directed to trim any extra whitespace from the end of each line it
  890. formats, using the "trim" option. If this option is specified with a
  891. true value, every line returned by C<form> will automatically have the
  892. substitution C<s/[ \t]+$//gm> applied to it.
  893.  
  894. Hence:
  895.  
  896.         print length form "[[[[[[[[[[", "short";
  897.         # 11
  898.  
  899.         print length form {trim=>1}, "[[[[[[[[[[", "short";
  900.         # 6
  901.  
  902.  
  903. It is also possible to control the character used to fill lines that are
  904. too short, using the 'filler' option. If this option is specified the
  905. value of the 'filler' flag is used as the fill string, rather than the
  906. default C<" ">.
  907.  
  908. For example:
  909.  
  910.         print form { filler=>'*' },
  911.                 "Pay bearer: ^^^^^^^^^^^^^^^^^^^",
  912.                 '$123.45';
  913.  
  914. prints:
  915.  
  916.         Pay bearer: ******$123.45******
  917.  
  918. If the filler string is longer than one character, it is truncated
  919. to the appropriate length. So:
  920.  
  921.         print form { filler=>'-->' },
  922.                 "Pay bearer: ]]]]]]]]]]]]]]]]]]]",
  923.                 ['$1234.50', '$123.45', '$12.34'];
  924.  
  925. prints:
  926.  
  927.         Pay bearer: ->-->-->-->$1234.50
  928.         Pay bearer: -->-->-->-->$123.45
  929.         Pay bearer: >-->-->-->-->$12.34
  930.  
  931. If the value of the 'filler' option is a hash, then it's 'left' and
  932. 'right' entries specify separate filler strings for each side of
  933. an interpolated value. So:
  934.  
  935.         print form { filler=>{left=>'->', right=>'*'} },
  936.                 "Pay bearer: <<<<<<<<<<<<<<<<<<",
  937.                 '$123.45',
  938.                 "Pay bearer: >>>>>>>>>>>>>>>>>>",
  939.                 '$123.45',
  940.                 "Pay bearer: ^^^^^^^^^^^^^^^^^^",
  941.                 '$123.45';
  942.  
  943. prints:
  944.  
  945.         Pay bearer: $123.45***********
  946.         Pay bearer: >->->->->->$123.45
  947.         Pay bearer: >->->$123.45******
  948.  
  949.  
  950. =head2 Temporary and permanent default options
  951.  
  952. If C<form> is called with options, but no template string or data, it resets
  953. it's defaults to the options specified. If called in a void context:
  954.  
  955.         form { squeeze => 1, trim => 1 };
  956.  
  957. the options become permanent defaults.
  958.  
  959. However, when called with only options in non-void context, C<form>
  960. resets its defaults to those options and returns an object. The reset
  961. default values persist only until that returned object is destroyed.
  962. Hence to temporarily reset C<form>'s defaults within a single subroutine:
  963.  
  964.         sub single {
  965.                 my $tmp = form { squeeze => 1, trim => 1 };
  966.  
  967.                 # do formatting with the obove defaults
  968.  
  969.         } # form's defaults revert to previous values as $tmp object destroyed
  970.  
  971.  
  972.  
  973. =head2 Multi-line format specifiers and interleaving
  974.  
  975. By default, if a format specifier contains two or more lines
  976. (i.e. one or more newline characters), the entire format specifier
  977. is repeatedly filled as a unit, until all block fields have consumed
  978. their corresponding arguments. For example, to build a simple
  979. look-up table:
  980.  
  981.         my @values   = (1..12);
  982.  
  983.         my @squares  = map { sprintf "%.6g", $_**2    } @values;
  984.         my @roots    = map { sprintf "%.6g", sqrt($_) } @values;
  985.         my @logs     = map { sprintf "%.6g", log($_)  } @values;
  986.         my @inverses = map { sprintf "%.6g", 1/$_     } @values;
  987.  
  988.         print form
  989.         "  N      N**2    sqrt(N)      log(N)      1/N",
  990.         "=====================================================",
  991.         "| [[  |  [[[  |  [[[[[[[[[[ | [[[[[[[[[ | [[[[[[[[[ |
  992.         -----------------------------------------------------",
  993.         \@values, \@squares, \@roots, \@logs, \@inverses;
  994.  
  995. The multiline format specifier:
  996.  
  997.         "| [[  |  [[[  |  [[[[[[[[[[ | [[[[[[[[[ | [[[[[[[[[ |
  998.         -----------------------------------------------------",
  999.  
  1000. is treated as a single logical line. So C<form> alternately fills the
  1001. first physical line (interpolating one value from each of the arrays)
  1002. and the second physical line (which puts a line of dashes between each
  1003. row of the table) producing:
  1004.  
  1005.           N      N**2    sqrt(N)      log(N)      1/N
  1006.         =====================================================
  1007.         | 1   |  1    |  1          | 0         | 1         |
  1008.         -----------------------------------------------------
  1009.         | 2   |  4    |  1.41421    | 0.693147  | 0.5       |
  1010.         -----------------------------------------------------
  1011.         | 3   |  9    |  1.73205    | 1.09861   | 0.333333  |
  1012.         -----------------------------------------------------
  1013.         | 4   |  16   |  2          | 1.38629   | 0.25      |
  1014.         -----------------------------------------------------
  1015.         | 5   |  25   |  2.23607    | 1.60944   | 0.2       |
  1016.         -----------------------------------------------------
  1017.         | 6   |  36   |  2.44949    | 1.79176   | 0.166667  |
  1018.         -----------------------------------------------------
  1019.         | 7   |  49   |  2.64575    | 1.94591   | 0.142857  |
  1020.         -----------------------------------------------------
  1021.         | 8   |  64   |  2.82843    | 2.07944   | 0.125     |
  1022.         -----------------------------------------------------
  1023.         | 9   |  81   |  3          | 2.19722   | 0.111111  |
  1024.         -----------------------------------------------------
  1025.         | 10  |  100  |  3.16228    | 2.30259   | 0.1       |
  1026.         -----------------------------------------------------
  1027.         | 11  |  121  |  3.31662    | 2.3979    | 0.0909091 |
  1028.         -----------------------------------------------------
  1029.         | 12  |  144  |  3.4641     | 2.48491   | 0.0833333 |
  1030.         -----------------------------------------------------
  1031.  
  1032. This implies that formats and the variables from which they're filled
  1033. need to be interleaved. That is, a multi-line specification like this:
  1034.  
  1035.         print form
  1036.         "Passed:                      ##
  1037.            [[[[[[[[[[[[[[[             # single format specification
  1038.         Failed:                        # (needs two sets of data)
  1039.            [[[[[[[[[[[[[[[",          ##
  1040.  
  1041.         \@passes, \@fails;            ##  data for previous format
  1042.  
  1043. would print:
  1044.  
  1045.         Passed:
  1046.            <pass 1>
  1047.         Failed:
  1048.            <fail 1>
  1049.         Passed:
  1050.            <pass 2>
  1051.         Failed:
  1052.            <fail 2>
  1053.         Passed:
  1054.            <pass 3>
  1055.         Failed:
  1056.            <fail 3>
  1057.  
  1058. because the four-line format specifier is treated as a single unit,
  1059. to be repeatedly filled until all the data in C<@passes> and C<@fails>
  1060. has been consumed.
  1061.  
  1062. Unlike the table example, where this unit filling correctly put a
  1063. line of dashes between lines of data, in this case the alternation of passes
  1064. and fails is probably I<not> the desired effect.
  1065.  
  1066. Judging by the labels, it is far more likely that the user wanted:
  1067.  
  1068.         Passed:
  1069.            <pass 1>
  1070.            <pass 2>
  1071.            <pass 3>
  1072.         Failed:
  1073.            <fail 4>
  1074.            <fail 5>
  1075.            <fail 6>
  1076.  
  1077. To achieve that, either explicitly interleave the formats and their data
  1078. sources:
  1079.  
  1080.         print form
  1081.         "Passed:",               ## single format (no data required)
  1082.         "   [[[[[[[[[[[[[[[",    ## single format (needs one set of data)
  1083.             \@passes,            ## data for previous format
  1084.         "Failed:",               ## single format (no data required)
  1085.         "   [[[[[[[[[[[[[[[",    ## single format (needs one set of data)
  1086.             \@fails;             ## data for previous format
  1087.  
  1088.  
  1089. or instruct C<form> to do it for you automagically, by setting the
  1090. 'interleave' flag true:
  1091.  
  1092.         print form {interleave=>1}
  1093.         "Passed:                 ##
  1094.            [[[[[[[[[[[[[[[        # single format
  1095.         Failed:                   # (needs two sets of data)
  1096.            [[[[[[[[[[[[[[[",     ##
  1097.  
  1098.                                  ## data to be automagically interleaved
  1099.         \@passes, \@fails;        # as necessary between lines of previous
  1100.                                  ## format
  1101.  
  1102.  
  1103. =head2 How C<form> hyphenates
  1104.  
  1105. Any line with a block field repeats on subsequent lines until all block fields
  1106. on that line have consumed all their data. Non-block fields on these lines are
  1107. replaced by the appropriate number of spaces.
  1108.  
  1109. Words are wrapped whole, unless they will not fit into the field at
  1110. all, in which case they are broken and (by default) hyphenated. Simple
  1111. hyphenation is used (i.e. break at the I<N-1>th character and insert a
  1112. '-'), unless a suitable alternative subroutine is specified instead.
  1113.  
  1114. Words will not be broken if the break would leave less than 2 characters on
  1115. the current line. This minimum can be varied by setting the 'minbreak' option
  1116. to a numeric value indicating the minumum total broken characters (including
  1117. hyphens) required on the current line. Note that, for very narrow fields,
  1118. words will still be broken (but I<unhyphenated>). For example:
  1119.  
  1120.         print form '~', 'split';
  1121.  
  1122. would print:
  1123.  
  1124.         s
  1125.         p
  1126.         l
  1127.         i
  1128.         t
  1129.  
  1130. whilst:
  1131.  
  1132.         print form {minbreak=>1}, '~', 'split';
  1133.  
  1134. would print:
  1135.  
  1136.         s-
  1137.         p-
  1138.         l-
  1139.         i-
  1140.         t
  1141.  
  1142. Alternative breaking subroutines can be specified using the "break" option in a
  1143. configuration hash. For example:
  1144.  
  1145.         form { break => \&my_line_breaker }
  1146.              $format_str,
  1147.              @data;
  1148.  
  1149. C<form> expects any user-defined line-breaking subroutine to take three
  1150. arguments (the string to be broken, the maximum permissible length of
  1151. the initial section, and the total width of the field being filled).
  1152. The C<hypenate> sub must return a list of two strings: the initial
  1153. (broken) section of the word, and the remainder of the string
  1154. respectively).
  1155.  
  1156. For example:
  1157.  
  1158.         sub tilde_break = sub($$$)
  1159.         {
  1160.                 (substr($_[0],0,$_[1]-1).'~', substr($_[0],$_[1]-1));
  1161.         }
  1162.  
  1163.         form { break => \&tilde_break }
  1164.              $format_str,
  1165.              @data;
  1166.  
  1167.  
  1168. makes '~' the hyphenation character, whilst:
  1169.  
  1170.         sub wrap_and_slop = sub($$$)
  1171.         {
  1172.                 my ($text, $reqlen, $fldlen) = @_;
  1173.                 if ($reqlen==$fldlen) { $text =~ m/\A(\s*\S*)(.*)/s }
  1174.                 else                  { ("", $text) }
  1175.         }
  1176.  
  1177.         form { break => \&wrap_and_slop }
  1178.              $format_str,
  1179.              @data;
  1180.  
  1181. wraps excessively long words to the next line and "slops" them over
  1182. the right margin if necessary.
  1183.  
  1184. The Text::Reform package provides three functions to simplify the use
  1185. of variant hyphenation schemes. The exportable subroutine
  1186. C<Text::Reform::break_wrap> generates a reference to a subroutine
  1187. implementing the "wrap-and-slop" algorithm shown in the last example,
  1188. which could therefore be rewritten:
  1189.  
  1190.         use Text::Reform qw( form break_wrap );
  1191.  
  1192.         form { break => break_wrap }
  1193.              $format_str,
  1194.              @data;
  1195.  
  1196. The subroutine C<Text::Reform::break_with> takes a single string
  1197. argument and returns a reference to a sub which hyphenates by cutting 
  1198. off the text at the right margin and appending the string argument.
  1199. Hence the first of the two examples could be rewritten:
  1200.  
  1201.         use Text::Reform qw( form break_with );
  1202.  
  1203.         form { break => break_with('~') }
  1204.              $format_str,
  1205.              @data;
  1206.  
  1207. The subroutine C<Text::Reform::break_at> takes a single string
  1208. argument and returns a reference to a sub which hyphenates by
  1209. breaking immediately after that string. For example:
  1210.  
  1211.         use Text::Reform qw( form break_at );
  1212.  
  1213.         form { break => break_at('-') }
  1214.                "[[[[[[[[[[[[[[",
  1215.            "The Newton-Raphson methodology";
  1216.  
  1217.     # returns:
  1218.     #
  1219.     #       "The Newton-
  1220.     #        Raphson 
  1221.     #        methodology"
  1222.  
  1223. Note that this differs from the behaviour of C<break_with>, which
  1224. would be:
  1225.  
  1226.         form { break => break_with('-') }
  1227.                "[[[[[[[[[[[[[[",
  1228.            "The Newton-Raphson methodology";
  1229.  
  1230.     # returns:
  1231.     #
  1232.     #       "The Newton-R-
  1233.     #        aphson metho-
  1234.     #        dology"
  1235.  
  1236. Hence C<break_at> is generally a better choice.
  1237.  
  1238. The subroutine C<Text::Reform::break_TeX> 
  1239. returns a reference to a sub which hyphenates using 
  1240. Jan Pazdziora's TeX::Hyphen module. For example:
  1241.  
  1242.         use Text::Reform qw( form break_wrap );
  1243.  
  1244.         form { break => break_TeX }
  1245.              $format_str,
  1246.              @data;
  1247.  
  1248. Note that in the previous examples there is no leading '\&' before
  1249. C<break_wrap>, C<break_with>, or C<break_TeX>, since each is being
  1250. directly I<called> (and returns a reference to some other suitable
  1251. subroutine);
  1252.  
  1253.  
  1254. =head2 The C<form> formatting algorithm
  1255.  
  1256. The algorithm C<form> uses is:
  1257.  
  1258.         1. If interleaving is specified, split the first string in the
  1259.            argument list into individual format lines and add a
  1260.            terminating newline (unless one is already present).
  1261.            Otherwise, treat the entire string as a single "line" (like
  1262.            /s does in regexes)
  1263.  
  1264.         2. For each format line...
  1265.  
  1266.                 2.1. determine the number of fields and shift
  1267.                      that many values off the argument list and
  1268.                      into the filling list. If insufficient
  1269.                      arguments are available, generate as many
  1270.                      empty strings as are required.
  1271.  
  1272.                 2.2. generate a text line by filling each field
  1273.                      in the format line with the initial contents
  1274.                      of the corresponding arg in the filling list
  1275.                      (and remove those initial contents from the arg).
  1276.  
  1277.                 2.3. replace any <,>, or ^ fields by an equivalent
  1278.                      number of spaces. Splice out the corresponding
  1279.                      args from the filling list.
  1280.  
  1281.                 2.4. Repeat from step 2.2 until all args in the
  1282.                      filling list are empty.
  1283.  
  1284.         3. concatenate the text lines generated in step 2
  1285.  
  1286.         4. repeat from step 1 until the argument list is empty
  1287.  
  1288.  
  1289. =head2 C<form> examples
  1290.  
  1291. As an example of the use of C<form>, the following:
  1292.  
  1293.         $count = 1;
  1294.         $text = "A big long piece of text to be formatted exquisitely";
  1295.  
  1296.         print form q
  1297.         q{       ||||  <<<<<<<<<<   },
  1298.         $count, $text,
  1299.         q{       ----------------   },
  1300.         q{       ^^^^  ]]]]]]]]]]|  },
  1301.         $count+11, $text,
  1302.         q{                       =
  1303.                  ]]].[[[            },
  1304.         "123 123.4\n123.456789";
  1305.  
  1306. produces the following output:
  1307.  
  1308.                  1    A big long
  1309.                 ----------------
  1310.                  12     piece of|
  1311.                       text to be|
  1312.                        formatted|
  1313.                       exquisite-|
  1314.                               ly|
  1315.                                 =
  1316.                 123.0
  1317.                                 =
  1318.                 123.4
  1319.                                 =
  1320.                 123.456
  1321.  
  1322. Note that block fields in a multi-line format string,
  1323. cause the entire multi-line format to be repeated as
  1324. often as necessary.
  1325.  
  1326. Picture strings and replacement values are interleaved in the
  1327. traditional C<format> format, but care is needed to ensure that the
  1328. correct number of substitution values are provided. Another
  1329. example:
  1330.  
  1331.         $report = form
  1332.                 'Name           Rank    Serial Number',
  1333.                 '====           ====    =============',
  1334.                 '<<<<<<<<<<<<<  ^^^^    <<<<<<<<<<<<<',
  1335.                  $name,         $rank,  $serial_number,
  1336.                 ''
  1337.                 'Age    Sex     Description',
  1338.                 '===    ===     ===========',
  1339.                 '^^^    ^^^     [[[[[[[[[[[',
  1340.                  $age,  $sex,   $description;
  1341.  
  1342.  
  1343. =head2 How C<form> consumes strings
  1344.  
  1345. Unlike C<format>, within C<form> non-block fields I<do> consume the text
  1346. they format, so the following:
  1347.  
  1348.         $text = "a line of text to be formatted over three lines";
  1349.         print form "<<<<<<<<<<\n  <<<<<<<<\n    <<<<<<\n",
  1350.                     $text,        $text,        $text;
  1351.  
  1352. produces:
  1353.  
  1354.         a line of
  1355.           text to
  1356.             be fo-
  1357.  
  1358. not:
  1359.  
  1360.         a line of
  1361.           a line
  1362.             a line
  1363.  
  1364. To achieve the latter effect, convert the variable arguments
  1365. to independent literals (by double-quoted interpolation):
  1366.  
  1367.         $text = "a line of text to be formatted over three lines";
  1368.         print form "<<<<<<<<<<\n  <<<<<<<<\n    <<<<<<\n",
  1369.                    "$text",      "$text",      "$text";
  1370.  
  1371. Although values passed from variable arguments are progressively consumed
  1372. I<within> C<form>, the values of the original variables passed to C<form>
  1373. are I<not> altered.  Hence:
  1374.  
  1375.         $text = "a line of text to be formatted over three lines";
  1376.         print form "<<<<<<<<<<\n  <<<<<<<<\n    <<<<<<\n",
  1377.                     $text,        $text,        $text;
  1378.         print $text, "\n";
  1379.  
  1380. will print:
  1381.  
  1382.         a line of
  1383.           text to
  1384.             be fo-
  1385.         a line of text to be formatted over three lines
  1386.  
  1387. To cause C<form> to consume the values of the original variables passed to
  1388. it, pass them as references. Thus:
  1389.  
  1390.         $text = "a line of text to be formatted over three lines";
  1391.         print form "<<<<<<<<<<\n  <<<<<<<<\n    <<<<<<\n",
  1392.                     \$text,       \$text,       \$text;
  1393.         print $text, "\n";
  1394.  
  1395. will print:
  1396.  
  1397.         a line of
  1398.           text to
  1399.             be fo-
  1400.         rmatted over three lines
  1401.  
  1402. Note that, for safety, the "non-consuming" behaviour takes precedence,
  1403. so if a variable is passed to C<form> both by reference I<and> by value,
  1404. its final value will be unchanged.
  1405.  
  1406. =head2 Numerical formatting
  1407.  
  1408. The ">>>.<<<" and "]]].[[[" field specifiers may be used to format
  1409. numeric values about a fixed decimal place marker. For example:
  1410.  
  1411.         print form '(]]]]].[[)', <<EONUMS;
  1412.                    1
  1413.                    1.0
  1414.                    1.001
  1415.                    1.009
  1416.                    123.456
  1417.                    1234567
  1418.                    one two
  1419.         EONUMS
  1420.  
  1421. would print:
  1422.  
  1423.         (    1.0 )
  1424.         (    1.0 )
  1425.         (    1.00)
  1426.         (    1.01)
  1427.         (  123.46)
  1428.         (#####.##)
  1429.         (?????.??)
  1430.         (?????.??)
  1431.  
  1432. Fractions are rounded to the specified number of places after the
  1433. decimal, but only significant digits are shown. That's why, in the
  1434. above example, 1 and 1.0 are formatted as "1.0", whilst 1.001 is
  1435. formatted as "1.00".
  1436.  
  1437. You can specify that the maximal number of decimal places always be used
  1438. by giving the configuration option 'numeric' a value that matches
  1439. /\bAllPlaces\b/i. For example:
  1440.  
  1441.         print form { numeric => AllPlaces },
  1442.                    '(]]]]].[[)', <<'EONUMS';
  1443.                    1
  1444.                    1.0
  1445.         EONUMS
  1446.  
  1447. would print:
  1448.  
  1449.         (    1.00)
  1450.         (    1.00)
  1451.  
  1452. Note that although decimal digits are rounded to fit the specified width, the
  1453. integral part of a number is never modified. If there are not enough places
  1454. before the decimal place to represent the number, the entire number is
  1455. replaced with hashes.
  1456.  
  1457. If a non-numeric sequence is passed as data for a numeric field, it is
  1458. formatted as a series of question marks. This querulous behaviour can be
  1459. changed by giving the configuration option 'numeric' a value that
  1460. matches /\bSkipNaN\b/i in which case, any invalid numeric data is simply
  1461. ignored. For example:
  1462.  
  1463.  
  1464.         print form { numeric => 'SkipNaN' }
  1465.                    '(]]]]].[[)',
  1466.                    <<EONUMS;
  1467.                    1
  1468.                    two three
  1469.                    4
  1470.         EONUMS
  1471.  
  1472. would print:
  1473.  
  1474.         (    1.0 )
  1475.         (    4.0 )
  1476.  
  1477.  
  1478. =head2 Filling block fields with lists of values
  1479.  
  1480. If an argument corresponding to a field is an array reference, then C<form>
  1481. automatically joins the elements of the array into a single string, separating
  1482. each element with a newline character. As a result, a call like this:
  1483.  
  1484.         @values = qw( 1 10 100 1000 );
  1485.         print form "(]]]].[[)", \@values;
  1486.  
  1487. will print out
  1488.  
  1489.          (   1.00)
  1490.          (  10.00)
  1491.          ( 100.00)
  1492.          (1000.00)
  1493.  
  1494. as might be expected.
  1495.  
  1496. Note however that arrays must be passed by reference (so that C<form>
  1497. knows that the entire array holds data for a single field). If the previous
  1498. example had not passed @values by reference:
  1499.  
  1500.         @values = qw( 1 10 100 1000 );
  1501.         print form "(]]]].[[)", @values;
  1502.  
  1503. the output would have been:
  1504.  
  1505.          (   1.00)
  1506.          10
  1507.          100
  1508.          1000
  1509.  
  1510. This is because @values would have been interpolated into C<form>'s
  1511. argument list, so only $value[0] would have been used as the data for
  1512. the initial format string. The remaining elements of @value would have
  1513. been treated as separate format strings, and printed out "verbatim".
  1514.  
  1515. Note too that, because arrays must be passed using a reference, their
  1516. original contents are consumed by C<form>, just like the contents of
  1517. scalars passed by reference.
  1518.  
  1519. To avoid having an array consumed by C<form>, pass it as an anonymous
  1520. array:
  1521.  
  1522.         print form "(]]]].[[)", [@values];
  1523.  
  1524.  
  1525. =head2 Headers, footers, and pages
  1526.  
  1527. The C<form> subroutine can also insert headers, footers, and page-feeds
  1528. as it formats. These features are controlled by the "header", "footer",
  1529. "pagefeed", "pagelen", and "pagenum" options.
  1530.  
  1531. The "pagenum" option takes a scalar value or a reference to a scalar
  1532. variable and starts page numbering at that value. If a reference to a
  1533. scalar variable is specified, the value of that variable is updated as
  1534. the formatting proceeds, so that the final page number is available in
  1535. it after formatting. This can be useful for multi-part reports.
  1536.  
  1537. The "pagelen" option specifies the total number of lines in a page (including
  1538. headers, footers, and page-feeds).
  1539.  
  1540. The "pagewidth" option specifies the total number of columns in a page.
  1541.  
  1542. If the "header" option is specified with a string value, that string is
  1543. used as the header of every page generated. If it is specified as a reference
  1544. to a subroutine, that subroutine is called at the start of every page and
  1545. its return value used as the header string. When called, the subroutine is
  1546. passed the current page number.
  1547.  
  1548. Likewise, if the "footer" option is specified with a string value, that
  1549. string is used as the footer of every page generated. If it is specified
  1550. as a reference to a subroutine, that subroutine is called at the I<start>
  1551. of every page and its return value used as the footer string. When called,
  1552. the footer subroutine is passed the current page number.
  1553.  
  1554. Both the header and footer options can also be specified as hash references.
  1555. In this case the hash entries for keys "left", "centre" (or "center"), and
  1556. "right" specify what is to appear on the left, centre, and right of the
  1557. header/footer. The entry for the key "width" specifies how wide the
  1558. footer is to be. If the "width" key is omitted, the "pagewidth" configuration
  1559. option (which defaults to 72 characters) is used.
  1560.  
  1561. The  "left", "centre", and "right" values may be literal
  1562. strings, or subroutines (just as a normal header/footer specification may
  1563. be.) See the second example, below.
  1564.  
  1565. Another alternative for header and footer options is to specify them as a
  1566. subroutine that returns a hash reference. The subroutine is called for each
  1567. page, then the resulting hash is treated like the hashes described in the
  1568. preceding paragraph. See the third example, below.
  1569.  
  1570. The "pagefeed" option acts in exactly the same way, to produce a
  1571. pagefeed which is appended after the footer. But note that the pagefeed
  1572. is not counted as part of the page length.
  1573.  
  1574. All three of these page components are recomputed at the start of each
  1575. new page, before the page contents are formatted (recomputing the header
  1576. and footer first makes it possible to determine how many lines of data to
  1577. format so as to adhere to the specified page length).
  1578.  
  1579. When the call to C<form> is complete and the data has been fully formatted,
  1580. the footer subroutine is called one last time, with an extra argument of 1.
  1581. The string returned by this final call is used as the final footer.
  1582.  
  1583. So for example, a 60-line per page report, starting at page 7,
  1584. with appropriate headers and footers might be set up like so:
  1585.  
  1586.         $page = 7;
  1587.  
  1588.         form { header => sub { "Page $_[0]\n\n" },
  1589.                footer => sub { my ($pagenum, $lastpage) = @_;
  1590.                                return "" if $lastpage;
  1591.                                return "-"x50 . "\n"
  1592.                                              .form ">"x50, "...".($pagenum+1);
  1593.                               },
  1594.                pagefeed => "\n\n",
  1595.                pagelen  => 60
  1596.                pagenum => \$page,
  1597.              },
  1598.              $template,
  1599.              @data;
  1600.  
  1601. Note the recursive use of C<form> within the "footer" option!
  1602.  
  1603. Alternatively, to set up headers and footers such that the running
  1604. head is right justified in the header and the page number is centred
  1605. in the footer:
  1606.  
  1607.         form { header => { right => "Running head" },
  1608.                footer => { centre => sub { "Page $_[0]" } },
  1609.                pagelen  => 60
  1610.              },
  1611.              $template,
  1612.              @data;
  1613.  
  1614. The footer in the previous example could also have been specified the other
  1615. way around, as a subroutine that returns a hash (rather than a hash containing
  1616. a subroutine):
  1617.  
  1618.         form { header => { right => "Running head" },
  1619.                footer => sub { return {centre => "Page $_[0]"} },
  1620.                pagelen  => 60
  1621.              },
  1622.              $template,
  1623.              @data;
  1624.  
  1625.  
  1626. =head2 The C<cols> option
  1627.  
  1628. Sometimes data to be used in a C<form> call needs to be extracted from a
  1629. nested data structure. For example, whilst it's easy to print a table if
  1630. you already have the data in columns:
  1631.  
  1632.         @name  = qw(Tom Dick Harry);
  1633.         @score = qw( 88   54    99);
  1634.         @time  = qw( 15   13    18);
  1635.  
  1636.         print form
  1637.         '-------------------------------',
  1638.         'Name             Score     Time',
  1639.         '-------------------------------',
  1640.         '[[[[[[[[[[[[[[   |||||     ||||',
  1641.          \@name,          \@score,  \@time;
  1642.  
  1643.  
  1644. if the data is aggregrated by rows:
  1645.  
  1646.         @data = (
  1647.             { name=>'Tom',   score=>88, time=>15 },
  1648.             { name=>'Dick',  score=>54, time=>13 },
  1649.             { name=>'Harry', score=>99, time=>18 },
  1650.         );
  1651.  
  1652. you need to do some fancy mapping before it can be fed to C<form>:
  1653.  
  1654.         print form
  1655.         '-------------------------------',
  1656.         'Name             Score     Time',
  1657.         '-------------------------------',
  1658.         '[[[[[[[[[[[[[[   |||||     ||||',
  1659.         [map $$_{name},  @data],
  1660.         [map $$_{score}, @data],
  1661.         [map $$_{time} , @data];
  1662.  
  1663. Or you could just use the C<'cols'> option:
  1664.  
  1665.         use Text::Reform qw(form columns);
  1666.  
  1667.         print form
  1668.         '-------------------------------',
  1669.         'Name             Score     Time',
  1670.         '-------------------------------',
  1671.         '[[[[[[[[[[[[[[   |||||     ||||',
  1672.         { cols => [qw(name score time)],
  1673.           from => \@data
  1674.         };
  1675.  
  1676. This option takes an array of strings that specifies the keys of the
  1677. hash entries to be extracted into columns. The C<'from'> entry (which
  1678. must be present) also takes an array, which is expected to contain a
  1679. list of references to hashes. For each key specified, this option
  1680. inserts into C<form>'s argument list a reference to an array containing
  1681. the entries for that key, extracted from each of the hash references
  1682. supplied by C<'from'>. So, for example, the option:
  1683.  
  1684.         { cols => [qw(name score time)],
  1685.           from => \@data
  1686.         }
  1687.  
  1688. is replaced by three array references, the first containing the C<'name'>
  1689. entries for each hash inside C<@data>, the second containing the
  1690. C<'score'> entries for each hash inside C<@data>, and the third
  1691. containing the C<'time'> entries for each hash inside C<@data>.
  1692.  
  1693. If, instead, you have a list of arrays containing the data:
  1694.  
  1695.         @data = (
  1696.                 # Time  Name     Score
  1697.                 [ 15,   'Tom',   88 ],
  1698.                 [ 13,   'Dick',  54 ],
  1699.                 [ 18,   'Harry', 99 ],
  1700.         );
  1701.  
  1702. the C<'cols'> option can extract the appropriate columns for that too. You
  1703. just specify the required indices, rather than keys:
  1704.  
  1705.         print form
  1706.         '-----------------------------',   
  1707.         'Name             Score   Time',   
  1708.         '-----------------------------',   
  1709.         '[[[[[[[[[[[[[[   |||||   ||||',
  1710.         { cols => [1,2,0],
  1711.           from => \@data
  1712.         }
  1713.  
  1714. Note that the indices can be in any order, and the resulting arrays are
  1715. returned in the same order.
  1716.  
  1717. If you need to merge columns extracted from two hierarchical 
  1718. data structures, just concatenate the data structures first,
  1719. like so:
  1720.  
  1721.         print form
  1722.         '---------------------------------------',   
  1723.         'Name             Score   Time   Ranking
  1724.         '---------------------------------------',   
  1725.         '[[[[[[[[[[[[[[   |||||   ||||   |||||||',
  1726.         { cols => [1,2,0],
  1727.           from => [@data, @olddata],
  1728.         }
  1729.  
  1730. Of course, this only works if the columns are in the same positions in
  1731. both data sets (and both datasets are stored in arrays) or if the
  1732. columns have the same keys (and both datasets are in hashes). If not,
  1733. you would need to format each dataset separately, like so:
  1734.  
  1735.         print form
  1736.         '-----------------------------',   
  1737.         'Name             Score   Time'
  1738.         '-----------------------------',   
  1739.         '[[[[[[[[[[[[[[   |||||   ||||',
  1740.         { cols=>[1,2,0],  from=>\@data },
  1741.         '[[[[[[[[[[[[[[   |||||   ||||',
  1742.         { cols=>[3,8,1],  from=>\@olddata },
  1743.         '[[[[[[[[[[[[[[   |||||   ||||',
  1744.         { cols=>[qw(name score time)],  from=>\@otherdata };
  1745.  
  1746.  
  1747. =head2 The C<tag> sub
  1748.  
  1749. The C<tag> subroutine may be exported from the module.
  1750. It takes two arguments: a tag specifier and a text to be
  1751. entagged. The tag specifier indicates the indenting of the tag, and of the
  1752. text. The sub generates an end-tag (using the usual "/I<tag>" variant),
  1753. unless an explicit end-tag is provided as the third argument.
  1754.  
  1755. The tag specifier consists of the following components (in order):
  1756.  
  1757. =over 4
  1758.  
  1759. =item An optional vertical spacer (zero or more whitespace-separated newlines)
  1760.  
  1761. One or more whitespace characters up to a final mandatory newline. This
  1762. vertical space is inserted before the tag and after the end-tag
  1763.  
  1764. =item An optional tag indent
  1765.  
  1766. Zero or more whitespace characters. Both the tag and the end-tag are indented
  1767. by this whitespace.
  1768.  
  1769. =item An optional left (opening) tag delimiter
  1770.  
  1771. Zero or more non-"word" characters (not alphanumeric or '_').
  1772. If the opening delimiter is omitted, the character '<' is used.
  1773.  
  1774. =item A tag
  1775.  
  1776. One or more "word" characters (alphanumeric or '_').
  1777.  
  1778. =item Optional tag arguments
  1779.  
  1780. Any number of any characters
  1781.  
  1782. =item An optional right (closing) tag delimiter
  1783.  
  1784. Zero or more non-"word" characters which balance some sequential portion
  1785. of the opening tag delimiter. For example, if the opening delimiter
  1786. is "<-(" then any of the following are acceptible closing delimiters:
  1787. ")->", "->", or ">".
  1788. If the closing delimiter is omitted, the "inverse" of the opening delimiter
  1789. is used (for example, ")->"),
  1790.  
  1791. =item An optional vertical spacer (zero or more newlines)
  1792.  
  1793. One or more whitespace characters up to a mandatory newline. This
  1794. vertical space is inserted before and after the complete text.
  1795.  
  1796. =item An optional text indent
  1797.  
  1798. Zero or more space of tab characters. Each line of text is indented
  1799. by this whitespace (in addition to the tag indent).
  1800.  
  1801.  
  1802. =back
  1803.  
  1804. For example:
  1805.  
  1806.         $text = "three lines\nof tagged\ntext";
  1807.  
  1808.         print tag "A HREF=#nextsection", $text;
  1809.  
  1810. prints:
  1811.  
  1812.         <A HREF=#nextsection>three lines
  1813.         of tagged
  1814.         text</A>
  1815.  
  1816. whereas:
  1817.  
  1818.         print tag "[-:GRIN>>>\n", $text;
  1819.  
  1820. prints:
  1821.  
  1822.         [-:GRIN>>>:-]
  1823.         three lines
  1824.         of tagged
  1825.         text
  1826.         [-:/GRIN>>>:-]
  1827.  
  1828. and:
  1829.  
  1830.         print tag "\n\n   <BOLD>\n\n   ", $text, "<END BOLD>";
  1831.  
  1832. prints:
  1833.  
  1834. S< >
  1835.  
  1836.            <BOLD>
  1837.  
  1838.               three lines
  1839.               of tagged
  1840.               text
  1841.  
  1842.            <END BOLD>
  1843.  
  1844. S< >
  1845.  
  1846. (with the indicated spacing fore and aft).
  1847.  
  1848. =head1 AUTHOR
  1849.  
  1850. Damian Conway (damian@conway.org)
  1851.  
  1852. =head1 BUGS
  1853.  
  1854. There are undoubtedly serious bugs lurking somewhere in code this funky :-)
  1855. Bug reports and other feedback are most welcome.
  1856.  
  1857. =head1 COPYRIGHT
  1858.  
  1859. Copyright (c) 1997-2000, Damian Conway. All Rights Reserved.
  1860. This module is free software. It may be used, redistributed
  1861. and/or modified under the terms of the Perl Artistic License
  1862.   (see http://www.perl.com/perl/misc/Artistic.html)
  1863.