diff options
90 files changed, 2297 insertions, 1224 deletions
@@ -18,6 +18,7 @@ Porting/Glossary Glossary of config.sh variables Porting/config.sh Sample config.sh Porting/config_H Sample config.h Porting/makerel Release making utility +Porting/patching.pod How to report changes made to Perl Porting/patchls Flexible patch file listing utility Porting/pumpkin.pod Guidelines and hints for Perl maintainers README The Instructions @@ -825,6 +826,7 @@ t/op/chop.t See if chop works t/op/closure.t See if closures work t/op/cmp.t See if the various string and numeric compare work t/op/cond.t See if conditional expressions work +t/op/defins.t See if auto-insert of defined() works t/op/delete.t See if delete works t/op/die_exit.t See if die and exit status interaction works t/op/do.t See if subroutines work diff --git a/Porting/makerel b/Porting/makerel index f719a5e936..d6582edba1 100644 --- a/Porting/makerel +++ b/Porting/makerel @@ -21,9 +21,15 @@ $patchlevel_h = `grep '#define ' patchlevel.h`; print $patchlevel_h; $patchlevel = $1 if $patchlevel_h =~ /PATCHLEVEL\s+(\d+)/; $subversion = $1 if $patchlevel_h =~ /SUBVERSION\s+(\d+)/; -die "Unable to parse patchlevel.h" unless $subversion > 0; +die "Unable to parse patchlevel.h" unless $subversion >= 0; $vers = sprintf("5.%03d", $patchlevel); -$vers.= sprintf( "_%02d", $subversion) if $subversion; +$vms_vers = sprintf("5_%03d", $patchlevel); +if ($subversion) { + $vers.= sprintf( "_%02d", $subversion); + $vms_vers.= sprintf( "%02d", $subversion); +} else { + $vms_vers.= " "; +} $perl = "perl$vers"; $reldir = "$relroot/$perl"; @@ -47,6 +53,10 @@ die "Aborted.\n" if @$missentry or @$missfile; print "\n"; +print "Updating VMS version specific files with $vms_vers...\n"; +system("perl -pi -e 's/^\QPERL_VERSION = \E\d\_\d+(\s*\#)/PERL_VERSION = $vms_vers$1/' vms/descrip.mms"); + + print "Setting file permissions...\n"; system("find . -type f -print | xargs chmod -w"); system("find . -type d -print | xargs chmod g-s"); @@ -78,7 +88,7 @@ print "\n"; print "Creating $reldir release directory...\n"; -die "$reldir release directory already exists\n" if -e "../$perl"; +die "$reldir release directory already exists\n" if -e "../$reldir"; die "$reldir.tar.gz release file already exists\n" if -e "../$reldir.tar.gz"; mkdir($reldir, 0755) or die "mkdir $reldir: $!\n"; print "\n"; diff --git a/Porting/patching.pod b/Porting/patching.pod new file mode 100644 index 0000000000..b2a86b6f34 --- /dev/null +++ b/Porting/patching.pod @@ -0,0 +1,275 @@ +=head1 Name + +patching.pod - Appropriate format for patches to the perl source tree + +=head2re to get this document + +The latest version of this document is available from + http://www.tdrenterprises.com/perl/perlpatch.html + +=head2 How to contribute to this document + +You may mail corrections, additions, and suggestions to me +at dgris@tdrenterprises.com but the preferred method would be +to follow the instructions set forth in this document and +submit a patch 8-). + +=head1 Description + +=head2 Why this document exists + +As an open source project Perl relies on patches and contributions from +its users to continue functioning properly and to root out the inevitable +bugs. But, some users are unsure as to the I<right> way to prepare a patch +and end up submitting seriously malformed patches. This makes it very +difficult for the current maintainer to integrate said patches into their +distribution. This document sets out usage guidelines for patches in an +attempt to make everybody's life easier. + +=head2 Common problems + +The most common problems appear to be patches being mangled by certain +mailers (I won't name names, but most of these seem to be originating on +boxes running a certain popular commercial operating system). Other problems +include patches not rooted in the appropriate place in the directory structure, +and patches not produced using standard utilities (such as diff). + +=head1 Proper Patch Guidelines + +=head2 How to prepare your patch + +=over 4 + +=item Creating your patch + +First, back up the original files. This can't be stressed enough, +back everything up _first_. + +Also, please create patches against a clean distribution of the perl source. +This insures that everyone else can apply your patch without clobbering their +source tree. + +=item diff + +While individual tastes vary (and are not the point here) patches should +be created using either C<-u> or C<-c> arguments to diff. These produce, +respectively, unified diffs (where the changed line appears immediately next +to the original) and context diffs (where several lines surrounding the changes +are included). See the manpage for diff for more details. + +Also, the preferred method for patching is - + +C<diff [C<-c> | C<-u>] E<lt>old-fileE<gt> E<lt>new-fileE<gt>> + +Note the order of files. + +Also, if your patch is to the core (rather than to a module) it +is better to create it as a context diff as some machines have +broken patch utilities that choke on unified diffs. + +=item Directories + +Patches should be generated from the source root directory, not from the +directory that the patched file resides in. This insures that the maintainer +patches the proper file and avoids name collisions (especially common when trying +to apply patches to files that appear in both $src_root/ext/* and $src_root/lib/*). +It is better to diff the file in $src_root/ext than the file in $src_root/lib. + +=item Filenames + +The most usual convention when submitting patches for a single file is to make +your changes to a copy of the file with the same name as the original. Rename +the original file in such a way that it is obvious what is being patched ($file~ or +$file.old seem to be popular). + +If you are submitting patches that affect multiple files then you should backup +the entire directory tree (to $source_root.old/ for example). This will allow +C<diff C<-c> E<lt>old-dirE<gt> E<lt>new-dirE<gt>> to create all the patches +at once. + +=back + +=head2 What to include in your patch + +=over 4 + +=item Description of problem + +The first thing you should include is a description of the problem that +the patch corrects. If it is a code patch (rather than a documentation +patch) you should also include a small test case that illustrates the +bug. + +=item Direction for application + +You should include instructions on how to properly apply your patch. +These should include the files affected, any shell scripts or commands +that need to be run before or after application of the patch, and +the command line necessary for application. + +=item If you have a code patch + +If you are submitting a code patch there are several other things that +you need to do. + +=over 4 + +=item Comments, Comments, Comments + +Be sure to adequately comment your code. While commenting every +line is unnecessary, anything that takes advantage of side effects of +operators, that creates changes that will be felt outside of the +function being patched, or that others may find confusing should +be documented. If you are going to err, it is better to err on the +side of adding too many comments than too few. + +=item Style + +Please follow the indentation style and nesting style in use in the +block of code that you are patching. + +=item Testsuite + +Also please include an addition to the regression tests to properly +exercise your patch. + +=back + +=item Test your patch + +Apply your patch to a clean distribution, compile, and run the +regression test suite (you did remember to add one for your +patch, didn't you). + +=back + +=head2 An example patch creation + +This should work for most patches- + + cp MANIFEST MANIFEST.old + emacs MANIFEST + (make changes) + cd .. + diff -c perl5.008_42/MANIFEST.old perl5.008_42/MANIFEST > mypatch + (testing the patch:) + mv perl5.008_42/MANIFEST perl5.008_42/MANIFEST.new + cp perl5.008_42/MANIFEST.old perl5.008_42/MANIFEST + patch -p < mypatch + (should succeed) + diff perl5.008_42/MANIFEST perl5.008_42/MANIFEST.new + (should produce no output) + +=head2 Submitting your patch + +=over 4 + +=item Mailers + +Please, please, please (get the point? 8-) don't use a mailer that +word wraps your patch or that MIME encodes it. Both of these leave +the patch essentially worthless to the maintainer. + +If you have no choice in mailers and no way to get your hands on a +better one there is, of course, a perl solution. Just do this- + + perl -ne 'print pack("u*",$_)' patch > patch.uue + +and post patch.uue with a note saying to unpack it using + + perl -ne 'print unpack("u*",$_)' patch.uue > patch + +=item Subject lines for patches + +The subject line on your patch should read + +[PATCH]5.xxx_xx (Area) Description + +where the x's are replaced by the appropriate version number, +area is a short keyword identifying what area of perl you are +patching, and description is a very brief summary of the +problem (don't forget this is an email header). + +Examples- + +[PATCH]5.004_04 (DOC) fix minor typos + +[PATCH]5.004_99 (CORE) New warning for foo() when frobbing + +[PATCH]5.005_42 (CONFIG) Added support for fribnatz 1.5 + +=item Where to send your patch + +If your patch is for the perl core it should be sent perlbug@perl.org. +If it is a patch to a module that you downloaded from CPAN you should +submit your patch to that module's author. + +=back + +=head2 Applying a patch + +=over 4 + +=item General notes on applying patches + +The following are some general notes on applying a patch +to your perl distribution. + +=over 4 + +=item patch C<-p> + +It is generally easier to apply patches with the C<-p> argument to +patch. This helps reconcile differing paths between the machine the +patch was created on and the machine on which it is being applied. + +=item Cut and paste + +_Never_ cut and paste a patch into your editor. This usually clobbers +the tabs and confuses patch. + +=item Hand editing patches + +Avoid hand editing patches as this frequently screws up the whitespace +in the patch and confuses the patch program. + +=back + +=back + +=head2 Final notes + +If you follow these guidelines it will make everybody's life a little +easier. You'll have the satisfaction of having contributed to perl, +others will have an easy time using your work, and it should be easier +for the maintainers to coordinate the occasionally large numbers of +patches received. + +Also, just because you're not a brilliant coder doesn't mean that you can't +contribute. As valuable as code patches are there is always a need for better +documentation (especially considering the general level of joy that most +programmers feel when forced to sit down and write docs). If all you do +is patch the documentation you have still contributed more than the person +who sent in an amazing new feature that noone can use because noone understands +the code (what I'm getting at is that documentation is both the hardest part to +do (because everyone hates doing it) and the most valuable). + +Mostly, when contributing patches, imagine that it is B<you> receiving hundreds +of patches and that it is B<your> responsibility to integrate them into the source. +Obviously you'd want the patches to be as easy to apply as possible. Keep that in +mind. 8-) + +=head1 Last Modified + +Last modified 1 May 1998 by Daniel Grisinger <dgris@tdrenterprises.com> + +=head1 Author and Copyright Information + +Copyright (c) 1998 Daniel Grisinger + +Adapted from a posting to perl5-porters by Tim Bunce (Tim.Bunce@ig.co.uk). + +I'd like to thank the perl5-porters for their suggestions. + + + @@ -21,6 +21,7 @@ Would be nice to have reference to compiled regexp lexically scoped functions: my sub foo { ... } lvalue functions + regression/sanity tests for suidperl Full 64 bit support (i.e. "long long") Possible pragmas @@ -55,5 +56,4 @@ Vague possibilities structured types autocroak? Modifiable $1 et al - substr EXPR,OFFSET,LENGTH,STRING @@ -171,8 +171,11 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe if (strNE(name,"-")) TAINT_ENV(); TAINT_PROPER("piped open"); - if (dowarn && name[strlen(name)-1] == '|') - warn("Can't do bidirectional pipe"); + if (name[strlen(name)-1] == '|') { + name[strlen(name)-1] = '\0' ; + if (dowarn) + warn("Can't do bidirectional pipe"); + } fp = PerlProc_popen(name,"w"); writing = 1; } @@ -717,6 +720,46 @@ do_sysseek(GV *gv, long int pos, int whence) return -1L; } +int +do_binmode(PerlIO *fp, int iotype, int flag) +{ + if (flag != TRUE) + croak("panic: unsetting binmode"); /* Not implemented yet */ +#ifdef DOSISH +#ifdef atarist + if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN)) + return 1; + else + return 0; +#else + if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) { +#if defined(WIN32) && defined(__BORLANDC__) + /* The translation mode of the stream is maintained independent + * of the translation mode of the fd in the Borland RTL (heavy + * digging through their runtime sources reveal). User has to + * set the mode explicitly for the stream (though they don't + * document this anywhere). GSAR 97-5-24 + */ + PerlIO_seek(fp,0L,0); + fp->flags |= _F_BIN; +#endif + return 1; + } + else + return 0; +#endif +#else +#if defined(USEMYBINMODE) + if (my_binmode(fp,iotype) != NULL) + return 1; + else + return 0; +#else + return 1; +#endif +#endif +} + #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) /* code courtesy of William Kucharski */ #define HAS_CHSIZE @@ -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 && !SvGMAGICAL(*mark) && SvOK(*mark)) { SvPV(*mark, tmplen); len += tmplen; } @@ -483,7 +483,11 @@ do_kv(ARGSproto) sv_magic(TARG, Nullsv, 'k', Nullch, 0); } LvTYPE(TARG) = 'k'; - LvTARG(TARG) = (SV*)hv; + if (LvTARG(TARG) != (SV*)hv) { + if (LvTARG(TARG)) + SvREFCNT_dec(LvTARG(TARG)); + LvTARG(TARG) = SvREFCNT_inc(hv); + } PUSHs(TARG); RETURN; } @@ -361,7 +361,7 @@ dump_pm(PMOP *pm) } if (pm->op_pmflags || (pm->op_pmregexp && pm->op_pmregexp->check_substr)) { SV *tmpsv = newSVpv("", 0); - if (pm->op_pmflags & PMf_USED) + if (pm->op_pmdynflags & PMdf_USED) sv_catpv(tmpsv, ",USED"); if (pm->op_pmflags & PMf_ONCE) sv_catpv(tmpsv, ",ONCE"); @@ -381,6 +381,8 @@ dump_pm(PMOP *pm) sv_catpv(tmpsv, ",GLOBAL"); if (pm->op_pmflags & PMf_CONTINUE) sv_catpv(tmpsv, ",CONTINUE"); + if (pm->op_pmflags & PMf_TAINTMEM) + sv_catpv(tmpsv, ",TAINTMEM"); if (pm->op_pmflags & PMf_EVAL) sv_catpv(tmpsv, ",EVAL"); dump("PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); @@ -141,6 +141,7 @@ #define div_amg Perl_div_amg #define div_ass_amg Perl_div_ass_amg #define do_aexec Perl_do_aexec +#define do_binmode Perl_do_binmode #define do_chomp Perl_do_chomp #define do_chop Perl_do_chop #define do_close Perl_do_close @@ -192,6 +193,7 @@ #define filter_add Perl_filter_add #define filter_del Perl_filter_del #define filter_read Perl_filter_read +#define find_script Perl_find_script #define find_threadsv Perl_find_threadsv #define fold Perl_fold #define fold_constants Perl_fold_constants @@ -287,11 +289,14 @@ #define magic_getarylen Perl_magic_getarylen #define magic_getdefelem Perl_magic_getdefelem #define magic_getglob Perl_magic_getglob +#define magic_getnkeys Perl_magic_getnkeys #define magic_getpack Perl_magic_getpack #define magic_getpos Perl_magic_getpos #define magic_getsig Perl_magic_getsig +#define magic_getsubstr Perl_magic_getsubstr #define magic_gettaint Perl_magic_gettaint #define magic_getuvar Perl_magic_getuvar +#define magic_getvec Perl_magic_getvec #define magic_len Perl_magic_len #define magic_mutexfree Perl_magic_mutexfree #define magic_nextpack Perl_magic_nextpack diff --git a/embedvar.h b/embedvar.h index 11ccca23af..9df05545ac 100644 --- a/embedvar.h +++ b/embedvar.h @@ -45,6 +45,7 @@ #define markstack (curinterp->Tmarkstack) #define markstack_max (curinterp->Tmarkstack_max) #define markstack_ptr (curinterp->Tmarkstack_ptr) +#define modcount (curinterp->Tmodcount) #define nrs (curinterp->Tnrs) #define ofs (curinterp->Tofs) #define ofslen (curinterp->Tofslen) @@ -127,7 +128,6 @@ #define incgv (curinterp->Iincgv) #define initav (curinterp->Iinitav) #define inplace (curinterp->Iinplace) -#define sys_intern (curinterp->Isys_intern) #define lastfd (curinterp->Ilastfd) #define lastscream (curinterp->Ilastscream) #define lastsize (curinterp->Ilastsize) @@ -191,6 +191,7 @@ #define sv_count (curinterp->Isv_count) #define sv_objcount (curinterp->Isv_objcount) #define sv_root (curinterp->Isv_root) +#define sys_intern (curinterp->Isys_intern) #define tainting (curinterp->Itainting) #define threadnum (curinterp->Ithreadnum) #define thrsv (curinterp->Ithrsv) @@ -247,7 +248,6 @@ #define Iincgv incgv #define Iinitav initav #define Iinplace inplace -#define Isys_intern sys_intern #define Ilastfd lastfd #define Ilastscream lastscream #define Ilastsize lastsize @@ -311,6 +311,7 @@ #define Isv_count sv_count #define Isv_objcount sv_objcount #define Isv_root sv_root +#define Isys_intern sys_intern #define Itainting tainting #define Ithreadnum threadnum #define Ithrsv thrsv @@ -344,6 +345,7 @@ #define Tmarkstack markstack #define Tmarkstack_max markstack_max #define Tmarkstack_ptr markstack_ptr +#define Tmodcount modcount #define Tnrs nrs #define Tofs ofs #define Tofslen ofslen @@ -428,7 +430,6 @@ #define incgv Perl_incgv #define initav Perl_initav #define inplace Perl_inplace -#define sys_intern Perl_sys_intern #define lastfd Perl_lastfd #define lastscream Perl_lastscream #define lastsize Perl_lastsize @@ -492,6 +493,7 @@ #define sv_count Perl_sv_count #define sv_objcount Perl_sv_objcount #define sv_root Perl_sv_root +#define sys_intern Perl_sys_intern #define tainting Perl_tainting #define threadnum Perl_threadnum #define thrsv Perl_thrsv @@ -525,6 +527,7 @@ #define markstack Perl_markstack #define markstack_max Perl_markstack_max #define markstack_ptr Perl_markstack_ptr +#define modcount Perl_modcount #define nrs Perl_nrs #define ofs Perl_ofs #define ofslen Perl_ofslen @@ -588,6 +591,7 @@ #define markstack (thr->Tmarkstack) #define markstack_max (thr->Tmarkstack_max) #define markstack_ptr (thr->Tmarkstack_ptr) +#define modcount (thr->Tmodcount) #define nrs (thr->Tnrs) #define ofs (thr->Tofs) #define ofslen (thr->Tofslen) diff --git a/ext/DynaLoader/dl_aix.xs b/ext/DynaLoader/dl_aix.xs index 4e865edd3b..ea5040857d 100644 --- a/ext/DynaLoader/dl_aix.xs +++ b/ext/DynaLoader/dl_aix.xs @@ -29,6 +29,20 @@ #include <a.out.h> #include <ldfcn.h> +/* + * 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 <ldfcn.h> */ #ifdef USE_PERLIO #define FSEEK(ldptr,o,p) PerlIO_seek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr)+o):o,p) diff --git a/ext/IO/IO.pm b/ext/IO/IO.pm index 1ba05ca916..4d4c81ce40 100644 --- a/ext/IO/IO.pm +++ b/ext/IO/IO.pm @@ -12,7 +12,7 @@ IO - load various IO modules =head1 DESCRIPTION -C<IO> provides a simple mechanism to load all of the IO modules at one go. +C<IO> provides a simple mechanism to load some of the IO modules at one go. Currently this includes: IO::Handle diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm index aadb502f19..406f74d2ff 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 47b1f5aa3c..ed4fe2b36f 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/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index b71e8b43cf..717b97ff84 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -152,7 +152,7 @@ like gv2cv, i_ncmp and ftsvtx. =item an operator tag name (optag) Operator tags can be used to refer to groups (or sets) of operators. -Tag names always being with a colon. The Opcode module defines several +Tag names always begin with a colon. The Opcode module defines several optags and the user can define others using the define_optag function. =item a negated opname or optag @@ -569,7 +569,7 @@ Originally designed and implemented by Malcolm Beattie, mbeattie@sable.ox.ac.uk as part of Safe version 1. Split out from Safe module version 1, named opcode tags and other -changes added by Tim Bunce E<lt>F<Tim.Bunce@ig.co.uk>E<gt>. +changes added by Tim Bunce. =cut diff --git a/ext/POSIX/POSIX.pod b/ext/POSIX/POSIX.pod index c781765a14..4726487b47 100644 --- a/ext/POSIX/POSIX.pod +++ b/ext/POSIX/POSIX.pod @@ -1392,7 +1392,9 @@ Tests the SigSet object to see if it contains a specific signal. =item new Create a new Termios object. This object will be destroyed automatically -when it is no longer needed. +when it is no longer needed. A Termios object corresponds to the termios +C struct. new() mallocs a new one, getattr() fills it from a file descriptor, +and setattr() sets a file descriptor's parameters to match Termios' contents. $termios = POSIX::Termios->new; @@ -1474,13 +1476,13 @@ array so an index must be specified. Set the c_cflag field of a termios object. - $termios->setcflag( &POSIX::CLOCAL ); + $termios->setcflag( $c_cflag | &POSIX::CLOCAL ); =item setiflag Set the c_iflag field of a termios object. - $termios->setiflag( &POSIX::BRKINT ); + $termios->setiflag( $c_iflag | &POSIX::BRKINT ); =item setispeed @@ -1494,13 +1496,13 @@ Returns C<undef> on failure. Set the c_lflag field of a termios object. - $termios->setlflag( &POSIX::ECHO ); + $termios->setlflag( $c_lflag | &POSIX::ECHO ); =item setoflag Set the c_oflag field of a termios object. - $termios->setoflag( &POSIX::OPOST ); + $termios->setoflag( $c_oflag | &POSIX::OPOST ); =item setospeed diff --git a/global.sym b/global.sym index 31a452b76b..ca97714ee9 100644 --- a/global.sym +++ b/global.sym @@ -389,11 +389,14 @@ magic_get magic_getarylen magic_getdefelem magic_getglob +magic_getnkeys magic_getpack magic_getpos magic_getsig +magic_getsubstr magic_gettaint magic_getuvar +magic_getvec magic_len magic_mutexfree magic_nextpack @@ -86,10 +86,18 @@ gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi) { dTHR; register GP *gp; + bool doproto = SvTYPE(gv) > SVt_NULL; + char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; sv_upgrade((SV*)gv, SVt_PVGV); - if (SvLEN(gv)) - Safefree(SvPVX(gv)); + if (SvLEN(gv)) { + if (proto) { + SvPVX(gv) = NULL; + SvLEN(gv) = 0; + SvPOK_off(gv); + } else + Safefree(SvPVX(gv)); + } Newz(602, gp, 1, GP); GvGP(gv) = gp_ref(gp); GvSV(gv) = NEWSV(72,0); @@ -102,6 +110,27 @@ gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi) GvNAMELEN(gv) = len; if (multi) GvMULTI_on(gv); + if (doproto) { /* Replicate part of newSUB here. */ + ENTER; + start_subparse(0,0); /* Create CV in compcv. */ + GvCV(gv) = compcv; + LEAVE; + + GvCVGEN(gv) = 0; + sub_generation++; + CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv); + CvFILEGV(GvCV(gv)) = curcop->cop_filegv; + CvSTASH(GvCV(gv)) = curstash; +#ifdef USE_THREADS + CvOWNER(GvCV(gv)) = 0; + New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex); + MUTEX_INIT(CvMUTEXP(GvCV(gv))); +#endif /* USE_THREADS */ + if (proto) { + sv_setpv((SV*)GvCV(gv), proto); + Safefree(proto); + } + } } static void @@ -565,13 +594,15 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) gv_init_sv(gv, sv_type); } return gv; + } else if (add & GV_NOINIT) { + return gv; } /* Adding a new symbol */ - if (add & 4) + if (add & GV_ADDWARN) warn("Had to create %s unexpectedly", nambeg); - gv_init(gv, stash, name, len, add & 2); + gv_init(gv, stash, name, len, add & GV_ADDMULTI); gv_init_sv(gv, sv_type); GvFLAGS(gv) |= add_gvflags; @@ -598,7 +629,8 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) GvMULTI_on(gv); sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0); /* NOTE: No support for tied ISA */ - if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILLp(av) == -1) + if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") + && AvFILLp(av) == -1) { char *pname; av_push(av, newSVpv(pname = "NDBM_File",0)); @@ -830,7 +862,7 @@ gv_check(HV *stash) } else if (isALPHA(*HeKEY(entry))) { gv = (GV*)HeVAL(entry); - if (GvMULTI(gv)) + if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) continue; curcop->cop_line = GvLINE(gv); filegv = GvFILEGV(gv); @@ -130,3 +130,4 @@ HV *GvHVn(); #define GV_ADD 0x01 #define GV_ADDMULTI 0x02 #define GV_ADDWARN 0x04 +#define GV_NOINIT 0x10 /* 8 is used without a symbolic constant */ diff --git a/lib/Carp.pm b/lib/Carp.pm index 685a7933d0..6bac36446a 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -47,10 +47,20 @@ environment variable. # This package is heavily used. Be small. Be fast. Be good. +# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an +# _almost_ complete understanding of the package. Corrections and +# comments are welcome. + +# The $CarpLevel variable can be set to "strip off" extra caller levels for +# those times when Carp calls are buried inside other functions. The +# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval +# text and function arguments should be formatted when printed. + $CarpLevel = 0; # How many extra package levels to skip on carp. $MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all. $MaxArgLen = 64; # How much of each argument to print. 0 = all. $MaxArgNums = 8; # How many arguments to print. 0 = all. +$Verbose = 0; # If true then make shortmess call longmess instead require Exporter; @ISA = ('Exporter'); @@ -58,30 +68,58 @@ require Exporter; @EXPORT_OK = qw(cluck verbose); @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode + +# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl") +# then the following method will be called by the Exporter which knows +# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word +# 'verbose'. + sub export_fail { shift; - if ($_[0] eq 'verbose') { - local $^W = 0; - *shortmess = \&longmess; - shift; - } + $Verbose = shift if $_[0] eq 'verbose'; return @_; } +# longmess() crawls all the way up the stack reporting on all the function +# calls made. The error string, $error, is originally constructed from the +# arguments passed into longmess() via confess(), cluck() or shortmess(). +# This gets appended with the stack trace messages which are generated for +# each function call on the stack. + sub longmess { my $error = join '', @_; my $mess = ""; my $i = 1 + $CarpLevel; my ($pack,$file,$line,$sub,$hargs,$eval,$require); my (@a); + # + # crawl up the stack.... + # while (do { { package DB; @a = caller($i++) } } ) { - ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; + # get copies of the variables returned from caller() + ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; + # + # if the $error error string is newline terminated then it + # is copied into $mess. Otherwise, $mess gets set (at the end of + # the 'else {' section below) to one of two things. The first time + # through, it is set to the "$error at $file line $line" message. + # $error is then set to 'called' which triggers subsequent loop + # iterations to append $sub to $mess before appending the "$error + # at $file line $line" which now actually reads "called at $file line + # $line". Thus, the stack trace message is constructed: + # + # first time: $mess = $error at $file line $line + # subsequent times: $mess .= $sub $error at $file line $line + # ^^^^^^ + # "called" if ($error =~ m/\n$/) { $mess .= $error; } else { + # Build a string, $sub, which names the sub-routine called. + # This may also be "require ...", "eval '...' or "eval {...}" if (defined $eval) { - if ($require) { + if ($require) { $sub = "require $eval"; } else { $eval =~ s/([\\\'])/\\$1/g; @@ -93,32 +131,48 @@ sub longmess { } elsif ($sub eq '(eval)') { $sub = 'eval {...}'; } + # if there are any arguments in the sub-routine call, format + # them according to the format variables defined earlier in + # this file and join them onto the $sub sub-routine string if ($hargs) { - @a = @DB::args; # must get local copy of args - if ($MaxArgNums and @a > $MaxArgNums) { - $#a = $MaxArgNums; - $a[$#a] = "..."; - } - for (@a) { - $_ = "undef", next unless defined $_; - if (ref $_) { - $_ .= ''; - s/'/\\'/g; + # we may trash some of the args so we take a copy + @a = @DB::args; # must get local copy of args + # don't print any more than $MaxArgNums + if ($MaxArgNums and @a > $MaxArgNums) { + # cap the length of $#a and set the last element to '...' + $#a = $MaxArgNums; + $a[$#a] = "..."; } - else { - s/'/\\'/g; - substr($_,$MaxArgLen) = '...' - if $MaxArgLen and $MaxArgLen < length; + for (@a) { + # set args to the string "undef" if undefined + $_ = "undef", next unless defined $_; + if (ref $_) { + # dunno what this is for... + $_ .= ''; + s/'/\\'/g; + } + else { + s/'/\\'/g; + # terminate the string early with '...' if too long + substr($_,$MaxArgLen) = '...' + if $MaxArgLen and $MaxArgLen < length; + } + # 'quote' arg unless it looks like a number + $_ = "'$_'" unless /^-?[\d.]+$/; + # print high-end chars as 'M-<char>' or '^<char>' + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; } - $_ = "'$_'" unless /^-?[\d.]+$/; - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; - } - $sub .= '(' . join(', ', @a) . ')'; + # append ('all', 'the', 'arguments') to the $sub string + $sub .= '(' . join(', ', @a) . ')'; } + # here's where the error message, $mess, gets constructed $mess .= "\t$sub " if $error eq "called"; $mess .= "$error at $file line $line\n"; } + # we don't need to print the actual error message again so we can + # change this to "called" so that the string "$error at $file line + # $line" makes sense as "called at $file line $line". $error = "called"; } # this kludge circumvents die's incorrect handling of NUL @@ -127,36 +181,71 @@ sub longmess { $$msg; } + +# shortmess() is called by carp() and croak() to skip all the way up to +# the top-level caller's package and report the error from there. confess() +# and cluck() generate a full stack trace so they call longmess() to +# generate that. In verbose mode shortmess() calls longmess() so +# you always get a stack trace + sub shortmess { # Short-circuit &longmess if called via multiple packages + goto &longmess if $Verbose; my $error = join '', @_; my ($prevpack) = caller(1); my $extra = $CarpLevel; my $i = 2; my ($pack,$file,$line); + # when reporting an error, we want to report it from the context of the + # calling package. So what is the calling package? Within a module, + # there may be many calls between methods and perhaps between sub-classes + # and super-classes, but the user isn't interested in what happens + # inside the package. We start by building a hash array which keeps + # track of all the packages to which the calling package belongs. We + # do this by examining its @ISA variable. Any call from a base class + # method (one of our caller's @ISA packages) can be ignored my %isa = ($prevpack,1); + # merge all the caller's @ISA packages into %isa. @isa{@{"${prevpack}::ISA"}} = () if(defined @{"${prevpack}::ISA"}); + # now we crawl up the calling stack and look at all the packages in + # there. For each package, we look to see if it has an @ISA and then + # we see if our caller features in that list. That would imply that + # our caller is a derived class of that package and its calls can also + # be ignored while (($pack,$file,$line) = caller($i++)) { if(defined @{$pack . "::ISA"}) { my @i = @{$pack . "::ISA"}; my %i; @i{@i} = (); + # merge any relevant packages into %isa @isa{@i,$pack} = () if(exists $i{$prevpack} || exists $isa{$pack}); } + # and here's where we do the ignoring... if the package in + # question is one of our caller's base or derived packages then + # we can ignore it (skip it) and go onto the next (but note that + # the continue { } block below gets called every time) next if(exists $isa{$pack}); + # Hey! We've found a package that isn't one of our caller's + # clan....but wait, $extra refers to the number of 'extra' levels + # we should skip up. If $extra > 0 then this is a false alarm. + # We must merge the package into the %isa hash (so we can ignore it + # if it pops up again), decrement $extra, and continue. if ($extra-- > 0) { %isa = ($pack,1); @isa{@{$pack . "::ISA"}} = () if(defined @{$pack . "::ISA"}); } else { - # this kludge circumvents die's incorrect handling of NUL + # OK! We've got a candidate package. Time to construct the + # relevant error message and return it. die() doesn't like + # to be given NUL characters (which $msg may contain) so we + # remove them first. (my $msg = "$error at $file line $line\n") =~ tr/\0//d; return $msg; } @@ -165,12 +254,23 @@ sub shortmess { # Short-circuit &longmess if called via multiple packages $prevpack = $pack; } + # uh-oh! It looks like we crawled all the way up the stack and + # never found a candidate package. Oh well, let's call longmess + # to generate a full stack trace. We use the magical form of 'goto' + # so that this shortmess() function doesn't appear on the stack + # to further confuse longmess() about it's calling package. goto &longmess; } -sub confess { die longmess @_; } -sub croak { die shortmess @_; } -sub carp { warn shortmess @_; } -sub cluck { warn longmess @_; } + +# the following four functions call longmess() or shortmess() depending on +# whether they should generate a full stack trace (confess() and cluck()) +# or simply report the caller's package (croak() and carp()), respectively. +# confess() and croak() die, carp() and cluck() warn. + +sub croak { die shortmess @_ } +sub confess { die longmess @_ } +sub carp { warn shortmess @_ } +sub cluck { warn longmess @_ } 1; diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 4f861dfe2a..99ca0bd1fb 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -1953,7 +1953,7 @@ pure_site_install :: }.$self->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{ doc_perl_install :: - }.$self->{NOECHO}.q{$(DOC_INSTALL) \ + -}.$self->{NOECHO}.q{$(DOC_INSTALL) \ "Module" "$(NAME)" \ "installed into" "$(INSTALLPRIVLIB)" \ LINKTYPE "$(LINKTYPE)" \ @@ -1962,7 +1962,7 @@ doc_perl_install :: >> }.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q{ doc_site_install :: - }.$self->{NOECHO}.q{$(DOC_INSTALL) \ + -}.$self->{NOECHO}.q{$(DOC_INSTALL) \ "Module" "$(NAME)" \ "installed into" "$(INSTALLSITELIB)" \ LINKTYPE "$(LINKTYPE)" \ @@ -2327,7 +2327,7 @@ $tmp/perlmain.c: $makefilename}, q{ push @m, q{ doc_inst_perl: }.$self->{NOECHO}.q{echo Appending installation info to $(INSTALLARCHLIB)/perllocal.pod - }.$self->{NOECHO}.q{$(DOC_INSTALL) \ + -}.$self->{NOECHO}.q{$(DOC_INSTALL) \ "Perl binary" "$(MAP_TARGET)" \ MAP_STATIC "$(MAP_STATIC)" \ MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \ diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm index 3333844ca6..e21af92682 100644 --- a/lib/File/Basename.pm +++ b/lib/File/Basename.pm @@ -160,23 +160,23 @@ sub fileparse { if ($fstype =~ /^VMS/i) { if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation else { - ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/); + ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/t); $dirpath ||= ''; # should always be defined } } if ($fstype =~ /^MS(DOS|Win32)/i) { - ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/); + ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/t); $dirpath .= '.\\' unless $dirpath =~ /[\\\/]$/; } elsif ($fstype =~ /^MacOS/i) { - ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/); + ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/t); } elsif ($fstype =~ /^AmigaOS/i) { - ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/); + ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/t); $dirpath = './' unless $dirpath; } elsif ($fstype !~ /^VMS/i) { # default to Unix - ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#); + ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#t); if ($^O eq 'VMS' and $fullname =~ m:/[^/]+/000000/?:) { # dev:[000000] is top of VMS tree, similar to Unix '/' ($basename,$dirpath) = ('',$fullname); @@ -188,7 +188,7 @@ sub fileparse { $tail = ''; foreach $suffix (@suffices) { my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$"; - if ($basename =~ s/$pat//) { + if ($basename =~ s/$pat//t) { $taint .= substr($suffix,0,0); $tail = $1 . $tail; } @@ -226,30 +226,30 @@ sub dirname { } if ($fstype =~ /MacOS/i) { return $dirname } elsif ($fstype =~ /MSDOS/i) { - $dirname =~ s/([^:])[\\\/]*$/$1/; + $dirname =~ s/([^:])[\\\/]*$/$1/t; unless( length($basename) ) { ($basename,$dirname) = fileparse $dirname; - $dirname =~ s/([^:])[\\\/]*$/$1/; + $dirname =~ s/([^:])[\\\/]*$/$1/t; } } elsif ($fstype =~ /MSWin32/i) { - $dirname =~ s/([^:])[\\\/]*$/$1/; + $dirname =~ s/([^:])[\\\/]*$/$1/t; unless( length($basename) ) { ($basename,$dirname) = fileparse $dirname; - $dirname =~ s/([^:])[\\\/]*$/$1/; + $dirname =~ s/([^:])[\\\/]*$/$1/t; } } elsif ($fstype =~ /AmigaOS/i) { if ( $dirname =~ /:$/) { return $dirname } chop $dirname; - $dirname =~ s#[^:/]+$## unless length($basename); + $dirname =~ s#[^:/]+$##t unless length($basename); } else { $dirname =~ s:(.)/*$:$1:; unless( length($basename) ) { local($File::Basename::Fileparse_fstype) = $fstype; ($basename,$dirname) = fileparse $dirname; - $dirname =~ s:(.)/*$:$1:; + $dirname =~ s:(.)/*$:$1:t; } } diff --git a/lib/File/Find.pm b/lib/File/Find.pm index 67abf6088b..1305d21e6b 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -202,7 +202,7 @@ sub find { find_opt(wrap_wanted($wanted), @_); } -sub find_depth { +sub finddepth { my $wanted = wrap_wanted(shift); $wanted->{bydepth} = 1; find_opt($wanted, @_); diff --git a/lib/Pod/Html.pm b/lib/Pod/Html.pm index 8ff3e8964b..dafa27d781 100644 --- a/lib/Pod/Html.pm +++ b/lib/Pod/Html.pm @@ -3,6 +3,8 @@ package Pod::Html; use Pod::Functions; use Getopt::Long; # package for handling command-line parameters require Exporter; +use vars qw($VERSION); +$VERSION = 1.01; @ISA = Exporter; @EXPORT = qw(pod2html htmlify); use Cwd; @@ -11,13 +13,15 @@ use Carp; use strict; +use Config; + =head1 NAME -Pod::HTML - module to convert pod files to HTML +Pod::Html - module to convert pod files to HTML =head1 SYNOPSIS - use Pod::HTML; + use Pod::Html; pod2html([options]); =head1 DESCRIPTION @@ -302,7 +306,7 @@ sub pod2html { for (my $i = 0; $i < @poddata; $i++) { if ($poddata[$i] =~ /^=head1\s*NAME\b/m) { for my $para ( @poddata[$i, $i+1] ) { - last TITLE_SEARCH if ($title) = $para =~ /(\S+\s+-+\s*.*)/s; + last TITLE_SEARCH if ($title) = $para =~ /(\S+\s+-+.*\S)/s; } } @@ -316,19 +320,22 @@ sub pod2html { warn "adopted '$title' as title for $podfile\n" if $verbose and $title; } - unless ($title) { + if ($title) { + $title =~ s/\s*\(.*\)//; + } else { warn "$0: no title for $podfile"; $podfile =~ /^(.*)(\.[^.\/]+)?$/; $title = ($podfile eq "-" ? 'No Title' : $1); warn "using $title" if $verbose; } print HTML <<END_OF_HEAD; - <HTML> - <HEAD> - <TITLE>$title</TITLE> - </HEAD> +<HTML> +<HEAD> +<TITLE>$title</TITLE> +<LINK REV="made" HREF="mailto:$Config{perladmin}"> +</HEAD> - <BODY> +<BODY> END_OF_HEAD @@ -368,9 +375,9 @@ END_OF_HEAD } else { next if @begin_stack && $begin_stack[-1] ne 'html'; - if (/^=(head[1-6])\s+(.*)/s) { # =head[1-6] heading + if (/^=(head[1-6])\s+(.*\S)/s) { # =head[1-6] heading process_head($1, $2); - } elsif (/^=item\s*(.*)/sm) { # =item text + } elsif (/^=item\s*(.*\S)/sm) { # =item text process_item($1); } elsif (/^=over\s*(.*)/) { # =over N process_over(); @@ -391,16 +398,16 @@ END_OF_HEAD next if @begin_stack && $begin_stack[-1] ne 'html'; my $text = $_; process_text(\$text, 1); - print HTML "$text\n<P>\n\n"; + print HTML "<P>\n$text"; } } # finish off any pending directives finish_list(); print HTML <<END_OF_TAIL; - </BODY> +</BODY> - </HTML> +</HTML> END_OF_TAIL # close the html file @@ -782,7 +789,7 @@ sub scan_headings { $index .= "\n" . ("\t" x $listdepth) . "<LI>" . "<A HREF=\"#" . htmlify(0,$title) . "\">" . - process_text(\$title, 0) . "</A>"; + html_escape(process_text(\$title, 0)) . "</A>"; } } @@ -823,8 +830,8 @@ sub scan_items { if ($1 eq "*") { # bullet list /\A=item\s+\*\s*(.*?)\s*\Z/s; $item = $1; - } elsif ($1 =~ /^[0-9]+/) { # numbered list - /\A=item\s+[0-9]+\.?(.*?)\s*\Z/s; + } elsif ($1 =~ /^\d+/) { # numbered list + /\A=item\s+\d+\.?(.*?)\s*\Z/s; $item = $1; } else { # /\A=item\s+(.*?)\s*\Z/s; @@ -856,6 +863,7 @@ sub process_head { print HTML "<H$level>"; # unless $listlevel; #print HTML "<H$level>" unless $listlevel; my $convert = $heading; process_text(\$convert, 0); + $convert = html_escape($convert); print HTML '<A NAME="' . htmlify(0,$heading) . "\">$convert</A>"; print HTML "</H$level>"; # unless $listlevel; print HTML "\n"; @@ -898,30 +906,36 @@ sub process_item { print HTML "<UL>\n"; } - print HTML "<LI><STRONG>"; - $text =~ /\A\*\s*(.*)\Z/s; - print HTML "<A NAME=\"item_" . htmlify(1,$1) . "\">" if $1 && !$items_named{$1}++; - $quote = 1; - #print HTML process_puretext($1, \$quote); - print HTML $1; - print HTML "</A>" if $1; - print HTML "</STRONG>"; + print HTML '<LI>'; + if ($text =~ /\A\*\s*(.+)\Z/s) { + print HTML '<STRONG>'; + if ($items_named{$1}++) { + print HTML html_escape($1); + } else { + my $name = 'item_' . htmlify(1,$1); + print HTML qq(<A NAME="$name">), html_escape($1), '</A>'; + } + print HTML '</STRONG>'; + } - } elsif ($text =~ /\A[0-9#]+/) { # numbered list + } elsif ($text =~ /\A[\d#]+/) { # numbered list if ($need_preamble) { push(@listend, "</OL>"); print HTML "<OL>\n"; } - print HTML "<LI><STRONG>"; - $text =~ /\A[0-9]+\.?(.*)\Z/s; - print HTML "<A NAME=\"item_" . htmlify(0,$1) . "\">" if $1; - $quote = 1; - #print HTML process_puretext($1, \$quote); - print HTML $1 if $1; - print HTML "</A>" if $1; - print HTML "</STRONG>"; + print HTML '<LI>'; + if ($text =~ /\A\d+\.?\s*(.+)\Z/s) { + print HTML '<STRONG>'; + if ($items_named{$1}++) { + print HTML html_escape($1); + } else { + my $name = 'item_' . htmlify(0,$1); + print HTML qq(<A NAME="$name">), html_escape($1), '</A>'; + } + print HTML '</STRONG>'; + } } else { # all others @@ -930,18 +944,17 @@ sub process_item { print HTML "<DL>\n"; } - print HTML "<DT><STRONG>"; - print HTML "<A NAME=\"item_" . htmlify(1,$text) . "\">" - if $text && !$items_named{($text =~ /(\S+)/)[0]}++; - # preceding craziness so that the duplicate leading bits in - # perlfunc work to find just the first one. otherwise - # open etc would have many names - $quote = 1; - #print HTML process_puretext($text, \$quote); - print HTML $text; - print HTML "</A>" if $text; - print HTML "</STRONG>"; - + print HTML '<DT>'; + if ($text =~ /(\S+)/) { + print HTML '<STRONG>'; + if ($items_named{$1}++) { + print HTML html_escape($text); + } else { + my $name = 'item_' . htmlify(1,$text); + print HTML qq(<A NAME="$name">), html_escape($text), '</A>'; + } + print HTML '</STRONG>'; + } print HTML '<DD>'; } @@ -1276,12 +1289,15 @@ sub process_puretext { $word = qq(<A HREF="$word">$word</A>); } elsif ($word =~ /[\w.-]+\@\w+\.\w/) { # looks like an e-mail address - $word = qq(<A HREF="MAILTO:$word">$word</A>); + my ($w1, $w2, $w3) = ("", $word, ""); + ($w1, $w2, $w3) = ("(", $1, ")$2") if $word =~ /^\((.*?)\)(,?)/; + ($w1, $w2, $w3) = ("<", $1, ">$2") if $word =~ /^<(.*?)>(,?)/; + $word = qq($w1<A HREF="mailto:$w2">$w2</A>$w3); } elsif ($word !~ /[a-z]/ && $word =~ /[A-Z]/) { # all uppercase? - $word = html_escape($word) if $word =~ /[&<>]/; + $word = html_escape($word) if $word =~ /["&<>]/; $word = "\n<FONT SIZE=-1>$word</FONT>" if $netscape; } else { - $word = html_escape($word) if $word =~ /[&<>]/; + $word = html_escape($word) if $word =~ /["&<>]/; } } @@ -1443,6 +1459,7 @@ sub process_C { $s1 =~ s/\([^()]*\)//g; # delete parentheses $s2 = $s1; $s1 =~ s/\W//g; # delete bogus characters + $str = html_escape($str); # if there was a pod file that we found earlier with an appropriate # =item directive, then create a link to that page. @@ -1512,7 +1529,7 @@ sub process_X { # after the entire pod file has been read and converted. # sub finish_list { - while ($listlevel >= 0) { + while ($listlevel > 0) { print HTML "</DL>\n"; $listlevel--; } @@ -1546,4 +1563,3 @@ BEGIN { } 1; - diff --git a/lib/Term/ReadLine.pm b/lib/Term/ReadLine.pm index 2183c8d235..83ba375742 100644 --- a/lib/Term/ReadLine.pm +++ b/lib/Term/ReadLine.pm @@ -310,7 +310,7 @@ sub ornaments { return $rl_term_set unless @_; $rl_term_set = shift; $rl_term_set ||= ',,,'; - $rl_term_set = 'us,ue,md,me' if $rl_term_set == 1; + $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1'; my @ts = split /,/, $rl_term_set, 4; eval { LoadTermCap }; unless (defined $terminal) { diff --git a/lib/strict.pm b/lib/strict.pm index 2b1d964e65..4e2baa3b1c 100644 --- a/lib/strict.pm +++ b/lib/strict.pm @@ -72,19 +72,11 @@ appears in curly braces or on the left hand side of the "=E<gt>" symbol. =back -See L<perlmod/Pragmatic Modules>. +See L<perlmodlib/Pragmatic Modules>. =cut -$strict::VERSION = "1.01"; - -my %bitmask = ( -refs => 0x00000002, -subs => 0x00000200, -vars => 0x00000400 -); - sub bits { my $bits = 0; foreach my $s (@_){ $bits |= $bitmask{$s} || 0; }; diff --git a/lib/subs.pm b/lib/subs.pm index 512bc9be9a..aa332a6785 100644 --- a/lib/subs.pm +++ b/lib/subs.pm @@ -20,7 +20,7 @@ C<use subs> 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<no vars> or C<no subs>. -See L<perlmod/Pragmatic Modules> and L<strict/strict subs>. +See L<perlmodlib/Pragmatic Modules> and L<strict/strict subs>. =cut diff --git a/lib/vars.pm b/lib/vars.pm index 5723ac6c2c..5256d1199f 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<perlmod/Pragmatic Modules>. +See L<perlmodlib/Pragmatic Modules>. =cut @@ -460,7 +460,8 @@ magic_get(SV *sv, MAGIC *mg) } sv_setpvn(sv,s,i); if (tainting) - tainted = was_tainted || RX_MATCH_TAINTED(rx); + tainted = (was_tainted || RX_MATCH_TAINTED(rx) || + (curpm->op_pmflags & PMf_TAINTMEM)); break; } } @@ -945,11 +946,33 @@ magic_setamagic(SV *sv, MAGIC *mg) #endif /* OVERLOAD */ int +magic_getnkeys(SV *sv, MAGIC *mg) +{ + HV *hv = (HV*)LvTARG(sv); + HE *entry; + I32 i = 0; + + if (hv) { + (void) hv_iterinit(hv); + if (!SvRMAGICAL(hv) || !mg_find((SV*)hv,'P')) + i = HvKEYS(hv); + else { + /*SUPPRESS 560*/ + while (entry = hv_iternext(hv)) { + i++; + } + } + } + + sv_setiv(sv, (IV)i); + return 0; +} + +int magic_setnkeys(SV *sv, MAGIC *mg) { if (LvTARG(sv)) { hv_ksplit((HV*)LvTARG(sv), SvIV(sv)); - LvTARG(sv) = Nullsv; /* Don't allow a ref to reassign this. */ } return 0; } @@ -1218,6 +1241,23 @@ magic_setglob(SV *sv, MAGIC *mg) } int +magic_getsubstr(SV *sv, MAGIC *mg) +{ + STRLEN len; + SV *lsv = LvTARG(sv); + char *tmps = SvPV(lsv,len); + I32 offs = LvTARGOFF(sv); + I32 rem = LvTARGLEN(sv); + + if (offs > len) + offs = len; + if (rem + offs > len) + rem = len - offs; + sv_setpvn(sv, tmps + offs, (STRLEN)rem); + return 0; +} + +int magic_setsubstr(SV *sv, MAGIC *mg) { STRLEN len; @@ -1253,6 +1293,72 @@ magic_settaint(SV *sv, MAGIC *mg) } int +magic_getvec(SV *sv, MAGIC *mg) +{ + SV *lsv = LvTARG(sv); + unsigned char *s; + unsigned long retnum; + STRLEN lsvlen; + I32 len; + I32 offset; + I32 size; + + if (!lsv) { + SvOK_off(sv); + return 0; + } + s = (unsigned char *) SvPV(lsv, lsvlen); + offset = LvTARGOFF(sv); + size = LvTARGLEN(sv); + len = (offset + size + 7) / 8; + + /* Copied from pp_vec() */ + + if (len > lsvlen) { + if (size <= 8) + retnum = 0; + else { + offset >>= 3; + if (size == 16) { + if (offset >= lsvlen) + retnum = 0; + else + retnum = (unsigned long) s[offset] << 8; + } + else if (size == 32) { + if (offset >= lsvlen) + retnum = 0; + else if (offset + 1 >= lsvlen) + retnum = (unsigned long) s[offset] << 24; + else if (offset + 2 >= lsvlen) + retnum = ((unsigned long) s[offset] << 24) + + ((unsigned long) s[offset + 1] << 16); + else + retnum = ((unsigned long) s[offset] << 24) + + ((unsigned long) s[offset + 1] << 16) + + (s[offset + 2] << 8); + } + } + } + else if (size < 8) + retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1); + else { + offset >>= 3; + if (size == 8) + retnum = s[offset]; + else if (size == 16) + retnum = ((unsigned long) s[offset] << 8) + s[offset+1]; + else if (size == 32) + retnum = ((unsigned long) s[offset] << 24) + + ((unsigned long) s[offset + 1] << 16) + + (s[offset + 2] << 8) + s[offset+3]; + } + + sv_setuv(sv, (UV)retnum); + return 0; +} + +int magic_setvec(SV *sv, MAGIC *mg) { do_vecset(sv); /* XXX slurp this routine */ @@ -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); } @@ -2669,7 +2672,7 @@ new_logop(I32 type, I32 flags, OP** firstp, OP** otherp) case OP_NULL: if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) - && (k1->op_type == OP_RV2SV || k1->op_type == OP_PADSV)) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) warnop = k2->op_type; break; @@ -2831,6 +2834,24 @@ newLOOPOP(I32 flags, I32 debuggable, OP *expr, OP *block) || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); + } else if (expr->op_flags & OPf_KIDS) { + OP *k1 = ((UNOP*)expr)->op_first; + OP *k2 = (k1) ? k1->op_sibling : NULL; + switch (expr->op_type) { + case OP_NULL: + if (k2 && k2->op_type == OP_READLINE + && (k2->op_flags & OPf_STACKED) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) + expr = newUNOP(OP_DEFINED, 0, expr); + break; + + case OP_SASSIGN: + if (k1->op_type == OP_READDIR + || k1->op_type == OP_GLOB + || k1->op_type == OP_EACH) + expr = newUNOP(OP_DEFINED, 0, expr); + break; + } } } @@ -2866,6 +2887,24 @@ newWHILEOP(I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *b || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) { expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); + } else if (expr && (expr->op_flags & OPf_KIDS)) { + OP *k1 = ((UNOP*)expr)->op_first; + OP *k2 = (k1) ? k1->op_sibling : NULL; + switch (expr->op_type) { + case OP_NULL: + if (k2 && k2->op_type == OP_READLINE + && (k2->op_flags & OPf_STACKED) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) + expr = newUNOP(OP_DEFINED, 0, expr); + break; + + case OP_SASSIGN: + if (k1->op_type == OP_READDIR + || k1->op_type == OP_GLOB + || k1->op_type == OP_EACH) + expr = newUNOP(OP_DEFINED, 0, expr); + break; + } } if (!block) @@ -3307,7 +3346,8 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) { dTHR; char *name = o ? SvPVx(cSVOPo->op_sv, na) : Nullch; - GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); + GV *gv = gv_fetchpv(name ? name : "__ANON__", + GV_ADDMULTI | (block ? 0 : GV_NOINIT), SVt_PVCV); char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, na) : Nullch; register CV *cv; I32 ix; @@ -3317,6 +3357,23 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) if (proto) SAVEFREEOP(proto); + if (SvTYPE(gv) != SVt_PVGV) { /* Prototype now, and had + maximum a prototype before. */ + if (SvTYPE(gv) > SVt_NULL) { + if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)) + warn("Runaway prototype"); + cv_ckproto((CV*)gv, NULL, ps); + } + if (ps) + sv_setpv((SV*)gv, ps); + else + sv_setiv((SV*)gv, -1); + SvREFCNT_dec(compcv); + compcv = NULL; + sub_generation++; + goto noblock; + } + if (!name || GvCVGEN(gv)) cv = Nullcv; else if (cv = GvCV(gv)) { @@ -3398,6 +3455,7 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) } } if (!block) { + noblock: copline = NOLINE; LEAVE_SCOPE(floor); return cv; @@ -181,9 +181,12 @@ struct pmop { REGEXP * op_pmregexp; /* compiled expression */ U16 op_pmflags; U16 op_pmpermflags; + U8 op_pmdynflags; }; -#define PMf_USED 0x0001 /* pm has been used once already */ +#define PMdf_USED 0x01 /* pm has been used once already */ + +#define PMf_TAINTMEM 0x0001 /* taint $1 etc. if target tainted */ #define PMf_ONCE 0x0002 /* use pattern only once per reset */ #define PMf_REVERSED 0x0004 /* Should be matched right->left */ /*#define PMf_ALL 0x0008*/ /* initial constant is whole pat */ @@ -2264,7 +2264,7 @@ EXT U32 opargs[] = { 0x00009c8e, /* oct */ 0x00009c8e, /* abs */ 0x00009c9c, /* length */ - 0x0091150c, /* substr */ + 0x0991150c, /* substr */ 0x0011151c, /* vec */ 0x0091151c, /* index */ 0x0091151c, /* rindex */ @@ -362,7 +362,7 @@ abs abs ck_fun fstu% S? # String stuff. length length ck_lengthconst istu% S? -substr substr ck_fun st@ S S S? +substr substr ck_fun st@ S S S? S? vec vec ck_fun ist@ S S S index index ck_index ist@ S S S? @@ -668,6 +668,7 @@ setuid perl scripts securely.\n"); s = argv[0]+1; reswitch: switch (*s) { + case ' ': case '0': case 'F': case 'a': @@ -1165,6 +1166,8 @@ perl_call_method(char *methname, I32 flags) XPUSHs(sv_2mortal(newSVpv(methname,0))); PUTBACK; pp_method(ARGS); + if(op == &myop) + op = Nullop; return perl_call_sv(*stack_sp--, flags); } @@ -1562,8 +1565,11 @@ moreswitches(char *s) inplace = savepv(s+1); /*SUPPRESS 530*/ for (s = inplace; *s && !isSPACE(*s); s++) ; - if (*s) + if (*s) { *s++ = '\0'; + if (*s == '-') /* Additional switches on #! line. */ + s++; + } return s; case 'I': /* -I handled both here and in parse_perl() */ forbid_setid("-I"); @@ -1735,6 +1741,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) @@ -1742,18 +1749,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 @@ -710,6 +710,15 @@ Free_t Perl_free _((Malloc_t where)); # endif #endif +/* XXX Experimental set-up for long long. Just add -DUSE_LONG_LONG + to your ccflags. --Andy Dougherty 4/1998 +*/ +#ifdef USE_LONG_LONG +# if defined(HAS_LONG_LONG) && LONGLONGSIZE == 8 +# define Quad_t long long +# endif +#endif + #ifdef Quad_t # define HAS_QUAD typedef Quad_t IV; @@ -1809,13 +1818,15 @@ EXT MGVTBL vtbl_glob = {magic_getglob, 0, 0, 0}; EXT MGVTBL vtbl_mglob = {0, magic_setmglob, 0, 0, 0}; -EXT MGVTBL vtbl_nkeys = {0, magic_setnkeys, +EXT MGVTBL vtbl_nkeys = {magic_getnkeys, + magic_setnkeys, 0, 0, 0}; EXT MGVTBL vtbl_taint = {magic_gettaint,magic_settaint, 0, 0, 0}; -EXT MGVTBL vtbl_substr = {0, magic_setsubstr, +EXT MGVTBL vtbl_substr = {magic_getsubstr, magic_setsubstr, 0, 0, 0}; -EXT MGVTBL vtbl_vec = {0, magic_setvec, +EXT MGVTBL vtbl_vec = {magic_getvec, + magic_setvec, 0, 0, 0}; EXT MGVTBL vtbl_pos = {magic_getpos, magic_setpos, diff --git a/pod/Makefile b/pod/Makefile index e9623a62ff..16f90a1891 100644 --- a/pod/Makefile +++ b/pod/Makefile @@ -239,7 +239,9 @@ toc: $(PERL) -I../lib pod2latex $*.pod clean: - rm -f $(MAN) $(HTML) $(TEX) + rm -f $(MAN) + rm -f $(HTML) + rm -f $(TEX) rm -f pod2html-*cache rm -f *.aux *.log *.exe diff --git a/pod/perlapio.pod b/pod/perlapio.pod index c963d232f6..f69e79502c 100644 --- a/pod/perlapio.pod +++ b/pod/perlapio.pod @@ -67,7 +67,7 @@ has been "tidied up a little". =item B<PerlIO *> -This takes the place of FILE *. Unlike FILE * it should be treated as +This takes the place of FILE *. Like FILE * it should be treated as opaque (it is probably safe to assume it is a pointer to something). =item B<PerlIO_stdin()>, B<PerlIO_stdout()>, B<PerlIO_stderr()> @@ -84,7 +84,7 @@ These correspond to fopen()/fdopen() arguments are the same. =item B<PerlIO_printf(f,fmt,...)>, B<PerlIO_vprintf(f,fmt,a)> -These are is fprintf()/vfprintf equivalents. +These are fprintf()/vfprintf() equivalents. =item B<PerlIO_stdoutf(fmt,...)> @@ -201,8 +201,8 @@ behaviour. =item B<PerlIO_setlinebuf(f)> This corresponds to setlinebuf(). Use is deprecated pending -further discussion. (Perl core uses it I<only> when "dumping" -is has nothing to do with $| auto-flush.) +further discussion. (Perl core uses it I<only> when "dumping"; +it has nothing to do with $| auto-flush.) =back diff --git a/pod/perlcall.pod b/pod/perlcall.pod index 865d3bf88d..37916ae6d8 100644 --- a/pod/perlcall.pod +++ b/pod/perlcall.pod @@ -1918,7 +1918,7 @@ refers to the last. =head2 Creating and calling an anonymous subroutine in C -As we've already shown, L<perl_call_sv> can be used to invoke an +As we've already shown, C<perl_call_sv> can be used to invoke an anonymous subroutine. However, our example showed how Perl script invoking an XSUB to preform this operation. Let's see how it can be done inside our C code: @@ -1931,8 +1931,9 @@ done inside our C code: perl_call_sv(cvrv, G_VOID|G_NOARGS); -L<perlguts/perl_eval_pv> is used to compile the anonymous subroutine, which -will be the return value as well. Once this code reference is in hand, it +C<perl_eval_pv> is used to compile the anonymous subroutine, which +will be the return value as well (read more about C<perl_eval_pv> in +L<perlguts/perl_eval_pv>). Once this code reference is in hand, it can be mixed in with all the previous examples we've shown. =head1 SEE ALSO diff --git a/pod/perldebug.pod b/pod/perldebug.pod index 8937c7e989..68f3684e44 100644 --- a/pod/perldebug.pod +++ b/pod/perldebug.pod @@ -63,7 +63,7 @@ it prints out the description for just that command. The special argument of C<h h> produces a more compact help listing, designed to fit together on one screen. -If the output the C<h> command (or any command, for that matter) scrolls +If the output of the C<h> command (or any command, for that matter) scrolls past your screen, either precede the command with a leading pipe symbol so it's run through your pager, as in @@ -281,7 +281,7 @@ The sequence of steps taken by the debugger is 4. prompt user if at a breakpoint or in single-step 5. evaluate line -For example, this will print out C<$foo> every time line +For example, this will print out $foo every time line 53 is passed: a 53 print "DB FOUND $foo\n" @@ -298,6 +298,14 @@ Add a global watch-expression. Delete all watch-expressions. +=item W [expr] + +Add a global watch-expression. + +=item W + +Delete all watch-expressions. + =item O [opt[=val]] [opt"val"] [opt?]... Set or query values of options. val defaults to 1. opt can @@ -667,8 +675,8 @@ C<main::pests> was called in a scalar context, also from I<camel_flea>, but from line 4. Note that if you execute C<T> command from inside an active C<use> -statement, the backtrace will contain both C<L<perlfunc/require>> -frame and an C<L<perlfunc/eval EXPR>>) frame. +statement, the backtrace will contain both C<require> +frame and an C<eval>) frame. =item Listing @@ -868,7 +876,7 @@ compile subname> for the same purpose. =head2 Debugger Customization -Most probably you not want to modify the debugger, it contains enough +Most probably you do not want to modify the debugger, it contains enough hooks to satisfy most needs. You may change the behaviour of debugger from the debugger itself, using C<O>ptions, from the command line via C<PERLDB_OPTS> environment variable, and from I<customization files>. @@ -966,14 +974,14 @@ application. =item * -The array C<@{"_<$filename"}> is the line-by-line contents of +The array C<@{"_E<lt>$filename"}> is the line-by-line contents of $filename for all the compiled files. Same for C<eval>ed strings which contain subroutines, or which are currently executed. The C<$filename> for C<eval>ed strings looks like C<(eval 34)>. =item * -The hash C<%{"_<$filename"}> contains breakpoints and action (it is +The hash C<%{"_E<lt>$filename"}> contains breakpoints and action (it is keyed by line number), and individual entries are settable (as opposed to the whole hash). Only true/false is important to Perl, though the values used by F<perl5db.pl> have the form @@ -981,22 +989,22 @@ C<"$break_condition\0$action">. Values are magical in numeric context: they are zeros if the line is not breakable. Same for evaluated strings which contain subroutines, or which are -currently executed. The C<$filename> for C<eval>ed strings looks like +currently executed. The $filename for C<eval>ed strings looks like C<(eval 34)>. =item * -The scalar C<${"_<$filename"}> contains C<"_<$filename">. Same for +The scalar C<${"_E<lt>$filename"}> contains C<"_E<lt>$filename">. Same for evaluated strings which contain subroutines, or which are currently -executed. The C<$filename> for C<eval>ed strings looks like C<(eval +executed. The $filename for C<eval>ed strings looks like C<(eval 34)>. =item * After each C<require>d file is compiled, but before it is executed, -C<DB::postponed(*{"_<$filename"})> is called (if subroutine +C<DB::postponed(*{"_E<lt>$filename"})> is called (if subroutine C<DB::postponed> exists). Here the $filename is the expanded name of -the C<require>d file (as found in values of C<%INC>). +the C<require>d file (as found in values of %INC). =item * diff --git a/pod/perldelta4.pod b/pod/perldelta4.pod index 9443f386d9..f1b6c8f096 100644 --- a/pod/perldelta4.pod +++ b/pod/perldelta4.pod @@ -753,26 +753,27 @@ in Windows NT). This port includes support for perl extension building tools like L<MakeMaker> and L<h2xs>, so that many extensions available on the Comprehensive Perl Archive Network (CPAN) can now be readily built under Windows NT. See http://www.perl.com/ for more -information on CPAN, and L<README.win32> for more details on how to -get started with building this port. +information on CPAN and F<README.win32> in the perl distribution for more +details on how to get started with building this port. There is also support for building perl under the Cygwin32 environment. Cygwin32 is a set of GNU tools that make it possible to compile and run many UNIX programs under Windows NT by providing a mostly UNIX-like -interface for compilation and execution. See L<README.cygwin32> for -more details on this port, and how to obtain the Cygwin32 toolkit. +interface for compilation and execution. See F<README.cygwin32> in the +perl distribution for more details on this port and how to obtain the +Cygwin32 toolkit. =head2 Plan 9 -See L<README.plan9>. +See F<README.plan9> in the perl distribution. =head2 QNX -See L<README.qnx>. +See F<README.qnx> in the perl distribution. =head2 AmigaOS -See L<README.amigaos>. +See F<README.amigaos> in the perl distribution. =head1 Pragmata @@ -1379,8 +1380,7 @@ a possibility to shut down by trapping this error is granted. (W) qw() lists contain items separated by whitespace; as with literal strings, comment characters are not ignored, but are instead treated as literal data. (You may have used different delimiters than the -exclamation marks parentheses shown here; braces are also frequently -used.) +parentheses shown here; braces are also frequently used.) You probably wrote something like this: diff --git a/pod/perldiag.pod b/pod/perldiag.pod index dedde649a6..cd4c876261 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<AutoSplit> the file, say, by doing C<make install>. -=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 @@ -1094,6 +1094,13 @@ a goto, or a loop control statement. (W) You are exiting a substitution by unconventional means, such as a return, a goto, or a loop control statement. +=item Explicit blessing to '' (assuming package main) + +(W) You are blessing a reference to a zero length string. This has +the effect of blessing the reference into the package main. This is +usually not what you want. Consider providing a default target +package, e.g. bless($ref, $p or 'MyPackage'); + =item Fatal VMS error at %s, line %d (P) An error peculiar to VMS. Something untoward happened in a VMS system @@ -1272,6 +1279,12 @@ don't take to this kindly. (W) You may have tried to use an 8 or 9 in a octal number. Interpretation of the octal number stopped before the 8 or 9. +=item Illegal hex digit ignored + +(W) You may have tried to use a character other than 0 - 9 or A - F in a +hexadecimal number. Interpretation of the hexadecimal number stopped +before the illegal character. + =item Illegal switch in PERL5OPT: %s (X) The PERL5OPT environment variable may only be used to set the @@ -1919,7 +1932,7 @@ was string. (P) The lexer got into a bad state while processing a case modifier. -=item Pareneses missing around "%s" list +=item Parentheses missing around "%s" list (W) You said something like @@ -1957,8 +1970,7 @@ the BSD version, which takes a pid. (W) qw() lists contain items separated by whitespace; as with literal strings, comment characters are not ignored, but are instead treated as literal data. (You may have used different delimiters than the -exclamation marks parentheses shown here; braces are also frequently -used.) +parentheses shown here; braces are also frequently used.) You probably wrote something like this: @@ -2075,6 +2087,18 @@ to use parens. In any case, a hash requires key/value B<pairs>. %hash = ( one => 1, two => 2, ); # right %hash = qw( one 1 two 2 ); # also fine +=item Reference found where even-sized list expected + +(W) You gave a single reference where Perl was expecting a list with +an even number of elements (for assignment to a hash). This +usually means that you used the anon hash constructor when you meant +to use parens. In any case, a hash requires key/value B<pairs>. + + %hash = { one => 1, two => 2, }; # WRONG + %hash = [ qw/ an anon array / ]; # WRONG + %hash = ( one => 1, two => 2, ); # right + %hash = qw( one 1 two 2 ); # also fine + =item Reference miscount in sv_replace() (W) The internal sv_replace() function was handed a new SV with a @@ -2183,6 +2207,7 @@ or possibly some other missing operator, such as a comma. Check your logic flow. =item Sequence (? incomplete + (F) A regular expression ended with an incomplete extension (?. See L<perlre>. @@ -2641,7 +2666,7 @@ the name you call Perl by to C<perl_>, C<perl__>, and so on. =item Unsupported function %s -(F) This machines doesn't implement the indicated function, apparently. +(F) This machine doesn't implement the indicated function, apparently. At least, Configure doesn't think so. =item Unsupported socket function "%s" called @@ -2701,7 +2726,7 @@ a split() explicitly to an array (or list). (D) As an (ahem) accidental feature, C<AUTOLOAD> subroutines are looked up as methods (using the C<@ISA> hierarchy) even when the subroutines to be autoloaded were called as plain functions (e.g. C<Foo::bar()>), not -as methods (e.g. C<Foo->bar()> or C<$obj->bar()>). +as methods (e.g. C<Foo-E<gt>bar()> or C<$obj-E<gt>bar()>). This bug will be rectified in Perl 5.005, which will use method lookup only for methods' C<AUTOLOAD>s. However, there is a significant base @@ -2716,7 +2741,7 @@ C<BaseClass>, execute C<*AUTOLOAD = \&BaseClass::AUTOLOAD> during startup. In code that currently says C<use AutoLoader; @ISA = qw(AutoLoader);> you should remove AutoLoader from @ISA and change C<use AutoLoader;> to -C<C<use AutoLoader 'AUTOLOAD';>. +C<use AutoLoader 'AUTOLOAD';>. =item Use of %s is deprecated diff --git a/pod/perlembed.pod b/pod/perlembed.pod index 32096789ec..689050c466 100644 --- a/pod/perlembed.pod +++ b/pod/perlembed.pod @@ -12,7 +12,7 @@ Do you want to: =item B<Use C from Perl?> -Read L<perlcall> and L<perlxs>. +Read L<perlxs>, L<perlxstut> and L<h2xs>. =item B<Use a Unix program from Perl?> @@ -20,8 +20,7 @@ Read about back-quotes and about C<system> and C<exec> in L<perlfunc>. =item B<Use Perl from Perl?> -Read about L<perlfunc/do> and L<perlfunc/eval> and L<perlfunc/require> -and L<perlfunc/use>. +Read about do(), eval(), require(), and use() in L<perlfunc>. =item B<Use C from C?> @@ -35,27 +34,49 @@ Read on... =head2 ROADMAP -L<Compiling your C program> +Compiling your C program There's one example in each of the nine sections: -L<Adding a Perl interpreter to your C program> +=over 4 -L<Calling a Perl subroutine from your C program> +=item * -L<Evaluating a Perl statement from your C program> +Adding a Perl interpreter to your C program -L<Performing Perl pattern matches and substitutions from your C program> +=item * -L<Fiddling with the Perl stack from your C program> +Calling a Perl subroutine from your C program -L<Maintaining a persistent interpreter> +=item * -L<Maintaining multiple interpreter instances> +Evaluating a Perl statement from your C program -L<Using Perl modules, which themselves use C libraries, from your C program> +=item * -L<Embedding Perl under Win32> +Performing Perl pattern matches and substitutions from your C program + +=item * + +Fiddling with the Perl stack from your C program + +=item * + +Maintaining a persistent interpreter + +=item * + +Maintaining multiple interpreter instances + +=item * + +Using Perl modules, which themselves use C libraries, from your C program + +=item * + +Embedding Perl under Win32 + +=back =head2 Compiling your C program @@ -96,7 +117,7 @@ Execute this statement for a hint about where to find CORE: perl -MConfig -e 'print $Config{archlib}' Here's how you'd compile the example in the next section, -L<Adding a Perl interpreter to your C program>, on my Linux box: +Adding a Perl interpreter to your C program, on my Linux box: % gcc -O2 -Dbool=char -DHAS_BOOL -I/usr/local/include -I/usr/local/lib/perl5/i586-linux/5.003/CORE @@ -199,8 +220,8 @@ calling I<perl_run()>. =head2 Calling a Perl subroutine from your C program To call individual Perl subroutines, you can use any of the B<perl_call_*> -functions documented in the L<perlcall> manpage. -In this example we'll use I<perl_call_argv>. +functions documented in L<perlcall>. +In this example we'll use perl_call_argv(). That's shown below, in a program I'll call I<showtime.c>. @@ -257,21 +278,20 @@ If you want to pass arguments to the Perl subroutine, you can add strings to the C<NULL>-terminated C<args> list passed to I<perl_call_argv>. For other data types, or to examine return values, you'll need to manipulate the Perl stack. That's demonstrated in the -last section of this document: L<Fiddling with the Perl stack from -your C program>. +last section of this document: Fiddling with the Perl stack from +your C program. =head2 Evaluating a Perl statement from your C program Perl provides two API functions to evaluate pieces of Perl code. -These are L<perlguts/perl_eval_sv()> and L<perlguts/perl_eval_pv()>. +These are perl_eval_sv() and perl_eval_pv(). Arguably, these are the only routines you'll ever need to execute snippets of Perl code from within your C program. Your code can be as long as you wish; it can contain multiple statements; it can employ -L<perlfunc/use>, L<perlfunc/require> and L<perlfunc/do> to include -external Perl files. +use(), require(), and do() to include external Perl files. -I<perl_eval_pv()> lets us evaluate individual Perl strings, and then +perl_eval_pv() lets us evaluate individual Perl strings, and then extract variables for coercion into C types. The following program, I<string.c>, executes three Perl strings, extracting an C<int> from the first, a C<float> from the second, and a C<char *> from the third. @@ -320,7 +340,7 @@ I<SvPV()> to create a string: In the example above, we've created a global variable to temporarily store the computed value of our eval'd expression. It is also possible and in most cases a better strategy to fetch the return value -from L<perl_eval_pv> instead. Example: +from perl_eval_pv() instead. Example: ... SV *val = perl_eval_pv("reverse 'rekcaH lreP rehtonA tsuJ'", TRUE); @@ -626,10 +646,10 @@ troubles. One way to avoid namespace collisions in this scenario is to translate the filename into a guaranteed-unique package name, and then compile -the code into that package using L<perlfunc/eval>. In the example +the code into that package using eval(). In the example below, each file will only be compiled once. Or, the application might choose to clean out the symbol table associated with the file -after it's no longer needed. Using L<perlcall/perl_call_argv>, We'll +after it's no longer needed. Using perl_call_argv(), We'll call the subroutine C<Embed::Persistent::eval_file> which lives in the file C<persistent.pl> and pass the filename and boolean cleanup/cache flag as arguments. @@ -640,7 +660,7 @@ conditions that cause Perl's symbol table to grow. You might want to add some logic that keeps track of the process size, or restarts itself after a certain number of requests, to ensure that memory consumption is minimized. You'll also want to scope your variables -with L<perlfunc/my> whenever possible. +with my() whenever possible. package Embed::Persistent; diff --git a/pod/perlfaq2.pod b/pod/perlfaq2.pod index bbc361a5ba..0f73eea978 100644 --- a/pod/perlfaq2.pod +++ b/pod/perlfaq2.pod @@ -169,7 +169,7 @@ include alt.sources; see their FAQ for details. =head2 Perl Books -A number books on Perl and/or CGI programming are available. A few of +A number of books on Perl and/or CGI programming are available. A few of these are good, some are ok, but many aren't worth your money. Tom Christiansen maintains a list of these books, some with extensive reviews, at http://www.perl.com/perl/critiques/index.html. @@ -314,7 +314,7 @@ to join or leave this list. =item Perl-Packrats Discussion related to archiving of perl materials, particularly the -Comprehensive PerlArchive Network (CPAN). Subscribe by emailing +Comprehensive Perl Archive Network (CPAN). Subscribe by emailing majordomo@cis.ufl.edu: subscribe perl-packrats diff --git a/pod/perlfaq3.pod b/pod/perlfaq3.pod index 65ebafdea5..7a307594da 100644 --- a/pod/perlfaq3.pod +++ b/pod/perlfaq3.pod @@ -85,7 +85,7 @@ perl-mode for emacs can provide a remarkable amount of help with most (but not all) code, and even less programmable editors can provide significant assistance. -If you are using to using vgrind program for printing out nice code to +If you are used to using vgrind program for printing out nice code to a laser printer, you can take a stab at this using http://www.perl.com/CPAN/doc/misc/tips/working.vgrind.entry, but the results are not particularly satisfying for sophisticated code. @@ -260,7 +260,7 @@ module written in C can. With the FCGI module (from CPAN), a Perl executable compiled with sfio (see the F<INSTALL> file in the distribution) and the mod_fastcgi module (available from http://www.fastcgi.com/) each of your perl scripts becomes a permanent -CGI daemon processes. +CGI daemon process. Both of these solutions can have far-reaching effects on your system and on the way you write your CGI scripts, so investigate them with diff --git a/pod/perlfaq4.pod b/pod/perlfaq4.pod index a5b505c4a7..4c38d906ba 100644 --- a/pod/perlfaq4.pod +++ b/pod/perlfaq4.pod @@ -559,7 +559,7 @@ quite a lot of space by using bit strings instead: @articles = ( 1..10, 150..2000, 2017 ); undef $read; - grep (vec($read,$_,1) = 1, @articles); + for (@articles) { vec($read,$_,1) = 1 } Now check whether C<vec($read,$n,1)> is true for some C<$n>. diff --git a/pod/perlfaq5.pod b/pod/perlfaq5.pod index 03d5e6a797..5d71f648de 100644 --- a/pod/perlfaq5.pod +++ b/pod/perlfaq5.pod @@ -802,7 +802,7 @@ files. =head2 Why does Perl let me delete read-only files? Why does C<-i> clobber protected files? Isn't this a bug in Perl? This is elaborately and painstakingly described in the "Far More Than -You Every Wanted To Know" in +You Ever Wanted To Know" in http://www.perl.com/CPAN/doc/FMTEYEWTK/file-dir-perms . The executive summary: learn how your filesystem works. The diff --git a/pod/perlfaq7.pod b/pod/perlfaq7.pod index 283aa2bb34..d62ee36621 100644 --- a/pod/perlfaq7.pod +++ b/pod/perlfaq7.pod @@ -669,7 +669,7 @@ before Perl has seen that such a package exists. It's wisest to make sure your packages are all defined before you start using them, which will be taken care of if you use the C<use> statement instead of C<require>. If not, make sure to use arrow notation (eg, -C<Guru->find("Samy")>) instead. Object notation is explained in +C<Guru-E<gt>find("Samy")>) instead. Object notation is explained in L<perlobj>. =head2 How can I find out my current package? diff --git a/pod/perlfaq8.pod b/pod/perlfaq8.pod index f4d3c12f6f..dbc1bcd10e 100644 --- a/pod/perlfaq8.pod +++ b/pod/perlfaq8.pod @@ -269,7 +269,7 @@ http://www.perl.com/CPAN/doc/misc/ancient/tutorial/eg/itimers.pl . In general, you may not be able to. The Time::HiRes module (available from CPAN) provides this functionality for some systems. -In general, you may not be able to. But if you system supports both the +In general, you may not be able to. But if your system supports both the syscall() function in Perl as well as a system call like gettimeofday(2), then you may be able to do something like this: @@ -758,8 +758,9 @@ If your version of perl is compiled without dynamic loading, then you just need to replace step 3 (B<make>) with B<make perl> and you will get a new F<perl> binary with your extension linked in. -See L<ExtUtils::MakeMaker> for more details on building extensions, -the question "How do I keep my own module/library directory?" +See L<ExtUtils::MakeMaker> for more details on building extensions +and an answer to the question "How do I keep my own module/library +directory?" =head2 How do I keep my own module/library directory? @@ -778,7 +779,7 @@ See Perl's L<lib> for more information. =head2 How do I add the directory my program lives in to the module/library search path? use FindBin; - use lib "$FindBin:Bin"; + use lib "$FindBin::Bin"; use your_own_modules; =head2 How do I add a directory to my include path at runtime? diff --git a/pod/perlform.pod b/pod/perlform.pod index 7e540b8ff6..0b2a68c3d4 100644 --- a/pod/perlform.pod +++ b/pod/perlform.pod @@ -20,8 +20,8 @@ apart from all the other "types" in Perl. This means that if you have a function named "Foo", it is not the same thing as having a format named "Foo". However, the default name for the format associated with a given filehandle is the same as the name of the filehandle. Thus, the default -format for STDOUT is name "STDOUT", and the default format for filehandle -TEMP is name "TEMP". They just look the same. They aren't. +format for STDOUT is named "STDOUT", and the default format for filehandle +TEMP is named "TEMP". They just look the same. They aren't. Output record formats are declared as follows: diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 1a5e0e6846..617879852c 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -657,7 +657,7 @@ Breaks the binding between a DBM file and a hash. [This function has been superseded by the tie() function.] -This binds a dbm(3), ndbm(3), sdbm(3), gdbm(), or Berkeley DB file to a +This binds a dbm(3), ndbm(3), sdbm(3), gdbm(3), or Berkeley DB file to a hash. HASH is the name of the hash. (Unlike normal open, the first argument is I<NOT> a filehandle, even though it looks like one). DBNAME is the name of the database (without the F<.dir> or F<.pag> extension if @@ -1083,6 +1083,15 @@ use system() instead of exec() if you want it to return. It fails and returns FALSE only if the command does not exist I<and> it is executed directly instead of via your system's command shell (see below). +Since it's a common mistake to use system() instead of exec(), Perl +warns you if there is a following statement which isn't die(), warn() +or exit() (if C<-w> is set - but you always do that). If you +I<really> want to follow an exec() with some other statement, you +can use one of these styles to avoid the warning: + + exec ('foo') or print STDERR "couldn't exec foo"; + { exec ('foo') }; print STDERR "couldn't exec foo"; + If there is more than one argument in LIST, or if LIST is an array with more than one value, calls execvp(3) with the arguments in LIST. If there is only one scalar argument, the argument is checked for shell @@ -1279,7 +1288,7 @@ you're done. You should reopen those to /dev/null if it's any issue. =item format -Declare a picture format with use by the write() function. For +Declare a picture format for use by the write() function. For example: format Something = @@ -1600,7 +1609,7 @@ Note that, because $_ is a reference into the list value, it can be used to modify the elements of the array. While this is useful and supported, it can cause bizarre results if the LIST is not a named array. Similarly, grep returns aliases into the original list, -much like the way that L<Foreach Loops>'s index variable aliases the list +much like the way that a for loops's index variable aliases the list elements. That is, modifying an element of a list returned by grep (for example, in a C<foreach>, C<map> or another C<grep>) actually modifies the element in the original list. @@ -1812,8 +1821,8 @@ subroutine, C<eval{}>, or C<do>. If more than one value is listed, the list must be placed in parentheses. See L<perlsub/"Temporary Values via local()"> for details, including issues with tied arrays and hashes. -But you really probably want to be using my() instead, because local() isn't -what most people think of as "local"). See L<perlsub/"Private Variables +You really probably want to be using my() instead, because local() isn't +what most people think of as "local". See L<perlsub/"Private Variables via my()"> for details. =item localtime EXPR @@ -2636,8 +2645,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</use> and -L<perlmod>. +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</use> and L<perlmod>. =item reset EXPR @@ -2981,7 +3008,7 @@ always sleep the full amount. For delays of finer granularity than one second, you may use Perl's syscall() interface to access setitimer(2) if your system supports it, -or else see L</select()> below. +or else see L</select()> above. See also the POSIX module's sigpause() function. @@ -3175,9 +3202,9 @@ splits on whitespace (after skipping any leading whitespace). Anything matching PATTERN is taken to be a delimiter separating the fields. (Note that the delimiter may be longer than one character.) -If LIMIT is specified and is not negative, splits into no more than -that many fields (though it may split into fewer). If LIMIT is -unspecified, trailing null fields are stripped (which potential users +If LIMIT is specified and is positive, splits into no more than that +many fields (though it may split into fewer). If LIMIT is unspecified +or zero, trailing null fields are stripped (which potential users of pop() would do well to remember). If LIMIT is negative, it is treated as if an arbitrarily large LIMIT had been specified. @@ -3326,7 +3353,7 @@ omitted, uses a semi-random value based on the current time and process ID, among other things. In versions of Perl prior to 5.004 the default seed was just the current time(). This isn't a particularly good seed, so many old programs supply their own seed value (often C<time ^ $$> or -C<time ^ ($$ + ($$ << 15))>), but that isn't necessary any more. +C<time ^ ($$ + ($$ E<lt>E<lt> 15))>), but that isn't necessary any more. In fact, it's usually not necessary to call srand() at all, because if it is not called explicitly, it is called implicitly at the first use of @@ -3476,6 +3503,8 @@ a NAME, it's an anonymous function declaration, and does actually return a value: the CODE ref of the closure you just created. See L<perlsub> and L<perlref> for details. +=item substr EXPR,OFFSET,LEN,REPLACEMENT + =item substr EXPR,OFFSET,LEN =item substr EXPR,OFFSET @@ -3498,6 +3527,12 @@ something longer than LEN, the string will grow to accommodate it. To keep the string the same length you may need to pad or chop your value using sprintf(). +An alternative to using substr() as an lvalue is to specify the +replacement string as the 4th argument. This allows you to replace +parts of the EXPR and return what was there before in one operation. +In this case LEN can be C<undef> if you want to affect everything to +the end of the string. + =item symlink OLDFILE,NEWFILE Creates a new filename symbolically linked to the old filename. @@ -3534,7 +3569,7 @@ Syscall returns whatever value returned by the system call it calls. If the system call fails, syscall returns -1 and sets C<$!> (errno). Note that some system calls can legitimately return -1. The proper way to handle such calls is to assign C<$!=0;> before the call and -check the value of <$!> if syscall returns -1. +check the value of C<$!> if syscall returns -1. There's a problem with C<syscall(&SYS_pipe)>: it returns the file number of the read end of the pipe it creates. There is no way @@ -3628,13 +3663,18 @@ Here's a more elaborate example of analysing the return value from system() on a Unix system to check for all possibilities, including for signals and core dumps. - $rc = 0xffff & system @args; + $! = 0; + $rc = system @args; printf "system(%s) returned %#04x: ", "@args", $rc; if ($rc == 0) { print "ran with normal exit\n"; } elsif ($rc == 0xff00) { - print "command failed: $!\n"; + # Note that $! can be an empty string if the command that + # system() tried to execute was not found, not executable, etc. + # These errors occur in the child process after system() has + # forked, so the errno value is not visible in the parent. + printf "command failed: %s\n", ($! || "Unknown system() error"); } elsif ($rc > 0x80) { $rc >>= 8; @@ -3802,7 +3842,8 @@ If EXPR is omitted, uses $_. =item umask Sets the umask for the process to EXPR and returns the previous value. -If EXPR is omitted, merely returns the current umask. Remember that a +If EXPR is omitted, merely returns the current umask. If umask(2) is +not implemented on your system, returns C<undef>. Remember that a umask is a number, usually given in octal; it is I<not> a string of octal digits. See also L</oct>, if all you have is a string. diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 6edb8b80e1..c27883ffcc 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -1326,7 +1326,7 @@ This is converted to a tree similar to this one: / \ $b $c -(but slightly more complicated). This tree reflect the way Perl +(but slightly more complicated). This tree reflects the way Perl parsed your code, but has nothing to do with the execution order. There is an additional "thread" going through the nodes of the tree which shows the order of execution of the nodes. In our simplified @@ -1399,7 +1399,7 @@ and corresponding check routines is described in F<opcode.pl> (do not forget to run C<make regen_headers> if you modify this file). A check routine is called when the node is fully constructed except -for the execution-order thread. Since at this time there is no +for the execution-order thread. Since at this time there are no back-links to the currently constructed node, one can do most any operation to the top-level node, including freeing it and/or creating new nodes above/below it. @@ -1442,7 +1442,7 @@ of free()ing (i.e. their type is changed to OP_NULL). After the compile tree for a subroutine (or for an C<eval> or a file) is created, an additional pass over the code is performed. This pass is neither top-down or bottom-up, but in the execution order (with -additional compilications for conditionals). These optimizations are +additional complications for conditionals). These optimizations are done in the subroutine peep(). Optimizations performed at this stage are subject to the same restrictions as in the pass 2. @@ -1701,7 +1701,7 @@ Used to indicate scalar context. See C<GIMME_V>, C<GIMME>, and L<perlcall>. Returns the glob with the given C<name> and a defined subroutine or C<NULL>. The glob lives in the given C<stash>, or in the stashes -accessable via @ISA and @<UNIVERSAL>. +accessable via @ISA and @UNIVERSAL. The argument C<level> should be either 0 or -1. If C<level==0>, as a side-effect creates a glob with the given C<name> in the given diff --git a/pod/perlhist.pod b/pod/perlhist.pod index cbbe0b9cac..60f0a8de26 100644 --- a/pod/perlhist.pod +++ b/pod/perlhist.pod @@ -6,7 +6,7 @@ perlhist - the Perl history records =for RCS # -# $Id: perlhist.pod,v 1.31 1998/03/10 16:39:28 jhi Exp $ +# $Id: perlhist.pod,v 1.32 1998/04/04 12:20:50 jhi Exp $ # =end RCS @@ -30,8 +30,8 @@ Perl history in brief, by Larry Wall: =head1 THE KEEPERS OF THE PUMPKIN -Larry Wall, Andy Dougherty, Tom Christiansen, Charles Bailey, -Nick Ing-Simmons, Chip Salzenberg, Tim Bunce, Malcolm Beattie. +Larry Wall, Andy Dougherty, Tom Christiansen, Charles Bailey, Nick +Ing-Simmons, Chip Salzenberg, Tim Bunce, Malcolm Beattie. =head2 PUMPKIN? @@ -272,6 +272,8 @@ the pumpking or the pumpkineer. 5.004_60 1998-Feb-20 5.004_61 1998-Feb-27 5.004_62 1998-Mar-06 + 5.004_63 1998-Mar-17 + 5.004_64 1998-Apr-03 =head2 SELECTED RELEASE SIZES @@ -440,7 +442,7 @@ context diff output format. p54rc1 1997-May-12 8 1 11 p54rc2 1997-May-14 6 0 40 - 5.004 1997-May-15 4 0 4 + 5.004 1997-May-15 4 0 4 Tim 5.004_01 1997-Jun-13 222 14 57 5.004_02 1997-Aug-07 112 16 119 @@ -452,8 +454,9 @@ context diff output format. Jarkko Hietaniemi <F<jhi@iki.fi>>. Thanks to the collective memory of the Perlfolk. In addition to the -Keepers of the Pumpkin also Alan Champion, Andreas König, John +Keepers of the Pumpkin also Alan Champion, Andreas Knig, John Macdonald, Matthias Neeracher, Michael Peppler, Randal Schwartz, and Paul D. Smith sent corrections and additions. =cut + diff --git a/pod/perlipc.pod b/pod/perlipc.pod index 030463c7a0..65818961d8 100644 --- a/pod/perlipc.pod +++ b/pod/perlipc.pod @@ -981,9 +981,6 @@ The C<kill> function in the parent's C<if> block is there to send a signal to our child process (current running in the C<else> block) as soon as the remote server has closed its end of the connection. -The C<kill> at the end of the parent's block is there to eliminate the -child process as soon as the server we connect to closes its end. - If the remote server sends data a byte at time, and you need that data immediately without waiting for a newline (which might not happen), you may wish to replace the C<while> loop in the parent with the @@ -1054,7 +1051,7 @@ you'll have to use the C<sysread> variant of the interactive client above. This server accepts one of five different commands, sending output back to the client. Note that unlike most network servers, this one only handles one incoming client at a time. Multithreaded servers are -covered in Chapter 6 of the Camel or in the perlipc(1) manpage. +covered in Chapter 6 of the Camel as well as later in this manpage. Here's the code. We'll diff --git a/pod/perllocale.pod b/pod/perllocale.pod index 70a32e4fe9..2a08835fe8 100644 --- a/pod/perllocale.pod +++ b/pod/perllocale.pod @@ -494,7 +494,7 @@ setting, characters like 'E<aelig>', 'E<eth>', 'E<szlig>', and The C<LC_CTYPE> locale also provides the map used in transliterating characters between lower and uppercase. This affects the case-mapping functions - lc(), lcfirst, uc() and ucfirst(); case-mapping -interpolation with C<\l>, C<\L>, C<\u> or <\U> in double-quoted strings +interpolation with C<\l>, C<\L>, C<\u> or C<\U> in double-quoted strings and in C<s///> substitutions; and case-independent regular expression pattern matching using the C<i> modifier. @@ -652,7 +652,7 @@ the locale: Scalar true/false (or less/equal/greater) result is never tainted. -=item B<Case-mapping interpolation> (with C<\l>, C<\L>, C<\u> or <\U>) +=item B<Case-mapping interpolation> (with C<\l>, C<\L>, C<\u> or C<\U>) Result string containing interpolated material is tainted if C<use locale> is in effect. @@ -676,7 +676,7 @@ Has the same behavior as the match operator. Also, the left operand of C<=~> becomes tainted when C<use locale> in effect, if it is modified as a result of a substitution based on a regular expression match involving C<\w>, C<\W>, C<\s>, or C<\S>; or of -case-mapping with C<\l>, C<\L>,C<\u> or <\U>. +case-mapping with C<\l>, C<\L>,C<\u> or C<\U>. =item B<In-memory formatting function> (sprintf()): @@ -754,7 +754,7 @@ of a match involving C<\w> when C<use locale> is in effect. A string that can suppress Perl's warning about failed locale settings at startup. Failure can occur if the locale support in the operating -system is lacking (broken) is some way - or if you mistyped the name of +system is lacking (broken) in some way - or if you mistyped the name of a locale when you set up your environment. If this environment variable is absent, or has a value which does not evaluate to integer zero - that is "0" or "" - Perl will complain about locale setting failures. @@ -906,11 +906,36 @@ operating system upgrade. =head1 SEE ALSO -L<POSIX (3)/isalnum>, L<POSIX (3)/isalpha>, L<POSIX (3)/isdigit>, -L<POSIX (3)/isgraph>, L<POSIX (3)/islower>, L<POSIX (3)/isprint>, -L<POSIX (3)/ispunct>, L<POSIX (3)/isspace>, L<POSIX (3)/isupper>, -L<POSIX (3)/isxdigit>, L<POSIX (3)/localeconv>, L<POSIX (3)/setlocale>, -L<POSIX (3)/strcoll>, L<POSIX (3)/strftime>, L<POSIX (3)/strtod>, +L<POSIX (3)/isalnum> + +L<POSIX (3)/isalpha> + +L<POSIX (3)/isdigit> + +L<POSIX (3)/isgraph> + +L<POSIX (3)/islower> + +L<POSIX (3)/isprint>, + +L<POSIX (3)/ispunct> + +L<POSIX (3)/isspace> + +L<POSIX (3)/isupper>, + +L<POSIX (3)/isxdigit> + +L<POSIX (3)/localeconv> + +L<POSIX (3)/setlocale>, + +L<POSIX (3)/strcoll> + +L<POSIX (3)/strftime> + +L<POSIX (3)/strtod>, + L<POSIX (3)/strxfrm> =head1 HISTORY diff --git a/pod/perlmodlib.pod b/pod/perlmodlib.pod index 14bb7ebfa4..6e4da5e307 100644 --- a/pod/perlmodlib.pod +++ b/pod/perlmodlib.pod @@ -998,8 +998,8 @@ Please remember to send me an updated entry for the Module list! =item Take care when changing a released module. -Always strive to remain compatible with previous released versions -(see 2.2 above) Otherwise try to add a mechanism to revert to the +Always strive to remain compatible with previous released versions. +Otherwise try to add a mechanism to revert to the old behaviour if people rely on it. Document incompatible changes. =back diff --git a/pod/perlop.pod b/pod/perlop.pod index 4781b7fbbe..538745dd6a 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -186,6 +186,11 @@ C<$a>. If C<$b> is negative, then C<$a % $b> is C<$a> minus the smallest multiple of C<$b> that is not less than C<$a> (i.e. the result will be less than or equal to zero). +Note than when C<use integer> is in scope "%" give you direct access +to the modulus operator as implemented by your C compiler. This +operator is not as well defined for negative operands, but it will +execute faster. + Binary "x" is the repetition operator. In a scalar context, it returns a string consisting of the left operand repeated the number of times specified by the right operand. In a list context, if the left @@ -599,7 +604,7 @@ a transliteration, the first ten of these sequences may be used. \Q quote regexp metacharacters till \E If C<use locale> is in effect, the case map used by C<\l>, C<\L>, C<\u> -and <\U> is taken from the current locale. See L<perllocale>. +and C<\U> is taken from the current locale. See L<perllocale>. Patterns are subject to an additional level of interpretation as a regular expression. This is done as a second pass, after variables are @@ -651,6 +656,7 @@ Options are: m Treat string as multiple lines. o Compile pattern only once. s Treat string as single line. + t Taint $1 etc. if target string is tainted. x Use extended regular expressions. If "/" is the delimiter then the initial C<m> is optional. With the C<m> @@ -897,7 +903,7 @@ text is not evaluated as a command. If the PATTERN is delimited by bracketing quotes, the REPLACEMENT has its own pair of quotes, which may or may not be bracketing quotes, e.g., C<s(foo)(bar)> or C<sE<lt>fooE<gt>/bar/>. A C</e> will cause the -replacement portion to be interpreter as a full-fledged Perl expression +replacement portion to be interpreted as a full-fledged Perl expression and eval()ed right then and there. It is, however, syntax checked at compile-time. @@ -1031,7 +1037,7 @@ an eval(): =head2 I/O Operators There are several I/O operators you should know about. -A string is enclosed by backticks (grave accents) first undergoes +A string enclosed by backticks (grave accents) first undergoes variable substitution just like a double quoted string. It is then interpreted as a command, and the output of that command is the value of the pseudo-literal, like in a shell. In a scalar context, a single @@ -1054,17 +1060,35 @@ Ordinarily you must assign that value to a variable, but there is one situation where an automatic assignment happens. I<If and ONLY if> the input symbol is the only thing inside the conditional of a C<while> or C<for(;;)> loop, the value is automatically assigned to the variable -C<$_>. The assigned value is then tested to see if it is defined. -(This may seem like an odd thing to you, but you'll use the construct -in almost every Perl script you write.) Anyway, the following lines -are equivalent to each other: +C<$_>. In these loop constructs, the assigned value (whether assignment +is automatic or explcit) is then tested to see if it is defined. +The defined test avoids problems where line has a string value +that would be treated as false by perl e.g. "" or "0" with no trailing +newline. (This may seem like an odd thing to you, but you'll use the +construct in almost every Perl script you write.) Anyway, the following +lines are equivalent to each other: while (defined($_ = <STDIN>)) { print; } + while ($_ = <STDIN>) { print; } while (<STDIN>) { print; } for (;<STDIN>;) { print; } print while defined($_ = <STDIN>); + print while ($_ = <STDIN>); print while <STDIN>; +and this also behaves similarly, but avoids the use of $_ : + + while (my $line = <STDIN>) { print $line } + +If you really mean such values to terminate the loop they should be +tested for explcitly: + + while (($_ = <STDIN>) ne '0') { ... } + while (<STDIN>) { last unless $_; ... } + +In other boolean contexts C<E<lt>I<filehandle>E<gt>> without explcit C<defined> +test or comparison will solicit a warning if C<-w> is in effect. + The filehandles STDIN, STDOUT, and STDERR are predefined. (The filehandles C<stdin>, C<stdout>, and C<stderr> will also work except in packages, where they would be interpreted as local identifiers rather @@ -1124,9 +1148,9 @@ Getopts modules or put a loop on the front like this: ... # code for each line } -The E<lt>E<gt> symbol will return FALSE only once. If you call it again after -this it will assume you are processing another @ARGV list, and if you -haven't set @ARGV, will input from STDIN. +The E<lt>E<gt> symbol will return C<undef> for end-of-file only once. +If you call it again after this it will assume you are processing another +@ARGV list, and if you haven't set @ARGV, will input from STDIN. If the string inside the angle brackets is a reference to a scalar variable (e.g., E<lt>$fooE<gt>), then that variable contains the name of the @@ -1174,9 +1198,12 @@ A glob evaluates its (embedded) argument only when it is starting a new list. All values must be read before it will start over. In a list context this isn't important, because you automatically get them all anyway. In a scalar context, however, the operator returns the next value -each time it is called, or a FALSE value if you've just run out. Again, -FALSE is returned only once. So if you're expecting a single value from -a glob, it is much better to say +each time it is called, or a C<undef> value if you've just run out. As +for filehandles an automatic C<defined> is generated when the glob +occurs in the test part of a C<while> or C<for> - because legal glob returns +(e.g. a file called F<0>) would otherwise terminate the loop. +Again, C<undef> is returned only once. So if you're expecting a single value +from a glob, it is much better to say ($file) = <blurch*>; diff --git a/pod/perlre.pod b/pod/perlre.pod index 95da75d95f..68ce4b9bf7 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -34,6 +34,13 @@ line anywhere within the string, Treat string as single line. That is, change "." to match any character whatsoever, even a newline, which it normally would not match. +The /s and /m modifiers both override the C<$*> setting. That is, no matter +what C<$*> contains, /s (without /m) will force "^" to match only at the +beginning of the string and "$" to match only at the end (or just before a +newline at the end) of the string. Together, as /ms, they let the "." match +any character whatsoever, while yet allowing "^" and "$" to match, +respectively, just after and just before newlines within the string. + =item x Extend your pattern's legibility by permitting whitespace and comments. @@ -139,7 +146,7 @@ also work: \Q quote (disable) regexp metacharacters till \E If C<use locale> is in effect, the case map used by C<\l>, C<\L>, C<\u> -and <\U> is taken from the current locale. See L<perllocale>. +and C<\U> is taken from the current locale. See L<perllocale>. In addition, Perl defines the following: @@ -238,7 +245,7 @@ non-alphanumeric characters: $pattern =~ s/(\W)/\\$1/g; Now it is much more common to see either the quotemeta() function or -the \Q escape sequence used to disable the metacharacters special +the C<\Q> escape sequence used to disable all metacharacters' special meanings like this: /$unquoted\Q$quoted\E$unquoted/ @@ -278,14 +285,15 @@ matches a word followed by a tab, without including the tab in C<$&>. A zero-width negative lookahead assertion. For example C</foo(?!bar)/> matches any occurrence of "foo" that isn't followed by "bar". Note however that lookahead and lookbehind are NOT the same thing. You cannot -use this for lookbehind. If you are looking for a "bar" which isn't preceeded -"foo", C</(?!foo)bar/> will not do what you want. That's because -the C<(?!foo)> is just saying that the next thing cannot be "foo"--and -it's not, it's a "bar", so "foobar" will match. You would have to do -something like C</(?!foo)...bar/> for that. We say "like" because there's -the case of your "bar" not having three characters before it. You could -cover that this way: C</(?:(?!foo)...|^.{0,2})bar/>. Sometimes it's still -easier just to say: +use this for lookbehind. + +If you are looking for a "bar" which isn't preceded by a "foo", C</(?!foo)bar/> +will not do what you want. That's because the C<(?!foo)> is just saying that +the next thing cannot be "foo"--and it's not, it's a "bar", so "foobar" will +match. You would have to do something like C</(?!foo)...bar/> for that. We +say "like" because there's the case of your "bar" not having three characters +before it. You could cover that this way: C</(?:(?!foo)...|^.{0,2})bar/>. +Sometimes it's still easier just to say: if (/bar/ && $` !~ /foo$/) @@ -387,7 +395,7 @@ Say, matches a chunk of non-parentheses, possibly included in parentheses themselves. -=item C<(?imsx)> +=item C<(?imstx)> One or more embedded pattern-match modifiers. This is particularly useful for patterns that are specified in a table somewhere, some of diff --git a/pod/perlref.pod b/pod/perlref.pod index 6aa086088d..34c071fcfe 100644 --- a/pod/perlref.pod +++ b/pod/perlref.pod @@ -15,9 +15,9 @@ hashes, hashes of arrays, arrays of hashes of functions, and so on. Hard references are smart--they keep track of reference counts for you, automatically freeing the thing referred to when its reference count goes -to zero. (Note: The reference counts for values in self-referential or +to zero. (Note: the reference counts for values in self-referential or cyclic data structures may not go to zero without a little help; see -L<perlobj/"Two-Phased Garbage Collection"> for a detailed explanation. +L<perlobj/"Two-Phased Garbage Collection"> for a detailed explanation.) If that thing happens to be an object, the object is destructed. See L<perlobj> for more about objects. (In a sense, everything in Perl is an object, but we usually reserve the word for references to objects that @@ -120,6 +120,15 @@ reference to it, you have these options: sub hashem { +{ @_ } } # ok sub hashem { return { @_ } } # ok +On the other hand, if you want the other meaning, you can do this: + + sub showem { { @_ } } # ambiguous (currently ok, but may change) + sub showem { {; @_ } } # ok + sub showem { { return @_ } } # ok + +Note how the leading C<+{> and C<{;> always serve to disambiguate +the expression to mean either the HASH reference, or the BLOCK. + =item 4. A reference to an anonymous subroutine can be constructed by using diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 4bb55bceeb..84ce270e3e 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -332,7 +332,7 @@ know when the filename has changed. It does, however, use ARGVOUT for the selected filehandle. Note that STDOUT is restored as the default output filehandle after the loop. -You can use C<eof> without parenthesis to locate the end of each input file, +You can use C<eof> without parentheses to locate the end of each input file, in case you want to append to each file, or reset line numbering (see example in L<perlfunc/eof>). diff --git a/pod/perlstyle.pod b/pod/perlstyle.pod index 5ad73cfafe..cf280ce1da 100644 --- a/pod/perlstyle.pod +++ b/pod/perlstyle.pod @@ -242,7 +242,7 @@ to fit on one line anyway. Always check the return codes of system calls. Good error messages should go to STDERR, include which program caused the problem, what the failed -system call and arguments were, and VERY IMPORTANT) should contain the +system call and arguments were, and (VERY IMPORTANT) should contain the standard system error message for what went wrong. Here's a simple but sufficient example: diff --git a/pod/perlsub.pod b/pod/perlsub.pod index c66bcb6e97..7212bb5907 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -159,7 +159,7 @@ Do not, however, be tempted to do this: Because like its flat incoming parameter list, the return list is also flat. So all you have managed to do here is stored everything in @a and -made @b an empty list. See L</"Pass by Reference"> for alternatives. +made @b an empty list. See L<Pass by Reference> for alternatives. A subroutine may be called using the "&" prefix. The "&" is optional in modern Perls, and so are the parentheses if the subroutine has been diff --git a/pod/perltoot.pod b/pod/perltoot.pod index 3a35c05b90..90ef81ae26 100644 --- a/pod/perltoot.pod +++ b/pod/perltoot.pod @@ -315,7 +315,7 @@ be made through methods. Perl doesn't impose restrictions on who gets to use which methods. The public-versus-private distinction is by convention, not syntax. (Well, unless you use the Alias module described below in -L</"Data Members as Variables">.) Occasionally you'll see method names beginning or ending +L<Data Members as Variables>.) Occasionally you'll see method names beginning or ending with an underscore or two. This marking is a convention indicating that the methods are private to that class alone and sometimes to its closest acquaintances, its immediate subclasses. But this distinction diff --git a/pod/perlvar.pod b/pod/perlvar.pod index 36b4ec47b6..2cb95afe05 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -413,6 +413,9 @@ C<$? & 255> gives which signal, if any, the process died from, and whether there was a core dump. (Mnemonic: similar to B<sh> and B<ksh>.) +Additionally, if the C<h_errno> variable is supported in C, its value +is returned via $? if any of the C<gethost*()> functions fail. + Note that if you have installed a signal handler for C<SIGCHLD>, the value of C<$?> will usually be wrong outside that handler. @@ -821,7 +824,7 @@ The C<__DIE__> handler is explicitly disabled during the call, so that you can die from a C<__DIE__> handler. Similarly for C<__WARN__>. Note that the C<$SIG{__DIE__}> hook is called even inside eval()ed -blocks/strings. See L<perlfunc/die>, L<perlvar/$^S> for how to +blocks/strings. See L<perlfunc/die> and L<perlvar/$^S> for how to circumvent this. Note that C<__DIE__>/C<__WARN__> handlers are very special in one diff --git a/pod/perlxs.pod b/pod/perlxs.pod index d065b94425..2f4be67a1e 100644 --- a/pod/perlxs.pod +++ b/pod/perlxs.pod @@ -25,6 +25,11 @@ linked. See L<perlxstut> for a tutorial on the whole extension creation process. +Note: For many extensions, Dave Beazley's SWIG system provides a +significantly more convenient mechanism for creating the XS glue +code. See L<http://www.cs.utah.edu/~beazley/SWIG> for more +information. + =head2 On The Road Many of the examples which follow will concentrate on creating an interface @@ -598,7 +603,7 @@ of $timep will either be undef or it will be a valid time. $timep = rpcb_gettime( "localhost" ); -The following XSUB uses the C<SV *> return type as a mneumonic only, +The following XSUB uses the C<SV *> return type as a mnemonic only, and uses a CODE: block to indicate to the compiler that the programmer has supplied all the necessary code. The sv_newmortal() call will initialize the return value to undef, making that diff --git a/pod/pod2man.PL b/pod/pod2man.PL index a91d3e585e..e7edf1f5e8 100644 --- a/pod/pod2man.PL +++ b/pod/pod2man.PL @@ -736,7 +736,7 @@ while (<>) { # first hide the escapes in case we need to # intuit something and get it wrong due to fmting - s/([A-Z]<[^<>]*>)/noremap($1)/ge; + 1 while s/([A-Z]<[^<>]*>)/noremap($1)/ge; # func() is a reference to a perl function s{ @@ -1050,10 +1050,6 @@ sub mkindex { my ($entry) = @_; my @entries = split m:\s*/\s*:, $entry; push @Indices, ".IX Xref " . join ' ', map {qq("$_")} @entries; - for $entry (@entries) { - print qq("$entry" ); - } - print "\n"; return ''; } diff --git a/pod/roffitall b/pod/roffitall index cbd19af4fe..244048af2d 100644 --- a/pod/roffitall +++ b/pod/roffitall @@ -199,3 +199,4 @@ eval $run $toroff rm -f $tmp/PerlTOC.tmp.man $tmp/PerlTOC.$ext.raw echo "$me: leaving you with $tmp/PerlDoc.$ext and $tmp/PerlTOC.$ext" + @@ -322,7 +322,11 @@ PP(pp_pos) } LvTYPE(TARG) = '.'; - LvTARG(TARG) = sv; + if (LvTARG(TARG) != sv) { + if (LvTARG(TARG)) + SvREFCNT_dec(LvTARG(TARG)); + LvTARG(TARG) = SvREFCNT_inc(sv); + } PUSHs(TARG); /* no SvSETMAGIC */ RETURN; } @@ -507,8 +511,14 @@ PP(pp_bless) if (MAXARG == 1) stash = curcop->cop_stash; - else - stash = gv_stashsv(POPs, TRUE); + else { + SV *ssv = POPs; + STRLEN len; + char *ptr = SvPV(ssv,len); + if (dowarn && len == 0) + warn("Explicit blessing to '' (assuming package main)"); + stash = gv_stashpvn(ptr, len, TRUE); + } (void)sv_bless(TOPs, stash); RETURN; @@ -1783,6 +1793,7 @@ PP(pp_substr) djSP; dTARGET; SV *sv; I32 len; + I32 len_ok = 0; STRLEN curlen; I32 pos; I32 rem; @@ -1790,10 +1801,25 @@ PP(pp_substr) I32 lvalue = op->op_flags & OPf_MOD; char *tmps; I32 arybase = curcop->cop_arybase; + char *repl = 0; + STRLEN repl_len; SvTAINTED_off(TARG); /* decontaminate */ - if (MAXARG > 2) + if (MAXARG > 3) { + /* pop off replacement string */ + sv = POPs; + repl = SvPV(sv, repl_len); + /* pop off length */ + sv = POPs; + if (SvOK(sv)) { + len = SvIV(sv); + len_ok++; + } + } else if (MAXARG == 3) { len = POPi; + len_ok++; + } + pos = POPi; sv = POPs; PUTBACK; @@ -1802,7 +1828,7 @@ PP(pp_substr) pos -= arybase; rem = curlen-pos; fail = rem; - if (MAXARG > 2) { + if (len_ok) { if (len < 0) { rem += len; if (rem < 0) @@ -1814,7 +1840,7 @@ PP(pp_substr) } else { pos += curlen; - if (MAXARG < 3) + if (!len_ok) rem = curlen; else if (len >= 0) { rem = pos+len; @@ -1832,7 +1858,7 @@ PP(pp_substr) rem -= pos; } if (fail < 0) { - if (dowarn || lvalue) + if (dowarn || lvalue || repl) warn("substr outside of string"); RETPUSHUNDEF; } @@ -1858,10 +1884,16 @@ PP(pp_substr) } LvTYPE(TARG) = 'x'; - LvTARG(TARG) = sv; + if (LvTARG(TARG) != sv) { + if (LvTARG(TARG)) + SvREFCNT_dec(LvTARG(TARG)); + LvTARG(TARG) = SvREFCNT_inc(sv); + } LvTARGOFF(TARG) = pos; LvTARGLEN(TARG) = rem; } + else if (repl) + sv_insert(sv, pos, rem, repl, repl_len); } SPAGAIN; PUSHs(TARG); /* avoid SvSETMAGIC here */ @@ -1893,7 +1925,11 @@ PP(pp_vec) } LvTYPE(TARG) = 'v'; - LvTARG(TARG) = src; + if (LvTARG(TARG) != src) { + if (LvTARG(TARG)) + SvREFCNT_dec(LvTARG(TARG)); + LvTARG(TARG) = SvREFCNT_inc(src); + } LvTARGOFF(TARG) = offset; LvTARGLEN(TARG) = size; } @@ -130,8 +130,8 @@ PP(pp_substcont) if (cx->sb_iters > cx->sb_maxiters) DIE("Substitution loop"); - if (!cx->sb_rxtainted) - cx->sb_rxtainted = SvTAINTED(TOPs); + if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs)) + cx->sb_rxtainted |= 2; sv_catsv(dstr, POPs); /* Are we done */ @@ -143,6 +143,7 @@ PP(pp_substcont) sv_catpvn(dstr, s, cx->sb_strend - s); TAINT_IF(cx->sb_rxtainted || RX_MATCH_TAINTED(rx)); + cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); (void)SvOOK_off(targ); Safefree(SvPVX(targ)); @@ -151,11 +152,15 @@ PP(pp_substcont) SvLEN_set(targ, SvLEN(dstr)); SvPVX(dstr) = 0; sv_free(dstr); + + TAINT_IF(cx->sb_rxtainted & 1); + PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); + (void)SvPOK_only(targ); + TAINT_IF(cx->sb_rxtainted); SvSETMAGIC(targ); SvTAINT(targ); - PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); LEAVE_SCOPE(cx->sb_oldsave); POPSUBST(cx); RETURNOP(pm->op_next); @@ -2454,7 +2459,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; @@ -251,6 +251,7 @@ PP(pp_aelemfast) djSP; AV *av = GvAV((GV*)cSVOP->op_sv); SV** svp = av_fetch(av, op->op_private, op->op_flags & OPf_MOD); + EXTEND(SP, 1); PUSHs(svp ? *svp : &sv_undef); RETURN; } @@ -791,7 +792,7 @@ PP(pp_match) DIE("panic: do_match"); TAINT_NOT; - if (pm->op_pmflags & PMf_USED) { + if (pm->op_pmdynflags & PMdf_USED) { failure: if (gimme == G_ARRAY) RETURN; @@ -887,7 +888,7 @@ play_it_again: { curpm = pm; if (pm->op_pmflags & PMf_ONCE) - pm->op_pmflags |= PMf_USED; + pm->op_pmdynflags |= PMdf_USED; goto gotcha; } else @@ -952,7 +953,7 @@ yup: /* Confirmed by check_substr */ ++BmUSEFUL(rx->check_substr); curpm = pm; if (pm->op_pmflags & PMf_ONCE) - pm->op_pmflags |= PMf_USED; + pm->op_pmdynflags |= PMdf_USED; Safefree(rx->subbase); rx->subbase = Nullch; if (global) { @@ -1476,6 +1477,7 @@ PP(pp_subst) s = SvPV(TARG, len); if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV) force_on_match = 1; + rxtainted = tainted << 1; TAINT_NOT; force_it: @@ -1562,7 +1564,7 @@ PP(pp_subst) curpm = pm; SvSCREAM_off(TARG); /* disable possible screamer */ if (once) { - rxtainted = RX_MATCH_TAINTED(rx); + rxtainted |= RX_MATCH_TAINTED(rx); if (rx->subbase) { m = orig + (rx->startp[0] - rx->subbase); d = orig + (rx->endp[0] - rx->subbase); @@ -1603,12 +1605,11 @@ PP(pp_subst) else { sv_chop(TARG, d); } - TAINT_IF(rxtainted); + TAINT_IF(rxtainted & 1); SPAGAIN; PUSHs(&sv_yes); } else { - rxtainted = 0; do { if (iters++ > maxiters) DIE("Substitution loop"); @@ -1632,11 +1633,12 @@ PP(pp_subst) SvCUR_set(TARG, d - SvPVX(TARG) + i); Move(s, d, i+1, char); /* include the NUL */ } - TAINT_IF(rxtainted); + TAINT_IF(rxtainted & 1); SPAGAIN; PUSHs(sv_2mortal(newSViv((I32)iters))); } (void)SvPOK_only(TARG); + TAINT_IF(rxtainted); if (SvSMAGICAL(TARG)) { PUTBACK; mg_set(TARG); @@ -1653,7 +1655,7 @@ PP(pp_subst) s = SvPV_force(TARG, len); goto force_it; } - rxtainted = RX_MATCH_TAINTED(rx); + rxtainted |= RX_MATCH_TAINTED(rx); dstr = NEWSV(25, len); sv_setpvn(dstr, m, s-m); curpm = pm; @@ -1684,8 +1686,6 @@ PP(pp_subst) } while (regexec_flags(rx, s, strend, orig, s == m, Nullsv, NULL, safebase)); sv_catpvn(dstr, s, strend - s); - TAINT_IF(rxtainted); - (void)SvOOK_off(TARG); Safefree(SvPVX(TARG)); SvPVX(TARG) = SvPVX(dstr); @@ -1694,11 +1694,14 @@ PP(pp_subst) SvPVX(dstr) = 0; sv_free(dstr); + TAINT_IF(rxtainted & 1); + PUSHs(sv_2mortal(newSViv((I32)iters))); + (void)SvPOK_only(TARG); + TAINT_IF(rxtainted); SvSETMAGIC(TARG); SvTAINT(TARG); SPAGAIN; - PUSHs(sv_2mortal(newSViv((I32)iters))); LEAVE_SCOPE(oldsave); RETURN; } @@ -464,7 +464,7 @@ PP(pp_umask) TAINT_PROPER("umask"); XPUSHi(anum); #else - DIE(no_func, "Unsupported function umask"); + XPUSHs(&sv_undef) #endif RETURN; } @@ -218,11 +218,14 @@ int magic_get _((SV* sv, MAGIC* mg)); int magic_getarylen _((SV* sv, MAGIC* mg)); int magic_getdefelem _((SV* sv, MAGIC* mg)); int magic_getglob _((SV* sv, MAGIC* mg)); +int magic_getnkeys _((SV* sv, MAGIC* mg)); int magic_getpack _((SV* sv, MAGIC* mg)); int magic_getpos _((SV* sv, MAGIC* mg)); int magic_getsig _((SV* sv, MAGIC* mg)); +int magic_getsubstr _((SV* sv, MAGIC* mg)); int magic_gettaint _((SV* sv, MAGIC* mg)); int magic_getuvar _((SV* sv, MAGIC* mg)); +int magic_getvec _((SV* sv, MAGIC* mg)); U32 magic_len _((SV* sv, MAGIC* mg)); #ifdef USE_THREADS int magic_mutexfree _((SV* sv, MAGIC* mg)); @@ -1135,8 +1135,11 @@ reg(I32 paren, I32 *flagp) break; default: --regparse; - while (*regparse && strchr("iogcmsx", *regparse)) - pmflag(®flags, *regparse++); + while (*regparse && strchr("iogcmsx", *regparse)) { + if (*regparse != 'o') + pmflag(®flags, *regparse); + ++regparse; + } unknown: if (*regparse != ')') FAIL2("Sequence (?%c...) not recognized", *regparse); @@ -2638,10 +2638,17 @@ sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) register char *midend; register char *bigend; register I32 i; + STRLEN curlen; + if (!bigstr) croak("Can't modify non-existent substring"); - SvPV_force(bigstr, na); + SvPV_force(bigstr, curlen); + if (offset + len > curlen) { + SvGROW(bigstr, offset+len+1); + Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); + SvCUR_set(bigstr, offset+len); + } i = littlelen - len; if (i > 0) { /* string might grow */ @@ -3703,7 +3710,7 @@ sv_reset(register char *s, HV *stash) if (!*s) { /* reset ?? searches */ for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) { - pm->op_pmflags &= ~PMf_USED; + pm->op_pmdynflags &= ~PMdf_USED; } return; } @@ -17,6 +17,7 @@ chdir 't' if -f 't/TEST'; die "You need to run \"make test\" first to set things up.\n" unless -e 'perl' or -e 'perl.exe'; +#$ENV{PERL_DESTRUCT_LEVEL} = '2'; $ENV{EMXSHELL} = 'sh'; # For OS/2 if ($#ARGV == -1) { diff --git a/t/lib/filefind.t b/t/lib/filefind.t index 21e29a2d7f..cd2e9771c7 100755 --- a/t/lib/filefind.t +++ b/t/lib/filefind.t @@ -5,9 +5,10 @@ BEGIN { @INC = '../lib'; } -print "1..1\n"; +print "1..2\n"; use File::Find; # hope we will eventually find ourself find(sub { print "ok 1\n" if $_ eq 'filefind.t'; }, "."); +finddepth(sub { print "ok 2\n" if $_ eq 'filefind.t'; }, "."); diff --git a/t/op/defins.t b/t/op/defins.t new file mode 100755 index 0000000000..5dd614d4b8 --- /dev/null +++ b/t/op/defins.t @@ -0,0 +1,144 @@ +#!./perl -w + +# +# test auto defined() test insertion +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + $SIG{__WARN__} = sub { $warns++; warn $_[0] }; + print "1..14\n"; +} + +print "not " if $warns; +print "ok 1\n"; + +open(FILE,">./0"); +print FILE "1\n"; +print FILE "0"; +close(FILE); + +open(FILE,"<./0"); +my $seen = 0; +my $dummy; +while (my $name = <FILE>) + { + $seen++ if $name eq '0'; + } +print "not " unless $seen; +print "ok 2\n"; + +seek(FILE,0,0); +$seen = 0; +my $line = ''; +do + { + $seen++ if $line eq '0'; + } while ($line = <FILE>); + +print "not " unless $seen; +print "ok 3\n"; + + +seek(FILE,0,0); +$seen = 0; +while (($seen ? $dummy : $name) = <FILE>) + { + $seen++ if $name eq '0'; + } +print "not " unless $seen; +print "ok 4\n"; + +seek(FILE,0,0); +$seen = 0; +my %where; +while ($where{$seen} = <FILE>) + { + $seen++ if $where{$seen} eq '0'; + } +print "not " unless $seen; +print "ok 5\n"; + +opendir(DIR,'.'); +$seen = 0; +while (my $name = readdir(DIR)) + { + $seen++ if $name eq '0'; + } +print "not " unless $seen; +print "ok 6\n"; + +rewinddir(DIR); +$seen = 0; +$dummy = ''; +while (($seen ? $dummy : $name) = readdir(DIR)) + { + $seen++ if $name eq '0'; + } +print "not " unless $seen; +print "ok 7\n"; + +rewinddir(DIR); +$seen = 0; +while ($where{$seen} = readdir(DIR)) + { + $seen++ if $where{$seen} eq '0'; + } +print "not " unless $seen; +print "ok 8\n"; + +$seen = 0; +while (my $name = glob('*')) + { + $seen++ if $name eq '0'; + } +print "not " unless $seen; +print "ok 9\n"; + +$seen = 0; +$dummy = ''; +while (($seen ? $dummy : $name) = glob('*')) + { + $seen++ if $name eq '0'; + } +print "not " unless $seen; +print "ok 10\n"; + +$seen = 0; +while ($where{$seen} = glob('*')) + { + $seen++ if $where{$seen} eq '0'; + } +print "not " unless $seen; +print "ok 11\n"; + +unlink("./0"); + +my %hash = (0 => 1, 1 => 2); + +$seen = 0; +while (my $name = each %hash) + { + $seen++ if $name eq '0'; + } +print "not " unless $seen; +print "ok 12\n"; + +$seen = 0; +$dummy = ''; +while (($seen ? $dummy : $name) = each %hash) + { + $seen++ if $name eq '0'; + } +print "not " unless $seen; +print "ok 13\n"; + +$seen = 0; +while ($where{$seen} = each %hash) + { + $seen++ if $where{$seen} eq '0'; + } +print "not " unless $seen; +print "ok 14\n"; + diff --git a/t/op/die_exit.t b/t/op/die_exit.t index b01dd35a97..b5760d6fa0 100755 --- a/t/op/die_exit.t +++ b/t/op/die_exit.t @@ -39,7 +39,9 @@ print "1..$max\n"; foreach my $test (1 .. $max) { my($bang, $query) = @{$tests{$test}}; my $exit = - system qq($perl -e '\$! = $bang; \$? = $query; die;' 2> /dev/null); + ($^O eq 'MSWin32' + ? system qq($perl -e "\$! = $bang; \$? = $query; die;" 2> nul) + : system qq($perl -e '\$! = $bang; \$? = $query; die;' 2> /dev/null)); printf "# 0x%04x 0x%04x 0x%04x\nnot ", $exit, $bang, $query unless $exit == (($bang || ($query >> 8) || 255) << 8); @@ -4,7 +4,7 @@ # various typeglob tests # -print "1..18\n"; +print "1..16\n"; # type coersion on assignment $foo = 'foo'; @@ -71,7 +71,7 @@ $foo = 'stuff'; @foo = qw(more stuff); %foo = qw(even more random stuff); undef *foo; -print +($foo || @foo || %foo) ? "not ok" : "ok", " 16\n"; +print +($foo || @foo || %foo) ? "not ok" : "ok", " 14\n"; # test warnings from assignment of undef to glob { @@ -79,7 +79,7 @@ print +($foo || @foo || %foo) ? "not ok" : "ok", " 16\n"; local $SIG{__WARN__} = sub { $msg = $_[0] }; local $^W = 1; *foo = 'bar'; - print $msg ? "not ok" : "ok", " 17\n"; + print $msg ? "not ok" : "ok", " 15\n"; *foo = undef; - print $msg ? "ok" : "not ok", " 18\n"; + print $msg ? "ok" : "not ok", " 16\n"; } diff --git a/t/op/ipcmsg.t b/t/op/ipcmsg.t index 336d6d1253..98cf8bcaf6 100755 --- a/t/op/ipcmsg.t +++ b/t/op/ipcmsg.t @@ -27,7 +27,7 @@ BEGIN { $Config{'d_msgctl'} eq 'define' && $Config{'d_msgsnd'} eq 'define' && $Config{'d_msgrcv'} eq 'define') { - print "0..0\n"; + print "1..0\n"; exit; } my @incpath = (split(/\s+/, $Config{usrinc}), split(/\s+/ ,$Config{locincpth})); diff --git a/t/op/ipcsem.t b/t/op/ipcsem.t index abe32fbf51..f3f6e3ce4c 100755 --- a/t/op/ipcsem.t +++ b/t/op/ipcsem.t @@ -27,7 +27,7 @@ use vars map { '$' . $_ } @define; BEGIN { unless($Config{'d_semget'} eq 'define' && $Config{'d_semctl'} eq 'define') { - print "0..0\n"; + print "1..0\n"; exit; } my @incpath = (split(/\s+/, $Config{usrinc}), split(/\s+/ ,$Config{locincpth})); diff --git a/t/op/substr.t b/t/op/substr.t index bb655f5209..967016a8d0 100755 --- a/t/op/substr.t +++ b/t/op/substr.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: substr.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:31 $ - -print "1..97\n"; +print "1..100\n"; #P = start of string Q = start of substr R = end of substr S = end of string @@ -178,3 +176,13 @@ for (0,1) { # check no spurious warnings print $w ? "not ok 97\n" : "ok 97\n"; + +# check new replacement syntax +$a = "abcxyz"; +print "not " unless substr($a, 0, 3, "") eq "abc" && $a eq "xyz"; +print "ok 98\n"; +print "not " unless substr($a, 0, 0, "abc") eq "" && $a eq "abcxyz"; +print "ok 99\n"; +print "not " unless substr($a, 3, undef, "") eq "xyz" && $a eq "abc"; +print "ok 100\n"; + diff --git a/t/op/taint.t b/t/op/taint.t index e18f123e9d..2b9da86b3f 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -83,7 +83,7 @@ print PROG 'print "@ARGV\n"', "\n"; close PROG; my $echo = "$Invoke_Perl $ECHO"; -print "1..140\n"; +print "1..145\n"; # First, let's make sure that Perl is checking the dangerous # environment variables. Maybe they aren't set yet, so we'll @@ -121,7 +121,10 @@ print "1..140\n"; } my $tmp; - unless ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_Dos) { + if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_Dos) { + print "# all directories are writeable\n"; + } + else { $tmp = (grep { defined and -d and (stat _)[2] & 2 } qw(/tmp /var/tmp /usr/tmp /sys$scratch), @ENV{qw(TMP TEMP)})[0] @@ -184,12 +187,16 @@ print "1..140\n"; test 20, not tainted $foo; test 21, $foo eq 'bar'; + $foo = $1 if ('bar' . $TAINT) =~ /(.+)/t; + test 22, tainted $foo; + test 23, $foo eq 'bar'; + my $pi = 4 * atan2(1,1) + $TAINT0; - test 22, tainted $pi; + test 24, tainted $pi; ($pi) = $pi =~ /(\d+\.\d+)/; - test 23, not tainted $pi; - test 24, sprintf("%.5f", $pi) eq '3.14159'; + test 25, not tainted $pi; + test 26, sprintf("%.5f", $pi) eq '3.14159'; } # How about command-line arguments? The problem is that we don't @@ -205,21 +212,21 @@ print "1..140\n"; }; close PROG; print `$Invoke_Perl "-T" $arg and some suspect arguments`; - test 25, !$?, "Exited with status $?"; + test 27, !$?, "Exited with status $?"; unlink $arg; } # Reading from a file should be tainted { my $file = './TEST'; - test 26, open(FILE, $file), "Couldn't open '$file': $!"; + test 28, open(FILE, $file), "Couldn't open '$file': $!"; my $block; sysread(FILE, $block, 100); my $line = <FILE>; close FILE; - test 27, tainted $block; - test 28, tainted $line; + test 29, tainted $block; + test 30, tainted $line; } # Globs should be forbidden, except under VMS, @@ -229,122 +236,122 @@ if ($Is_VMS) { } else { my @globs = eval { <*> }; - test 29, @globs == 0 && $@ =~ /^Insecure dependency/; + test 31, @globs == 0 && $@ =~ /^Insecure dependency/; @globs = eval { glob '*' }; - test 30, @globs == 0 && $@ =~ /^Insecure dependency/; + test 32, @globs == 0 && $@ =~ /^Insecure dependency/; } # Output of commands should be tainted { my $foo = `$echo abc`; - test 31, tainted $foo; + test 33, tainted $foo; } # Certain system variables should be tainted { - test 32, all_tainted $^X, $0; + test 34, all_tainted $^X, $0; } # Results of matching should all be untainted { my $foo = "abcdefghi" . $TAINT; - test 33, tainted $foo; + test 35, tainted $foo; $foo =~ /def/; - test 34, not any_tainted $`, $&, $'; + test 36, not any_tainted $`, $&, $'; $foo =~ /(...)(...)(...)/; - test 35, not any_tainted $1, $2, $3, $+; + test 37, not any_tainted $1, $2, $3, $+; my @bar = $foo =~ /(...)(...)(...)/; - test 36, not any_tainted @bar; + test 38, not any_tainted @bar; - test 37, tainted $foo; # $foo should still be tainted! - test 38, $foo eq "abcdefghi"; + test 39, tainted $foo; # $foo should still be tainted! + test 40, $foo eq "abcdefghi"; } # Operations which affect files can't use tainted data. { - test 39, eval { chmod 0, $TAINT } eq '', 'chmod'; - test 40, $@ =~ /^Insecure dependency/, $@; + test 41, eval { chmod 0, $TAINT } eq '', 'chmod'; + test 42, $@ =~ /^Insecure dependency/, $@; # There is no feature test in $Config{} for truncate, # so we allow for the possibility that it's missing. - test 41, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate'; - test 42, $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@; - - test 43, eval { rename '', $TAINT } eq '', 'rename'; - test 44, $@ =~ /^Insecure dependency/, $@; + test 43, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate'; + test 44, $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@; - test 45, eval { unlink $TAINT } eq '', 'unlink'; + test 45, eval { rename '', $TAINT } eq '', 'rename'; test 46, $@ =~ /^Insecure dependency/, $@; - test 47, eval { utime $TAINT } eq '', 'utime'; + test 47, eval { unlink $TAINT } eq '', 'unlink'; test 48, $@ =~ /^Insecure dependency/, $@; + test 49, eval { utime $TAINT } eq '', 'utime'; + test 50, $@ =~ /^Insecure dependency/, $@; + if ($Config{d_chown}) { - test 49, eval { chown -1, -1, $TAINT } eq '', 'chown'; - test 50, $@ =~ /^Insecure dependency/, $@; + test 51, eval { chown -1, -1, $TAINT } eq '', 'chown'; + test 52, $@ =~ /^Insecure dependency/, $@; } else { - for (49..50) { print "ok $_ # Skipped: chown() is not available\n" } + for (51..52) { print "ok $_ # Skipped: chown() is not available\n" } } if ($Config{d_link}) { - test 51, eval { link $TAINT, '' } eq '', 'link'; - test 52, $@ =~ /^Insecure dependency/, $@; + test 53, eval { link $TAINT, '' } eq '', 'link'; + test 54, $@ =~ /^Insecure dependency/, $@; } else { - for (51..52) { print "ok $_ # Skipped: link() is not available\n" } + for (53..54) { print "ok $_ # Skipped: link() is not available\n" } } if ($Config{d_symlink}) { - test 53, eval { symlink $TAINT, '' } eq '', 'symlink'; - test 54, $@ =~ /^Insecure dependency/, $@; + test 55, eval { symlink $TAINT, '' } eq '', 'symlink'; + test 56, $@ =~ /^Insecure dependency/, $@; } else { - for (53..54) { print "ok $_ # Skipped: symlink() is not available\n" } + for (55..56) { print "ok $_ # Skipped: symlink() is not available\n" } } } # Operations which affect directories can't use tainted data. { - test 55, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir'; - test 56, $@ =~ /^Insecure dependency/, $@; - - test 57, eval { rmdir $TAINT } eq '', 'rmdir'; + test 57, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir'; test 58, $@ =~ /^Insecure dependency/, $@; - test 59, eval { chdir $TAINT } eq '', 'chdir'; + test 59, eval { rmdir $TAINT } eq '', 'rmdir'; test 60, $@ =~ /^Insecure dependency/, $@; + test 61, eval { chdir $TAINT } eq '', 'chdir'; + test 62, $@ =~ /^Insecure dependency/, $@; + if ($Config{d_chroot}) { - test 61, eval { chroot $TAINT } eq '', 'chroot'; - test 62, $@ =~ /^Insecure dependency/, $@; + test 63, eval { chroot $TAINT } eq '', 'chroot'; + test 64, $@ =~ /^Insecure dependency/, $@; } else { - for (61..62) { print "ok $_ # Skipped: chroot() is not available\n" } + for (63..64) { print "ok $_ # Skipped: chroot() is not available\n" } } } # Some operations using files can't use tainted data. { my $foo = "imaginary library" . $TAINT; - test 63, eval { require $foo } eq '', 'require'; - test 64, $@ =~ /^Insecure dependency/, $@; + test 65, eval { require $foo } eq '', 'require'; + test 66, $@ =~ /^Insecure dependency/, $@; my $filename = "./taintB$$"; # NB: $filename isn't tainted! END { unlink $filename if defined $filename } $foo = $filename . $TAINT; unlink $filename; # in any case - test 65, eval { open FOO, $foo } eq '', 'open for read'; - test 66, $@ eq '', $@; # NB: This should be allowed - test 67, $! == ($Config{"archname"} !~ "djgpp" ? 2 : 22); # File not found + test 67, eval { open FOO, $foo } eq '', 'open for read'; + test 68, $@ eq '', $@; # NB: This should be allowed + test 69, $! == 2; # File not found - test 68, eval { open FOO, "> $foo" } eq '', 'open for write'; - test 69, $@ =~ /^Insecure dependency/, $@; + test 70, eval { open FOO, "> $foo" } eq '', 'open for write'; + test 71, $@ =~ /^Insecure dependency/, $@; } # Commands to the system can't use tainted data @@ -352,67 +359,67 @@ else { my $foo = $TAINT; if ($^O eq 'amigaos') { - for (70..73) { print "ok $_ # Skipped: open('|') is not available\n" } + for (72..75) { print "ok $_ # Skipped: open('|') is not available\n" } } else { - test 70, eval { open FOO, "| $foo" } eq '', 'popen to'; - test 71, $@ =~ /^Insecure dependency/, $@; - - test 72, eval { open FOO, "$foo |" } eq '', 'popen from'; + test 72, eval { open FOO, "| $foo" } eq '', 'popen to'; test 73, $@ =~ /^Insecure dependency/, $@; - } - test 74, eval { exec $TAINT } eq '', 'exec'; - test 75, $@ =~ /^Insecure dependency/, $@; + test 74, eval { open FOO, "$foo |" } eq '', 'popen from'; + test 75, $@ =~ /^Insecure dependency/, $@; + } - test 76, eval { system $TAINT } eq '', 'system'; + test 76, eval { exec $TAINT } eq '', 'exec'; test 77, $@ =~ /^Insecure dependency/, $@; + test 78, eval { system $TAINT } eq '', 'system'; + test 79, $@ =~ /^Insecure dependency/, $@; + $foo = "*"; taint_these $foo; - test 78, eval { `$echo 1$foo` } eq '', 'backticks'; - test 79, $@ =~ /^Insecure dependency/, $@; + test 80, eval { `$echo 1$foo` } eq '', 'backticks'; + test 81, $@ =~ /^Insecure dependency/, $@; if ($Is_VMS) { # wildcard expansion doesn't invoke shell, so is safe - test 80, join('', eval { glob $foo } ) ne '', 'globbing'; - test 81, $@ eq '', $@; + test 82, join('', eval { glob $foo } ) ne '', 'globbing'; + test 83, $@ eq '', $@; } else { - for (80..81) { print "ok $_ # Skipped: this is not VMS\n"; } + for (82..83) { print "ok $_ # Skipped: this is not VMS\n"; } } } # Operations which affect processes can't use tainted data. { - test 82, eval { kill 0, $TAINT } eq '', 'kill'; - test 83, $@ =~ /^Insecure dependency/, $@; + test 84, eval { kill 0, $TAINT } eq '', 'kill'; + test 85, $@ =~ /^Insecure dependency/, $@; if ($Config{d_setpgrp}) { - test 84, eval { setpgrp 0, $TAINT } eq '', 'setpgrp'; - test 85, $@ =~ /^Insecure dependency/, $@; + test 86, eval { setpgrp 0, $TAINT } eq '', 'setpgrp'; + test 87, $@ =~ /^Insecure dependency/, $@; } else { - for (84..85) { print "ok $_ # Skipped: setpgrp() is not available\n" } + for (86..87) { print "ok $_ # Skipped: setpgrp() is not available\n" } } if ($Config{d_setprior}) { - test 86, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority'; - test 87, $@ =~ /^Insecure dependency/, $@; + test 88, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority'; + test 89, $@ =~ /^Insecure dependency/, $@; } else { - for (86..87) { print "ok $_ # Skipped: setpriority() is not available\n" } + for (88..89) { print "ok $_ # Skipped: setpriority() is not available\n" } } } # Some miscellaneous operations can't use tainted data. { if ($Config{d_syscall}) { - test 88, eval { syscall $TAINT } eq '', 'syscall'; - test 89, $@ =~ /^Insecure dependency/, $@; + test 90, eval { syscall $TAINT } eq '', 'syscall'; + test 91, $@ =~ /^Insecure dependency/, $@; } else { - for (88..89) { print "ok $_ # Skipped: syscall() is not available\n" } + for (90..91) { print "ok $_ # Skipped: syscall() is not available\n" } } { @@ -421,17 +428,17 @@ else { local *FOO; my $temp = "./taintC$$"; END { unlink $temp } - test 90, open(FOO, "> $temp"), "Couldn't open $temp for write: $!"; + test 92, open(FOO, "> $temp"), "Couldn't open $temp for write: $!"; - test 91, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl'; - test 92, $@ =~ /^Insecure dependency/, $@; + test 93, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl'; + test 94, $@ =~ /^Insecure dependency/, $@; if ($Config{d_fcntl}) { - test 93, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl'; - test 94, $@ =~ /^Insecure dependency/, $@; + test 95, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl'; + test 96, $@ =~ /^Insecure dependency/, $@; } else { - for (93..94) { print "ok $_ # Skipped: fcntl() is not available\n" } + for (95..96) { print "ok $_ # Skipped: fcntl() is not available\n" } } close FOO; @@ -442,65 +449,65 @@ else { { my $foo = 'abc' . $TAINT; my $fooref = \$foo; - test 95, not tainted $fooref; - test 96, tainted $$fooref; - test 97, tainted $foo; + test 97, not tainted $fooref; + test 98, tainted $$fooref; + test 99, tainted $foo; } # Some tests involving assignment { my $foo = $TAINT0; my $bar = $foo; - test 98, all_tainted $foo, $bar; - test 99, tainted($foo = $bar); - test 100, tainted($bar = $bar); - test 101, tainted($bar += $bar); - test 102, tainted($bar -= $bar); - test 103, tainted($bar *= $bar); - test 104, tainted($bar++); - test 105, tainted($bar /= $bar); - test 106, tainted($bar += 0); - test 107, tainted($bar -= 2); - test 108, tainted($bar *= -1); - test 109, tainted($bar /= 1); - test 110, tainted($bar--); - test 111, $bar == 0; + test 100, all_tainted $foo, $bar; + test 101, tainted($foo = $bar); + test 102, tainted($bar = $bar); + test 103, tainted($bar += $bar); + test 104, tainted($bar -= $bar); + test 105, tainted($bar *= $bar); + test 106, tainted($bar++); + test 107, tainted($bar /= $bar); + test 108, tainted($bar += 0); + test 109, tainted($bar -= 2); + test 110, tainted($bar *= -1); + test 111, tainted($bar /= 1); + test 112, tainted($bar--); + test 113, $bar == 0; } # Test assignment and return of lists { my @foo = ("A", "tainted" . $TAINT, "B"); - test 112, not tainted $foo[0]; - test 113, tainted $foo[1]; - test 114, not tainted $foo[2]; + test 114, not tainted $foo[0]; + test 115, tainted $foo[1]; + test 116, not tainted $foo[2]; my @bar = @foo; - test 115, not tainted $bar[0]; - test 116, tainted $bar[1]; - test 117, not tainted $bar[2]; + test 117, not tainted $bar[0]; + test 118, tainted $bar[1]; + test 119, not tainted $bar[2]; my @baz = eval { "A", "tainted" . $TAINT, "B" }; - test 118, not tainted $baz[0]; - test 119, tainted $baz[1]; - test 120, not tainted $baz[2]; + test 120, not tainted $baz[0]; + test 121, tainted $baz[1]; + test 122, not tainted $baz[2]; my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ]; - test 121, not tainted $plugh[0]; - test 122, tainted $plugh[1]; - test 123, not tainted $plugh[2]; + test 123, not tainted $plugh[0]; + test 124, tainted $plugh[1]; + test 125, not tainted $plugh[2]; my $nautilus = sub { "A", "tainted" . $TAINT, "B" }; - test 124, not tainted ((&$nautilus)[0]); - test 125, tainted ((&$nautilus)[1]); - test 126, not tainted ((&$nautilus)[2]); + test 126, not tainted ((&$nautilus)[0]); + test 127, tainted ((&$nautilus)[1]); + test 128, not tainted ((&$nautilus)[2]); my @xyzzy = &$nautilus; - test 127, not tainted $xyzzy[0]; - test 128, tainted $xyzzy[1]; - test 129, not tainted $xyzzy[2]; + test 129, not tainted $xyzzy[0]; + test 130, tainted $xyzzy[1]; + test 131, not tainted $xyzzy[2]; my $red_october = sub { return "A", "tainted" . $TAINT, "B" }; - test 130, not tainted ((&$red_october)[0]); - test 131, tainted ((&$red_october)[1]); - test 132, not tainted ((&$red_october)[2]); + test 132, not tainted ((&$red_october)[0]); + test 133, tainted ((&$red_october)[1]); + test 134, not tainted ((&$red_october)[2]); my @corge = &$red_october; - test 133, not tainted $corge[0]; - test 134, tainted $corge[1]; - test 135, not tainted $corge[2]; + test 135, not tainted $corge[0]; + test 136, tainted $corge[1]; + test 137, not tainted $corge[2]; } # Test for system/library calls returning string data of dubious origin. @@ -510,7 +517,7 @@ else { setpwent(); my @getpwent = getpwent(); die "getpwent: $!\n" unless (@getpwent); - test 136,( not tainted $getpwent[0] + test 138,( not tainted $getpwent[0] and not tainted $getpwent[1] and not tainted $getpwent[2] and not tainted $getpwent[3] @@ -521,17 +528,17 @@ else { and not tainted $getpwent[8]); endpwent(); } else { - print "ok 136 # Skipped: getpwent() is not available\n"; + print "ok 138 # Skipped: getpwent() is not available\n"; } if ($Config{d_readdir}) { # pretty hard to imagine not local(*D); opendir(D, "op") or die "opendir: $!\n"; my $readdir = readdir(D); - test 137, tainted $readdir; + test 139, tainted $readdir; closedir(OP); } else { - print "ok 137 # Skipped: readdir() is not available\n"; + print "ok 139 # Skipped: readdir() is not available\n"; } if ($Config{d_readlink} && $Config{d_symlink}) { @@ -539,10 +546,10 @@ else { unlink($symlink); symlink("/something/naughty", $symlink) or die "symlink: $!\n"; my $readlink = readlink($symlink); - test 138, tainted $readlink; + test 140, tainted $readlink; unlink($symlink); } else { - print "ok 138 # Skipped: readlink() or symlink() is not available\n"; + print "ok 140 # Skipped: readlink() or symlink() is not available\n"; } } @@ -550,9 +557,22 @@ else { { my $why = "y"; my $j = "x" | $why; - test 139, not tainted $j; + test 141, not tainted $j; $why = $TAINT."y"; $j = "x" | $why; - test 140, tainted $j; + test 142, tainted $j; } +# test target of substitution (regression bug) +{ + my $why = $TAINT."y"; + $why =~ s/y/z/; + test 143, tainted $why; + + my $z = "[z]"; + $why =~ s/$z/zee/; + test 144, tainted $why; + + $why =~ s/e/'-'.$$/ge; + test 145, tainted $why; +} @@ -4858,6 +4858,8 @@ void pmflag(U16 *pmfl, int ch) *pmfl |= PMf_MULTILINE; else if (ch == 's') *pmfl |= PMf_SINGLELINE; + else if (ch == 't') + *pmfl |= PMf_TAINTMEM; else if (ch == 'x') *pmfl |= PMf_EXTENDED; } @@ -4879,7 +4881,7 @@ scan_pat(char *start) pm = (PMOP*)newPMOP(OP_MATCH, 0); if (multi_open == '?') pm->op_pmflags |= PMf_ONCE; - while (*s && strchr("iogcmsx", *s)) + while (*s && strchr("iogcmstx", *s)) pmflag(&pm->op_pmflags,*s++); pm->op_pmpermflags = pm->op_pmflags; @@ -4924,13 +4926,15 @@ scan_subst(char *start) multi_start = first_start; /* so whole substitution is taken together */ pm = (PMOP*)newPMOP(OP_SUBST, 0); - while (*s && strchr("iogcmsex", *s)) { + while (*s) { if (*s == 'e') { s++; es++; } - else + else if (strchr("iogcmstx", *s)) pmflag(&pm->op_pmflags,*s++); + else + break; } if (es) { @@ -1835,46 +1835,6 @@ VTOH(vtohs,short) VTOH(vtohl,long) #endif -int -do_binmode(PerlIO *fp, int iotype, int flag) -{ - if (flag != TRUE) - croak("panic: unsetting binmode"); /* Not implemented yet */ -#ifdef DOSISH -#ifdef atarist - if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN)) - return 1; - else - return 0; -#else - if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) { -#if defined(WIN32) && defined(__BORLANDC__) - /* The translation mode of the stream is maintained independent - * of the translation mode of the fd in the Borland RTL (heavy - * digging through their runtime sources reveal). User has to - * set the mode explicitly for the stream (though they don't - * document this anywhere). GSAR 97-5-24 - */ - PerlIO_seek(fp,0L,0); - fp->flags |= _F_BIN; -#endif - return 1; - } - else - return 0; -#endif -#else -#if defined(USEMYBINMODE) - if (my_binmode(fp,iotype) != NULL) - return 1; - else - return 0; -#else - return 1; -#endif -#endif -} - /* VMS' my_popen() is in VMS.c, same with OS/2. */ #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) PerlIO * @@ -2429,7 +2389,7 @@ scan_hex(char *start, I32 len, I32 *retlen) register char *s = start; register UV retval = 0; bool overflowed = FALSE; - char *tmp; + char *tmp = s; while (len-- && *s && (tmp = strchr((char *) hexdigit, *s))) { register UV n = retval << 4; @@ -2440,6 +2400,9 @@ scan_hex(char *start, I32 len, I32 *retlen) retval = n | ((tmp - hexdigit) & 15); s++; } + if (dowarn && !tmp) { + warn("Illegal hex digit ignored"); + } *retlen = s - start; return retval; } diff --git a/utils/h2ph.PL b/utils/h2ph.PL index dc2207cc4d..2c685e0383 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())) { $_ .= <IN>; 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/utils/perlbug.PL b/utils/perlbug.PL index 724df6b449..68ff2901d5 100644 --- a/utils/perlbug.PL +++ b/utils/perlbug.PL @@ -17,7 +17,7 @@ chdir dirname($0); $file = basename($0, '.PL'); $file .= '.com' if $^O eq 'VMS'; -open OUT,">$file" or die "Can't create $file: $!"; +open OUT, ">$file" or die "Can't create $file: $!"; # extract patchlevel.h information @@ -27,7 +27,7 @@ my $patchlevel_date = (stat PATCH_LEVEL)[9]; while (<PATCH_LEVEL>) { last if $_ =~ /^\s*static\s+char.*?local_patches\[\]\s*=\s*{\s*$/; -}; +} my @patches; while (<PATCH_LEVEL>) { @@ -37,11 +37,9 @@ while (<PATCH_LEVEL>) { s/"?,?$//; s/(['\\])/\\$1/g; push @patches, $_ unless $_ eq 'NULL'; -}; -my $patch_desc = "'" . join("',\n\t'", @patches) . "'"; -my @patch_tags = map { my $p=$_; $p=~s/\s.*//; $p } @patches; -my $patch_tags = join " ", map { "+$_" } @patch_tags; -$patch_tags .= " " if $patch_tags; +} +my $patch_desc = "'" . join("',\n '", @patches) . "'"; +my $patch_tags = join "", map /(\S+)/ ? "+$1 " : (), @patches; close PATCH_LEVEL; @@ -65,7 +63,7 @@ my \$config_tag1 = '$] - $Config{cf_time}'; my \$patchlevel_date = $patchlevel_date; my \$patch_tags = '$patch_tags'; my \@patches = ( - $patch_desc + $patch_desc ); !GROK!THIS! @@ -75,21 +73,18 @@ print OUT <<'!NO!SUBS!'; use Config; use Getopt::Std; - -BEGIN { - eval "use Mail::Send;"; - $::HaveSend = ($@ eq ""); - eval "use Mail::Util;"; - $::HaveUtil = ($@ eq ""); -}; - - use strict; sub paraprint; +BEGIN { + eval "use Mail::Send;"; + $::HaveSend = ($@ eq ""); + eval "use Mail::Util;"; + $::HaveUtil = ($@ eq ""); +}; -my($Version) = "1.20"; +my $Version = "1.22"; # Changed in 1.06 to skip Mail::Send and Mail::Util if not available. # Changed in 1.07 to see more sendmail execs, and added pipe output. @@ -114,33 +109,32 @@ my($Version) = "1.20"; # add local patch information # warn on '-ok' if this is an old system; add '-okay' # Changed in 1.20 Added patchlevel.h reading and version/config checks +# Changed in 1.21 Added '-nok' for reporting build failure DFD 98-05-05 +# Changed in 1.22 Heavy reformatting & minor bugfixes HVDS 98-05-10 # TODO: - Allow the user to re-name the file on mail failure, and -# make sure failure (transmission-wise) of Mail::Send is +# make sure failure (transmission-wise) of Mail::Send is # accounted for. # - Test -b option my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename, - $subject, $from, $verbose, $ed, + $subject, $from, $verbose, $ed, $fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP, $ok); my $config_tag2 = "$] - $Config{cf_time}"; Init(); -if($::opt_h) { Help(); exit; } - -if($::opt_d) { Dump(*STDOUT); exit; } - -if(!-t STDIN) { - paraprint <<EOF; -Please use perlbug interactively. If you want to +if ($::opt_h) { Help(); exit; } +if ($::opt_d) { Dump(*STDOUT); exit; } +if (!-t STDIN) { + paraprint <<EOF; +Please use perlbug interactively. If you want to include a file, you can use the -f switch. EOF - die "\n"; + die "\n"; } - -if(!-t STDOUT) { Dump(*STDOUT); exit; } +if (!-t STDOUT) { Dump(*STDOUT); exit; } Query(); Edit() unless $usefile; @@ -150,108 +144,114 @@ Send(); exit; sub Init { - - # -------- Setup -------- - - $Is_MSWin32 = $^O eq 'MSWin32'; - $Is_VMS = $^O eq 'VMS'; - - getopts("dhva:s:b:f:r:e:SCc:to:"); - - - # This comment is needed to notify metaconfig that we are - # using the $perladmin, $cf_by, and $cf_time definitions. - - - # -------- Configuration --------- - - # perlbug address - $perlbug = 'perlbug@perl.com'; - - - # Test address - $testaddress = 'perlbug-test@perl.com'; - - # Target address - $address = $::opt_a || ($::opt_t ? $testaddress : $perlbug); - - # Users address, used in message and in Reply-To header - $from = $::opt_r || ""; - - # Include verbose configuration information - $verbose = $::opt_v || 0; - - # Subject of bug-report message - $subject = $::opt_s || ""; - - # Send a file - $usefile = ($::opt_f || 0); - - # File to send as report - $file = $::opt_f || ""; - - # Body of report - $body = $::opt_b || ""; - - # Editor - $ed = ( $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT} || - ($Is_VMS ? "edit/tpu" : $Is_MSWin32 ? "notepad" : "vi") - ); - - # OK - send "OK" report for build on this system - $ok = 0; - if ( $::opt_o ) { - if ( $::opt_o eq 'k' or $::opt_o eq 'kay' ) { - my $age = time - $patchlevel_date; - if ( $::opt_o eq 'k' and $age > 60 * 24 * 60 * 60 ) { - my $date = localtime $patchlevel_date; - print <<"EOF"; -\"perlbug -ok\" does not report on Perl versions which are more than -60 days old. This Perl version was constructed on $date. -If you really want to report this, use \"perlbug -okay\". + # -------- Setup -------- + + $Is_MSWin32 = $^O eq 'MSWin32'; + $Is_VMS = $^O eq 'VMS'; + + getopts("dhva:s:b:f:r:e:SCc:to:n:"); + + # This comment is needed to notify metaconfig that we are + # using the $perladmin, $cf_by, and $cf_time definitions. + + # -------- Configuration --------- + + # perlbug address + $perlbug = 'perlbug@perl.com'; + + # Test address + $testaddress = 'perlbug-test@perl.com'; + + # Target address + $address = $::opt_a || ($::opt_t ? $testaddress : $perlbug); + + # Users address, used in message and in Reply-To header + $from = $::opt_r || ""; + + # Include verbose configuration information + $verbose = $::opt_v || 0; + + # Subject of bug-report message + $subject = $::opt_s || ""; + + # Send a file + $usefile = ($::opt_f || 0); + + # File to send as report + $file = $::opt_f || ""; + + # Body of report + $body = $::opt_b || ""; + + # Editor + $ed = $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT} + || ($Is_VMS && "edit/tpu") + || ($Is_MSWin32 && "notepad") + || "vi"; + + # Not OK - provide build failure template by finessing OK report + if ($::opt_n) { + if (substr($::opt_n, 0, 2) eq 'ok' ) { + $::opt_o = substr($::opt_n, 1); + } else { + Help(); + exit(); + } + } + + # OK - send "OK" report for build on this system + $ok = 0; + if ($::opt_o) { + if ($::opt_o eq 'k' or $::opt_o eq 'kay') { + my $age = time - $patchlevel_date; + if ($::opt_o eq 'k' and $age > 60 * 24 * 60 * 60 ) { + my $date = localtime $patchlevel_date; + print <<"EOF"; +"perlbug -ok" and "perlbug -nok" do not report on Perl versions which +are more than 60 days old. This Perl version was constructed on +$date. If you really want to report this, use +"perlbug -okay" or "perlbug -nokay". EOF - exit(); - }; - # force these options - $::opt_S = 1; # don't prompt for send - $::opt_C = 1; # don't send a copy to the local admin - $::opt_s = 1; - $subject = "OK: perl $] ${patch_tags}on" - ." $::Config{'archname'} $::Config{'osvers'} $subject"; - $::opt_b = 1; - $body = "Perl reported to build OK on this system.\n"; - $ok = 1; - } - else { - Help(); exit(); } + # force these options + unless ($::opt_n) { + $::opt_S = 1; # don't prompt for send + $::opt_b = 1; # we have a body + $body = "Perl reported to build OK on this system.\n"; + } + $::opt_C = 1; # don't send a copy to the local admin + $::opt_s = 1; # we have a subject line + $subject = ($::opt_n ? 'Not ' : '') + . "OK: perl $] ${patch_tags}on" + ." $::Config{'archname'} $::Config{'osvers'} $subject"; + $ok = 1; + } else { + Help(); + exit(); } - - # Possible administrator addresses, in order of confidence - # (Note that cf_email is not mentioned to metaconfig, since - # we don't really want it. We'll just take it if we have to.) - # - # This has to be after the $ok stuff above because of the way - # that $::opt_C is forced. - $cc = ($::opt_C ? "" : ( - $::opt_c || $::Config{perladmin} || $::Config{cf_email} || $::Config{cf_by} - )); - - # My username - $me = ( $Is_MSWin32 - ? $ENV{'USERNAME'} - : ( $^O eq 'os2' - ? $ENV{'USER'} || $ENV{'LOGNAME'} - : eval { getpwuid($<) }) ); # May be missing - -} + } + # Possible administrator addresses, in order of confidence + # (Note that cf_email is not mentioned to metaconfig, since + # we don't really want it. We'll just take it if we have to.) + # + # This has to be after the $ok stuff above because of the way + # that $::opt_C is forced. + $cc = $::opt_C ? "" : ( + $::opt_c || $::Config{'perladmin'} + || $::Config{'cf_email'} || $::Config{'cf_by'} + ); + + # My username + $me = $Is_MSWin32 ? $ENV{'USERNAME'} + : $^O eq 'os2' ? $ENV{'USER'} || $ENV{'LOGNAME'} + : eval { getpwuid($<) }; # May be missing +} # sub Init sub Query { - - # Explain what perlbug is - if ( ! $ok ) { + # Explain what perlbug is + unless ($ok) { paraprint <<EOF; This program provides an easy way to create a message reporting a bug in perl, and e-mail it to $address. It is *NOT* intended for @@ -263,156 +263,121 @@ and any solutions to such problems, to the people who maintain perl. If you're just looking for help with perl, try posting to the Usenet newsgroup comp.lang.perl.misc. If you're looking for help with using perl with CGI, try posting to comp.infosystems.www.programming.cgi. - EOF } - - # Prompt for subject of message, if needed - if(! $subject) { - paraprint <<EOF; -First of all, please provide a subject for the -message. It should be a concise description of + # Prompt for subject of message, if needed + unless ($subject) { + paraprint <<EOF; +First of all, please provide a subject for the +message. It should be a concise description of the bug or problem. "perl bug" or "perl problem" is not a concise description. - EOF - print "Subject: "; - - $subject = <>; - chop $subject; - - my($err)=0; - while( $subject =~ /^\s*$/ ) { - print "\nPlease enter a subject: "; - $subject = <>; - chop $subject; - if($err++>5) { - die "Aborting.\n"; - } - } + print "Subject: "; + $subject = <>; + + my $err = 0; + while ($subject !~ /\S/) { + print "\nPlease enter a subject: "; + $subject = <>; + if ($err++ > 5) { + die "Aborting.\n"; + } } - - - # Prompt for return address, if needed - if( !$from) { - - # Try and guess return address - my($domain); - - if($::HaveUtil) { - $domain = Mail::Util::maildomain(); - } elsif ($Is_MSWin32) { - $domain = $ENV{'USERDOMAIN'}; + chop $subject; + } + + # Prompt for return address, if needed + unless ($from) { + # Try and guess return address + my $guess; + + $guess = $ENV{'REPLY-TO'} || $ENV{'REPLYTO'} || ''; + unless ($guess) { + my $domain; + if ($::HaveUtil) { + $domain = Mail::Util::maildomain(); + } elsif ($Is_MSWin32) { + $domain = $ENV{'USERDOMAIN'}; + } else { + require Sys::Hostname; + $domain = Sys::Hostname::hostname(); + } + if ($domain) { + if ($Is_VMS && !$::Config{'d_socket'}) { + $guess = "$domain\:\:$me"; } else { - require Sys::Hostname; - $domain = Sys::Hostname::hostname(); + $guess = "$me\@$domain" if $domain; } - - my($guess); - - if( !$domain) { - $guess = ""; - } elsif ($Is_VMS && !$::Config{'d_socket'}) { - $guess = "$domain\:\:$me"; - } else { - $guess = "$me\@$domain" if $domain; - $guess = "$me\@unknown.addresss" unless $domain; - } - - $guess = $ENV{'REPLYTO'} if defined($ENV{'REPLYTO'}); - $guess = $ENV{"REPLY-TO"} if defined($ENV{'REPLY-TO'}); - - if( $guess ) { - if ( ! $ok ) { - paraprint <<EOF; - + } + } + if ($guess) { + unless ($ok) { + paraprint <<EOF; Your e-mail address will be useful if you need to be contacted. If the default shown is not your full internet e-mail address, please correct it. - EOF - } - } else { - paraprint <<EOF; - -So that you may be contacted if necessary, please enter + } + } else { + paraprint <<EOF; +So that you may be contacted if necessary, please enter your full internet e-mail address here. - EOF - } - - if ( $ok && $guess ne '' ) { - # use it - $from = $guess; - } - else { - # verify it - print "Your address [$guess]: "; - - $from = <>; - chop $from; - - if($from eq "") { $from = $guess } - } - } - - #if( $from =~ /^(.*)\@(.*)$/ ) { - # $mailname = $1; - # $maildomain = $2; - #} - - if( $from eq $cc or $me eq $cc ) { - # Try not to copy ourselves - $cc = "yourself"; - } - - # Prompt for administrator address, unless an override was given - if( !$::opt_C and !$::opt_c ) { - paraprint <<EOF; + if ($ok && $guess) { + # use it + $from = $guess; + } else { + # verify it + print "Your address [$guess]: "; + $from = <>; + chop $from; + $from = $guess if $from eq ''; + } + } + if ($from eq $cc or $me eq $cc) { + # Try not to copy ourselves + $cc = "yourself"; + } + # Prompt for administrator address, unless an override was given + if( !$::opt_C and !$::opt_c ) { + paraprint <<EOF; A copy of this report can be sent to your local -perl administrator. If the address is wrong, please +perl administrator. If the address is wrong, please correct it, or enter 'none' or 'yourself' to not send a copy. - EOF + print "Local perl administrator [$cc]: "; + my $entry = scalar <>; + chop $entry; - print "Local perl administrator [$cc]: "; - - my($entry) = scalar(<>); - chop $entry; - - if($entry ne "") { - $cc = $entry; - if($me eq $cc) { $cc = "" } - } - + if ($entry ne "") { + $cc = $entry; + $cc = '' if $me eq $cc; } + } - if($cc =~ /^(none|yourself|me|myself|ourselves)$/i) { $cc = "" } - - $andcc = " and $cc" if $cc; + $cc = '' if $cc =~ /^(none|yourself|me|myself|ourselves)$/i; + $andcc = " and $cc" if $cc; + # Prompt for editor, if no override is given editor: - - # Prompt for editor, if no override is given - if(! $::opt_e and ! $::opt_f and ! $::opt_b) { - paraprint <<EOF; - - + unless ($::opt_e || $::opt_f || $::opt_b) { + paraprint <<EOF; Now you need to supply the bug report. Try to make -the report concise but descriptive. Include any +the report concise but descriptive. Include any relevant detail. If you are reporting something that does not work as you think it should, please -try to include example of both the actual +try to include example of both the actual result, and what you expected. Some information about your local -perl configuration will automatically be included +perl configuration will automatically be included at the end of the report. If you are using any unusual version of perl, please try and confirm exactly which versions are relevant. @@ -424,96 +389,71 @@ the name of the editor you would like to use. If you would like to use a prepared file, type "file", and you will be asked for the filename. - EOF - - print "Editor [$ed]: "; - - my($entry) =scalar(<>); - chop $entry; - - $usefile = 0; - if($entry eq "file") { - $usefile = 1; - } elsif($entry ne "") { - $ed = $entry; - } + print "Editor [$ed]: "; + my $entry =scalar <>; + chop $entry; + + $usefile = 0; + if ($entry eq "file") { + $usefile = 1; + } elsif ($entry ne "") { + $ed = $entry; } + } + # Generate scratch file to edit report in + $filename = filename(); - # Generate scratch file to edit report in - - { - my($dir) = ($Is_VMS ? 'sys$scratch:' : - (($Is_MSWin32 && $ENV{'TEMP'}) ? $ENV{'TEMP'} : '/tmp/')); - $filename = "bugrep0$$"; - $dir .= "\\" if $Is_MSWin32 and $dir !~ m|[\\/]$|; - $filename++ while -e "$dir$filename"; - $filename = "$dir$filename"; - } - - - # Prompt for file to read report from, if needed - - if( $usefile and ! $file) { + # Prompt for file to read report from, if needed + if ($usefile and !$file) { filename: - paraprint <<EOF; - + paraprint <<EOF; What is the name of the file that contains your report? - EOF + print "Filename: "; + my $entry = scalar <>; + chop $entry; - print "Filename: "; - - my($entry) = scalar(<>); - chop($entry); - - if($entry eq "") { - paraprint <<EOF; - -No filename? I'll let you go back and choose an editor again. - + if ($entry eq "") { + paraprint <<EOF; +No filename? I'll let you go back and choose an editor again. EOF - goto editor; - } - - if(!-f $entry or !-r $entry) { - paraprint <<EOF; - + goto editor; + } + + unless (-f $entry and -r $entry) { + paraprint <<EOF; I'm sorry, but I can't read from `$entry'. Maybe you mistyped the name of the file? If you don't want to send a file, just enter a blank line and you can get back to the editor selection. - EOF - goto filename; - } - $file = $entry; - + goto filename; } + $file = $entry; + } + # Generate report + open(REP,">$filename"); + my $reptype = $ok ? "build failure" : "bug"; - # Generate report - - open(REP,">$filename"); - - my $reptype = $ok ? "success" : "bug"; - - print REP <<EOF; + print REP <<EOF; This is a $reptype report for perl from $from, generated with the help of perlbug $Version running under perl $]. EOF - if($body) { - print REP $body; - } elsif($usefile) { - open(F,"<$file") or die "Unable to read report file from `$file': $!\n"; - while(<F>) { - print REP $_ - } - close(F); - } else { - print REP <<EOF; + if ($body) { + print REP $body; + } elsif ($usefile) { + open(F, "<$file") + or die "Unable to read report file from `$file': $!\n"; + while (<F>) { + print REP $_ + } + close(F); + } else { + print REP <<EOF; ----------------------------------------------------------------- [Please enter your report here] @@ -523,164 +463,138 @@ EOF [Please do not change anything below this line] ----------------------------------------------------------------- EOF - } - - Dump(*REP); - close(REP); - - # read in the report template once so that - # we can track whether the user does any editing. - # yes, *all* whitespace is ignored. - open(REP, "<$filename"); - while (<REP>) { - s/\s+//g; - $REP{$_}++; - } - close(REP); - -} + } + Dump(*REP); + close(REP); + + # read in the report template once so that + # we can track whether the user does any editing. + # yes, *all* whitespace is ignored. + open(REP, "<$filename"); + while (<REP>) { + s/\s+//g; + $REP{$_}++; + } + close(REP); +} # sub Query sub Dump { - local(*OUT) = @_; - - print REP "\n---\n"; + local(*OUT) = @_; - print REP "This perlbug was built using Perl $config_tag1\n", - "It is being executed now by Perl $config_tag2.\n\n" - if $config_tag2 ne $config_tag1; + print REP "\n---\n"; + print REP "This perlbug was built using Perl $config_tag1\n", + "It is being executed now by Perl $config_tag2.\n\n" + if $config_tag2 ne $config_tag1; - print OUT <<EOF; + print OUT <<EOF; Site configuration information for perl $]: EOF + if ($::Config{cf_by} and $::Config{cf_time}) { + print OUT "Configured by $::Config{cf_by} at $::Config{cf_time}.\n\n"; + } + print OUT Config::myconfig; - if( $::Config{cf_by} and $::Config{cf_time}) { - print OUT "Configured by $::Config{cf_by} at $::Config{cf_time}.\n\n"; - } - - print OUT Config::myconfig; - - if (@patches) { - print OUT join "\n\t", "Locally applied patches:", @patches; - print OUT "\n"; - }; + if (@patches) { + print OUT join "\n ", "Locally applied patches:", @patches; + print OUT "\n"; + }; - print OUT <<EOF; + print OUT <<EOF; --- \@INC for perl $]: EOF - for my $i (@INC) { - print OUT "\t$i\n"; - } + for my $i (@INC) { + print OUT " $i\n"; + } - print OUT <<EOF; + print OUT <<EOF; --- Environment for perl $]: EOF - for my $env (sort - (qw(PATH LD_LIBRARY_PATH - LANG PERL_BADLANG - SHELL HOME LOGDIR), - grep { /^(?:PERL|LC_)/ } keys %ENV)) { - print OUT " $env", - exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)', - "\n"; - } - if($verbose) { - print OUT "\nComplete configuration data for perl $]:\n\n"; - my($value); - foreach (sort keys %::Config) { - $value = $::Config{$_}; - $value =~ s/'/\\'/g; - print OUT "$_='$value'\n"; - } + for my $env (sort + (qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR), + grep /^(?:PERL|LC_)/, keys %ENV) + ) { + print OUT " $env", + exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)', + "\n"; + } + if ($verbose) { + print OUT "\nComplete configuration data for perl $]:\n\n"; + my $value; + foreach (sort keys %::Config) { + $value = $::Config{$_}; + $value =~ s/'/\\'/g; + print OUT "$_='$value'\n"; } -} + } +} # sub Dump sub Edit { - # Edit the report - - if($usefile) { - $usefile = 0; - paraprint <<EOF; - + # Edit the report + if ($usefile || $body) { + paraprint <<EOF; Please make sure that the name of the editor you want to use is correct. - EOF - print "Editor [$ed]: "; - - my($entry) =scalar(<>); - chop $entry; - - if($entry ne "") { - $ed = $entry; - } - } - -tryagain: - if(!$usefile and !$body) { - my $sts = system("$ed $filename"); - if($sts) { - #print "\nUnable to run editor!\n"; - paraprint <<EOF; + print "Editor [$ed]: "; + my $entry =scalar <>; + chop $entry; + $ed = $entry unless $entry eq ''; + } +tryagain: + my $sts = system("$ed $filename"); + if ($sts) { + paraprint <<EOF; The editor you chose (`$ed') could apparently not be run! Did you mistype the name of your editor? If so, please -correct it here, otherwise just press Enter. - +correct it here, otherwise just press Enter. EOF - print "Editor [$ed]: "; - - my($entry) =scalar(<>); - chop $entry; - - if($entry ne "") { - $ed = $entry; - goto tryagain; - } else { - - paraprint <<EOF; + print "Editor [$ed]: "; + my $entry =scalar <>; + chop $entry; + if ($entry ne "") { + $ed = $entry; + goto tryagain; + } else { + paraprint <<EOF; You may want to save your report to a file, so you can edit and mail it yourself. EOF - } - } - } - - return if $ok; - # Check that we have a report that has some, eh, report in it. - - my $unseen = 0; - - open(REP, "<$filename"); - # a strange way to check whether any significant editing - # have been done: check whether any new non-empty lines - # have been added. Yes, the below code ignores *any* space - # in *any* line. - while (<REP>) { - s/\s+//g; - $unseen++ if ($_ ne '' and not exists $REP{$_}); } + } - while ($unseen == 0) { - paraprint <<EOF; + return if ($ok and not $::opt_n) || $body; + # Check that we have a report that has some, eh, report in it. + my $unseen = 0; + + open(REP, "<$filename"); + # a strange way to check whether any significant editing + # have been done: check whether any new non-empty lines + # have been added. Yes, the below code ignores *any* space + # in *any* line. + while (<REP>) { + s/\s+//g; + $unseen++ if $_ ne '' and not exists $REP{$_}; + } + while ($unseen == 0) { + paraprint <<EOF; I am sorry but it looks like you did not report anything. - EOF - print "Action (Retry Edit/Cancel) "; - my ($action) = scalar(<>); - if ($action =~ /^[re]/i) { # <R>etry <E>dit - goto tryagain; - } elsif ($action =~ /^[cq]/i) { # <C>ancel, <Q>uit - Cancel(); - } - } - -} + print "Action (Retry Edit/Cancel) "; + my ($action) = scalar(<>); + if ($action =~ /^[re]/i) { # <R>etry <E>dit + goto tryagain; + } elsif ($action =~ /^[cq]/i) { # <C>ancel, <Q>uit + Cancel(); + } + } +} # sub Edit sub Cancel { 1 while unlink($filename); # remove all versions under VMS @@ -689,227 +603,211 @@ sub Cancel { } sub NowWhat { - - # Report is done, prompt for further action - if( !$::opt_S ) { - while(1) { - - paraprint <<EOF; - - -Now that you have completed your report, would you like to send -the message to $address$andcc, display the message on + # Report is done, prompt for further action + if( !$::opt_S ) { + while(1) { + paraprint <<EOF; +Now that you have completed your report, would you like to send +the message to $address$andcc, display the message on the screen, re-edit it, or cancel without sending anything? You may also save the message as a file to mail at another time. - EOF - - print "Action (Send/Display/Edit/Cancel/Save to File): "; - my($action) = scalar(<>); - chop $action; - - if( $action =~ /^(f|sa)/i ) { # <F>ile/<Sa>ve - print "\n\nName of file to save message in [perlbug.rep]: "; - my($file) = scalar(<>); - chop $file; - if($file eq "") { $file = "perlbug.rep" } - - open(FILE,">$file"); - open(REP,"<$filename"); - print FILE "To: $address\nSubject: $subject\n"; - print FILE "Cc: $cc\n" if $cc; - print FILE "Reply-To: $from\n" if $from; - print FILE "\n"; - while(<REP>) { print FILE } - close(REP); - close(FILE); - - print "\nMessage saved in `$file'.\n"; - exit; - - } elsif( $action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow - # Display the message - open(REP,"<$filename"); - while(<REP>) { print $_ } - close(REP); - } elsif( $action =~ /^se/i ) { # <S>end - # Send the message - print "\ -Are you certain you want to send this message? -Please type \"yes\" if you are: "; - my($reply) = scalar(<STDIN>); - chop($reply); - if( $reply eq "yes" ) { - last; - } else { - paraprint <<EOF; - + print "Action (Send/Display/Edit/Cancel/Save to File): "; + my $action = scalar <>; + chop $action; + + if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve + print "\n\nName of file to save message in [perlbug.rep]: "; + my $file = scalar <>; + chop $file; + $file = "perlbug.rep" if $file eq ""; + + open(FILE, ">$file"); + open(REP, "<$filename"); + print FILE "To: $address\nSubject: $subject\n"; + print FILE "Cc: $cc\n" if $cc; + print FILE "Reply-To: $from\n" if $from; + print FILE "\n"; + while (<REP>) { print FILE } + close(REP); + close(FILE); + + print "\nMessage saved in `$file'.\n"; + exit; + } elsif ($action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow + # Display the message + open(REP, "<$filename"); + while (<REP>) { print $_ } + close(REP); + } elsif ($action =~ /^se/i) { # <S>end + # Send the message + print "Are you certain you want to send this message?\n" + . 'Please type "yes" if you are: '; + my $reply = scalar <STDIN>; + chop $reply; + if ($reply eq "yes") { + last; + } else { + paraprint <<EOF; That wasn't a clear "yes", so I won't send your message. If you are sure your message should be sent, type in "yes" (without the quotes) at the confirmation prompt. - EOF - - } - } elsif( $action =~ /^[er]/i ) { # <E>dit, <R>e-edit - # edit the message - Edit(); - #system("$ed $filename"); - } elsif( $action =~ /^[qc]/i ) { # <C>ancel, <Q>uit - Cancel(); - } elsif( $action =~ /^s/ ) { - paraprint <<EOF; - + } + } elsif ($action =~ /^[er]/i) { # <E>dit, <R>e-edit + # edit the message + Edit(); + } elsif ($action =~ /^[qc]/i) { # <C>ancel, <Q>uit + Cancel(); + } elsif ($action =~ /^s/) { + paraprint <<EOF; I'm sorry, but I didn't understand that. Please type "send" or "save". EOF - } - - } + } } -} - + } +} # sub NowWhat sub Send { + # Message has been accepted for transmission -- Send the message + if ($::HaveSend) { + $msg = new Mail::Send Subject => $subject, To => $address; + $msg->cc($cc) if $cc; + $msg->add("Reply-To",$from) if $from; + + $fh = $msg->open; + open(REP, "<$filename"); + while (<REP>) { print $fh $_ } + close(REP); + $fh->close; + + print "\nMessage sent.\n"; + } elsif ($Is_VMS) { + if ( ($address =~ /@/ and $address !~ /^\w+%"/) or + ($cc =~ /@/ and $cc !~ /^\w+%"/) ) { + my $prefix; + foreach (qw[ IN MX SMTP UCX PONY WINS ], '') { + $prefix = "$_%", last if $ENV{"MAIL\$PROTOCOL_$_"}; + } + $address = qq[${prefix}"$address"] unless $address =~ /^\w+%"/; + $cc = qq[${prefix}"$cc"] unless !$cc || $cc =~ /^\w+%"/; + } + $subject =~ s/"/""/g; $address =~ s/"/""/g; $cc =~ s/"/""/g; + my $sts = system(qq[mail/Subject="$subject" $filename. "$address","$cc"]); + if ($sts) { + die <<EOF; +Can't spawn off mail + (leaving bug report in $filename): $sts +EOF + } + } else { + my $sendmail = ""; + for (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/ucblib/sendmail)) { + $sendmail = $_, last if -e $_; + } + if ($^O eq 'os2' and $sendmail eq "") { + my $path = $ENV{PATH}; + $path =~ s:\\:/: ; + my @path = split /$Config{'path_sep'}/, $path; + for (@path) { + $sendmail = "$_/sendmail", last if -e "$_/sendmail"; + $sendmail = "$_/sendmail.exe", last if -e "$_/sendmail.exe"; + } + } - # Message has been accepted for transmission -- Send the message - - if($::HaveSend) { - - $msg = new Mail::Send Subject => $subject, To => $address; - - $msg->cc($cc) if $cc; - $msg->add("Reply-To",$from) if $from; - - $fh = $msg->open; - - open(REP,"<$filename"); - while(<REP>) { print $fh $_ } - close(REP); - - $fh->close; - - print "\nMessage sent.\n"; - } else { - if ($Is_VMS) { - if ( ($address =~ /@/ and $address !~ /^\w+%"/) or - ($cc =~ /@/ and $cc !~ /^\w+%"/) ){ - my($prefix); - foreach (qw[ IN MX SMTP UCX PONY WINS ],'') { - $prefix = "$_%",last if $ENV{"MAIL\$PROTOCOL_$_"}; - } - $address = qq[${prefix}"$address"] unless $address =~ /^\w+%"/; - $cc = qq[${prefix}"$cc"] unless !$cc || $cc =~ /^\w+%"/; - } - $subject =~ s/"/""/g; $address =~ s/"/""/g; $cc =~ s/"/""/g; - my($sts) = system(qq[mail/Subject="$subject" $filename. "$address","$cc"]); - if ($sts) { die "Can't spawn off mail\n\t(leaving bug report in $filename): $sts\n;" } - } else { - my($sendmail) = ""; - - foreach (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/ucblib/sendmail)) - { - $sendmail = $_, last if -e $_; - } - - if ($^O eq 'os2' and $sendmail eq "") { - my $path = $ENV{PATH}; - $path =~ s:\\:/: ; - my @path = split /$Config{path_sep}/, $path; - for (@path) { - $sendmail = "$_/sendmail", last - if -e "$_/sendmail"; - $sendmail = "$_/sendmail.exe", last - if -e "$_/sendmail.exe"; - } - } - - paraprint(<<"EOF"), die "\n" if $sendmail eq ""; - + paraprint(<<"EOF"), die "\n" if $sendmail eq ""; I am terribly sorry, but I cannot find sendmail, or a close equivalent, and the perl package Mail::Send has not been installed, so I can't send your bug report. We apologize for the inconvenience. So you may attempt to find some way of sending your message, it has been left in the file `$filename'. - EOF - - open(SENDMAIL,"|$sendmail -t") || die "'|$sendmail -t' failed: $|"; - print SENDMAIL "To: $address\n"; - print SENDMAIL "Subject: $subject\n"; - print SENDMAIL "Cc: $cc\n" if $cc; - print SENDMAIL "Reply-To: $from\n" if $from; - print SENDMAIL "\n\n"; - open(REP,"<$filename"); - while(<REP>) { print SENDMAIL $_ } - close(REP); - - if (close(SENDMAIL)) { - print "\nMessage sent.\n"; - } else { - warn "\nSendmail returned status '",$?>>8,"'\n"; - } - } - - } - - 1 while unlink($filename); # remove all versions under VMS + open(SENDMAIL, "|$sendmail -t") || die "'|$sendmail -t' failed: $!"; + print SENDMAIL "To: $address\n"; + print SENDMAIL "Subject: $subject\n"; + print SENDMAIL "Cc: $cc\n" if $cc; + print SENDMAIL "Reply-To: $from\n" if $from; + print SENDMAIL "\n\n"; + open(REP, "<$filename"); + while (<REP>) { print SENDMAIL $_ } + close(REP); -} + if (close(SENDMAIL)) { + print "\nMessage sent.\n"; + } else { + warn "\nSendmail returned status '", $? >> 8, "'\n"; + } + } + 1 while unlink($filename); # remove all versions under VMS +} # sub Send sub Help { - print <<EOF; + print <<EOF; -A program to help generate bug reports about perl5, and mail them. +A program to help generate bug reports about perl5, and mail them. It is designed to be used interactively. Normally no arguments will be needed. - + Usage: $0 [-v] [-a address] [-s subject] [-b body | -f file ] [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t] [-h] - +$0 [-v] [-r returnaddress] [-ok | -okay | -nok | -nokay] + Simplest usage: run "$0", and follow the prompts. Options: -v Include Verbose configuration data in the report - -f File containing the body of the report. Use this to + -f File containing the body of the report. Use this to quickly send a prepared message. -S Send without asking for confirmation. -a Address to send the report to. Defaults to `$address'. -c Address to send copy of report to. Defaults to `$cc'. -C Don't send copy to administrator. - -s Subject to include with the message. You will be prompted + -s Subject to include with the message. You will be prompted if you don't supply one on the command line. -b Body of the report. If not included on the command line, or in a file with -f, you will get a chance to edit the message. -r Your return address. The program will ask you to confirm this if you don't give it here. - -e Editor to use. + -e Editor to use. -t Test mode. The target address defaults to `$testaddress'. - -d Data mode (the default if you redirect or pipe output.) + -d Data mode (the default if you redirect or pipe output.) This prints out your configuration data, without mailing anything. You can use this with -v to get more complete data. -ok Report successful build on this system to perl porters - (use alone or with -v). Only use -ok if *everything* was ok. - If there were *any* problems at all then don't use -ok. + (use alone or with -v). Only use -ok if *everything* was ok: + if there were *any* problems at all, use -nok. -okay As -ok but allow report from old builds. - -h Print this help message. - + -nok Report unsuccessful build on this system to perl porters + (use alone or with -v). You must describe what went wrong + in the body of the report which you will be asked to edit. + -nokay As -nok but allow report from old builds. + -h Print this help message. + EOF } +sub filename { + my $dir = $Is_VMS ? 'sys$scratch:' + : ($Is_MSWin32 && $ENV{'TEMP'}) ? $ENV{'TEMP'} + : '/tmp/'; + $filename = "bugrep0$$"; + $dir .= "\\" if $Is_MSWin32 and $dir !~ m|[\\/]$|; + $filename++ while -e "$dir$filename"; + $filename = "$dir$filename"; +} + sub paraprint { my @paragraphs = split /\n{2,}/, "@_"; print "\n\n"; for (@paragraphs) { # implicit local $_ - s/(\S)\s*\n/$1 /g; - write; - print "\n"; + s/(\S)\s*\n/$1 /g; + write; + print "\n"; } - } - format STDOUT = ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~ @@ -929,12 +827,13 @@ S<[ B<-b> I<body> | B<-f> I<file> ]> S<[ B<-r> I<returnaddress> ]> S<[ B<-e> I<editor> ]> S<[ B<-c> I<adminaddress> | B<-C> ]> S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-h> ]> -B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]> S<[ B<-ok> | B<okay> ]> +B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]> +S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]> =head1 DESCRIPTION A program to help generate bug reports about perl or the modules that -come with it, and mail them. +come with it, and mail them. If you have found a bug with a non-standard port (one that was not part of the I<standard distribution>), a binary distribution, or a @@ -1073,7 +972,7 @@ with B<-v> to get more complete data. =item B<-e> -Editor to use. +Editor to use. =item B<-f> @@ -1097,6 +996,21 @@ system is less than 60 days old. As B<-ok> except it will report on older systems. +=item B<-nok> + +Report unsuccessful build on this system. Forces B<-C>. Forces and +supplies a value for B<-s>, then requires you to edit the report +and say what went wrong. Alternatively, a prepared report may be +supplied using B<-f>. Only prompts for a return address if it +cannot guess it (for use with B<make>). Honors return address +specified with B<-r>. You can use this with B<-v> to get more +complete data. Only makes a report if this system is less than 60 +days old. + +=item B<-nokay> + +As B<-nok> except it will report on older systems. + =item B<-r> Your return address. The program will ask you to confirm its default @@ -1126,8 +1040,9 @@ Include verbose configuration data in the report. Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently I<doc>tored by Gurusamy Sarathy (E<lt>gsar@umich.eduE<gt>), Tom Christiansen (E<lt>tchrist@perl.comE<gt>), Nathan Torkington (E<lt>gnat@frii.comE<gt>), -Charles F. Randall (E<lt>cfr@pobox.comE<gt>) and -Mike Guy (E<lt>mjtg@cam.a.ukE<gt>). +Charles F. Randall (E<lt>cfr@pobox.comE<gt>), Mike Guy +(E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop (E<lt>domo@computer.orgE<gt>) +and Hugo van der Sanden (E<lt>hv@crypt0.demon.co.ukE<gt>). =head1 SEE ALSO diff --git a/vms/descrip.mms b/vms/descrip.mms index a7fbf3d1bf..eb1a5a34e5 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) @@ -196,7 +196,7 @@ prime_env_iter(void) # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */ #endif unsigned long int flags = CLI$M_NOWAIT | CLI$M_NOCLISYM | CLI$M_NOKEYPAD | CLI$M_TRUSTED; - unsigned long int retsts, substs = 0, wakect = 0; + unsigned long int i, retsts, substs = 0, wakect = 0; STRLEN eqvlen; SV *oldrs, *linesv, *eqvsv; $DESCRIPTOR(cmddsc,"Show Logical *"); $DESCRIPTOR(nldsc,"_NLA0:"); @@ -212,12 +212,18 @@ prime_env_iter(void) /* Perform a dummy fetch as an lval to insure that the hash table is * set up. Otherwise, the hv_store() will turn into a nullop. */ (void) hv_fetch(envhv,"DEFAULT",7,TRUE); - /* Also, set up the four "special" keys that the CRTL defines, - * whether or not underlying logical names exist. */ - (void) hv_fetch(envhv,"HOME",4,TRUE); - (void) hv_fetch(envhv,"TERM",4,TRUE); - (void) hv_fetch(envhv,"PATH",4,TRUE); - (void) hv_fetch(envhv,"USER",4,TRUE); + /* Also, set up any "special" keys that the CRTL defines, + * either by itself or becasue we were called from a C program + * using exec[lv]e() */ + for (i = 0; environ[i]; i++) { + if (!(start = strchr(environ[i],'='))) { + warn("Ill-formed CRTL environ value \"%s\"\n",environ[i]); + } + else { + start++; + (void) hv_store(envhv,environ[i],start - environ[i] - 1,newSVpv(start,0),0); + } + } /* Now, go get the logical names */ create_mbx(&chan,&mbxdsc); diff --git a/win32/Makefile b/win32/Makefile index 4a518fbbd7..d860a3c1a7 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -25,12 +25,14 @@ INST_TOP = $(INST_DRV)\perl5004.5x # # if you have the source for des_fcrypt(), uncomment this and make sure the -# file exists (see README.win32) +# file exists (see README.win32). File should be located at the perl +# top level directory. #CRYPT_SRC = des_fcrypt.c # # if you didn't set CRYPT_SRC and if you have des_fcrypt() available in a # library, uncomment this, and make sure the library exists (see README.win32) +# Specify the full pathname of the library. #CRYPT_LIB = des_fcrypt.lib # @@ -254,7 +256,9 @@ CORE_SRC = \ ..\universal.c \ ..\util.c -CORE_SRC = $(CORE_SRC) $(CRYPT_SRC) +!IF "$(CRYPT_SRC)" != "" +CORE_SRC = $(CORE_SRC) ..\$(CRYPT_SRC) +!ENDIF !IF "$(PERL_MALLOC)" == "define" CORE_SRC = $(CORE_SRC) ..\malloc.c @@ -277,6 +281,10 @@ PERL95_SRC = \ win32mt.c \ win32sckmt.c +!IF "$(CRYPT_SRC)" != "" +PERL95_SRC = $(PERL95_SRC) ..\$(CRYPT_SRC) +!ENDIF + DLL_SRC = $(DYNALOADER).c @@ -550,6 +558,9 @@ $(PERL95EXE): $(PERLDLL) $(CONFIGPM) $(PERL95_OBJ) $(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM) if not exist $(AUTODIR) mkdir $(AUTODIR) + cd $(EXTDIR)\$(*B) + ..\$(MINIPERL) -I..\..\lib $(*B).pm.PL + cd ..\..\win32 $(XCOPY) $(EXTDIR)\$(*B)\$(*B).pm $(LIBDIR)\$(NULL) cd $(EXTDIR)\$(*B) $(XSUBPP) dl_win32.xs > $(*B).c diff --git a/win32/makefile.mk b/win32/makefile.mk index 17dda74c73..e77713ce68 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -32,12 +32,14 @@ CCTYPE *= BORLAND # # if you have the source for des_fcrypt(), uncomment this and make sure the -# file exists (see README.win32) +# file exists (see README.win32). File should be located at the perl +# top level directory. #CRYPT_SRC *= des_fcrypt.c # # if you didn't set CRYPT_SRC and if you have des_fcrypt() available in a # library, uncomment this, and make sure the library exists (see README.win32) +# Specify the full pathname of the library. #CRYPT_LIB *= des_fcrypt.lib # @@ -362,7 +364,9 @@ CORE_SRC = \ ..\universal.c \ ..\util.c -CORE_SRC += $(CRYPT_SRC) +.IF "$(CRYPT_SRC)" != "" +CORE_SRC += ..\$(CRYPT_SRC) +.ENDIF .IF "$(PERL_MALLOC)" == "define" CORE_SRC += ..\malloc.c @@ -385,6 +389,10 @@ PERL95_SRC = \ win32mt.c \ win32sckmt.c +.IF "$(CRYPT_SRC)" != "" +PERL95_SRC += ..\$(CRYPT_SRC) +.ENDIF + DLL_SRC = $(DYNALOADER).c @@ -727,6 +735,7 @@ $(PERL95EXE): $(PERLDLL) $(CONFIGPM) $(PERL95_OBJ) $(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM) if not exist $(AUTODIR) mkdir $(AUTODIR) + cd $(EXTDIR)\$(*B) && ..\$(MINIPERL) -I..\..\lib $(*B).pm.PL $(XCOPY) $(EXTDIR)\$(*B)\$(*B).pm $(LIBDIR)\$(NULL) cd $(EXTDIR)\$(*B) && $(XSUBPP) dl_win32.xs > $(*B).c $(XCOPY) $(EXTDIR)\$(*B)\dlutils.c . diff --git a/x2p/find2perl.PL b/x2p/find2perl.PL index c23fc923a8..ea13c710f9 100644 --- a/x2p/find2perl.PL +++ b/x2p/find2perl.PL @@ -26,7 +26,7 @@ print "Extracting $file (with variable substitutions)\n"; print OUT <<"!GROK!THIS!"; $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' - if \$running_under_some_shell; + if \$running_under_some_shell; \$startperl = "$Config{startperl}"; \$perlpath = "$Config{perlpath}"; !GROK!THIS! @@ -34,10 +34,16 @@ $Config{startperl} # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; + # # Modified September 26, 1993 to provide proper handling of years after 1999 # Tom Link <tml+@pitt.edu> # University of Pittsburgh +# +# Modified April 7, 1998 with nasty hacks to implement the troublesome -follow +# Billy Constantine <wdconsta@cs.adelaide.edu.au> <billy@smug.adelaide.edu.au> +# University of Adelaide, Adelaide, South Australia +# while ($ARGV[0] =~ /^[^-!(]/) { push(@roots, shift); @@ -47,6 +53,8 @@ for (@roots) { $_ = "e($_); } $roots = join(',', @roots); $indent = 1; +$stat = 'lstat'; +$decl = ''; while (@ARGV) { $_ = shift; @@ -60,6 +68,12 @@ while (@ARGV) { $indent--; $out .= &tab . ")"; } + elsif ($_ eq 'follow') { + $stat = 'stat'; + $decl = '%already_seen = ();'; + $out .= &tab . '(not $already_seen{"$dev,$ino"}) &&'; + $out .= "\n" . &tab . '(($already_seen{"$dev,$ino"} = !(-d _)) || 1)'; + } elsif ($_ eq '!') { $out .= &tab . "!"; next; @@ -178,7 +192,7 @@ while (@ARGV) { $file = shift; $newername = 'AGE_OF' . $file; $newername =~ s/[^\w]/_/g; - $newername = '$' . $newername; + $newername = "\$$newername"; $out .= "(-M _ < $newername)"; $initnewer .= "$newername = -M " . "e($file) . ";\n"; } @@ -278,10 +292,10 @@ require "$find.pl"; # Traverse desired filesystems +$decl &$find($roots); $flushall exit; - sub wanted { $out; } @@ -312,10 +326,11 @@ END } if ($initls) { - print <<'END'; + print <<"INTERP", <<'END'; sub ls { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm, - $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_); + (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$sizemm, + \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\); +INTERP $pname = $name; @@ -380,7 +395,7 @@ END } if ($initcpio) { -print <<'END'; +print <<'START', <<"INTERP", <<'END'; sub cpio { local($nc,$fh) = @_; local($text); @@ -390,8 +405,10 @@ sub cpio { $size = 0; } else { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_); +START + (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$size, + \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\); +INTERP if (-f _) { open(IN, "./$_\0") || do { warn "Couldn't open $name: $!\n"; @@ -465,14 +482,16 @@ END } if ($inittar) { -print <<'END'; +print <<'START', <<"INTERP", <<'END'; sub tar { local($fh) = @_; local($linkname,$header,$l,$slop); local($linkflag) = "\0"; - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_); +START + (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$size, + \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\); +INTERP $nm = $name; if ($nlink > 1) { if ($linkname = $linkseen{$fh,$dev,$ino}) { @@ -561,13 +580,13 @@ sub tab { } else { if ($saw_or) { - $tabstring .= <<'ENDOFSTAT' . $tabstring; -($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && + $tabstring .= <<"ENDOFSTAT" . $tabstring; +(\$nlink || ((\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid) = $stat\(\$_\))) && ENDOFSTAT } else { - $tabstring .= <<'ENDOFSTAT' . $tabstring; -(($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && + $tabstring .= <<"ENDOFSTAT" . $tabstring; +((\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid) = $stat\(\$_\)) && ENDOFSTAT } $statdone = 1; |