view release on metacpan or  search on metacpan

script/s2p  view on Meta::CPAN

[TheEnd]

# generate the sed loop
#
$Code .= <<'[TheEnd]';
sub openARGV();
sub getsARGV(;\$);
sub eofARGV();
sub printQ();

# Run: the sed loop reading input and applying the script
#
sub Run(){
    my( $h, $icnt, $s, $n );
    # hack (not unbreakable :-/) to avoid // matching an empty string
    my $z = "\000"; $z =~ /$z/;
    # Initialize.
    openARGV();
    $Hold    = '';
    $CondReg = 0;
    $doPrint = $doAutoPrint;
CYCLE:
    while( getsARGV() ){
	chomp();
	$CondReg = 0;   # cleared on t
BOS:;
[TheEnd]

    # parse - avoid opening files when doing s2p
    #
    ( $svOpenWrite, $doOpenWrite ) = (  $doOpenWrite, $svOpenWrite )
      if $doGenerate;
    Parse();
    ( $svOpenWrite, $doOpenWrite ) = (  $doOpenWrite, $svOpenWrite )
      if $doGenerate;

    # append trailing code
    #
    $Code .= <<'[TheEnd]';
EOS:    if( $doPrint ){
            print $_, "\n";
        } else {
	    $doPrint = $doAutoPrint;
	}
        printQ() if @Q;
    }

    exit( 0 );
}
[TheEnd]


# append optional functions, prepend prototypes
#
my $Proto = "# prototypes\n";
if( $GenKey{'l'} ){
    $Proto .= "sub _l();\n";
    $Func .= <<'[TheEnd]';
# _l: l command processing
#
sub _l(){
    my $h = $_;
    my $mcpl = 70;
    # transform non printing chars into escape notation
    $h =~ s/\\/\\\\/g;
    if( $h =~ /[^[:print:]]/ ){
	$h =~ s/\a/\\a/g;
	$h =~ s/\f/\\f/g;
	$h =~ s/\n/\\n/g;
	$h =~ s/\t/\\t/g;
	$h =~ s/\r/\\r/g;
	$h =~ s/\e/\\e/g;
        $h =~ s/([^[:print:]])/sprintf("\\%03o", ord($1))/ge;
    }
    # split into lines of length $mcpl
    while( length( $h ) > $mcpl ){
	my $l = substr( $h, 0, $mcpl-1 );
	$h = substr( $h, $mcpl );
	# remove incomplete \-escape from end of line
	if( $l =~ s/(?<!\\)(\\[0-7]{0,2})$// ){
	    $h = $1 . $h;
	}
	print $l, "\\\n";
    }
    print "$h\$\n";
}

[TheEnd]
}

if( $GenKey{'r'} ){
    $Proto .= "sub _r(\$);\n";
    $Func .= <<'[TheEnd]';
# _r: r command processing: Save a reference to the pathname.
#
sub _r($){
    my $path = shift();
    push( @Q, \$path );
}

[TheEnd]
}

if( $GenKey{'t'} ){
    $Proto .= "sub _t();\n";
    $Func .= <<'[TheEnd]';
# _t: t command - condition register test/reset
#
sub _t(){
    my $res = $CondReg;
    $CondReg = 0;
    $res;
}

[TheEnd]
}

if( $GenKey{'w'} ){
    $Proto .= "sub _w(\$);\n";
    $Func .= <<'[TheEnd]';
# _w: w command and s command's w flag - write to file
#
sub _w($){
    my $path   = shift();
    my $handle = $wFiles{$path};
    if( ! $doOpenWrite && ! defined( fileno( $handle ) ) ){
	open( $handle, ">$path" )
	|| die( "$0: $path: cannot open ($!)\n" );
    }
    print $handle $_, "\n";
}

[TheEnd]
}

$Code = $Proto . $Code;

# magic "#n" - same as -n option
#
$doAutoPrint = 0 if substr( $Commands[0], 0, 2 ) eq '#n';

# eval code - check for errors
#
print "Code:\n$Code$Func" if $useDEBUG;
eval $Code . $Func;
if( $@ ){
    print "Code:\n$Code$Func";
    die( "$0: internal error - generated incorrect Perl code: $@\n" );
}

if( $doGenerate ){

    # write full Perl program
    #

    # bang line, declarations, prototypes
    print <<TheEnd;
#!$Config{perlpath} -w
eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
  if 0;
\$0 =~ s/^.*?(\\w+)\[\\.\\w+\]*\$/\$1/;

use strict;
use Symbol;
use vars qw{ \$isEOF \$Hold \%wFiles \@Q \$CondReg
	     \$doAutoPrint \$doOpenWrite \$doPrint };
\$doAutoPrint = $doAutoPrint;
\$doOpenWrite = $doOpenWrite;
TheEnd

    my $wf = "'" . join( "', '",  keys( %wFiles ) ) . "'";
    if( $wf ne "''" ){
	print <<TheEnd;
sub makeHandle(\$);
for my \$p ( $wf ){
   exit( 1 ) unless makeHandle( \$p );
}
TheEnd
   }

   print $Code;
   print "Run();\n";
   print $Func;