From ee580363108be8ac33155650c6c18d2e5cf051f3 Mon Sep 17 00:00:00 2001 From: Gurusamy Sarathy Date: Thu, 14 May 1998 23:34:26 +0000 Subject: [PATCH] [win32] merge change#904 from maintbranch p4raw-link: @904 on //depot/maint-5.004/perl: 0af7994b889ad0dfcacb011f16f9e3c77a9292b9 p4raw-id: //depot/win32/perl@975 --- doop.c | 2 +- ext/DynaLoader/dl_aix.xs | 14 ++++ ext/IO/lib/IO/Socket.pm | 2 +- ext/NDBM_File/NDBM_File.pm | 3 +- lib/strict.pm | 2 +- lib/subs.pm | 2 +- lib/vars.pm | 2 +- op.c | 7 +- perl.c | 13 ++-- pod/perldiag.pod | 2 +- pod/perlembed.pod | 2 +- pod/perlfunc.pod | 22 +++++- pp_ctl.c | 2 +- utils/h2ph.PL | 190 ++++++++++++++++++++++++++++----------------- vms/descrip.mms | 4 + 15 files changed, 178 insertions(+), 91 deletions(-) diff --git a/doop.c b/doop.c index 11dc837..e7c5e35 100644 --- a/doop.c +++ b/doop.c @@ -106,7 +106,7 @@ do_join(register SV *sv, SV *del, register SV **mark, register SV **sp) sv_upgrade(sv, SVt_PV); if (SvLEN(sv) < len + items) { /* current length is way too short */ while (items-- > 0) { - if (*mark) { + if (*mark && !SvGMAGIC(*mark) && SvOK(*mark)) { SvPV(*mark, tmplen); len += tmplen; } diff --git a/ext/DynaLoader/dl_aix.xs b/ext/DynaLoader/dl_aix.xs index 4e865ed..ea50408 100644 --- a/ext/DynaLoader/dl_aix.xs +++ b/ext/DynaLoader/dl_aix.xs @@ -29,6 +29,20 @@ #include #include +/* + * AIX 4.3 does remove some useful definitions from ldfcn.h. Define + * these here to compensate for that lossage. + */ +#ifndef BEGINNING +# define BEGINNING SEEK_SET +#endif +#ifndef FSEEK +# define FSEEK(ldptr,o,p) fseek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr) +o):o,p) +#endif +#ifndef FREAD +# define FREAD(p,s,n,ldptr) fread(p,s,n,IOPTR(ldptr)) +#endif + /* If using PerlIO, redefine these macros from */ #ifdef USE_PERLIO #define FSEEK(ldptr,o,p) PerlIO_seek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr)+o):o,p) diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm index aadb502..406f74d 100644 --- a/ext/IO/lib/IO/Socket.pm +++ b/ext/IO/lib/IO/Socket.pm @@ -186,7 +186,7 @@ sub socketpair { my $fh1 = $class->new(); my $fh2 = $class->new(); - socketpair($fh1,$fh1,$domain,$type,$protocol) or + socketpair($fh1,$fh2,$domain,$type,$protocol) or return (); ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type; diff --git a/ext/NDBM_File/NDBM_File.pm b/ext/NDBM_File/NDBM_File.pm index 47b1f5a..ed4fe2b 100644 --- a/ext/NDBM_File/NDBM_File.pm +++ b/ext/NDBM_File/NDBM_File.pm @@ -12,7 +12,7 @@ require DynaLoader; @ISA = qw(Tie::Hash DynaLoader); -$VERSION = "1.00"; +$VERSION = "1.01"; bootstrap NDBM_File $VERSION; @@ -27,6 +27,7 @@ NDBM_File - Tied access to ndbm files =head1 SYNOPSIS use NDBM_File; + use Fcntl; # for O_ constants tie(%h, 'NDBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640); diff --git a/lib/strict.pm b/lib/strict.pm index d9eaba1..463b056 100644 --- a/lib/strict.pm +++ b/lib/strict.pm @@ -72,7 +72,7 @@ appears in curly braces or on the left hand side of the "=E" symbol. =back -See L. +See L. =cut diff --git a/lib/subs.pm b/lib/subs.pm index 512bc9b..aa332a6 100644 --- a/lib/subs.pm +++ b/lib/subs.pm @@ -20,7 +20,7 @@ C declarations are not BLOCK-scoped. They are thus effective for the entire file in which they appear. You may not rescind such declarations with C or C. -See L and L. +See L and L. =cut diff --git a/lib/vars.pm b/lib/vars.pm index 5723ac6..5256d11 100644 --- a/lib/vars.pm +++ b/lib/vars.pm @@ -61,6 +61,6 @@ outside of the package), it can act as an acceptable substitute by pre-declaring global symbols, ensuring their availability to the later-loaded routines. -See L. +See L. =cut diff --git a/op.c b/op.c index 1f564de..b86a27c 100644 --- a/op.c +++ b/op.c @@ -1681,9 +1681,12 @@ fold_constants(register OP *o) if (type == OP_RV2GV) return newGVOP(OP_GV, 0, (GV*)sv); else { - if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK) { + /* try to smush double to int, but don't smush -2.0 to -2 */ + if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK && + type != OP_NEGATE) + { IV iv = SvIV(sv); - if ((double)iv == SvNV(sv)) { /* can we smush double to int */ + if ((double)iv == SvNV(sv)) { SvREFCNT_dec(sv); sv = newSViv(iv); } diff --git a/perl.c b/perl.c index 97b0c38..2fdac45 100644 --- a/perl.c +++ b/perl.c @@ -1739,6 +1739,7 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); /* compliments of Tom Christiansen */ /* unexec() can be found in the Gnu emacs distribution */ +/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */ void my_unexec(void) @@ -1746,18 +1747,16 @@ my_unexec(void) #ifdef UNEXEC SV* prog; SV* file; - int status; + int status = 1; extern int etext; - prog = newSVpv(BIN_EXP); + prog = newSVpv(BIN_EXP, 0); sv_catpv(prog, "/perl"); - file = newSVpv(origfilename); + file = newSVpv(origfilename, 0); sv_catpv(file, ".perldump"); - status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0); - if (status) - PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", - SvPVX(prog), SvPVX(file)); + unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0); + /* unexec prints msg to stderr in case of failure */ PerlProc_exit(status); #else # ifdef VMS diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 4808563..d46ff33 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -670,7 +670,7 @@ but there is no function to autoload. Most probable causes are a misprint in a function/method name or a failure to C the file, say, by doing C. -=item Can't locate %s in @INC +=item Can't locate file '%s' in @INC (F) You said to do (or require, or use) a file that couldn't be found in any of the libraries mentioned in @INC. Perhaps you need to set the diff --git a/pod/perlembed.pod b/pod/perlembed.pod index 7876da5..689050c 100644 --- a/pod/perlembed.pod +++ b/pod/perlembed.pod @@ -12,7 +12,7 @@ Do you want to: =item B -Read L and L. +Read L, L and L. =item B diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 6a0f9c2..8e95de5 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -2636,8 +2636,26 @@ replaces "F<::>" with "F" in the filename for you, to make it easy to load standard modules. This form of loading of modules does not risk altering your namespace. -For a yet-more-powerful import facility, see L and -L. +In other words, if you try this: + + require Foo::Bar ; # a splendid bareword + +The require function will actually look for the "Foo/Bar.pm" file in the +directories specified in the @INC array. + +But if you try this : + + $class = 'Foo::Bar'; + require $class ; # $class is not a bareword +or + require "Foo::Bar" ; # not a bareword because of the "" + +The require function will look for the "Foo::Bar" file in the @INC array and +will complain about not finding "Foo::Bar" there. In this case you can do : + + eval "require $class"; + +For a yet-more-powerful import facility, see L and L. =item reset EXPR diff --git a/pp_ctl.c b/pp_ctl.c index db626a1..1ee85a6 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2454,7 +2454,7 @@ PP(pp_require) SvREFCNT_dec(namesv); if (!tryrsfp) { if (op->op_type == OP_REQUIRE) { - SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name)); + SV *msg = sv_2mortal(newSVpvf("Can't locate file '%s' in @INC", name)); SV *dirmsgsv = NEWSV(0, 0); AV *ar = GvAVn(incgv); I32 i; diff --git a/utils/h2ph.PL b/utils/h2ph.PL index dc2207c..2c685e0 100644 --- a/utils/h2ph.PL +++ b/utils/h2ph.PL @@ -1,7 +1,7 @@ #!/usr/local/bin/perl use Config; -use File::Basename qw(&basename &dirname); +use File::Basename qw(basename dirname); # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you @@ -38,8 +38,7 @@ use Config; use File::Path qw(mkpath); use Getopt::Std; -getopts('d:rlh'); - +getopts('Dd:rlh'); my $Exit = 0; @@ -76,8 +75,7 @@ while (defined ($file = next_file())) { if ($file eq '-') { open(IN, "-"); open(OUT, ">-"); - } - else { + } else { ($outfile = $file) =~ s/\.h$/.ph/ || next; print "$file -> $outfile\n"; if ($file =~ m|^(.*)/|) { @@ -94,6 +92,7 @@ while (defined ($file = next_file())) { $_ .= ; chop; } + print OUT "# $_\n" if $opt_D; if (s:/\*:\200:g) { s:\*/:\201:g; s/\200[^\201]*\201//g; # delete single line comments @@ -103,7 +102,7 @@ while (defined ($file = next_file())) { redo; } } - if (s/^#\s*//) { + if (s/^\s*#\s*//) { if (s/^define\s+(\w+)//) { $name = $1; $new = ''; @@ -122,86 +121,121 @@ while (defined ($file = next_file())) { } s/^\s+//; expr(); - $new =~ s/(["\\])/\\$1/g; + $new =~ s/(["\\])/\\$1/g; #"]); + $new = reindent($new); + $args = reindent($args); if ($t ne '') { - $new =~ s/(['\\])/\\$1/g; + $new =~ s/(['\\])/\\$1/g; #']); if ($opt_h) { print OUT $t, - "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n"; + "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n"; $eval_index++; } else { print OUT $t, - "eval 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n"; + "eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n"; } - } - else { - print OUT "unless (defined(\&$name)) {\nsub $name $proto\{\n ${args}eval \"$new\";\n}\n}\n"; + } else { + print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n"; } %curargs = (); - } - else { + } else { s/^\s+//; expr(); $new = 1 if $new eq ''; + $new = reindent($new); + $args = reindent($args); if ($t ne '') { - $new =~ s/(['\\])/\\$1/g; + $new =~ s/(['\\])/\\$1/g; #']); if ($opt_h) { print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n"; $eval_index++; } else { print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n"; } - } - else { - print OUT $t,"unless(defined(\&$name)) {\nsub $name () {",$new,";}\n}\n"; + } else { + print OUT $t,"unless(defined(\&$name)) {\n sub $name () {\t",$new,";}\n}\n"; } } - } - elsif (/^include\s*<(.*)>/) { - ($incl = $1) =~ s/\.h$/.ph/; + } elsif (/^(include|import)\s*[<"](.*)[>"]/) { + ($incl = $2) =~ s/\.h$/.ph/; print OUT $t,"require '$incl';\n"; - } - elsif (/^ifdef\s+(\w+)/) { - print OUT $t,"if (defined &$1) {\n"; + } elsif(/^include_next\s*[<"](.*)[>"]/) { + ($incl = $1) =~ s/\.h$/.ph/; + # should've read up on #include_next properly before attempting + # to implement it... + # + #print OUT $t, "{\n"; + #$tab += 4; + #$t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + #print OUT $t, "my(\$INC) = shift(\@INC);\n"; + #print OUT $t, "require '$incl';\n"; + #print OUT $t, "unshift(\@INC, \$INC);}\n"; + #$tab -= 4; + #$t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + #print OUT $t, "}\n"; + # + # try this instead: + print OUT ($t, "my(\$i) = 0;\n"); + print OUT ($t, "if(exists(\$INC{$incl})) {\n"); $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^ifndef\s+(\w+)/) { - print OUT $t,"if (!defined &$1) {\n"; + print OUT ($t, "++\$i while (\$i <= \$#INC", + " and \$INC[\$i].'/$incl' ne \$INC{'$incl'});\n"); + print OUT ($t, "\$i = 0 if \$INC[\$i].'/$incl' ne", + " \$INC{'$incl'};\n"); + $tab -= 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + print OUT ($t, "}\n"); + print OUT ($t, + "eval(\"require '\" . ", + "(\$i ? \$INC[\$i].'/' : '') . \"\$incl';\");"); + # any better? require is smart enough not to try and include a + # file twice, i believe, so require-ing the same actual file + # should end up just being a null operation... + } elsif (/^ifdef\s+(\w+)/) { + print OUT $t,"if(defined(&$1)) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (s/^if\s+//) { + } elsif (/^ifndef\s+(\w+)/) { + print OUT $t,"unless(defined(&$1)) {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } elsif (s/^if\s+//) { $new = ''; $inif = 1; expr(); $inif = 0; - print OUT $t,"if ($new) {\n"; + print OUT $t,"if($new) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (s/^elif\s+//) { + } elsif (s/^elif\s+//) { $new = ''; $inif = 1; expr(); $inif = 0; $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n${t}elsif ($new) {\n"; + print OUT $t,"}\n elsif($new) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^else/) { + } elsif (/^else/) { $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n${t}else {\n"; + print OUT $t,"} else {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^endif/) { + } elsif (/^endif/) { $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); print OUT $t,"}\n"; + } elsif(/^undef\s+(\w+)/) { + print OUT $t, "undef(&$1) if defined(&$1);\n"; + } elsif(/^error\s+(.*)/) { + print OUT $t, "die(\"$1\");\n"; + } elsif(/^warning\s+(.*)/) { + print OUT $t, "warn(\"$1\");\n"; + } elsif(/^ident\s+(.*)/) { + print OUT $t, "# $1\n"; } } } @@ -210,10 +244,20 @@ while (defined ($file = next_file())) { exit $Exit; +sub reindent($) { + my($text) = shift; + $text =~ s/\n/\n /g; + $text =~ s/ /\t/g; + $text; +} + sub expr { + if(keys(%curargs)) { + my($joined_args) = join('|', keys(%curargs)); + } while ($_ ne '') { - s/^\&\&// && do { $new .= "&&"; next;}; # handle && operator - s/^\&//; # hack for things that take the address of + s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator + s/^\&([\(a-z\)]+)/$1/i; # hack for things that take the address of s/^(\s+)// && do {$new .= ' '; next;}; s/^(0X[0-9A-F]+)[UL]*//i && do {$new .= lc($1); next;}; s/^(-?\d+\.\d+E[-+]\d+)F?//i && do {$new .= $1; next;}; @@ -222,8 +266,7 @@ sub expr { s/^'((\\"|[^"])*)'// && do { if ($curargs{$1}) { $new .= "ord('\$$1')"; - } - else { + } else { $new .= "ord('$1')"; } next; @@ -260,11 +303,22 @@ sub expr { } s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them. }; - # struct/union member: - s/^([_A-Z]\w*((\.|->)[_A-Z]\w*)+)//i && do { + # struct/union member, including arrays: + s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do { $id = $1; - $id =~ s/(\.|(->))([^\.-]*)/->\{$3\}/g; - $new .= ' ($' . $id . ')'; + $id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g; + $id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args); + while($id =~ /\[\s*([^\$\&\d\]]+)\]/) { + my($index) = $1; + $index =~ s/\s//g; + if(exists($curargs{$index})) { + $index = "\$$index"; + } else { + $index = "&$index"; + } + $id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/; + } + $new .= " (\$$id)"; }; s/^([_a-zA-Z]\w*)// && do { $id = $1; @@ -272,41 +326,33 @@ sub expr { s/^\s+(\w+)//; $id .= ' ' . $1; $isatype{$id} = 1; - } - elsif ($id =~ /^((un)?signed)|(long)|(short)$/) { + } elsif ($id =~ /^((un)?signed)|(long)|(short)$/) { while (s/^\s+(\w+)//) { $id .= ' ' . $1; } $isatype{$id} = 1; } if ($curargs{$id}) { - $new .= '$' . $id; - } - elsif ($id eq 'defined') { + $new .= "\$$id"; + $new .= '->' if /^[\[\{]/; + } elsif ($id eq 'defined') { $new .= 'defined'; - } - elsif (/^\(/) { + } elsif (/^\(/) { s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat $new .= " &$id"; - } - elsif ($isatype{$id}) { + } elsif ($isatype{$id}) { if ($new =~ /{\s*$/) { $new .= "'$id'"; - } - elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) { + } elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) { $new =~ s/\(\s*$//; s/^[\s*]*\)//; - } - else { + } else { $new .= q(').$id.q('); } - } - else { + } else { if ($inif && $new !~ /defined\s*\($/) { $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)'; - } - elsif (/^\[/) { - $new .= ' $' . $id; - } - else { + } elsif (/^\[/) { + $new .= " \$$id"; + } else { $new .= ' &' . $id; } } @@ -334,7 +380,7 @@ sub next_file } else { print STDERR "Skipping directory `$file'\n"; } - } else { + } else { print STDERR "Skipping `$file': not a file or directory\n"; } } @@ -356,8 +402,11 @@ sub expand_glob # expand_glob() is going to be called until $ARGV[0] isn't a # directory; so push directories, and unshift everything else. - if (-d "$directory/$_") { push @ARGV, "$directory/$_" } - else { unshift @ARGV, "$directory/$_" } + if (-d "$directory/$_") { + push @ARGV, "$directory/$_"; + } else { + unshift @ARGV, "$directory/$_"; + } } closedir DIR; } @@ -382,7 +431,6 @@ sub link_if_possible unlink "$Dest_dir/$dirlink" or print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n"; } - if (eval 'symlink($target, "$Dest_dir/$dirlink")') { print "Linking $target -> $Dest_dir/$dirlink\n"; diff --git a/vms/descrip.mms b/vms/descrip.mms index a7fbf3d..eb1a5a3 100644 --- a/vms/descrip.mms +++ b/vms/descrip.mms @@ -462,6 +462,10 @@ $(ARCHDIR)config.pm : [.lib]config.pm @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto] @ $(MINIPERL) -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]DynaLoader.pm +[.ext.dynaloader]dynaloader.pm : [.ext.dynaloader]dynaloader.pm_pl + $(MINIPERL) $(MMS$SOURCE) + @ Rename/Log dynaloader.pm [.ext.dynaloader] + Opcode : [.lib]Opcode.pm [.lib]ops.pm [.lib]Safe.pm [.lib.auto.Opcode]Opcode$(E) @ $(NOOP) -- 2.7.4