X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=x2p%2Fs2p.PL;h=d1ce6ea45ed1ad299a56e8157a3f6098ef6f8568;hb=765d19531dbb4c32d1fcf33fa38e791ed5816743;hp=6d9f8eebe58e9084dc6aa6185a23a9fb01e4d01a;hpb=a7486cbbe7de2a5d93376a3ce396434afeb67f8a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/x2p/s2p.PL b/x2p/s2p.PL index 6d9f8ee..d1ce6ea 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,18 +50,26 @@ print OUT <<"!GROK!THIS!"; $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' if \$running_under_some_shell; -my \$startperl = '$Config{startperl}'; -my \$perlpath = '$Config{perlpath}'; +my \$startperl; +my \$perlpath; +(\$startperl = <<'/../') =~ s/\\s*\\z//; +$Config{startperl} +/../ +(\$perlpath = <<'/../') =~ s/\\s*\\z//; +$Config{perlpath} +/../ !GROK!THIS! # In the following, perl variables are not expanded during extraction. 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. +# Jul 23 2007: Fix bug in regex stripping (M.Thorland) use strict; use integer; @@ -48,12 +77,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 @@ -178,6 +209,7 @@ literally. =cut my %ComTab; +my %GenKey; #-------------------------------------------------------------------------- $ComTab{'a'}=[ 1, 'txt', \&Emit, '{ push( @Q, <<'."'TheEnd' ) }\n" ]; #ok @@ -307,7 +339,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(); @@ -324,7 +356,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 ); @@ -376,7 +408,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 @@ -534,11 +565,18 @@ $useEXTBRE =~ s/[^<>wWyB]//g; # gawk RE's handle these my $doAutoPrint = 1; # automatic printing of pattern space (-n => 0) my $doOpenWrite = 1; # open w command output files at start (-a => 0) my $svOpenWrite = 0; # save $doOpenWrite -my $doGenerate = $0 eq 's2p'; + +# lower case $0 below as a VMSism. The VMS build procedure creates the +# s2p file traditionally in upper case on the disk. When VMS is in a +# case preserved or case sensitive mode, $0 will be returned in the exact +# case which will be on the disk, and that is not predictable at this time. + +my $doGenerate = lc($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 @@ -705,15 +743,21 @@ sub Comment($$$$$$){ 0; } - -sub stripRegex($$){ - my( $del, $sref ) = @_; +# stripRegex from the current command. If we're in the first +# part of s///, trailing spaces have to be kept as the initial +# part of the replacement string. +# +sub stripRegex($$;$){ + my( $del, $sref, $sub ) = @_; my $regex = $del; print "stripRegex:$del:$$sref:\n" if $useDEBUG; while( $$sref =~ s{^(.*?)(\\*)\Q$del\E(\s*)}{}s ){ my $sl = $2; $regex .= $1.$sl.$del; if( length( $sl ) % 2 == 0 ){ + if( $sub && (length( $3 ) > 0) ){ + $$sref = $3 . $$sref; + } return $regex; } $regex .= $3; @@ -755,7 +799,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++; } @@ -813,6 +857,7 @@ TheEnd if( defined( $path ) ){ $wFiles{$path} = ''; $code .= " _w( '$path' ) if \$s;\n"; + $GenKey{'w'} = 1; } $code .= "}"; } @@ -1269,6 +1314,7 @@ sub Parse(){ my $key = $1; my $tabref = $ComTab{$key}; + $GenKey{$key} = 1; if( $naddr > $tabref->[0] ){ Warn( "excess address(es)", $fl ); $error++; @@ -1314,7 +1360,7 @@ sub Parse(){ } if( $cmd =~ s{^([^\\\n])}{} ){ my $del = $1; - my $regex = stripRegex( $del, \$cmd ); + my $regex = stripRegex( $del, \$cmd, "s" ); if( ! defined( $regex ) ){ Warn( "malformed regular expression", $fl ); $error++; @@ -1549,8 +1595,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 ); @@ -1559,6 +1607,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 = ) ){ @@ -1572,10 +1622,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; @@ -1592,66 +1646,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 ); @@ -1663,6 +1669,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 @@ -1702,16 +1720,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" ); } @@ -1720,12 +1824,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. @@ -1848,7 +1952,7 @@ script or script file. =item string lengths in `y' command differ -The translation table strings in a B commanf must have equal lengths. +The translation table strings in a B command must have equal lengths. =item undefined label `%s' @@ -1954,5 +2058,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 $file to psed.\n"; +if (defined $Config{d_link}) { + link $file, 'psed'; +} else { + unshift @INC, '../lib'; + require File::Copy; + File::Copy::syscopy('s2p', 'psed'); +} exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; chdir $origdir;