#! /usr/bin/perl
$RCS_ID = '$Id: reporttbl,v 2.1 1992/06/16 09:22:03 hobbs Exp $';
($pgm  = $0) =~ s-.*/-- ;
$HelpInfo = <<EOH ;

	    RDB operator: $pgm

Usage:  $pgm  [options]  file.frm

Options:
    -help    Print this help info.
    -pN      Page size in of N lines. Default is 60 lines.
	     A value of zero '-p0' will turn paging off.

Formats and prints an arbitrary style report, as specified in the file
"file.frm". An (optional) page header may be specified.

The format of "file.frm" is similar to a PERL format, except that column
names are used (without commas) instead of variable names. Also the
special names "_pgnr_" and "_date_" may be used to have the page number
and current date inserted into the output. Example:

format top =
Page @>,		Any Page Header     @<<<<<<<<<<<<<<<<<<<<<<<<<<<
   _pgnr_ 					_date_
.
format =
    Name:   @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<   Type:  @>>>>>>>>>>>>>>>
		NAME					   TYP
    Amt:    @<<<<<<<<<<<<<<   Comment:  ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
		AMT			   COMMENT
.
Note that the picture field for "Comment:" start with a '^' char so it
will be repeated as necessary in order to print the entire data value.

This RDB operator reads an rdbtable from STDIN and writes a formatted report
on STDOUT. Options may be abbreviated.

$RCS_ID
EOH
$: = "\n " ;	# default line break list (white space)
$frm = "frm01" ;
$tmp = "tmp01" ;
while ( $ARGV[0] =~ /^-/ ) {				# Get args
    $_ = shift ;
    if( /-p(\d+)/ ){ $= = $1 ; next ; }	# page size
    if( /-h.*/ ){ print $HelpInfo ; exit; }
    if( /-x.*/ ){ $XBUG++ ; next ; }	# debug
    die "Bad arg: $_\n", $HelpInfo ;
}
die "No form file given.\n", $HelpInfo if ! @ARGV ;
open( FRM, $ARGV[0] ) || die "Can't open $ARGV[0]\n" ;

$date = `date` ;
while(<STDIN>){			# pass header
    if( /^#\s|^\s+#/ && ! $lln ){	# comment 
	next ; }
    chop ;
    if( ++$lln == 1 ){
	@H = split( /\t/, $_ ) ; } # save column names
    last if $lln == 2 ;
}
while(<FRM>){
    if( /^\s*format/i ){	# format line
	$inform++ ;
	if( /^\s*format\s+=/i ){	# main format
	    s/=/$frm =/ ;	# chg format name
	    $inform++ ;
	    $pmin = 0 ;			# init $pmin
	    $xcode = "\$~ = $frm ;\n" ;	# init $xcode
	    $xcode .= "    \$- = 0 if \$- < \$pmin ;\n" ;
	    $frm++ ; }
	push( @frm, $_ ) ;
	next ; }
    if( ! $inform ){		# not in a format section
	$inform++ ;
	push( @frm, "format $frm =\n" ) ;
	$xcode .= "    \$~ = $frm ;\n" ;
	$frm++ ; }
    if( /^\./ ){		# end format line
	if( ! $longfld ){
	    $xcode .= "    write ;" ; }
	$inform = 0 ; }
    push( @frm, $_ ) ;
    $pmin++ if $inform ;
    next if ! /[@\^]/ ;		# no pic fields in line
    $picln = $_ ;
    @p = split(' ') ;
    $_ = <FRM> ;		# column names
    @c = split(' ') ;
    for( $i=0; $i <= $#c ; $i++ ){	# chk for cmds w/ spaces
	if( $c[$i] =~ /^[_\`]/ && $c[$i] !~ /[_\`]$/ ){
	    for( $x = "", $j=$i; $j <= $#c ; $j++ ){
		if( $c[$j] =~ /[_\`]$/ ){
		    $x .= $c[$j] . " ";
		    splice( @c, $i, $j-$i, $x ) ;
		    last ; }
		else{
		    $x .= $c[$j] . " "; }
	    }
	}
    }
    $vvln = $exp = $init = $longfld = $notfst = $vln = "" ;
    for $pic (@p){		# process words in pic line
	next if $pic !~ /^[@\^]/ ;
	$vln .= ", " if $notfst++ ;
	if( $pic =~ /^@/ ){			# fixed field
	    $vln .= &convar( shift( @c )) ;	# variable names on line
	    next ; }
	$longfld++ ;			# long field
	$vln .= "\$$tmp" ;	# variable line for @frm
	if( $init++ ){
	    $vvln .= ", " ;
	    $exp .= " || " ; }
	$vvln .= "\$$tmp" ;	# 2nd variable line for @frm
	$v = &convar( shift( @c )) ;
	$xcode .= "    \$$tmp = $v ;\n" ;	# move to scalar
	$exp .= "\$$tmp" ;			# expression
	$tmp++ ;
    }
    push( @frm, $vln . "\n" ) ;			# add to @frm
    next if ! $longfld ;	# long field stuff below ...
    push( @frm, ".\nformat $frm =\n" ) ;
    @a = split( //, $picln ) ;
    $savf = 0 ;
    for ( @a ){			# gen new line with only long fields
	if( ! /\^/ && ! $savf ){
	    $_ = ' ' ;
	    next ; }
	$savf++ ;
	next if m-[\^<|>]- ;
	$savf = 0 ;
	$_ = ' ' ; }
    $picln = join( '', @a ) ;
    push( @frm, $picln, "\n" ) ;
    push( @frm, $vvln, "\n.\n" ) ;
    $inform = 0 ;
    $xcode .= <<EOF ;		# finish $xcode
    write ;
    \$~ = $frm ;
    while( $exp ){ write ; }
EOF
    $frm++ ;
    $longfld = 0 ;
}
$" = "" ;
$fcode = <<EOF ;	# build main code
@frm
while(<STDIN>){
    chop ;
    \@F = split( /\\t/, \$_ );
    $xcode}
EOF
print $fcode, "\n" if $XBUG ;	# debug
eval $fcode ;		# do the work
print $@ if $@ ;

sub convar {		# convert column name (input) into internal variable
    local( $arg ) = $_[0] ;
    local( $f, $var ) ;
    return '$%' if $arg eq '_pgnr_' ;
    return '$date' if $arg eq '_date_' ;
    return '++$rcnr' if $arg eq '_rcnr_' ;
    if( $arg =~ /^_\`(.+)\`_ *$/ ){	# cmd to execute once
	eval "\$$tmp = `$1`" ;
	$cmd = "\$$tmp" ;
	$tmp++ ;
	return $cmd ; }
    return "$arg" if $arg =~ /^\`.+\`$/ ;	# cmd to execute repeatedly
    for( $f=0 ; $f <= $#H ; $f++ ){
	if( $arg eq $H[$f] ){	# col name trans
	    $arg = '$F[' . $f . ']' ;
	    return $arg ;
	}
    }
    warn "Warning, Bad column name: $arg\n" ;
    return "_BAD_" ;
}
