X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=x2p%2Fs2p.PL;h=4b2daa918dd190b3b2b27462e2b6a16cd45a82f5;hb=0159f81bfe8e286f119bb9a00f0567234a23235b;hp=d215781dae0c34d21a61e67509780f86a5679529;hpb=ed6d8ea1078be98ee684a04b1fb3f2df943fb9e4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/x2p/s2p.PL b/x2p/s2p.PL index d215781..4b2daa9 100644 --- a/x2p/s2p.PL +++ b/x2p/s2p.PL @@ -3,6 +3,27 @@ use Config; use File::Basename qw(&basename &dirname); use Cwd; +use subs qw(link); + +sub link { # This is a cut-down version of installperl:link(). + my($from,$to) = @_; + my($success) = 0; + + eval { + CORE::link($from, $to) + ? $success++ + : ($from =~ m#^/afs/# || $to =~ m#^/afs/#) + ? die "AFS" # okay inside eval {} + : die "Couldn't link $from to $to: $!\n"; + }; + if ($@) { + require File::Copy; + File::Copy::copy($from, $to) + ? $success++ + : warn "Couldn't copy $from to $to: $!\n"; + } + $success; +} # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you @@ -29,8 +50,8 @@ print OUT <<"!GROK!THIS!"; $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' if \$running_under_some_shell; -my $startperl; -my $perlpath; +my \$startperl; +my \$perlpath; (\$startperl = <<'/../') =~ s/\\s*\\z//; $Config{startperl} /../ @@ -43,10 +64,11 @@ $Config{perlpath} print OUT <<'!NO!SUBS!'; -$0 =~ s/^.*?(\w+)$/$1/; +$0 =~ s/^.*?(\w+)[\.\w]*$/$1/; # (p)sed - a stream editor # History: Aug 12 2000: Original version. +# Mar 25 2002: Rearrange generated Perl program. use strict; use integer; @@ -54,12 +76,14 @@ use Symbol; =head1 NAME -sed - a stream editor +psed - a stream editor =head1 SYNOPSIS - sed [-an] script [file ...] - sed [-an] [-e script] [-f script-file] [file ...] + psed [-an] script [file ...] + psed [-an] [-e script] [-f script-file] [file ...] + + s2p [-an] [-e script] [-f script-file] =head1 DESCRIPTION @@ -184,6 +208,7 @@ literally. =cut my %ComTab; +my %GenKey; #-------------------------------------------------------------------------- $ComTab{'a'}=[ 1, 'txt', \&Emit, '{ push( @Q, <<'."'TheEnd' ) }\n" ]; #ok @@ -313,7 +338,7 @@ octal number for all other non-printable characters. #-------------------------------------------------------------------------- $ComTab{'n'}=[ 2, '', \&Emit, <<'-X-' ]; #ok { print $_, "\n" if $doPrint; - printQ if @Q; + printQ() if @Q; $CondReg = 0; last CYCLE unless getsARGV(); chomp(); @@ -330,7 +355,7 @@ there is no more input, processing is terminated. #-------------------------------------------------------------------------- $ComTab{'N'}=[ 2, '', \&Emit, <<'-X-' ]; #ok -{ printQ if @Q; +{ printQ() if @Q; $CondReg = 0; last CYCLE unless getsARGV( $h ); chomp( $h ); @@ -382,7 +407,6 @@ Branch to the end of the script and quit without starting a new cycle. #-------------------------------------------------------------------------- $ComTab{'r'}=[ 1, 'str', \&Emit, "{ _r( '-X-' ) }" ]; #ok -### FIXME: lazy reading - big files??? =item [1addr]B I @@ -544,7 +568,8 @@ my $doGenerate = $0 eq 's2p'; # Collected and compiled script # -my( @Commands, %Defined, @BlockStack, %Label, $labNum, $Code ); +my( @Commands, %Defined, @BlockStack, %Label, $labNum, $Code, $Func ); +$Code = ''; ################## # Compile Time @@ -761,7 +786,7 @@ sub makey($$$){ my $fc = substr($fr,$i,1); my $tc = substr($to,$i,1); if( exists( $tr{$fc} ) && $tr{$fc} ne $tc ){ - Warn( "ambiguos translation for character `$fc' in `y' command", + Warn( "ambiguous translation for character `$fc' in `y' command", $fl ); $error++; } @@ -819,6 +844,7 @@ TheEnd if( defined( $path ) ){ $wFiles{$path} = ''; $code .= " _w( '$path' ) if \$s;\n"; + $GenKey{'w'} = 1; } $code .= "}"; } @@ -1275,6 +1301,7 @@ sub Parse(){ my $key = $1; my $tabref = $ComTab{$key}; + $GenKey{$key} = 1; if( $naddr > $tabref->[0] ){ Warn( "excess address(es)", $fl ); $error++; @@ -1555,8 +1582,10 @@ print STDERR "Files: @ARGV\n" if $useDEBUG; # generate leading code # - $Code = <<'[TheEnd]'; +$Func = <<'[TheEnd]'; +# openARGV: open 1st input file +# sub openARGV(){ unshift( @ARGV, '-' ) unless @ARGV; my $file = shift( @ARGV ); @@ -1565,6 +1594,8 @@ sub openARGV(){ $isEOF = 0; } +# getsARGV: Read another input line into argument (default: $_). +# Move on to next input file, and reset EOF flag $isEOF. sub getsARGV(;\$){ my $argref = @_ ? shift() : \$_; while( $isEOF || ! defined( $$argref = ) ){ @@ -1578,10 +1609,14 @@ sub getsARGV(;\$){ 1; } +# eofARGV: end-of-file test +# sub eofARGV(){ return @ARGV == 0 && ( $isEOF = eof( ARG ) ); } +# makeHandle: Generates another file handle for some file (given by its path) +# to be written due to a w command or an s command's w flag. sub makeHandle($){ my( $path ) = @_; my $handle; @@ -1598,66 +1633,18 @@ sub makeHandle($){ return $handle; } -sub _r($){ - my $path = shift(); - push( @Q, \$path ); -} - -sub _l(){ - my $h = $_; - my $mcpl = 70; - $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; - } - 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/(?$path" ) - || die( "$0: $path: cannot open ($!)\n" ); - } - print $handle $_, "\n"; -} - -# condition register test/reset -# -sub _t(){ - my $res = $CondReg; - $CondReg = 0; - $res; -} - -# printQ -# +# printQ: Print queued output which is either a string or a reference +# to a pathname. sub printQ(){ for my $q ( @Q ){ if( ref( $q ) ){ + # flush open w files so that reading this file gets it all if( exists( $wFiles{$$q} ) && $wFiles{$$q} ne '' ){ open( $wFiles{$$q}, ">>$$q" ); } + # copy file to stdout: slow, but safe if( open( RF, "<$$q" ) ){ - my $line; - while( defined( $line = ) ){ + while( defined( my $line = ) ){ print $line; } close( RF ); @@ -1669,6 +1656,18 @@ sub printQ(){ undef( @Q ); } +[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 @@ -1708,16 +1707,102 @@ EOS: if( $doPrint ){ } [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/(?$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" if $useDEBUG; -eval $Code; +print "Code:\n$Code$Func" if $useDEBUG; +eval $Code . $Func; if( $@ ){ - print "Code:\n$Code"; + print "Code:\n$Code$Func"; die( "$0: internal error - generated incorrect Perl code: $@\n" ); } @@ -1726,12 +1811,12 @@ if( $doGenerate ){ # write full Perl program # - # bang line, declarations + # bang line, declarations, prototypes print <. =over 4 -=item ambiguos translation for character `%s' in `y' command +=item ambiguous translation for character `%s' in `y' command The indicated character appears twice, with different translations. @@ -1960,5 +2045,14 @@ way you wish, provided you do not restrict others from doing the same. close OUT or die "Can't close $file: $!"; chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +unlink 'psed'; +print "Linking s2p to psed.\n"; +if (defined $Config{d_link}) { + link 's2p', 'psed'; +} else { + unshift @INC, '../lib'; + require File::Copy; + File::Copy::syscopy('s2p', 'psed'); +} exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; chdir $origdir;