# This is a patch for perl5.004_01 to bring it up to perl5.004_01_02. # To apply this patch, chdir to you perl5.004_01 source directory and enter # # /bin/sh # patch -p1 -N < touch win32/bin/runperl.bat exit Index: perl5.004_01_02/patchlevel.h *** perl5.004_01/patchlevel.h Wed Jun 11 03:06:10 1997 --- perl5.004_01_02/patchlevel.h Thu Jul 31 22:55:52 1997 *************** *** 38,43 **** --- 38,44 ---- */ static char *local_patches[] = { NULL + ,"MAINT_TRIAL_2 - Maintenance release trial 2" ,NULL }; Index: perl5.004_01_02/Configure Prereq: 3.0.1.8 *** perl5.004_01/Configure Wed Jun 11 00:28:03 1997 --- perl5.004_01_02/Configure Fri Aug 1 00:20:50 1997 *************** *** 739,745 **** loclibpth="$loclibpth /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib" : general looking path for locating libraries ! glibpth="/shlib /usr/shlib /lib/pa1.1 /usr/lib/large" glibpth="$glibpth /lib /usr/lib $xlibpth" glibpth="$glibpth /lib/large /usr/lib/small /lib/small" glibpth="$glibpth /usr/ccs/lib /usr/ucblib /usr/local/lib" --- 739,745 ---- loclibpth="$loclibpth /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib" : general looking path for locating libraries ! glibpth="/shlib /usr/shlib /usr/lib/pa1.1 /usr/lib/large" glibpth="$glibpth /lib /usr/lib $xlibpth" glibpth="$glibpth /lib/large /usr/lib/small /lib/small" glibpth="$glibpth /usr/ccs/lib /usr/ucblib /usr/local/lib" *************** *** 1780,1785 **** --- 1780,1789 ---- bsd386) osname=bsd386 osvers=`$uname -r` ;; + powerux | power_ux | powermax_os | powermaxos | \ + powerunix | power_unix) osname=powerux + osvers="$3" + ;; next*) osname=next ;; solaris) osname=solaris case "$3" in *************** *** 6377,6383 **** EOCP : check sys/file.h first to get FREAD on Sun if $test `./findhdr sys/file.h` && \ ! $cc $cppflags "-DI_SYS_FILE" open3.c -o open3 >/dev/null 2>&1 ; then h_sysfile=true; echo " defines the O_* constants..." >&4 if ./open3; then --- 6381,6387 ---- EOCP : check sys/file.h first to get FREAD on Sun if $test `./findhdr sys/file.h` && \ ! $cc $ccflags "-DI_SYS_FILE" -o open3 $ldflags open3.c $libs ; then h_sysfile=true; echo " defines the O_* constants..." >&4 if ./open3; then *************** *** 6388,6394 **** val="$undef" fi elif $test `./findhdr fcntl.h` && \ ! $cc "-DI_FCNTL" open3.c -o open3 >/dev/null 2>&1 ; then h_fcntl=true; echo " defines the O_* constants..." >&4 if ./open3; then --- 6392,6398 ---- val="$undef" fi elif $test `./findhdr fcntl.h` && \ ! $cc $ccflags "-DI_FCNTL" -o open3 $ldflags open3.c $libs ; then h_fcntl=true; echo " defines the O_* constants..." >&4 if ./open3; then Index: perl5.004_01_02/INSTALL Prereq: 1.18 *** perl5.004_01/INSTALL Wed Jun 11 02:09:17 1997 --- perl5.004_01_02/INSTALL Thu Jul 31 23:43:20 1997 *************** *** 123,128 **** --- 123,132 ---- then Configure will suggest /opt/perl/lib instead of /opt/perl/lib/perl5/. + NOTE: You must not specify an installation directory that is below + your perl source directory. If you do, installperl will attempt + infinite recursion. + By default, Configure will compile perl to use dynamic loading if your system supports it. If you want to force perl to be compiled statically, you can either choose this when Configure prompts you or *************** *** 661,680 **** =over 4 ! =item -DDEBUGGING_MSTATS ! ! If DEBUGGING_MSTATS is defined, you can extract malloc ! statistics from the Perl interpreter. The overhead this imposes is not ! large (perl just twiddles integers at malloc/free/sbrk time). When you ! run perl with the environment variable PERL_DEBUG_MSTATS set to ! either 1 or 2, the interpreter will dump statistics to stderr at exit ! time and (with a value of 2) after compilation. If you install the ! Devel::Peek module you can get the statistics whenever you like by ! invoking its mstat() function. ! ! =item -DEMERGENCY_SBRK ! If EMERGENCY_SBRK is defined, running out of memory need not be a fatal error: a memory pool can allocated by assigning to the special variable $^M. See perlvar(1) for more details. --- 665,673 ---- =over 4 ! =item -DPERL_EMERGENCY_SBRK ! If PERL_EMERGENCY_SBRK is defined, running out of memory need not be a fatal error: a memory pool can allocated by assigning to the special variable $^M. See perlvar(1) for more details. *************** *** 1145,1154 **** =head1 make test ! This will run the regression tests on the perl you just made. If it ! doesn't say "All tests successful" then something went wrong. See the ! file t/README in the t subdirectory. Note that you can't run the ! tests in background if this disables opening of /dev/tty. If make test bombs out, just cd to the t directory and run ./TEST by hand to see if it makes any difference. If individual tests --- 1138,1151 ---- =head1 make test ! This will run the regression tests on the perl you just made (you ! should run plain 'make' before 'make test' otherwise you won't have a ! complete build). If 'make test' doesn't say "All tests successful" ! then something went wrong. See the file t/README in the t subdirectory. ! ! If you want to run make test in the background you should ! Note that you can't run the tests in background if this disables ! opening of /dev/tty. If make test bombs out, just cd to the t directory and run ./TEST by hand to see if it makes any difference. If individual tests *************** *** 1410,1413 **** =head1 LAST MODIFIED ! $Id: INSTALL,v 1.18 1997/05/29 18:24:10 doughera Exp $ --- 1407,1410 ---- =head1 LAST MODIFIED ! $Id: INSTALL,v 1.21.1.1 1997/07/31 21:48:38 timbo Released $ Index: perl5.004_01_02/MANIFEST *** perl5.004_01/MANIFEST Thu Jun 12 21:32:45 1997 --- perl5.004_01_02/MANIFEST Tue Jul 29 01:01:17 1997 *************** *** 819,825 **** win32/TEST Win32 port win32/autosplit.pl Win32 port win32/bin/network.pl Win32 port ! win32/bin/pl2bat.bat Win32 port win32/bin/search.bat Win32 port win32/bin/test.bat Win32 port win32/bin/webget.bat Win32 port --- 819,826 ---- win32/TEST Win32 port win32/autosplit.pl Win32 port win32/bin/network.pl Win32 port ! win32/bin/pl2bat.bat wrap perl scripts into batch files ! win32/bin/runperl.bat run perl script via batch file namesake win32/bin/search.bat Win32 port win32/bin/test.bat Win32 port win32/bin/webget.bat Win32 port Index: perl5.004_01_02/Makefile.SH *** perl5.004_01/Makefile.SH Thu Jun 12 23:27:56 1997 --- perl5.004_01_02/Makefile.SH Thu Jul 31 23:11:41 1997 *************** *** 359,367 **** install.man: all installman ./perl installman ! # Not implemented yet. ! #install.html: all installhtml ! # ./perl installhtml # I now supply perly.c with the kits, so the following section is # used only if you force byacc to run by saying --- 359,376 ---- install.man: all installman ./perl installman ! # XXX Experimental. Hardwired values, but useful for testing. ! # Eventually Configure could ask for some of these values. ! install.html: all installhtml ! ./installhtml \ ! --podroot=. --podpath=. --recurse \ ! --htmldir=$(privlib)/html \ ! --htmlroot=$(privlib)/html \ ! --splithead=pod/perlipc \ ! --splititem=pod/perlfunc \ ! --libpods=perlfunc:perlguts:perlvar:perlrun:perlop \ ! --verbose ! # I now supply perly.c with the kits, so the following section is # used only if you force byacc to run by saying Index: perl5.004_01_02/Porting/patchls Prereq: 1.3 *** perl5.004_01/Porting/patchls Wed Jun 11 21:18:59 1997 --- perl5.004_01_02/Porting/patchls Thu Jul 31 19:48:43 1997 *************** *** 18,25 **** use strict; sub usage { ! die qq{ ! patchls [options] patchfile [ ... ] -i Invert: for each patched file list which patch files patch it --- 18,24 ---- use strict; sub usage { ! die q{ patchls [options] patchfile [ ... ] -i Invert: for each patched file list which patch files patch it *************** *** 29,35 **** -m print formatted Meta-information (Subject,From,Msg-ID etc) -p N strip N levels of directory Prefix (like patch), else automatic -v more verbose (-d for noisy debugging) ! } } --- 28,35 ---- -m print formatted Meta-information (Subject,From,Msg-ID etc) -p N strip N levels of directory Prefix (like patch), else automatic -v more verbose (-d for noisy debugging) ! -f F only list patches which patch files matching regexp F ! (F has $ appended unless it contains a /). } } *************** *** 43,52 **** $::opt_h = 0; $::opt_l = 0; $::opt_c = 0; usage unless @ARGV; ! getopts("mihlvcp:") or usage; my %cat_title = ( 'TEST' => 'TESTS', --- 43,53 ---- $::opt_h = 0; $::opt_l = 0; $::opt_c = 0; + $::opt_f = ''; usage unless @ARGV; ! getopts("mihlvcp:f:") or usage; my %cat_title = ( 'TEST' => 'TESTS', *************** *** 141,146 **** --- 142,160 ---- $a->{category} cmp $b->{category} || $a->{in} cmp $b->{in} } values %ls; + if ($::opt_f) { + my $out; + $::opt_f .= '$' unless $::opt_f =~ m:/:; + @ls = grep { + my @out = keys %{$_->{out}}; + my $match = 0; + for $out (@out) { + ++$match if $out =~ m/$::opt_f/o; + } + $match; + } @ls; + } + unless ($::opt_c and $::opt_m) { foreach $ls (@ls) { next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in}; *************** *** 194,199 **** --- 208,215 ---- sub trim_name { # reduce/tidy file paths from diff lines my $name = shift; $name = "$name ($in)" if $name eq "/dev/null"; + $name =~ s:\\:/:g; # adjust windows paths + $name =~ s://:/:g; # simplify (and make win \\share into absolute path) if (defined $::opt_p) { # strip on -p levels of directory prefix my $dc = $::opt_p; *************** *** 202,208 **** else { # try to strip off leading path to perl directory # if absolute path, strip down to any *perl* directory first $name =~ s:^/.*?perl.*?/::i; ! $name =~ s:.*perl[-_]?5\.[-_a-z0-9.]+/::i; $name =~ s:^\./::; } return $name; --- 218,224 ---- else { # try to strip off leading path to perl directory # if absolute path, strip down to any *perl* directory first $name =~ s:^/.*?perl.*?/::i; ! $name =~ s:.*perl[-_]?5?[._]?[-_a-z0-9.+]*/::i; $name =~ s:^\./::; } return $name; *************** *** 239,245 **** sub my_wrap { ! return expand(wrap(@_)); } --- 255,263 ---- sub my_wrap { ! my $txt = eval { expand(wrap(@_)) }; # die's on long lines! ! return $txt unless $@; ! return expand("@_"); } Index: perl5.004_01_02/README.os2 *** perl5.004_01/README.os2 Thu May 8 18:31:34 1997 --- perl5.004_01_02/README.os2 Tue Jul 29 01:44:50 1997 *************** *** 1082,1089 **** =item ! Since L is present in EMX, but is not functional, the same is ! true for perl. Here is the list of things which may be "broken" on EMX (from EMX docs): =over --- 1082,1094 ---- =item ! Since L is present in EMX, but is not functional, it is ! emulated by perl. To disable the emulations, set environment variable ! C. ! ! =item ! ! Here is the list of things which may be "broken" on EMX (from EMX docs): =over *************** *** 1099,1105 **** =item * ! L is not yet implemented (dummy function). =item * --- 1104,1110 ---- =item * ! L is not yet implemented (dummy function). (Perl has a workaround.) =item * *************** *** 1155,1160 **** --- 1160,1171 ---- C special-cases F and F. + =item C + + Since L is present in EMX, but is not functional, it is + emulated by perl. To disable the emulations, set environment variable + C. + =back =head1 Perl flavors *************** *** 1333,1338 **** --- 1344,1355 ---- Specific for EMX port. Gives the directory part of the location for F. + + =head2 C + + Specific for EMX port. Since L is present in EMX, but is not + functional, it is emulated by perl. To disable the emulations, set + environment variable C. =head2 C or C Index: perl5.004_01_02/README.win32 *** perl5.004_01/README.win32 Wed Jun 11 23:15:58 1997 --- perl5.004_01_02/README.win32 Tue Jul 29 01:02:36 1997 *************** *** 24,30 **** was extracted. Make sure you read and understand the terms under which this software is being distributed. ! Also make sure you read the L section below for the known limitations of this port. The INSTALL file in the perl top-level has much information that is --- 24,30 ---- was extracted. Make sure you read and understand the terms under which this software is being distributed. ! Also make sure you read L below for the known limitations of this port. The INSTALL file in the perl top-level has much information that is *************** *** 142,147 **** --- 142,151 ---- extension dll's under the lib\auto directory. If the build fails for any reason, make sure you have done the previous steps correctly. + The build process may produce "harmless" compiler warnings (more or + less copiously, depending on how picky your compiler gets). The + maintainers are aware of these warnings, thankyouverymuch. :) + When building using Visual C++, a perl95.exe will also get built. This executable is only needed on Windows95, and should be used instead of perl.exe, and then only if you want sockets to work properly on Windows95. *************** *** 290,296 **** perl -e "print 'foo'; print STDERR 'bar'" 2> blurch | less ! Discovering the usage of the "command.com" shell on Windows95 is left as an exercise to the reader :) =item Building Extensions --- 294,300 ---- perl -e "print 'foo'; print STDERR 'bar'" 2> blurch | less ! Discovering the usefulness of the "command.com" shell on Windows95 is left as an exercise to the reader :) =item Building Extensions *************** *** 337,343 **** CPAN in source form, along with many added bugfixes, and with MakeMaker support. This bundle is available at: ! http://www.perl.com/CPAN/authors/id/GSAR/libwin32-0.06.tar.gz See the README in that distribution for building and installation instructions. Look for later versions that may be available at the --- 341,347 ---- CPAN in source form, along with many added bugfixes, and with MakeMaker support. This bundle is available at: ! http://www.perl.com/CPAN/authors/id/GSAR/libwin32-0.08.tar.gz See the README in that distribution for building and installation instructions. Look for later versions that may be available at the *************** *** 348,353 **** --- 352,427 ---- the 5.004 release of perl, at which point the need for a dedicated bundle such as the above should diminish. + =item Running Perl Scripts + + Perl scripts on UNIX use the "#!" (a.k.a "shebang") line to + indicate to the OS that it should execute the file using perl. + Win32 has no comparable means to indicate arbitrary files are + executables. + + Instead, all available methods to execute plain text files on + Win32 rely on the file "extension". There are three methods + to use this to execute perl scripts: + + =over 8 + + =item 1 + + There is a facility called "file extension associations" that will + work in Windows NT 4.0. This can be manipulated via the two + commands "assoc" and "ftype" that come standard with Windows NT + 4.0. Type "ftype /?" for a complete example of how to set this + up for perl scripts (Say what? You thought Windows NT wasn't + perl-ready? :). + + =item 2 + + Since file associations don't work everywhere, and there are + reportedly bugs with file associations where it does work, the + old method of wrapping the perl script to make it look like a + regular batch file to the OS, may be used. The install process + makes available the "pl2bat.bat" script which can be used to wrap + perl scripts into batch files. For example: + + pl2bat foo.pl + + will create the file "FOO.BAT". Note "pl2bat" strips any + .pl suffix and adds a .bat suffix to the generated file. + + If you use the 4DOS/NT or similar command shell, note that + "pl2bat" uses the "%*" variable in the generated batch file to + refer to all the command line arguments, so you may need to make + sure that construct works in batch files. As of this writing, + 4DOS/NT users will need a "ParameterChar = *" statement in their + 4NT.INI file, or will need to execute "setdos /p*" in the 4DOS/NT + startup file to enable this to work. + + =item 3 + + Using "pl2bat" has a few problems: the file name gets changed, + so scripts that rely on C<$0> to find what they must do may not + run properly; running "pl2bat" replicates the contents of the + original script, and so this process can be maintenance intensive + if the originals get updated often. A different approach that + avoids both problems is possible. + + A script called "runperl.bat" is available that can be copied + to any filename (along with the .bat suffix). For example, + if you call it "foo.bat", it will run the file "foo" when it is + executed. Since you can run batch files on Win32 platforms simply + by typing the name (without the extension), this effectively + runs the file "foo", when you type either "foo" or "foo.bat". + With this method, "foo.bat" can even be in a different location + than the file "foo", as long as "foo" is available somewhere on + the PATH. If your scripts are on a filesystem that allows symbolic + links, you can even avoid copying "runperl.bat". + + Here's a diversion: copy "runperl.bat" to "runperl", and type + "runperl". Explain the observed behavior, or lack thereof. :) + Hint: .gnidnats llits er'uoy fi ,"lrepnur" eteled :tniH + + =back + =item Miscellaneous Things A full set of HTML documentation is installed, so you should be *************** *** 374,391 **** changes in any of these areas: build process, installation structure, supported utilities/modules, and supported perl functionality. In particular, functionality specific to the Win32 environment may ! ultimately be supported as either core modules or extensions. This ! means that you should be prepared to recompile extensions when binary ! incompatibilites arise due to changes in the internal structure of ! the code. ! ! The DLLs produced by the two supported compilers are incompatible ! with each other due to the conventions they use to export symbols, ! and due to differences in the Runtime libraries that they provide. ! This means that extension binaries built under either compiler will ! only work with the perl binaries built under the same compiler. ! If you know of a robust, freely available C Runtime that can ! be used under win32, let us know. If you have had prior exposure to Perl on Unix platforms, you will notice this port exhibits behavior different from what is documented. Most of the --- 448,467 ---- changes in any of these areas: build process, installation structure, supported utilities/modules, and supported perl functionality. In particular, functionality specific to the Win32 environment may ! ultimately be supported as either core modules or extensions. The ! beta status implies, among other things, that you should be prepared ! to recompile extensions when binary incompatibilites arise due to ! changes in the internal structure of the code. ! ! An effort has been made to ensure that the DLLs produced by the two ! supported compilers are compatible with each other (despite the ! best efforts of the compiler vendors). Extension binaries produced ! by one compiler should also coexist with a perl binary built by ! a different compiler. In order to accomplish this, PERL.DLL provides ! a layer of runtime code that uses the C Runtime that perl was compiled ! with. Extensions which include "perl.h" will transparently access ! the functions in this layer, thereby ensuring that both perl and ! extensions use the same runtime functions. If you have had prior exposure to Perl on Unix platforms, you will notice this port exhibits behavior different from what is documented. Most of the *************** *** 404,416 **** =item * ! The following functions are currently unavailable: C, C, C, C, C, C, C, C, C, C, C, C, C. This list is possibly very incomplete. =item * Various C related calls are supported, but they may not behave as on Unix platforms. --- 480,498 ---- =item * ! The following functions are currently unavailable: C, C, C, C, C, C, C, C, C, C, C, C. This list is possibly very incomplete. =item * + crypt() is not available due to silly export restrictions. It may + become available when the laws change. Meanwhile, look in CPAN for + extensions that provide it. + + =item * + Various C related calls are supported, but they may not behave as on Unix platforms. *************** *** 440,446 **** =item * Signal handling may not behave as on Unix platforms (where it ! doesn't exactly "behave", either :). =item * --- 522,533 ---- =item * Signal handling may not behave as on Unix platforms (where it ! doesn't exactly "behave", either :). For instance, calling C ! or C from signal handlers will cause an exception, since most ! implementations of C on Win32 are severely crippled. ! Thus, signals may work only for simple things like setting a flag ! variable in the handler. Using signals under this port should ! currently be considered unsupported. =item * *************** *** 473,478 **** --- 560,567 ---- =back + This document is maintained by Gurusamy Sarathy. + =head1 SEE ALSO L *************** *** 488,494 **** Borland support was added in 5.004_01 (Gurusamy Sarathy). ! Last updated: 11 June 1997 =cut --- 577,583 ---- Borland support was added in 5.004_01 (Gurusamy Sarathy). ! Last updated: 25 July 1997 =cut Index: perl5.004_01_02/Todo *** perl5.004_01/Todo Wed Feb 12 19:45:24 1997 --- perl5.004_01_02/Todo Thu Jul 31 21:43:18 1997 *************** *** 47,53 **** ref function in list context data prettyprint function? (or is it, as I suspect, a lib routine?) make tr/// return histogram in list context? - undef wantarray in void context Loop control on do{} et al Explicit switch statements built-in globbing --- 47,52 ---- Index: perl5.004_01_02/XSUB.h *** perl5.004_01/XSUB.h Mon Apr 28 19:52:56 1997 --- perl5.004_01_02/XSUB.h Tue Jul 29 01:37:31 1997 *************** *** 44,56 **** Sv = ST(1); \ else { \ /* XXX GV_ADDWARN */ \ ! Sv = perl_get_sv(vn = form("%s::XS_VERSION", module), FALSE); \ if (!Sv || !SvOK(Sv)) \ ! Sv = perl_get_sv(vn = form("%s::VERSION", module), FALSE); \ } \ if (Sv && (!SvOK(Sv) || strNE(XS_VERSION, SvPV(Sv, na)))) \ ! croak("%s object version %s does not match $%s %_", \ ! module, XS_VERSION, vn, Sv); \ } STMT_END #else # define XS_VERSION_BOOTCHECK --- 44,58 ---- Sv = ST(1); \ else { \ /* XXX GV_ADDWARN */ \ ! Sv = perl_get_sv(form("%s::%s", module, \ ! vn = "XS_VERSION"), FALSE); \ if (!Sv || !SvOK(Sv)) \ ! Sv = perl_get_sv(form("%s::%s", module, \ ! vn = "VERSION"), FALSE); \ } \ if (Sv && (!SvOK(Sv) || strNE(XS_VERSION, SvPV(Sv, na)))) \ ! croak("%s object version %s does not match $%s::%s %_", \ ! module, XS_VERSION, module, vn, Sv); \ } STMT_END #else # define XS_VERSION_BOOTCHECK Index: perl5.004_01_02/av.c *** perl5.004_01/av.c Fri Mar 7 06:10:31 1997 --- perl5.004_01_02/av.c Mon Jul 28 23:55:36 1997 *************** *** 253,269 **** av = (AV*)NEWSV(8,0); sv_upgrade((SV *) av,SVt_PVAV); - New(4,ary,size+1,SV*); - AvALLOC(av) = ary; AvFLAGS(av) = AVf_REAL; ! SvPVX(av) = (char*)ary; ! AvFILL(av) = size - 1; ! AvMAX(av) = size - 1; ! for (i = 0; i < size; i++) { ! assert (*strp); ! ary[i] = NEWSV(7,0); ! sv_setsv(ary[i], *strp); ! strp++; } return av; } --- 253,271 ---- av = (AV*)NEWSV(8,0); sv_upgrade((SV *) av,SVt_PVAV); AvFLAGS(av) = AVf_REAL; ! if (size) { /* `defined' was returning undef for size==0 anyway. */ ! New(4,ary,size,SV*); ! AvALLOC(av) = ary; ! SvPVX(av) = (char*)ary; ! AvFILL(av) = size - 1; ! AvMAX(av) = size - 1; ! for (i = 0; i < size; i++) { ! assert (*strp); ! ary[i] = NEWSV(7,0); ! sv_setsv(ary[i], *strp); ! strp++; ! } } return av; } Index: perl5.004_01_02/configpm *** perl5.004_01/configpm Sat Mar 29 23:36:23 1997 --- perl5.004_01_02/configpm Thu Jul 31 20:50:34 1997 *************** *** 79,85 **** sub myconfig { return $summary if $summary_expanded; ! $summary =~ s/\$(\w+)/$Config{$1}/ge; $summary_expanded = 1; $summary; } --- 79,86 ---- sub myconfig { return $summary if $summary_expanded; ! $summary =~ s{\$(\w+)} ! { my $c = $Config{$1}; defined($c) ? $c : 'undef' }ge; $summary_expanded = 1; $summary; } Index: perl5.004_01_02/doio.c *** perl5.004_01/doio.c Wed Jun 11 04:50:24 1997 --- perl5.004_01_02/doio.c Tue Jul 29 02:08:11 1997 *************** *** 942,948 **** } } ! #ifndef OS2 bool do_exec(cmd) --- 942,948 ---- } } ! #if !defined(OS2) && !defined(WIN32) bool do_exec(cmd) *************** *** 1033,1039 **** return FALSE; } ! #endif /* OS2 */ I32 apply(type,mark,sp) --- 1033,1039 ---- return FALSE; } ! #endif /* OS2 || WIN32 */ I32 apply(type,mark,sp) *************** *** 1364,1392 **** infosize = sizeof(struct semid_ds); else if (cmd == GETALL || cmd == SETALL) { #ifdef __linux__ /* XXX Need metaconfig test */ ! /* linux uses : ! int semctl (int semid, int semnun, int cmd, union semun arg) ! union semun { int val; struct semid_ds *buf; ushort *array; }; */ ! union semun semds; ! if (semctl(id, 0, IPC_STAT, semds) == -1) #else - struct semid_ds semds; if (semctl(id, 0, IPC_STAT, &semds) == -1) #endif return -1; getinfo = (cmd == GETALL); - #ifdef __linux__ /* XXX Need metaconfig test */ - infosize = semds.buf->sem_nsems * sizeof(short); - #else infosize = semds.sem_nsems * sizeof(short); - #endif /* "short" is technically wrong but much more portable than guessing about u_?short(_t)? */ } --- 1364,1388 ---- infosize = sizeof(struct semid_ds); else if (cmd == GETALL || cmd == SETALL) { + struct semid_ds semds; #ifdef __linux__ /* XXX Need metaconfig test */ ! /* linux (and Solaris2?) uses : ! int semctl (int semid, int semnum, int cmd, union semun arg) union semun { int val; struct semid_ds *buf; ushort *array; }; */ ! union semun semun; ! semun.buf = &semds; ! if (semctl(id, 0, IPC_STAT, semun) == -1) #else if (semctl(id, 0, IPC_STAT, &semds) == -1) #endif return -1; getinfo = (cmd == GETALL); infosize = semds.sem_nsems * sizeof(short); /* "short" is technically wrong but much more portable than guessing about u_?short(_t)? */ } Index: perl5.004_01_02/dosish.h *** perl5.004_01/dosish.h Mon Apr 14 03:23:55 1997 --- perl5.004_01_02/dosish.h Thu Jul 31 18:38:06 1997 *************** *** 11,20 **** # define PERL_SYS_INIT(argcp, argvp) STMT_START { \ Perl_DJGPP_init(); } STMT_END #else /* DJGPP */ - # define PERL_SYS_INIT(c,v) # ifdef WIN32 # define BIT_BUCKET "nul" # else # define BIT_BUCKET "\\dev\\nul" /* "wanna be like, umm, Newlined, or somethin?" */ # endif #endif /* DJGPP */ --- 11,21 ---- # define PERL_SYS_INIT(argcp, argvp) STMT_START { \ Perl_DJGPP_init(); } STMT_END #else /* DJGPP */ # ifdef WIN32 + # define PERL_SYS_INIT(c,v) Perl_win32_init(c,v) # define BIT_BUCKET "nul" # else + # define PERL_SYS_INIT(c,v) # define BIT_BUCKET "\\dev\\nul" /* "wanna be like, umm, Newlined, or somethin?" */ # endif #endif /* DJGPP */ Index: perl5.004_01_02/embed.h *** perl5.004_01/embed.h Tue Jun 10 01:48:57 1997 --- perl5.004_01_02/embed.h Tue Jul 29 01:33:25 1997 *************** *** 307,314 **** #define lshift_amg Perl_lshift_amg #define lshift_ass_amg Perl_lshift_ass_amg #define lt_amg Perl_lt_amg - #define magic_clearenv Perl_magic_clearenv #define magic_clear_all_env Perl_magic_clear_all_env #define magic_clearpack Perl_magic_clearpack #define magic_clearsig Perl_magic_clearsig #define magic_existspack Perl_magic_existspack --- 307,314 ---- #define lshift_amg Perl_lshift_amg #define lshift_ass_amg Perl_lshift_ass_amg #define lt_amg Perl_lt_amg #define magic_clear_all_env Perl_magic_clear_all_env + #define magic_clearenv Perl_magic_clearenv #define magic_clearpack Perl_magic_clearpack #define magic_clearsig Perl_magic_clearsig #define magic_existspack Perl_magic_existspack *************** *** 1046,1051 **** --- 1046,1052 ---- #define sv_setptrobj Perl_sv_setptrobj #define sv_setpv Perl_sv_setpv #define sv_setpvf Perl_sv_setpvf + #define sv_setpviv Perl_sv_setpviv #define sv_setpvn Perl_sv_setpvn #define sv_setref_iv Perl_sv_setref_iv #define sv_setref_nv Perl_sv_setref_nv Index: perl5.004_01_02/ext/DB_File/DB_File.pm *** perl5.004_01/ext/DB_File/DB_File.pm Thu May 1 02:24:48 1997 --- perl5.004_01_02/ext/DB_File/DB_File.pm Thu Jul 31 20:54:11 1997 *************** *** 1,8 **** # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (pmarquess@bfsec.bt.co.uk) ! # last modified 30th Apr 1997 ! # version 1.14 # # Copyright (c) 1995, 1996, 1997 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or --- 1,8 ---- # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (pmarquess@bfsec.bt.co.uk) ! # last modified 29th Jun 1997 ! # version 1.15 # # Copyright (c) 1995, 1996, 1997 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or *************** *** 98,104 **** croak ref($self) . " does not define the method ${method}" ; } - sub DESTROY { undef %{$_[0]} } sub FIRSTKEY { my $self = shift ; $self->NotHere("FIRSTKEY") } sub NEXTKEY { my $self = shift ; $self->NotHere("NEXTKEY") } sub CLEAR { my $self = shift ; $self->NotHere("CLEAR") } --- 98,103 ---- *************** *** 146,152 **** use Carp; ! $VERSION = "1.14" ; #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; $DB_BTREE = new DB_File::BTREEINFO ; --- 145,151 ---- use Carp; ! $VERSION = "1.15" ; #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; $DB_BTREE = new DB_File::BTREEINFO ; *************** *** 212,228 **** } ! # import borrowed from IO::File ! # exports Fcntl constants if available. ! sub import { ! my $pkg = shift; ! my $callpkg = caller; ! Exporter::export $pkg, $callpkg, @_; ! eval { ! require Fcntl; ! Exporter::export 'Fcntl', $callpkg, '/^O_/'; ! }; ! } bootstrap DB_File $VERSION; --- 211,223 ---- } ! eval { ! # Make all Fcntl O_XXX constants available for importing ! require Fcntl; ! my @O = grep /^O_/, @Fcntl::EXPORT; ! Fcntl->import(@O); # first we import what we want to export ! push(@EXPORT, @O); ! }; bootstrap DB_File $VERSION; *************** *** 1665,1670 **** --- 1660,1680 ---- Made it illegal to tie an associative array to a RECNO database and an ordinary array to a HASH or BTREE database. + + =item 1.15 + + Patch from Gisle Aas to suppress "use of undefined + value" warning with db_get and db_seq. + + Patch from Gisle Aas to make DB_File export only the O_* + constants from Fcntl. + + Removed the DESTROY method from the DB_File::HASHINFO module. + + Previously DB_File hard-wired the class name of any object that it + created to "DB_File". This makes sub-classing difficult. Now DB_File + creats objects in the namespace of the package it has been inherited + into. =back Index: perl5.004_01_02/ext/DB_File/DB_File.xs *** perl5.004_01/ext/DB_File/DB_File.xs Thu May 1 02:24:48 1997 --- perl5.004_01_02/ext/DB_File/DB_File.xs Thu Jul 31 20:53:33 1997 *************** *** 3,10 **** DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess (pmarquess@bfsec.bt.co.uk) ! last modified 30th Apr 1997 ! version 1.14 All comments/suggestions/problems are welcome --- 3,10 ---- DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess (pmarquess@bfsec.bt.co.uk) ! last modified 29th Jun 1997 ! version 1.15 All comments/suggestions/problems are welcome *************** *** 42,47 **** --- 42,50 ---- 1.13 - Tidied up a few casts. 1.14 - Made it illegal to tie an associative array to a RECNO database and an ordinary array to a HASH or BTREE database. + 1.15 - Patch from Gisle Aas to suppress "use of + undefined value" warning with db_get and db_seq. + */ *************** *** 50,55 **** --- 53,61 ---- #include "XSUB.h" #include + /* #ifdef DB_VERSION_MAJOR */ + /* #include */ + /* #endif */ #include *************** *** 87,93 **** typedef DBT DBTKEY ; ! /* #define TRACE */ #define db_DESTROY(db) ((db->dbp)->close)(db->dbp) #define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) --- 93,99 ---- typedef DBT DBTKEY ; ! /* #define TRACE */ #define db_DESTROY(db) ((db->dbp)->close)(db->dbp) #define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) *************** *** 1062,1068 **** db_get(db, key, value, flags=0) DB_File db DBTKEY key ! DBT value u_int flags INIT: CurrentDB = db ; --- 1068,1074 ---- db_get(db, key, value, flags=0) DB_File db DBTKEY key ! DBT value = NO_INIT u_int flags INIT: CurrentDB = db ; *************** *** 1098,1104 **** db_seq(db, key, value, flags) DB_File db DBTKEY key ! DBT value u_int flags INIT: CurrentDB = db ; --- 1104,1110 ---- db_seq(db, key, value, flags) DB_File db DBTKEY key ! DBT value = NO_INIT u_int flags INIT: CurrentDB = db ; Index: perl5.004_01_02/ext/DB_File/typemap *** perl5.004_01/ext/DB_File/typemap Fri Aug 16 20:41:48 1996 --- perl5.004_01_02/ext/DB_File/typemap Thu Jul 31 20:53:33 1997 *************** *** 34,36 **** --- 34,38 ---- OutputKey($arg, $var) T_dbtdatum OutputValue($arg, $var) + T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); Index: perl5.004_01_02/ext/GDBM_File/typemap *** perl5.004_01/ext/GDBM_File/typemap Tue Oct 18 17:28:59 1994 --- perl5.004_01_02/ext/GDBM_File/typemap Thu Jul 31 19:50:24 1997 *************** *** 23,25 **** --- 23,27 ---- sv_setpvn($arg, $var.dptr, $var.dsize); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); + T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); Index: perl5.004_01_02/ext/IO/IO.xs *** perl5.004_01/ext/IO/IO.xs Tue May 13 18:27:54 1997 --- perl5.004_01_02/ext/IO/IO.xs Thu Jul 31 20:54:38 1997 *************** *** 271,276 **** --- 271,278 ---- CODE: /* Should check HAS_SETVBUF once Configure tests for that */ #if defined(PERLIO_IS_STDIO) && defined(_IOFBF) + if (!handle) /* Try input stream. */ + handle = IoIFP(sv_2io(ST(0))); if (handle) RETVAL = setvbuf(handle, buf, type, size); else { Index: perl5.004_01_02/ext/IO/lib/IO/File.pm *** perl5.004_01/ext/IO/lib/IO/File.pm Thu May 15 20:15:57 1997 --- perl5.004_01_02/ext/IO/lib/IO/File.pm Tue Jul 29 01:20:54 1997 *************** *** 115,138 **** @ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader); ! $VERSION = "1.0602"; @EXPORT = @IO::Seekable::EXPORT; ! sub import { ! my $pkg = shift; ! my $callpkg = caller; ! Exporter::export $pkg, $callpkg, @_; ! ! # ! # If the Fcntl extension is available, ! # export its constants for sysopen(). ! # ! eval { ! require Fcntl; ! Exporter::export 'Fcntl', $callpkg, '/^O_/'; ! }; ! } ################################################ --- 115,131 ---- @ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader); ! $VERSION = "1.06021"; @EXPORT = @IO::Seekable::EXPORT; ! eval { ! # Make all Fcntl O_XXX constants available for importing ! require Fcntl; ! my @O = grep /^O_/, @Fcntl::EXPORT; ! Fcntl->import(@O); # first we import what we want to export ! push(@EXPORT, @O); ! }; ################################################ Index: perl5.004_01_02/ext/IO/lib/IO/Handle.pm *** perl5.004_01/ext/IO/lib/IO/Handle.pm Wed Apr 9 20:48:13 1997 --- perl5.004_01_02/ext/IO/lib/IO/Handle.pm Thu Jul 31 19:50:00 1997 *************** *** 20,25 **** --- 20,26 ---- $fh->print("Some text\n"); } + use IO::Handle '_IOLBF'; $fh->setvbuf($buffer_var, _IOLBF, 1024); undef $fh; # automatically closes the file if it's open *************** *** 151,157 **** specifies a scalar variable to use as a buffer. WARNING: A variable used as a buffer by C or C must not be modified in any way until the IO::Handle is closed or C or C is called ! again, or memory corruption may result! Lastly, there is a special method for working under B<-T> and setuid/gid scripts: --- 152,159 ---- specifies a scalar variable to use as a buffer. WARNING: A variable used as a buffer by C or C must not be modified in any way until the IO::Handle is closed or C or C is called ! again, or memory corruption may result! Note that you need to import ! the constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Lastly, there is a special method for working under B<-T> and setuid/gid scripts: Index: perl5.004_01_02/ext/IO/lib/IO/Socket.pm *** perl5.004_01/ext/IO/lib/IO/Socket.pm Thu Apr 10 15:28:37 1997 --- perl5.004_01_02/ext/IO/lib/IO/Socket.pm Thu Jul 31 22:03:20 1997 *************** *** 380,385 **** --- 380,386 ---- my %socket_type = ( tcp => SOCK_STREAM, udp => SOCK_DGRAM, + icmp => SOCK_RAW, ); =head2 IO::Socket::INET *************** *** 557,563 **** } else { return _error($fh,'Cannot determine remote port') ! unless($rport || $type == SOCK_DGRAM); if($type == SOCK_STREAM || defined $raddr) { return _error($fh,'Bad peer address') --- 558,564 ---- } else { return _error($fh,'Cannot determine remote port') ! unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW); if($type == SOCK_STREAM || defined $raddr) { return _error($fh,'Bad peer address') Index: perl5.004_01_02/ext/NDBM_File/typemap *** perl5.004_01/ext/NDBM_File/typemap Tue Oct 18 17:29:10 1994 --- perl5.004_01_02/ext/NDBM_File/typemap Thu Jul 31 19:50:24 1997 *************** *** 23,25 **** --- 23,27 ---- sv_setpvn($arg, $var.dptr, $var.dsize); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); + T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); Index: perl5.004_01_02/ext/ODBM_File/ODBM_File.xs *** perl5.004_01/ext/ODBM_File/ODBM_File.xs Wed Apr 23 20:21:42 1997 --- perl5.004_01_02/ext/ODBM_File/ODBM_File.xs Thu Jul 31 19:50:24 1997 *************** *** 73,79 **** } RETVAL = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0); ST(0) = sv_mortalcopy(&sv_undef); ! sv_setptrobj(ST(0), RETVAL, "ODBM_File"); } void --- 73,79 ---- } RETVAL = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0); ST(0) = sv_mortalcopy(&sv_undef); ! sv_setptrobj(ST(0), RETVAL, dbtype); } void Index: perl5.004_01_02/ext/POSIX/POSIX.xs *** perl5.004_01/ext/POSIX/POSIX.xs Fri Mar 21 02:34:28 1997 --- perl5.004_01_02/ext/POSIX/POSIX.xs Thu Jul 31 21:52:49 1997 *************** *** 40,46 **** --- 40,48 ---- #include #include #include + #ifdef I_UNISTD #include + #endif #include #if defined(__VMS) && !defined(__POSIX_SOURCE) *************** *** 55,61 **** # define mkfifo(a,b) (not_here("mkfifo"),-1) # define tzset() not_here("tzset") ! # if __VMS_VER < 70000000 /* The default VMS emulation of Unix signals isn't very POSIXish */ typedef int sigset_t; # define sigpending(a) (not_here("sigpending"),0) --- 57,66 ---- # define mkfifo(a,b) (not_here("mkfifo"),-1) # define tzset() not_here("tzset") ! #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) ! # define HAS_TZNAME /* shows up in VMS 7.0 or Dec C 5.6 */ ! # include ! #else /* The default VMS emulation of Unix signals isn't very POSIXish */ typedef int sigset_t; # define sigpending(a) (not_here("sigpending"),0) *************** *** 125,133 **** # define sa_handler sv_handler # define sa_mask sv_mask # define sigsuspend(set) sigpause(*set) ! # else ! # define HAS_TZNAME /* shows up in VMS 7.0 */ ! # endif /* __VMS_VER < 70000000 */ /* The POSIX notion of ttyname() is better served by getname() under VMS */ static char ttnambuf[64]; --- 130,136 ---- # define sa_handler sv_handler # define sa_mask sv_mask # define sigsuspend(set) sigpause(*set) ! # endif /* __VMS_VER >= 70000000 or Dec C 5.6 */ /* The POSIX notion of ttyname() is better served by getname() under VMS */ static char ttnambuf[64]; Index: perl5.004_01_02/ext/SDBM_File/typemap *** perl5.004_01/ext/SDBM_File/typemap Tue Oct 18 17:29:55 1994 --- perl5.004_01_02/ext/SDBM_File/typemap Thu Jul 31 19:50:24 1997 *************** *** 23,25 **** --- 23,27 ---- sv_setpvn($arg, $var.dptr, $var.dsize); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); + T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); Index: perl5.004_01_02/global.sym *** perl5.004_01/global.sym Tue Jun 10 01:52:04 1997 --- perl5.004_01_02/global.sym Tue Jul 29 00:02:07 1997 *************** *** 1118,1123 **** --- 1118,1124 ---- sv_setnv sv_setptrobj sv_setpv + sv_setpviv sv_setpvn sv_setref_iv sv_setref_nv Index: perl5.004_01_02/gv.c *** perl5.004_01/gv.c Fri Jun 6 23:34:25 1997 --- perl5.004_01_02/gv.c Mon Jul 28 22:25:39 1997 *************** *** 827,833 **** sv_upgrade((SV *)io,SVt_PVIO); SvREFCNT(io) = 1; SvOBJECT_on(io); ! iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV); SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv)); return io; } --- 827,835 ---- sv_upgrade((SV *)io,SVt_PVIO); SvREFCNT(io) = 1; SvOBJECT_on(io); ! iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV); ! if (!iogv) ! iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV); SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv)); return io; } Index: perl5.004_01_02/hints/cxux.sh *** perl5.004_01/hints/cxux.sh Fri Mar 21 05:24:03 1997 --- perl5.004_01_02/hints/cxux.sh Thu Jul 31 18:32:39 1997 *************** *** 61,76 **** # glibpth="/usr/sde/elf/usr/lib $glibpth" ! # Need to use Concurrent cc for most of these options to be meaningful (if you ! # want to get this to work with gcc, you're on your own :-). Passing # -Bexport to the linker when linking perl is important because it leaves # the interpreter internal symbols visible to the shared libs that will be ! # loaded on demand (and will try to reference those symbols). The -u ! # option to drag 'sigaction' into the perl main program is to make sure ! # it gets defined for the posix shared library (for some reason sigaction ! # is static, rather than being defined in libc.so.1). # ! cc='/bin/cc -Xa' cccdlflags='-Zelf -Zpic' ccdlflags='-Zelf -Zlink=dynamic -Wl,-Bexport -u sigaction' lddlflags='-Zlink=so' --- 61,78 ---- # glibpth="/usr/sde/elf/usr/lib $glibpth" ! # Need to use Concurrent cc for most of these options to be meaningful (if ! # you want to get this to work with gcc, you're on your own :-). Passing # -Bexport to the linker when linking perl is important because it leaves # the interpreter internal symbols visible to the shared libs that will be ! # loaded on demand (and will try to reference those symbols). The -u option ! # to drag 'sigaction' into the perl main program is to make sure it gets ! # defined for the posix shared library (for some reason sigaction is static, ! # rather than being defined in libc.so.1). The 88110compat option makes sure ! # the code will run on both 88100 and 88110 machines. The define is added to ! # trigger a work around for a compiler bug which shows up in pp.c. # ! cc='/bin/cc -Xa -Qtarget=M88110compat -DCXUX_BROKEN_CONSTANT_CONVERT' cccdlflags='-Zelf -Zpic' ccdlflags='-Zelf -Zlink=dynamic -Wl,-Bexport -u sigaction' lddlflags='-Zlink=so' Index: perl5.004_01_02/hints/os2.sh *** perl5.004_01/hints/os2.sh Fri Mar 21 05:24:04 1997 --- perl5.004_01_02/hints/os2.sh Tue Jul 29 01:44:51 1997 *************** *** 189,194 **** --- 189,203 ---- d_getprior='define' d_setprior='define' + # Make denser object files and DLL + case "X$optimize" in + X) + optimize="-O2 -fomit-frame-pointer -malign-loops=2 -malign-jumps=2 -malign-functions=2" + lddlflags="$lddlflags -s" # Strip symbol table + aout_ldflags="$aout_ldflags -s" # Strip symbol table + ;; + esac + ####### All the rest is commented # The next two are commented. pdksh handles #! Index: perl5.004_01_02/hints/svr4.sh *** perl5.004_01/hints/svr4.sh Wed Jun 11 17:21:10 1997 --- perl5.004_01_02/hints/svr4.sh Thu Jul 31 19:44:33 1997 *************** *** 33,44 **** d_lstat=define # UnixWare has a broken csh. The undocumented -X argument to uname is probably ! # a reasonable way of detecting UnixWare uw_ver=`uname -v` uw_isuw=`uname -X 2>&1 | grep Release` ! if [ "$uw_isuw" = "Release = 4.2MP" -a \ ! \( "$uw_ver" = "2.1" -o "$uw_ver" = "2.1.1" \) ]; then ! d_csh='undef' fi # DDE SMES Supermax Enterprise Server --- 33,55 ---- d_lstat=define # UnixWare has a broken csh. The undocumented -X argument to uname is probably ! # a reasonable way of detecting UnixWare. Also in 2.1.1 the fields in ! # FILE* got renamed! uw_ver=`uname -v` uw_isuw=`uname -X 2>&1 | grep Release` ! if [ "$uw_isuw" = "Release = 4.2MP" ]; then ! case $uw_ver in ! 2.1) ! d_csh='undef' ! ;; ! 2.1.*) ! d_csh='undef' ! stdio_cnt='((fp)->__cnt)' ! d_stdio_cnt_lval='define' ! stdio_ptr='((fp)->__ptr)' ! d_stdio_ptr_lval='define' ! ;; ! esac fi # DDE SMES Supermax Enterprise Server Index: perl5.004_01_02/installhtml *** perl5.004_01/installhtml Thu Jun 12 17:57:19 1997 --- perl5.004_01_02/installhtml Thu Jul 31 22:58:06 1997 *************** *** 93,106 **** perl documentation: ./installhtml --podpath=lib:ext:pod:vms \ ! --podroot=/usr/src/perl \ ! --htmldir=/perl/nmanual \ ! --htmlroot=/perl/nmanual \ ! --splithead=pod/perlipc \ ! --splititem=pod/perlfunc \ ! --libpods=perlfunc:perlguts:perlvar:perlrun:perlop \ ! --recurse \ ! --verbose =head1 AUTHOR --- 93,106 ---- perl documentation: ./installhtml --podpath=lib:ext:pod:vms \ ! --podroot=/usr/src/perl \ ! --htmldir=/perl/nmanual \ ! --htmlroot=/perl/nmanual \ ! --splithead=pod/perlipc \ ! --splititem=pod/perlfunc \ ! --libpods=perlfunc:perlguts:perlvar:perlrun:perlop \ ! --recurse \ ! --verbose =head1 AUTHOR Index: perl5.004_01_02/lib/CPAN.pm Prereq: 1.139 *** perl5.004_01/lib/CPAN.pm Sat Jun 7 02:00:48 1997 --- perl5.004_01_02/lib/CPAN.pm Thu Jul 31 21:36:22 1997 *************** *** 23,30 **** use Text::Wrap; my $getcwd; ! $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; ! $Cwd = Cwd->$getcwd(); END { $End++; &cleanup; } --- 23,30 ---- use Text::Wrap; my $getcwd; ! $getcwd = $CPAN::Config->{'getcwd'} || 'Cwd::cwd'; ! $Cwd = &$getcwd(); END { $End++; &cleanup; } *************** *** 306,313 **** no strict; $META->checklock(); my $getcwd; ! $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; ! my $cwd = Cwd->$getcwd(); my $rl_avail = $Suppress_readline ? "suppressed" : ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : "available (get Term::ReadKey and Term::ReadLine::Perl ". --- 306,313 ---- no strict; $META->checklock(); my $getcwd; ! $getcwd = $CPAN::Config->{'getcwd'} || 'Cwd::cwd'; ! my $cwd = &$getcwd(); my $rl_avail = $Suppress_readline ? "suppressed" : ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : "available (get Term::ReadKey and Term::ReadLine::Perl ". *************** *** 422,429 **** $self->debug("reading dir[$dir]") if $CPAN::DEBUG; $dir ||= $self->{ID}; my $getcwd; ! $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; ! my($cwd) = Cwd->$getcwd(); chdir $dir or Carp::croak("Can't chdir to $dir: $!"); my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!"); my(@entries); --- 422,429 ---- $self->debug("reading dir[$dir]") if $CPAN::DEBUG; $dir ||= $self->{ID}; my $getcwd; ! $getcwd = $CPAN::Config->{'getcwd'} || 'Cwd::cwd'; ! my($cwd) = &$getcwd(); chdir $dir or Carp::croak("Can't chdir to $dir: $!"); my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!"); my(@entries); *************** *** 520,526 **** # print "caller[$caller]func[$func]line[$line]rest[@rest]\n"; # print "CPAN::DEBUG{caller}[$CPAN::DEBUG{$caller}]CPAN::DEBUG[$CPAN::DEBUG]\n"; if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){ ! if (ref $arg) { eval { require Data::Dumper }; if ($@) { print $arg->as_string; --- 520,526 ---- # print "caller[$caller]func[$func]line[$line]rest[@rest]\n"; # print "CPAN::DEBUG{caller}[$CPAN::DEBUG{$caller}]CPAN::DEBUG[$CPAN::DEBUG]\n"; if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){ ! if ($arg and ref $arg) { eval { require Data::Dumper }; if ($@) { print $arg->as_string; *************** *** 1615,1621 **** my($perms,%user,%group); my $pname = $name; ! if (defined $blocks) { $blocks = int(($blocks + 1) / 2); } else { --- 1615,1621 ---- my($perms,%user,%group); my $pname = $name; ! if ($blocks) { $blocks = int(($blocks + 1) / 2); } else { *************** *** 2242,2249 **** my $dir = $self->dir or $self->get; $dir = $self->dir; my $getcwd; ! $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; ! my $pwd = Cwd->$getcwd(); chdir($dir); print qq{Working directory is $dir.\n}; system($CPAN::Config->{'shell'}) == 0 or die "Subprocess shell error"; --- 2242,2249 ---- my $dir = $self->dir or $self->get; $dir = $self->dir; my $getcwd; ! $getcwd = $CPAN::Config->{'getcwd'} || 'Cwd::cwd'; ! my $pwd = &$getcwd(); chdir($dir); print qq{Working directory is $dir.\n}; system($CPAN::Config->{'shell'}) == 0 or die "Subprocess shell error"; *************** *** 2411,2418 **** sub perl { my($self) = @_; my($perl) = MM->file_name_is_absolute($^X) ? $^X : ""; ! my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; ! my $pwd = Cwd->$getcwd(); my $candidate = $CPAN::META->catfile($pwd,$^X); $perl ||= $candidate if MM->maybe_command($candidate); unless ($perl) { --- 2411,2418 ---- sub perl { my($self) = @_; my($perl) = MM->file_name_is_absolute($^X) ? $^X : ""; ! my $getcwd = $CPAN::Config->{'getcwd'} || 'Cwd::cwd'; ! my $pwd = &$getcwd(); my $candidate = $CPAN::META->catfile($pwd,$^X); $perl ||= $candidate if MM->maybe_command($candidate); unless ($perl) { *************** *** 2684,2691 **** my $manifest = $CPAN::META->catfile($where,"MANIFEST"); unless (-f $manifest) { require ExtUtils::Manifest; ! my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; ! my $cwd = Cwd->$getcwd(); chdir $where; ExtUtils::Manifest::mkmanifest(); chdir $cwd; --- 2684,2691 ---- my $manifest = $CPAN::META->catfile($where,"MANIFEST"); unless (-f $manifest) { require ExtUtils::Manifest; ! my $getcwd = $CPAN::Config->{'getcwd'} || 'Cwd::cwd'; ! my $cwd = &$getcwd(); chdir $where; ExtUtils::Manifest::mkmanifest(); chdir $cwd; Index: perl5.004_01_02/lib/Class/Struct.pm *** perl5.004_01/lib/Class/Struct.pm Thu Apr 10 20:55:05 1997 --- perl5.004_01_02/lib/Class/Struct.pm Mon Jul 28 22:14:27 1997 *************** *** 146,154 **** # Create accessor methods. - if ( $got_class && $CHECK_CLASS_MEMBERSHIP ) { - $out .= " use UNIVERSAL;\n"; - } my( $pre, $pst, $sel ); $cnt = 0; foreach $name (@methods){ --- 146,151 ---- Index: perl5.004_01_02/lib/Exporter.pm *** perl5.004_01/lib/Exporter.pm Sat Apr 12 03:49:18 1997 --- perl5.004_01_02/lib/Exporter.pm Thu Jul 31 21:39:19 1997 *************** *** 108,114 **** last; } } elsif ($sym !~ s/^&// || !$exports{$sym}) { ! warn qq["$sym" is not exported by the $pkg module]; $oops++; } } --- 108,115 ---- last; } } elsif ($sym !~ s/^&// || !$exports{$sym}) { ! require Carp; ! Carp::carp(qq["$sym" is not exported by the $pkg module]); $oops++; } } *************** *** 137,144 **** if (@failed) { @failed = $pkg->export_fail(@failed); foreach $sym (@failed) { ! warn qq["$sym" is not implemented by the $pkg module ], ! "on this architecture"; } if (@failed) { require Carp; --- 138,146 ---- if (@failed) { @failed = $pkg->export_fail(@failed); foreach $sym (@failed) { ! require Carp; ! Carp::carp(qq["$sym" is not implemented by the $pkg module ], ! "on this architecture"); } if (@failed) { require Carp; Index: perl5.004_01_02/lib/ExtUtils/Command.pm *** perl5.004_01/lib/ExtUtils/Command.pm Tue Apr 1 21:16:53 1997 --- perl5.004_01_02/lib/ExtUtils/Command.pm Thu Jul 31 21:51:13 1997 *************** *** 10,16 **** use vars qw(@ISA @EXPORT $VERSION); @ISA = qw(Exporter); @EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f); ! $VERSION = '1.00'; =head1 NAME --- 10,16 ---- use vars qw(@ISA @EXPORT $VERSION); @ISA = qw(Exporter); @EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f); ! $VERSION = '1.01'; =head1 NAME *************** *** 18,33 **** =head1 SYNOPSIS ! perl -MExtUtils::command -e cat files... > destination ! perl -MExtUtils::command -e mv source... destination ! perl -MExtUtils::command -e cp source... destination ! perl -MExtUtils::command -e touch files... ! perl -MExtUtils::command -e rm_f file... ! perl -MExtUtils::command -e rm_rf directories... ! perl -MExtUtils::command -e mkpath directories... ! perl -MExtUtils::command -e eqtime source destination ! perl -MExtUtils::command -e chmod mode files... ! perl -MExtUtils::command -e test_f file =head1 DESCRIPTION --- 18,33 ---- =head1 SYNOPSIS ! perl -MExtUtils::Command -e cat files... > destination ! perl -MExtUtils::Command -e mv source... destination ! perl -MExtUtils::Command -e cp source... destination ! perl -MExtUtils::Command -e touch files... ! perl -MExtUtils::Command -e rm_f file... ! perl -MExtUtils::Command -e rm_rf directories... ! perl -MExtUtils::Command -e mkpath directories... ! perl -MExtUtils::Command -e eqtime source destination ! perl -MExtUtils::Command -e chmod mode files... ! perl -MExtUtils::Command -e test_f file =head1 DESCRIPTION Index: perl5.004_01_02/lib/ExtUtils/Install.pm *** perl5.004_01/lib/ExtUtils/Install.pm Fri Jun 6 22:44:10 1997 --- perl5.004_01_02/lib/ExtUtils/Install.pm Thu Jul 31 21:51:13 1997 *************** *** 1,14 **** package ExtUtils::Install; ! $VERSION = substr q$Revision: 1.16 $, 10; ! # $Date: 1996/12/17 00:31:26 $ use Exporter; use Carp (); ! use Config (); use vars qw(@ISA @EXPORT $VERSION); @ISA = ('Exporter'); ! @EXPORT = ('install','uninstall','pm_to_blib'); $Is_VMS = $^O eq 'VMS'; my $splitchar = $^O eq 'VMS' ? '|' : $^O eq 'os2' ? ';' : ':'; --- 1,14 ---- package ExtUtils::Install; ! $VERSION = substr q$Revision: 1.18 $, 10; ! # $Date: 1997/06/28 15:16:44 $ use Exporter; use Carp (); ! use Config qw(%Config); use vars qw(@ISA @EXPORT $VERSION); @ISA = ('Exporter'); ! @EXPORT = ('install','uninstall','pm_to_blib', 'install_default'); $Is_VMS = $^O eq 'VMS'; my $splitchar = $^O eq 'VMS' ? '|' : $^O eq 'os2' ? ';' : ':'; *************** *** 144,149 **** --- 144,171 ---- } } + sub install_default { + @_ < 2 or die "install_default should be called with 0 or 1 argument"; + my $FULLEXT = @_ ? shift : $ARGV[0]; + defined $FULLEXT or die "Do not know to where to write install log"; + my $INST_LIB = MM->catdir(MM->curdir,"blib","lib"); + my $INST_ARCHLIB = MM->catdir(MM->curdir,"blib","arch"); + my $INST_BIN = MM->catdir(MM->curdir,'blib','bin'); + my $INST_SCRIPT = MM->catdir(MM->curdir,'blib','script'); + my $INST_MAN1DIR = MM->catdir(MM->curdir,'blib','man1'); + my $INST_MAN3DIR = MM->catdir(MM->curdir,'blib','man3'); + install({ + read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist", + write => "$Config{installsitearch}/auto/$FULLEXT/.packlist", + $INST_LIB => $Config{installsitelib}, + $INST_ARCHLIB => $Config{installsitearch}, + $INST_BIN => $Config{installbin} , + $INST_SCRIPT => $Config{installscript}, + $INST_MAN1DIR => $Config{installman1dir}, + $INST_MAN3DIR => $Config{installman3dir}, + },1,0,0); + } + sub my_cmp { my($one,$two) = @_; local(*F,*T); *************** *** 192,198 **** my $MY = {}; bless $MY, 'MY'; my %seen_dir = (); ! foreach $dir (@INC, @PERL_ENV_LIB, @Config::Config{qw/archlibexp privlibexp sitearchexp sitelibexp/}) { next if $dir eq "."; next if $seen_dir{$dir}++; my($targetfile) = $MY->catfile($dir,$libdir,$file); --- 214,220 ---- my $MY = {}; bless $MY, 'MY'; my %seen_dir = (); ! foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw/archlibexp privlibexp sitearchexp sitelibexp/}) { next if $dir eq "."; next if $seen_dir{$dir}++; my($targetfile) = $MY->catfile($dir,$libdir,$file); *************** *** 332,337 **** --- 354,373 ---- be merged into the written file. The read and the written file may be identical, but on AFS it is quite likely, people are installing to a different directory than the one where the files later appear. + + install_default() takes one or less arguments. If no arguments are + specified, it takes $ARGV[0] as if it was specified as an argument. + The argument is the value of MakeMaker's C key, like F. + This function calls install() with the same arguments as the defaults + the MakeMaker would use. + + The argumement-less form is convenient for install scripts like + + perl -MExtUtils::Install -e install_default Tk/Canvas + + Assuming this command is executed in a directory with populated F + directory, it will proceed as if the F was build by MakeMaker on + this machine. This is useful for binary distributions. uninstall() takes as first argument a file containing filenames to be unlinked. The second argument is a verbose switch, the third is a Index: perl5.004_01_02/lib/ExtUtils/Liblist.pm *** perl5.004_01/lib/ExtUtils/Liblist.pm Sat Jun 7 01:19:44 1997 --- perl5.004_01_02/lib/ExtUtils/Liblist.pm Thu Jul 31 21:51:13 1997 *************** *** 2,8 **** use vars qw($VERSION); # Broken out of MakeMaker from version 4.11 ! $VERSION = substr q$Revision: 1.2201 $, 10; use Config; use Cwd 'cwd'; --- 2,8 ---- use vars qw($VERSION); # Broken out of MakeMaker from version 4.11 ! $VERSION = substr q$Revision: 1.24 $, 10; use Config; use Cwd 'cwd'; *************** *** 15,21 **** } sub _unix_os2_ext { ! my($self,$potential_libs, $Verbose) = @_; if ($^O =~ 'os2' and $Config{libs}) { # Dynamic libraries are not transitive, so we may need including # the libraries linked against perl.dll again. --- 15,21 ---- } sub _unix_os2_ext { ! my($self,$potential_libs, $verbose) = @_; if ($^O =~ 'os2' and $Config{libs}) { # Dynamic libraries are not transitive, so we may need including # the libraries linked against perl.dll again. *************** *** 24,30 **** $potential_libs .= $Config{libs}; } return ("", "", "", "") unless $potential_libs; ! print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose; my($so) = $Config{'so'}; my($libs) = $Config{'libs'}; --- 24,30 ---- $potential_libs .= $Config{libs}; } return ("", "", "", "") unless $potential_libs; ! print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; my($so) = $Config{'so'}; my($libs) = $Config{'libs'}; *************** *** 50,56 **** my($ptype) = $1; unless (-d $thislib){ print STDOUT "$ptype$thislib ignored, directory does not exist\n" ! if $Verbose; next; } unless ($self->file_name_is_absolute($thislib)) { --- 50,56 ---- my($ptype) = $1; unless (-d $thislib){ print STDOUT "$ptype$thislib ignored, directory does not exist\n" ! if $verbose; next; } unless ($self->file_name_is_absolute($thislib)) { *************** *** 125,134 **** # # , the compilation tools expand the environment variables.) } else { ! print STDOUT "$thislib not found in $thispth\n" if $Verbose; next; } ! print STDOUT "'-l$thislib' found at $fullname\n" if $Verbose; my($fullnamedir) = dirname($fullname); push @ld_run_path, $fullnamedir unless $ld_run_path_seen{$fullnamedir}++; $found++; --- 125,134 ---- # # , the compilation tools expand the environment variables.) } else { ! print STDOUT "$thislib not found in $thispth\n" if $verbose; next; } ! print STDOUT "'-l$thislib' found at $fullname\n" if $verbose; my($fullnamedir) = dirname($fullname); push @ld_run_path, $fullnamedir unless $ld_run_path_seen{$fullnamedir}++; $found++; *************** *** 183,189 **** } sub _win32_ext { ! my($self, $potential_libs, $Verbose) = @_; # If user did not supply a list, we punt. # (caller should probably use the list in $Config{libs}) --- 183,189 ---- } sub _win32_ext { ! my($self, $potential_libs, $verbose) = @_; # If user did not supply a list, we punt. # (caller should probably use the list in $Config{libs}) *************** *** 202,208 **** $potential_libs .= " " if $potential_libs; $potential_libs .= $libs; } ! print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose; # compute $extralibs from $potential_libs --- 202,208 ---- $potential_libs .= " " if $potential_libs; $potential_libs .= $libs; } ! print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; # compute $extralibs from $potential_libs *************** *** 219,225 **** # Handle possible linker path arguments. if ($thislib =~ s/^-L// and not -d $thislib) { print STDOUT "-L$thislib ignored, directory does not exist\n" ! if $Verbose; next; } elsif (-d $thislib) { --- 219,225 ---- # Handle possible linker path arguments. if ($thislib =~ s/^-L// and not -d $thislib) { print STDOUT "-L$thislib ignored, directory does not exist\n" ! if $verbose; next; } elsif (-d $thislib) { *************** *** 238,247 **** my($found_lib)=0; foreach $thispth (@searchpath, @libpath){ unless (-f ($fullname="$thispth\\$thislib")) { ! print STDOUT "$thislib not found in $thispth\n" if $Verbose; next; } ! print STDOUT "'$thislib' found at $fullname\n" if $Verbose; $found++; $found_lib++; push(@extralibs, $fullname); --- 238,247 ---- my($found_lib)=0; foreach $thispth (@searchpath, @libpath){ unless (-f ($fullname="$thispth\\$thislib")) { ! print STDOUT "$thislib not found in $thispth\n" if $verbose; next; } ! print STDOUT "'$thislib' found at $fullname\n" if $verbose; $found++; $found_lib++; push(@extralibs, $fullname); *************** *** 370,376 **** if ($ctype) { eval '$' . $ctype . "{'$cand'}++"; die "Error recording library: $@" if $@; ! print STDOUT "\tFound as $cand (really $ctest), type $ctype\n" if $verbose > 1; next LIB; } } --- 370,376 ---- if ($ctype) { eval '$' . $ctype . "{'$cand'}++"; die "Error recording library: $@" if $@; ! print STDOUT "\tFound as $cand (really $test), type $ctype\n" if $verbose > 1; next LIB; } } *************** *** 403,409 **** C ! C =head1 DESCRIPTION --- 403,409 ---- C ! C =head1 DESCRIPTION Index: perl5.004_01_02/lib/ExtUtils/MM_Unix.pm Prereq: 1.113 *** perl5.004_01/lib/ExtUtils/MM_Unix.pm Thu Jun 12 22:06:18 1997 --- perl5.004_01_02/lib/ExtUtils/MM_Unix.pm Thu Jul 31 21:51:13 1997 *************** *** 8,15 **** use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 $Verbose %pm %static $Xsubpp_Version); ! $VERSION = substr q$Revision: 1.114 $, 10; ! # $Id: MM_Unix.pm,v 1.113 1997/02/11 21:54:09 k Exp $ Exporter::import('ExtUtils::MakeMaker', qw( $Verbose &neatvalue)); --- 8,15 ---- use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 $Verbose %pm %static $Xsubpp_Version); ! $VERSION = substr q$Revision: 1.117 $, 10; ! # $Id: MM_Unix.pm,v 1.117 1997/06/28 15:16:44 k Exp $ Exporter::import('ExtUtils::MakeMaker', qw( $Verbose &neatvalue)); *************** *** 181,186 **** --- 181,187 ---- sub ExtUtils::MM_Unix::extliblist ; sub ExtUtils::MM_Unix::file_name_is_absolute ; sub ExtUtils::MM_Unix::find_perl ; + sub ExtUtils::MM_Unix::fixin ; sub ExtUtils::MM_Unix::force ; sub ExtUtils::MM_Unix::guess_name ; sub ExtUtils::MM_Unix::has_link_code ; *************** *** 1103,1108 **** --- 1104,1189 ---- =over 2 + =item fixin + + Inserts the sharpbang or equivalent magic number to a script + + =cut + + sub fixin { # stolen from the pink Camel book, more or less + my($self,@files) = @_; + my($does_shbang) = $Config::Config{'sharpbang'} =~ /^\s*\#\!/; + my($file,$interpreter); + for $file (@files) { + local(*FIXIN); + local(*FIXOUT); + open(FIXIN, $file) or Carp::croak "Can't process '$file': $!"; + local $/ = "\n"; + chomp(my $line = ); + next unless $line =~ s/^\s*\#!\s*//; # Not a shbang file. + # Now figure out the interpreter name. + my($cmd,$arg) = split ' ', $line, 2; + $cmd =~ s!^.*/!!; + + # Now look (in reverse) for interpreter in absolute PATH (unless perl). + if ($cmd eq "perl") { + $interpreter = $Config{perlpath}; + } else { + my(@absdirs) = reverse grep {$self->file_name_is_absolute} $self->path; + $interpreter = ''; + my($dir); + foreach $dir (@absdirs) { + if ($self->maybe_command($cmd)) { + warn "Ignoring $interpreter in $file\n" if $Verbose && $interpreter; + $interpreter = $self->catfile($dir,$cmd); + } + } + } + # Figure out how to invoke interpreter on this machine. + + my($shb) = ""; + if ($interpreter) { + print STDOUT "Changing sharpbang in $file to $interpreter" if $Verbose; + if ($does_shbang) { + $shb .= "$Config{'sharpbang'}$interpreter"; + $shb .= ' ' . $arg if defined $arg; + $shb .= "\n"; + } + $shb .= qq{ + eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' + if \$running_under_some_shell; + }; + } else { + warn "Can't find $cmd in PATH, $file unchanged" + if $Verbose; + next; + } + + unless ( rename($file, "$file.bak") ) { + warn "Can't modify $file"; + next; + } + unless ( open(FIXOUT,">$file") ) { + warn "Can't create new $file: $!\n"; + next; + } + my($dev,$ino,$mode) = stat FIXIN; + $mode = 0755 unless $dev; + chmod $mode, $file; + + # Print out the new #! line (or equivalent). + local $\; + undef $/; + print FIXOUT $shb, ; + close FIXIN; + close FIXOUT; + unlink "$file.bak"; + } continue { + chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; + system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';; + } + } + =item force (o) Just writes FORCE: *************** *** 1280,1286 **** # my $fh = new FileHandle; local *FH; my($ispod)=0; - # one day test, if $/ can be set to '' safely (is the bug fixed that was in 5.001m?) # if ($fh->open("<$name")) { if (open(FH,"<$name")) { # while (<$fh>) { --- 1361,1366 ---- *************** *** 1297,1303 **** $ispod = 1; } if( $ispod ) { ! $manifypods{$name} = $self->catfile('$(INST_MAN1DIR)',basename($name).'.$(MAN1EXT)'); } } } --- 1377,1385 ---- $ispod = 1; } if( $ispod ) { ! $manifypods{$name} = ! $self->catfile('$(INST_MAN1DIR)', ! basename($name).'.$(MAN1EXT)'); } } } *************** *** 1901,1922 **** $fromto{$from}=$to; } @to = values %fromto; ! push(@m, " EXE_FILES = @{$self->{EXE_FILES}} all :: @to realclean :: $self->{RM_F} @to ! "); while (($from,$to) = each %fromto) { last unless defined $from; my $todir = dirname($to); push @m, " ! $to: $from $self->{MAKEFILE} ".$self->catfile($todir,'.exists')." $self->{NOECHO}$self->{RM_F} $to $self->{CP} $from $to "; } join "", @m; --- 1983,2008 ---- $fromto{$from}=$to; } @to = values %fromto; ! push(@m, qq{ EXE_FILES = @{$self->{EXE_FILES}} + FIXIN = \$(PERL) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) -MExtUtils::MakeMaker \\ + -e "MY->fixin(shift)" + all :: @to realclean :: $self->{RM_F} @to ! }); while (($from,$to) = each %fromto) { last unless defined $from; my $todir = dirname($to); push @m, " ! $to: $from $self->{MAKEFILE} $todir/.exists $self->{NOECHO}$self->{RM_F} $to $self->{CP} $from $to + \$(FIXIN) $to "; } join "", @m; *************** *** 2430,2443 **** $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; next if $inpod; chop; ! next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/; my $eval = qq{ package ExtUtils::MakeMaker::_version; no strict; ! \$$1=undef; do { $_ ! }; \$$1 }; local($^W) = 0; $result = eval($eval) || 0; --- 2516,2531 ---- $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; next if $inpod; chop; ! # next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/; ! next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/; my $eval = qq{ package ExtUtils::MakeMaker::_version; no strict; ! local $1$2; ! \$$2=undef; do { $_ ! }; \$$2 }; local($^W) = 0; $result = eval($eval) || 0; Index: perl5.004_01_02/lib/ExtUtils/MM_VMS.pm *** perl5.004_01/lib/ExtUtils/MM_VMS.pm Mon Jun 9 14:01:04 1997 --- perl5.004_01_02/lib/ExtUtils/MM_VMS.pm Thu Jul 31 19:42:52 1997 *************** *** 96,102 **** } my($fixedpath,$prefix,$name); ! if ($path =~ m#^\$\(.+\)$# || $path =~ m#[/:>\]]#) { if ($force_path or $path =~ /(?:DIR\)|\])$/) { $fixedpath = vmspath($self->eliminate_macros($path)); } --- 96,102 ---- } my($fixedpath,$prefix,$name); ! if ($path =~ m#^\$\([^\)]+\)$# || $path =~ m#[/:>\]]#) { if ($force_path or $path =~ /(?:DIR\)|\])$/) { $fixedpath = vmspath($self->eliminate_macros($path)); } *************** *** 105,111 **** } } elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#)) && $self->{$prefix}) { ! my($vmspre) = vmspath($self->eliminate_macros("\$($prefix)")) || ''; # is it a dir or just a name? $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; $fixedpath = vmspath($fixedpath) if $force_path; } --- 105,113 ---- } } elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#)) && $self->{$prefix}) { ! my($vmspre) = $self->eliminate_macros("\$($prefix)"); ! # is it a dir or just a name? ! $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR$/) ? vmspath($vmspre) : ''; $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; $fixedpath = vmspath($fixedpath) if $force_path; } Index: perl5.004_01_02/lib/ExtUtils/MakeMaker.pm *** perl5.004_01/lib/ExtUtils/MakeMaker.pm Fri Jun 6 22:44:12 1997 --- perl5.004_01_02/lib/ExtUtils/MakeMaker.pm Thu Jul 31 21:51:13 1997 *************** *** 2,11 **** package ExtUtils::MakeMaker; ! $Version = $VERSION = "5.4002"; $Version_OK = "5.17"; # Makefiles older than $Version_OK will die # (Will be checked from MakeMaker version 4.13 onwards) ! ($Revision = substr(q$Revision: 1.211 $, 10)) =~ s/\s+$//; --- 2,11 ---- package ExtUtils::MakeMaker; ! $Version = $VERSION = "5.41"; $Version_OK = "5.17"; # Makefiles older than $Version_OK will die # (Will be checked from MakeMaker version 4.13 onwards) ! ($Revision = substr(q$Revision: 1.215 $, 10)) =~ s/\s+$//; *************** *** 1157,1162 **** --- 1157,1167 ---- and the values portion of the XS attribute hash. This is not currently used by MakeMaker but may be handy in Makefile.PLs. + =item CCFLAGS + + String that will be included in the compiler call command line between + the arguments INC and OPTIMIZE. + =item CONFIG Arrayref. E.g. [qw(archname manext)] defines ARCHNAME & MANEXT from *************** *** 1257,1262 **** --- 1262,1271 ---- Ref to array of *.h file names. Similar to C. + =item IMPORTS + + IMPORTS is only used on OS/2. + =item INC Include file dirs eg: C<"-I/usr/5include -I/path/to/inc"> *************** *** 1564,1578 **** single line to compute the version number. The first line in the file that contains the regular expression ! /\$(([\w\:\']*)\bVERSION)\b.*\=/ will be evaluated with eval() and the value of the named variable B the eval() will be assigned to the VERSION attribute of the MakeMaker object. The following lines will be parsed o.k.: $VERSION = '1.00'; ! ( $VERSION ) = '$Revision: 1.211 $ ' =~ /\$Revision:\s+([^\s]+)/; $FOO::VERSION = '1.10'; but these will fail: --- 1573,1589 ---- single line to compute the version number. The first line in the file that contains the regular expression ! /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ will be evaluated with eval() and the value of the named variable B the eval() will be assigned to the VERSION attribute of the MakeMaker object. The following lines will be parsed o.k.: $VERSION = '1.00'; ! *VERSION = \'1.01'; ! ( $VERSION ) = '$Revision: 1.215 $ ' =~ /\$Revision:\s+([^\s]+)/; $FOO::VERSION = '1.10'; + *FOO::VERSION = \'1.11'; but these will fail: *************** *** 1580,1588 **** local $VERSION = '1.02'; local $FOO::VERSION = '1.30'; ! The file named in VERSION_FROM is added as a dependency to Makefile to ! guarantee, that the Makefile contains the correct VERSION macro after ! a change of the file. =item XS --- 1591,1606 ---- local $VERSION = '1.02'; local $FOO::VERSION = '1.30'; ! The file named in VERSION_FROM is not added as a dependency to ! Makefile. This is not really correct, but it would be a major pain ! during development to have to rewrite the Makefile for any smallish ! change in that file. If you want to make sure that the Makefile ! contains the correct VERSION macro after any change of the file, you ! would have to do something like ! ! depend => { Makefile => '$(VERSION_FROM)' } ! ! See attribute C below. =item XS Index: perl5.004_01_02/lib/ExtUtils/Mksymlists.pm *** perl5.004_01/lib/ExtUtils/Mksymlists.pm Fri Jun 6 22:44:12 1997 --- perl5.004_01_02/lib/ExtUtils/Mksymlists.pm Thu Jul 31 21:51:13 1997 *************** *** 7,13 **** use vars qw( @ISA @EXPORT $VERSION ); @ISA = 'Exporter'; @EXPORT = '&Mksymlists'; ! $VERSION = substr q$Revision: 1.13 $, 10; sub Mksymlists { my(%spec) = @_; --- 7,13 ---- use vars qw( @ISA @EXPORT $VERSION ); @ISA = 'Exporter'; @EXPORT = '&Mksymlists'; ! $VERSION = substr q$Revision: 1.15 $, 10; sub Mksymlists { my(%spec) = @_; *************** *** 106,121 **** open(DEF,">$data->{FILE}.def") or croak("Can't create $data->{FILE}.def: $!\n"); ! print DEF "LIBRARY $data->{DLBASE}\n"; print DEF "CODE LOADONCALL\n"; print DEF "DATA LOADONCALL NONSHARED MULTIPLE\n"; print DEF "EXPORTS\n "; if ($Config::Config{'cc'} =~ /^bcc/i) { ! for (@{$data->{DL_VARS}}) { $_ = "$_ = _$_" } ! for (@{$data->{FUNCLIST}}) { $_ = "$_ = _$_" } } ! print DEF join("\n ",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}}; ! print DEF join("\n ",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}}; if (%{$data->{IMPORTS}}) { print DEF "IMPORTS\n"; my ($name, $exp); --- 106,133 ---- open(DEF,">$data->{FILE}.def") or croak("Can't create $data->{FILE}.def: $!\n"); ! # put library name in quotes (it could be a keyword, like 'Alias') ! print DEF "LIBRARY \"$data->{DLBASE}\"\n"; print DEF "CODE LOADONCALL\n"; print DEF "DATA LOADONCALL NONSHARED MULTIPLE\n"; print DEF "EXPORTS\n "; + my @syms; + # Export public symbols both with and without underscores to + # ensure compatibility between DLLs from different compilers + # NOTE: DynaLoader itself only uses the names without underscores, + # so this is only to cover the case when the extension DLL may be + # linked to directly from C. GSAR 97-07-10 if ($Config::Config{'cc'} =~ /^bcc/i) { ! for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) { ! push @syms, "_$_", "$_ = _$_"; ! } ! } ! else { ! for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) { ! push @syms, "$_", "_$_ = $_"; ! } } ! print DEF join("\n ",@syms, "\n") if @syms; if (%{$data->{IMPORTS}}) { print DEF "IMPORTS\n"; my ($name, $exp); Index: perl5.004_01_02/lib/ExtUtils/xsubpp *** perl5.004_01/lib/ExtUtils/xsubpp Sat Jun 7 01:36:53 1997 --- perl5.004_01_02/lib/ExtUtils/xsubpp Thu Jul 31 20:50:56 1997 *************** *** 6,12 **** =head1 SYNOPSIS ! B [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-typemap typemap>]... file.xs =head1 DESCRIPTION --- 6,12 ---- =head1 SYNOPSIS ! B [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>]... file.xs =head1 DESCRIPTION *************** *** 55,60 **** --- 55,64 ---- from the C<.xs> file) and the C<.pm> files have the same version number. + =item B<-nolinenumbers> + + Prevents the inclusion of `#line' directives in the output. + =back =head1 ENVIRONMENT *************** *** 83,89 **** # Global Constants ! $XSUBPP_version = "1.9402"; my ($Is_VMS, $SymSet); if ($^O eq 'VMS') { --- 87,93 ---- # Global Constants ! $XSUBPP_version = "1.9504"; my ($Is_VMS, $SymSet); if ($^O eq 'VMS') { *************** *** 96,102 **** $FH = 'File0000' ; ! $usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-s pattern] [-typemap typemap]... file.xs\n"; $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; --- 100,106 ---- $FH = 'File0000' ; ! $usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-s pattern] [-typemap typemap]... file.xs\n"; $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; *************** *** 104,109 **** --- 108,114 ---- $WantPrototypes = -1 ; $WantVersionChk = 1 ; $ProtoUsed = 0 ; + $WantLineNumbers = 1 ; SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $flag = shift @ARGV; $flag =~ s/^-// ; *************** *** 115,120 **** --- 120,127 ---- $WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck'; $except = " TRY", next SWITCH if $flag eq 'except'; push(@tm,shift), next SWITCH if $flag eq 'typemap'; + $WantLineNumbers = 0, next SWITCH if $flag eq 'nolinenumbers'; + $WantLineNumbers = 1, next SWITCH if $flag eq 'linenumbers'; (print "xsubpp version $XSUBPP_version\n"), exit if $flag eq 'v'; die $usage; *************** *** 239,251 **** } sub print_section { ! my $count = 0; ! $_ = shift(@line) while !/\S/ && @line; for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { - print line_directive() unless ($count++); print "$_\n"; } } sub process_keyword($) --- 246,304 ---- } + if ($WantLineNumbers) { + { + package xsubpp::counter; + sub TIEHANDLE { + my ($class, $cfile) = @_; + my $buf = ""; + $SECTION_END_MARKER = "#line --- \"$cfile\""; + $line_no = 1; + bless \$buf; + } + + sub PRINT { + my $self = shift; + for (@_) { + $$self .= $_; + while ($$self =~ s/^([^\n]*\n)//) { + my $line = $1; + ++ $line_no; + $line =~ s|^\#line\s+---(?=\s)|#line $line_no|; + print STDOUT $line; + } + } + } + + sub PRINTF { + my $self = shift; + my $fmt = shift; + $self->PRINT(sprintf($fmt, @_)); + } + + sub DESTROY { + # Not necessary if we're careful to end with a "\n" + my $self = shift; + print STDOUT $$self; + } + } + + my $cfile = $filename; + $cfile =~ s/\.xs$/.c/i or $cfile .= ".c"; + tie(*PSEUDO_STDOUT, 'xsubpp::counter', $cfile); + select PSEUDO_STDOUT; + } + sub print_section { ! # the "do" is required for right semantics ! do { $_ = shift(@line) } while !/\S/ && @line; ! ! print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n") ! if $WantLineNumbers && !/^\s*#\s*line\b/; for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { print "$_\n"; } + print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; } sub process_keyword($) *************** *** 255,261 **** &{"${kwd}_handler"}() while $kwd = check_keyword($pattern) ; - print line_directive(); } sub CASE_handler { --- 308,313 ---- *************** *** 332,338 **** unless defined($args_match{$outarg}); blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next unless defined $var_types{$outarg} ; - print line_directive(); if ($outcode) { print "\t$outcode\n"; } else { --- 384,389 ---- *************** *** 650,656 **** */ EOM ! print "#line 1 \"$filename\"\n"; while (<$FH>) { last if ($Module, $Package, $Prefix) = --- 701,710 ---- */ EOM ! ! ! print("#line 1 \"$filename\"\n") ! if $WantLineNumbers; while (<$FH>) { last if ($Module, $Package, $Prefix) = *************** *** 787,793 **** if (check_keyword("BOOT")) { &check_cpp; ! push (@BootCode, $_, line_directive(), @line, "") ; next PARAGRAPH ; } --- 841,849 ---- if (check_keyword("BOOT")) { &check_cpp; ! push (@BootCode, "#line $line_no[@line_no - @line] \"$filename\"") ! if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/; ! push (@BootCode, @line, "") ; next PARAGRAPH ; } *************** *** 1005,1011 **** } elsif ($gotRETVAL || $wantRETVAL) { &generate_output($ret_type, 0, 'RETVAL'); } - print line_directive(); # do cleanup process_keyword("CLEANUP|ALIAS|PROTOTYPE") ; --- 1061,1066 ---- *************** *** 1064,1074 **** if ($ProtoThisXSUB) { $newXS = "newXSproto"; ! if ($ProtoThisXSUB == 2) { # User has specified empty prototype $proto = ', ""' ; } ! elsif ($ProtoThisXSUB != 1) { # User has specified a prototype $proto = ', "' . $ProtoThisXSUB . '"'; } --- 1119,1129 ---- if ($ProtoThisXSUB) { $newXS = "newXSproto"; ! if ($ProtoThisXSUB eq 2) { # User has specified empty prototype $proto = ', ""' ; } ! elsif ($ProtoThisXSUB ne 1) { # User has specified a prototype $proto = ', "' . $ProtoThisXSUB . '"'; } *************** *** 1135,1142 **** if (@BootCode) { ! print "\n /* Initialisation Section */\n" ; ! print grep (s/$/\n/, @BootCode) ; print "\n /* End of Initialisation Section */\n\n" ; } --- 1190,1198 ---- if (@BootCode) { ! print "\n /* Initialisation Section */\n\n" ; ! @line = @BootCode; ! print_section(); print "\n /* End of Initialisation Section */\n\n" ; } *************** *** 1156,1170 **** local($arg) = "ST(" . ($num - 1) . ")"; eval qq/print " $init\\\n"/; - } - - sub line_directive - { - # work out the line number - my $line_no = $line_no[@line_no - @line -1] ; - - return "#line $line_no \"$filename\"\n" ; - } sub Warn --- 1212,1217 ---- Index: perl5.004_01_02/lib/File/Compare.pm *** perl5.004_01/lib/File/Compare.pm Wed Feb 5 17:59:54 1997 --- perl5.004_01_02/lib/File/Compare.pm Mon Jul 28 22:14:27 1997 *************** *** 5,11 **** require Exporter; use Carp; - use UNIVERSAL qw(isa); $VERSION = '1.1001'; @ISA = qw(Exporter); --- 5,10 ---- *************** *** 34,40 **** croak("from undefined") unless (defined $from); croak("to undefined") unless (defined $to); ! if (ref($from) && (isa($from,'GLOB') || isa($from,'IO::Handle'))) { *FROM = *$from; } elsif (ref(\$from) eq 'GLOB') { *FROM = $from; --- 33,40 ---- croak("from undefined") unless (defined $from); croak("to undefined") unless (defined $to); ! if (ref($from) && ! (UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) { *FROM = *$from; } elsif (ref(\$from) eq 'GLOB') { *FROM = $from; *************** *** 45,51 **** $fromsize = -s FROM; } ! if (ref($to) && (isa($to,'GLOB') || isa($to,'IO::Handle'))) { *TO = *$to; } elsif (ref(\$to) eq 'GLOB') { *TO = $to; --- 45,52 ---- $fromsize = -s FROM; } ! if (ref($to) && ! (UNIVERSAL::isa($to,'GLOB') || UNIVERSAL::isa($to,'IO::Handle'))) { *TO = *$to; } elsif (ref(\$to) eq 'GLOB') { *TO = $to; Index: perl5.004_01_02/lib/File/Copy.pm *** perl5.004_01/lib/File/Copy.pm Tue Dec 31 07:09:37 1996 --- perl5.004_01_02/lib/File/Copy.pm Mon Jul 28 22:14:27 1997 *************** *** 9,15 **** use strict; use Carp; - use UNIVERSAL qw(isa); use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $Too_Big © &syscopy &cp &mv); --- 9,14 ---- *************** *** 48,58 **** my $from_a_handle = (ref($from) ? (ref($from) eq 'GLOB' ! || isa($from, 'GLOB') || isa($from, 'IO::Handle')) : (ref(\$from) eq 'GLOB')); my $to_a_handle = (ref($to) ? (ref($to) eq 'GLOB' ! || isa($to, 'GLOB') || isa($to, 'IO::Handle')) : (ref(\$to) eq 'GLOB')); if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) { --- 47,59 ---- my $from_a_handle = (ref($from) ? (ref($from) eq 'GLOB' ! || UNIVERSAL::isa($from, 'GLOB') ! || UNIVERSAL::isa($from, 'IO::Handle')) : (ref(\$from) eq 'GLOB')); my $to_a_handle = (ref($to) ? (ref($to) eq 'GLOB' ! || UNIVERSAL::isa($to, 'GLOB') ! || UNIVERSAL::isa($to, 'IO::Handle')) : (ref(\$to) eq 'GLOB')); if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) { Index: perl5.004_01_02/lib/File/Find.pm *** perl5.004_01/lib/File/Find.pm Thu Dec 19 22:11:40 1996 --- perl5.004_01_02/lib/File/Find.pm Thu Jul 31 22:10:02 1997 *************** *** 78,95 **** # compatibility. local($topdir,$topdev,$topino,$topmode,$topnlink); foreach $topdir (@_) { ! (($topdev,$topino,$topmode,$topnlink) = stat($topdir)) || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { ($dir,$_) = ($topdir,'.'); $name = $topdir; &$wanted; ! my $fixtopdir = $topdir; ! $fixtopdir =~ s,/$,, ; ! $fixtopdir =~ s/\.dir$// if $Is_VMS; ! $fixtopdir =~ s/\\dir$// if $Is_NT; ! &finddir($wanted,$fixtopdir,$topnlink); } else { warn "Can't cd to $topdir: $!\n"; --- 78,99 ---- # compatibility. local($topdir,$topdev,$topino,$topmode,$topnlink); foreach $topdir (@_) { ! (($topdev,$topino,$topmode,$topnlink) = ! ($Is_VMS ? stat($topdir) : lstat($topdir))) || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { ($dir,$_) = ($topdir,'.'); $name = $topdir; + $prune = 0; &$wanted; ! if (!$prune) { ! my $fixtopdir = $topdir; ! $fixtopdir =~ s,/$,, ; ! $fixtopdir =~ s/\.dir$// if $Is_VMS; ! $fixtopdir =~ s/\\dir$// if $Is_NT; ! &finddir($wanted,$fixtopdir,$topnlink); ! } } else { warn "Can't cd to $topdir: $!\n"; *************** *** 169,175 **** # compatibility. local($topdir, $topdev, $topino, $topmode, $topnlink); foreach $topdir (@_) { ! (($topdev,$topino,$topmode,$topnlink) = stat($topdir)) || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { --- 173,180 ---- # compatibility. local($topdir, $topdev, $topino, $topmode, $topnlink); foreach $topdir (@_) { ! (($topdev,$topino,$topmode,$topnlink) = ! ($Is_VMS ? stat($topdir) : lstat($topdir))) || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { *************** *** 190,195 **** --- 195,201 ---- unless (($_,$dir) = File::Basename::fileparse($topdir)) { ($dir,$_) = ('.', $topdir); } + $name = $topdir; chdir $dir && &$wanted; } chdir $cwd; Index: perl5.004_01_02/lib/File/Path.pm *** perl5.004_01/lib/File/Path.pm Thu Apr 24 17:39:44 1997 --- perl5.004_01_02/lib/File/Path.pm Thu Jul 31 23:57:26 1997 *************** *** 130,136 **** my $parent = File::Basename::dirname($path); push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent); print "mkdir $path\n" if $verbose; ! mkdir($path,$mode) || croak "mkdir $path: $!"; push(@created, $path); } @created; --- 130,139 ---- my $parent = File::Basename::dirname($path); push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent); print "mkdir $path\n" if $verbose; ! unless (mkdir($path,$mode)) { ! # allow for another process to have created it meanwhile ! croak "mkdir $path: $!" unless -d $path; ! } push(@created, $path); } @created; Index: perl5.004_01_02/lib/FileHandle.pm *** perl5.004_01/lib/FileHandle.pm Fri Jan 31 17:44:23 1997 --- perl5.004_01_02/lib/FileHandle.pm Thu Jul 31 23:38:31 1997 *************** *** 93,98 **** --- 93,103 ---- ($r, $w); } + # Rebless standard file handles + bless *STDIN{IO}, "FileHandle" if ref *STDIN{IO} eq "IO::Handle"; + bless *STDOUT{IO}, "FileHandle" if ref *STDOUT{IO} eq "IO::Handle"; + bless *STDERR{IO}, "FileHandle" if ref *STDERR{IO} eq "IO::Handle"; + 1; __END__ Index: perl5.004_01_02/lib/Net/hostent.pm *** perl5.004_01/lib/Net/hostent.pm Thu Apr 10 17:00:21 1997 --- perl5.004_01_02/lib/Net/hostent.pm Thu Jul 31 23:28:04 1997 *************** *** 76,84 **** gethostbyaddr() functions, replacing them with versions that return "Net::hostent" objects. This object has methods that return the similarly named structure field name from the C's hostent structure from F; ! namely name, aliases, addrtype, length, and addresses. The aliases and ! addresses methods return array reference, the rest scalars. The addr ! method is equivalent to the zeroth element in the addresses array reference. You may also import all the structure fields directly into your namespace --- 76,84 ---- gethostbyaddr() functions, replacing them with versions that return "Net::hostent" objects. This object has methods that return the similarly named structure field name from the C's hostent structure from F; ! namely name, aliases, addrtype, length, and addr_list. The aliases and ! addr_list methods return array reference, the rest scalars. The addr ! method is equivalent to the zeroth element in the addr_list array reference. You may also import all the structure fields directly into your namespace Index: perl5.004_01_02/lib/Pod/Html.pm *** perl5.004_01/lib/Pod/Html.pm Thu Jun 12 21:52:53 1997 --- perl5.004_01_02/lib/Pod/Html.pm Thu Jul 31 22:01:47 1997 *************** *** 761,767 **** # scan for =head directives, note their name, and build an index # pointing to each of them. foreach my $line (@data) { ! if ($line =~ /^\s*=(head)([1-6])\s+(.*)/) { ($tag,$which_head, $title) = ($1,$2,$3); chomp($title); $$sections{htmlify(0,$title)} = 1; --- 761,767 ---- # scan for =head directives, note their name, and build an index # pointing to each of them. foreach my $line (@data) { ! if ($line =~ /^=(head)([1-6])\s+(.*)/) { ($tag,$which_head, $title) = ($1,$2,$3); chomp($title); $$sections{htmlify(0,$title)} = 1; *************** *** 788,794 **** # get rid of bogus lists $index =~ s,\t*
    \s*
\n,,g; ! $ignore = 1; # retore old value; return $index; } --- 788,794 ---- # get rid of bogus lists $index =~ s,\t*
    \s*
\n,,g; ! $ignore = 1; # restore old value; return $index; } Index: perl5.004_01_02/lib/Sys/Hostname.pm *** perl5.004_01/lib/Sys/Hostname.pm Thu May 8 15:41:14 1997 --- perl5.004_01_02/lib/Sys/Hostname.pm Mon Jul 28 22:31:26 1997 *************** *** 39,45 **** if ($^O eq 'VMS') { # method 2 - no sockets ==> return DECnet node name ! eval {my($test) = gethostbyname('me')}; # returns 'me' on most systems if ($@) { return $host = $ENV{'SYS$NODE'}; } # method 3 - has someone else done the job already? It's common for the --- 39,45 ---- if ($^O eq 'VMS') { # method 2 - no sockets ==> return DECnet node name ! eval { local $SIG{__DIE__}; (gethostbyname('me'))[0] }; if ($@) { return $host = $ENV{'SYS$NODE'}; } # method 3 - has someone else done the job already? It's common for the *************** *** 69,74 **** --- 69,75 ---- # method 2 - syscall is preferred since it avoids tainting problems eval { + local $SIG{__DIE__}; { package main; require "syscall.ph"; *************** *** 79,94 **** --- 80,98 ---- # method 3 - trusty old hostname command || eval { + local $SIG{__DIE__}; $host = `(hostname) 2>/dev/null`; # bsdish } # method 4 - sysV uname command (may truncate) || eval { + local $SIG{__DIE__}; $host = `uname -n 2>/dev/null`; ## sysVish } # method 5 - Apollo pre-SR10 || eval { + local $SIG{__DIE__}; ($host,$a,$b,$c,$d)=split(/[:\. ]/,`/com/host`,6); } Index: perl5.004_01_02/lib/Sys/Syslog.pm *** perl5.004_01/lib/Sys/Syslog.pm Tue Jun 10 23:45:59 1997 --- perl5.004_01_02/lib/Sys/Syslog.pm Thu Jul 31 21:35:38 1997 *************** *** 54,59 **** --- 54,72 ---- Sets log mask I<$mask_priority> and returns the old mask. + =item setlogsock $sock_type + + Sets the socket type to be used for the next call to + C or C. + + A value of 'unix' will connect to the UNIX domain socket returned + by C<_PATH_LOG> in F. A value of 'inet' will connect + to an INET socket returned by getservbyname(). + Any other value croaks. + + The default is for the INET socket to be used. + + =item closelog Closes the log file. *************** *** 70,78 **** --- 83,94 ---- closelog(); syslog('debug', 'this is the last test'); + + setlogsock('unix'); openlog("$program $$", 'ndelay', 'user'); syslog('notice', 'fooprogram: this is really done'); + setlogsock('inet'); $! = 55; syslog('info', 'problem was %m'); # %m == $! in syslog(3) *************** *** 86,92 **** =head1 AUTHOR ! Tom Christiansen EFE and Larry Wall EFE =cut --- 102,110 ---- =head1 AUTHOR ! Tom Christiansen EFE and Larry Wall EFE. ! UNIX domain sockets added by Sean Robinson EFE ! with support from Tim Bunce and the perl5-porters mailing list. =cut *************** *** 114,119 **** --- 132,148 ---- $oldmask; } + sub setlogsock { + local($setsock) = shift; + if (lc($setsock) eq 'unix') { + $sock_unix = 1; + } elsif (lc($setsock) eq 'inet') { + undef($sock_unix); + } else { + croak "Invalid argument passed to setlogsock; must be 'unix' or 'inet'"; + } + } + sub syslog { local($priority) = shift; local($mask) = shift; *************** *** 172,178 **** $message = sprintf ($mask, @_); $sum = $numpri + $numfac; ! unless (send(SYSLOG,"<$sum>$whoami: $message",0)) { if ($lo_cons) { if ($pid = fork) { unless ($lo_nowait) { --- 201,207 ---- $message = sprintf ($mask, @_); $sum = $numpri + $numfac; ! unless (send(SYSLOG,"<$sum>$whoami: $message\0",0)) { if ($lo_cons) { if ($pid = fork) { unless ($lo_nowait) { *************** *** 203,214 **** my($host_uniq) = Sys::Hostname::hostname(); ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _) } ! my $udp = getprotobyname('udp'); ! my $syslog = getservbyname('syslog','udp'); ! my $this = sockaddr_in($syslog, INADDR_ANY); ! my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host"); ! socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!"; ! connect(SYSLOG,$that) || croak "connect: $!"; local($old) = select(SYSLOG); $| = 1; select($old); $connected = 1; } --- 232,250 ---- my($host_uniq) = Sys::Hostname::hostname(); ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _) } ! unless ( $sock_unix ) { ! my $udp = getprotobyname('udp'); ! my $syslog = getservbyname('syslog','udp'); ! my $this = sockaddr_in($syslog, INADDR_ANY); ! my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host"); ! socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!"; ! connect(SYSLOG,$that) || croak "connect: $!"; ! } else { ! my $syslog = &_PATH_LOG || croak "_PATH_LOG not found in syslog.ph"; ! my $that = sockaddr_un($syslog) || croak "Can't locate $syslog"; ! socket(SYSLOG,AF_UNIX,SOCK_STREAM,0) || croak "open: $!"; ! connect(SYSLOG,$that) || croak "connect: $!"; ! } local($old) = select(SYSLOG); $| = 1; select($old); $connected = 1; } Index: perl5.004_01_02/lib/Term/ReadLine.pm *** perl5.004_01/lib/Term/ReadLine.pm Fri Jun 6 23:53:34 1997 --- perl5.004_01_02/lib/Term/ReadLine.pm Thu Jul 31 20:54:52 1997 *************** *** 105,118 **** All these commands are callable via method interface and have names which conform to standard conventions with the leading C stripped. ! The stub package included with the perl distribution allows two ! additional methods: C and C. The first one makes Tk event loop run when waiting for user input (i.e., during ! C method), the second one makes the command line stand out ! by using termcap data. The argument to C should be 0, 1, ! or a string of a form "aa,bb,cc,dd". Four components of this string ! should be names of I, first two will be issued to ! make the prompt standout, last two to make the input line standout. =head1 EXPORTS --- 105,137 ---- All these commands are callable via method interface and have names which conform to standard conventions with the leading C stripped. ! The stub package included with the perl distribution allows some ! additional methods: ! ! =over 12 ! ! =item C ! makes Tk event loop run when waiting for user input (i.e., during ! C method). ! ! =item C ! ! makes the command line stand out by using termcap data. The argument ! to C should be 0, 1, or a string of a form ! C<"aa,bb,cc,dd">. Four components of this string should be names of ! I, first two will be issued to make the prompt ! standout, last two to make the input line standout. ! ! =item C ! ! takes two arguments which are input filehandle and output filehandle. ! Switches to use these filehandles. ! ! =back ! ! One can check whether the currently loaded ReadLine package supports ! these methods by checking for corresponding C. =head1 EXPORTS *************** *** 206,217 **** bless [$FIN, $FOUT]; } } sub IN { shift->[0] } sub OUT { shift->[1] } sub MinLine { undef } sub Attribs { {} } ! my %features = (tkRunning => 1, ornaments => 1); sub Features { \%features } package Term::ReadLine; # So late to allow the above code be defined? --- 225,246 ---- bless [$FIN, $FOUT]; } } + + sub newTTY { + my ($self, $in, $out) = @_; + $self->[0] = $in; + $self->[1] = $out; + my $sel = select($out); + $| = 1; # for DB::OUT + select($sel); + } + sub IN { shift->[0] } sub OUT { shift->[1] } sub MinLine { undef } sub Attribs { {} } ! my %features = (tkRunning => 1, ornaments => 1, newTTY => 1); sub Features { \%features } package Term::ReadLine; # So late to allow the above code be defined? Index: perl5.004_01_02/lib/Time/Local.pm *** perl5.004_01/lib/Time/Local.pm Sun Nov 24 08:02:03 1996 --- perl5.004_01_02/lib/Time/Local.pm Mon Jul 28 22:22:25 1997 *************** *** 48,58 **** $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0; ! my $t = time; ! my @lt = localtime($t); ! my @gt = gmtime($t); ! $tzsec = ($gt[1] - $lt[1]) * $MIN + ($gt[2] - $lt[2]) * $HR; my($lday,$gday) = ($lt[7],$gt[7]); if($lt[5] > $gt[5]) { --- 48,69 ---- $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0; ! } ! ! sub timegm { ! $ym = pack(C2, @_[5,4]); ! $cheat = $cheat{$ym} || &cheat; ! return -1 if $cheat<0 and $^O ne 'VMS'; ! $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAY; ! } ! ! sub timelocal { ! my $t = &timegm; ! ! my (@lt) = localtime($t); ! my (@gt) = gmtime($t); ! my $tzsec = ($gt[1] - $lt[1]) * $MIN + ($gt[2] - $lt[2]) * $HR; my($lday,$gday) = ($lt[7],$gt[7]); if($lt[5] > $gt[5]) { *************** *** 65,82 **** $tzsec += ($gt[7] - $lt[7]) * $DAY; } ! $tzsec += $HR if($lt[8]); ! } ! ! sub timegm { ! $ym = pack(C2, @_[5,4]); ! $cheat = $cheat{$ym} || &cheat; ! return -1 if $cheat<0 and $^O ne 'VMS'; ! $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAY; ! } ! ! sub timelocal { ! $time = &timegm + $tzsec; return -1 if $cheat<0 and $^O ne 'VMS'; @test = localtime($time); $time -= $HR if $test[2] != $_[2]; --- 76,84 ---- $tzsec += ($gt[7] - $lt[7]) * $DAY; } ! $tzsec += $HR if($lt[8]); ! ! $time = $t + $tzsec; return -1 if $cheat<0 and $^O ne 'VMS'; @test = localtime($time); $time -= $HR if $test[2] != $_[2]; Index: perl5.004_01_02/lib/UNIVERSAL.pm *** perl5.004_01/lib/UNIVERSAL.pm Mon Mar 24 20:43:43 1997 --- perl5.004_01_02/lib/UNIVERSAL.pm Mon Jul 28 23:41:07 1997 *************** *** 1,7 **** package UNIVERSAL; require Exporter; ! @ISA = qw(Exporter); @EXPORT_OK = qw(isa can); 1; --- 1,10 ---- package UNIVERSAL; + # UNIVERSAL should not contain any extra subs/methods beyond those + # that it exists to define. The use of Exporter below is a historical + # accident that should be fixed sometime. require Exporter; ! *import = \&Exporter::import; @EXPORT_OK = qw(isa can); 1; *************** *** 13,24 **** =head1 SYNOPSIS - use UNIVERSAL qw(isa); - - $yes = isa($ref, "HASH"); $io = $fd->isa("IO::Handle"); $sub = $obj->can('print'); =head1 DESCRIPTION C is the base class which all bless references will inherit from, --- 16,26 ---- =head1 SYNOPSIS $io = $fd->isa("IO::Handle"); $sub = $obj->can('print'); + $yes = UNIVERSAL::isa($ref, "HASH"); + =head1 DESCRIPTION C is the base class which all bless references will inherit from, *************** *** 54,64 **** =back ! C also optionally exports the following subroutines =over 4 ! =item isa ( VAL, TYPE ) C returns I if the first argument is a reference and either of the following statements is true. --- 56,66 ---- =back ! The C and C methods can also be called as subroutines =over 4 ! =item UNIVERSAL::isa ( VAL, TYPE ) C returns I if the first argument is a reference and either of the following statements is true. *************** *** 76,82 **** =back ! =item can ( VAL, METHOD ) If C is a blessed reference which has a method called C, C returns a reference to the subroutine. If C is not --- 78,84 ---- =back ! =item UNIVERSAL::can ( VAL, METHOD ) If C is a blessed reference which has a method called C, C returns a reference to the subroutine. If C is not *************** *** 84,88 **** --- 86,97 ---- I is returned. =back + + These subroutines should I be imported via S>. + If you want simple local access to them you can do + + *isa = \&UNIVERSAL::isa; + + to import isa into your package. =cut Index: perl5.004_01_02/lib/ftp.pl Prereq: 1.17 *** perl5.004_01/lib/ftp.pl Thu Jun 12 00:58:24 1997 --- perl5.004_01_02/lib/ftp.pl Thu Jul 31 23:53:22 1997 *************** *** 88,102 **** # Initial revision # ! eval { require 'chat2.pl' }; ! die qq{$@ ! The obsolete and problematic chat2.pl library has been removed from the ! Perl distribution at the request of it's author. You can either get a ! copy yourself or, preferably, fetch the new and much better Net::FTP ! package from a CPAN ftp site. ! } if $@ && $@ =~ /locate chat2.pl/; ! die $@ if $@; ! eval "require 'socket.ph'" || eval "require 'sys/socket.ph'" || die "socket.ph missing: $!\n"; package ftp; --- 88,96 ---- # Initial revision # ! require 'chat2.pl'; # into main ! eval "require 'socket.ph'" || eval "require 'sys/socket.ph'" ! || die "socket.ph missing: $!\n"; package ftp; Index: perl5.004_01_02/lib/perl5db.pl *** perl5.004_01/lib/perl5db.pl Tue Apr 15 17:09:27 1997 --- perl5.004_01_02/lib/perl5db.pl Thu Jul 31 20:54:52 1997 *************** *** 428,433 **** --- 428,434 ---- @typeahead = @$pretype, @typeahead; CMD: while (($term || &setterm), + ($term_pid == $$ or &resetterm), defined ($cmd=&readline(" DB" . ('<' x $level) . ($#hist+1) . ('>' x $level) . " "))) { *************** *** 1062,1068 **** $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval; if ($onetimeDump) { $onetimeDump = undef; ! } else { print $OUT "\n"; } } continue { # CMD: --- 1063,1069 ---- $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval; if ($onetimeDump) { $onetimeDump = undef; ! } elsif ($term_pid == $$) { print $OUT "\n"; } } continue { # CMD: *************** *** 1386,1391 **** --- 1387,1415 ---- $term->SetHistory(@hist); } ornaments($ornaments) if defined $ornaments; + $term_pid = $$; + } + + sub resetterm { # We forked, so we need a different TTY + $term_pid = $$; + if (defined &get_fork_TTY) { + &get_fork_TTY; + } elsif (not defined $fork_TTY + and defined $ENV{TERM} and $ENV{TERM} eq 'xterm' + and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) { + # Possibly _inside_ XTERM + open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\ + sleep 10000000' |]; + $fork_TTY = ; + chomp $fork_TTY; + } + if (defined $fork_TTY) { + TTY($fork_TTY); + undef $fork_TTY; + } else { + print $OUT "Forked, but do not know how to change a TTY.\n", + "Define \$DB::fork_TTY or get_fork_TTY().\n"; + } } sub readline { *************** *** 1511,1518 **** } sub TTY { ! if ($term) { ! &warn("Too late to set TTY, enabled on next `R'!\n") if @_; } $tty = shift if @_; $tty or $console; --- 1535,1555 ---- } sub TTY { ! if (@_ and $term and $term->Features->{newTTY}) { ! my ($in, $out) = shift; ! if ($in =~ /,/) { ! ($in, $out) = split /,/, $in, 2; ! } else { ! $out = $in; ! } ! open IN, $in or die "cannot open `$in' for read: $!"; ! open OUT, ">$out" or die "cannot open `$out' for write: $!"; ! $term->newTTY(\*IN, \*OUT); ! $IN = \*IN; ! $OUT = \*OUT; ! return $tty = $in; ! } elsif ($term and @_) { ! &warn("Too late to set TTY, enabled on next `R'!\n"); } $tty = shift if @_; $tty or $console; Index: perl5.004_01_02/malloc.c *** perl5.004_01/malloc.c Fri Mar 21 02:43:49 1997 --- perl5.004_01_02/malloc.c Mon Jul 28 23:55:47 1997 *************** *** 2,7 **** --- 2,11 ---- * */ + #if defined(PERL_CORE) && !defined(DEBUGGING_MSTATS) + # define DEBUGGING_MSTATS + #endif + #ifndef lint # if defined(DEBUGGING) && !defined(NO_RCHECK) # define RCHECK *************** *** 781,786 **** --- 785,793 ---- #ifdef PERL_CORE reqsize = size; /* just for the DEBUG_m statement */ #endif + #ifdef PACK_MALLOC + size = (size + 0x7ff) & ~0x7ff; + #endif if (size <= Perl_sbrk_oldsize) { got = Perl_sbrk_oldchunk; Perl_sbrk_oldchunk += size; *************** *** 796,801 **** --- 803,811 ---- small = 1; } got = (IV)SYSTEM_ALLOC(size); + #ifdef PACK_MALLOC + got = (got + 0x7ff) & ~0x7ff; + #endif if (small) { /* Chunk is small, register the rest for future allocs. */ Perl_sbrk_oldchunk = got + reqsize; Index: perl5.004_01_02/mg.c *** perl5.004_01/mg.c Fri Jun 13 15:14:03 1997 --- perl5.004_01_02/mg.c Tue Jul 29 01:55:01 1997 *************** *** 1664,1669 **** --- 1664,1684 ---- return 0; } + static SV* sig_sv; + + static void + unwind_handler_stack(p) + void *p; + { + U32 flags = *(U32*)p; + + if (flags & 1) + savestack_ix -= 5; /* Unprotect save in progress. */ + /* cxstack_ix-- Not needed, die already unwound it. */ + if (flags & 64) + SvREFCNT_dec(sig_sv); + } + Signal_t sighandler(sig) int sig; *************** *** 1671,1685 **** dSP; GV *gv; HV *st; ! SV *sv; CV *cv; AV *oldstack; ! if (!psig_ptr[sig]) die("Signal SIG%s received, but no signal handler set.\n", sig_name[sig]); ! cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE); if (!cv || !CvROOT(cv)) { if (dowarn) warn("SIG%s handler \"%s\" not defined.\n", --- 1686,1741 ---- dSP; GV *gv; HV *st; ! SV *sv, *tSv = Sv; CV *cv; AV *oldstack; ! OP *myop = op; ! U32 flags = 0; ! I32 o_save_i = savestack_ix, type; ! CONTEXT *cx; ! XPV *tXpv = Xpv; ! ! if (savestack_ix + 15 <= savestack_max) ! flags |= 1; ! if (cxstack_ix < cxstack_max - 2) ! flags |= 2; ! if (markstack_ptr < markstack_max - 2) ! flags |= 4; ! if (retstack_ix < retstack_max - 2) ! flags |= 8; ! if (scopestack_ix < scopestack_max - 3) ! flags |= 16; ! ! if (flags & 2) { /* POPBLOCK may decrease cxstack too early. */ ! cxstack_ix++; /* Protect from overwrite. */ ! cx = &cxstack[cxstack_ix]; ! type = cx->cx_type; /* Can be during partial write. */ ! cx->cx_type = CXt_NULL; /* Make it safe for unwind. */ ! } if (!psig_ptr[sig]) die("Signal SIG%s received, but no signal handler set.\n", sig_name[sig]); ! /* Max number of items pushed there is 3*n or 4. We cannot fix ! infinity, so we fix 4 (in fact 5): */ ! if (flags & 1) { ! savestack_ix += 5; /* Protect save in progress. */ ! o_save_i = savestack_ix; ! SAVEDESTRUCTOR(unwind_handler_stack, (void*)&flags); ! } ! if (flags & 4) ! markstack_ptr++; /* Protect mark. */ ! if (flags & 8) { ! retstack_ix++; ! retstack[retstack_ix] = NULL; ! } ! if (flags & 16) ! scopestack_ix += 1; ! /* sv_2cv is too complicated, try a simpler variant first: */ ! if (!SvROK(psig_ptr[sig]) || !(cv = (CV*)SvRV(psig_ptr[sig])) ! || SvTYPE(cv) != SVt_PVCV) ! cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE); ! if (!cv || !CvROOT(cv)) { if (dowarn) warn("SIG%s handler \"%s\" not defined.\n", *************** *** 1692,1700 **** AvFILL(signalstack) = 0; SWITCHSTACK(curstack, signalstack); ! if(psig_name[sig]) sv = SvREFCNT_inc(psig_name[sig]); ! else { sv = sv_newmortal(); sv_setpv(sv,sig_name[sig]); } --- 1748,1758 ---- AvFILL(signalstack) = 0; SWITCHSTACK(curstack, signalstack); ! if(psig_name[sig]) { sv = SvREFCNT_inc(psig_name[sig]); ! flags |= 64; ! sig_sv = sv; ! } else { sv = sv_newmortal(); sv_setpv(sv,sig_name[sig]); } *************** *** 1705,1710 **** perl_call_sv((SV*)cv, G_DISCARD); SWITCHSTACK(signalstack, oldstack); ! return; } --- 1763,1785 ---- perl_call_sv((SV*)cv, G_DISCARD); SWITCHSTACK(signalstack, oldstack); ! if (flags & 1) ! savestack_ix -= 8; /* Unprotect save in progress. */ ! if (flags & 2) { ! cxstack[cxstack_ix].cx_type = type; ! cxstack_ix -= 1; ! } ! if (flags & 4) ! markstack_ptr--; ! if (flags & 8) ! retstack_ix--; ! if (flags & 16) ! scopestack_ix -= 1; ! if (flags & 64) ! SvREFCNT_dec(sv); ! op = myop; /* Apparently not needed... */ ! ! Sv = tSv; /* Restore global temporaries. */ ! Xpv = tXpv; return; } Index: perl5.004_01_02/op.c *** perl5.004_01/op.c Sat Jun 7 03:24:13 1997 --- perl5.004_01_02/op.c Tue Jul 29 01:38:15 1997 *************** *** 1059,1064 **** --- 1059,1066 ---- case OP_RV2AV: case OP_RV2HV: + if (!type && cUNOP->op_first->op_type != OP_GV) + croak("Can't localize through a reference"); if (type == OP_REFGEN && op->op_flags & OPf_PARENS) { modcount = 10000; return op; /* Treat \(@foo) like ordinary list. */ *************** *** 1080,1086 **** break; case OP_RV2SV: if (!type && cUNOP->op_first->op_type != OP_GV) ! croak("Can't localize a reference"); ref(cUNOP->op_first, op->op_type); /* FALL THROUGH */ case OP_GV: --- 1082,1088 ---- break; case OP_RV2SV: if (!type && cUNOP->op_first->op_type != OP_GV) ! croak("Can't localize through a reference"); ref(cUNOP->op_first, op->op_type); /* FALL THROUGH */ case OP_GV: *************** *** 1550,1555 **** --- 1552,1567 ---- if (!(opargs[type] & OA_FOLDCONST)) goto nope; + + switch (type) { + case OP_SPRINTF: + case OP_UCFIRST: + case OP_LCFIRST: + case OP_UC: + case OP_LC: + if (o->op_private & OPpLOCALE) + goto nope; + } if (error_count) goto nope; /* Don't try to run w/ errors */ Index: perl5.004_01_02/opcode.pl *** perl5.004_01/opcode.pl Tue Apr 29 15:28:40 1997 --- perl5.004_01_02/opcode.pl Thu Jul 31 20:53:24 1997 *************** *** 342,348 **** index index ck_index ist S S S? rindex rindex ck_index ist S S S? ! sprintf sprintf ck_fun_locale mst S L formline formline ck_fun ms S L ord ord ck_fun ifstu S? chr chr ck_fun fstu S? --- 342,348 ---- index index ck_index ist S S S? rindex rindex ck_index ist S S S? ! sprintf sprintf ck_fun_locale mfst S L formline formline ck_fun ms S L ord ord ck_fun ifstu S? chr chr ck_fun fstu S? Index: perl5.004_01_02/os2/Changes *** perl5.004_01/os2/Changes Fri Feb 21 14:59:57 1997 --- perl5.004_01_02/os2/Changes Tue Jul 29 01:44:49 1997 *************** *** 143,145 **** --- 143,151 ---- environment). Known problems: $$ does not work - is 0, waitpid returns immediately, thus Perl cannot wait for completion of started programs. + + after 5.004_01: + flock emulation added (disable by setting env PERL_USE_FLOCK=0), + thanks to Rocco Caputo; + RSX bug with missing waitpid circomvented; + -S bug with full path with \ corrected. Index: perl5.004_01_02/os2/Makefile.SHs *** perl5.004_01/os2/Makefile.SHs Thu Dec 19 00:30:35 1996 --- perl5.004_01_02/os2/Makefile.SHs Tue Jul 29 01:44:49 1997 *************** *** 54,59 **** --- 54,60 ---- echo ' "dlerror"' >>$@ echo ' "my_tmpfile"' >>$@ echo ' "my_tmpnam"' >>$@ + echo ' "my_flock"' >>$@ !NO!SUBS! if [ ! -z "$myttyname" ] ; then Index: perl5.004_01_02/os2/diff.configure *** perl5.004_01/os2/diff.configure Fri Feb 28 15:46:06 1997 --- perl5.004_01_02/os2/diff.configure Tue Jul 29 01:44:49 1997 *************** *** 51,57 **** case "$libs" in '') ;; *) for thislib in $libs; do ! @@ -4136,6 +4144,10 @@ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun --- 51,66 ---- case "$libs" in '') ;; *) for thislib in $libs; do ! @@ -3968,6 +3976,8 @@ ! : ! elif try=`./loc $thislib X $libpth`; $test -f "$try"; then ! : ! + elif try=`./loc $thislib$lib_ext X $libpth`; $test -f "$try"; then ! + : ! elif try=`./loc Slib$thislib$lib_ext X $xlibpth`; $test -f "$try"; then ! : ! else ! @@ -4152,6 +4162,10 @@ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun *************** *** 175,181 **** dflt=`./try` case "$dflt" in [1-4][1-4][1-4][1-4]|12345678|87654321) ! @@ -8692,7 +8714,7 @@ '') $echo $n ".$c" if $cc $ccflags \ $i_time $i_systime $i_systimek $sysselect $s_timeval $s_timezone \ --- 184,214 ---- dflt=`./try` case "$dflt" in [1-4][1-4][1-4][1-4]|12345678|87654321) ! @@ -8707,18 +8731,18 @@ ! $cc $ccflags -c bar1.c >/dev/null 2>&1 ! $cc $ccflags -c bar2.c >/dev/null 2>&1 ! $cc $ccflags -c foo.c >/dev/null 2>&1 ! -ar rc bar$lib_ext bar2.o bar1.o >/dev/null 2>&1 ! +$ar rc bar$lib_ext bar2.o bar1.o >/dev/null 2>&1 ! if $cc $ccflags $ldflags -o foobar foo.o bar$lib_ext $libs > /dev/null 2>&1 && ! ./foobar >/dev/null 2>&1; then ! - echo "ar appears to generate random libraries itself." ! + echo "$ar appears to generate random libraries itself." ! orderlib=false ! ranlib=":" ! -elif ar ts bar$lib_ext >/dev/null 2>&1 && ! +elif $ar ts bar$lib_ext >/dev/null 2>&1 && ! $cc $ccflags $ldflags -o foobar foo.o bar$lib_ext $libs > /dev/null 2>&1 && ! ./foobar >/dev/null 2>&1; then ! - echo "a table of contents needs to be added with 'ar ts'." ! + echo "a table of contents needs to be added with '$ar ts'." ! orderlib=false ! - ranlib="ar ts" ! + ranlib="$ar ts" ! else ! case "$ranlib" in ! :) ranlib='';; ! @@ -8790,7 +8814,7 @@ '') $echo $n ".$c" if $cc $ccflags \ $i_time $i_systime $i_systimek $sysselect $s_timeval $s_timezone \ Index: perl5.004_01_02/os2/os2.c *** perl5.004_01/os2/os2.c Wed Apr 30 20:30:09 1997 --- perl5.004_01_02/os2/os2.c Tue Jul 29 01:44:50 1997 *************** *** 1196,1198 **** --- 1196,1311 ---- return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but grants TMP. */ } + + #undef flock + + /* This code was contributed by Rocco Caputo. */ + int + my_flock(int handle, int op) + { + FILELOCK rNull, rFull; + ULONG timeout, handle_type, flag_word; + APIRET rc; + int blocking, shared; + static int use_my = -1; + + if (use_my == -1) { + char *s = getenv("USE_PERL_FLOCK"); + if (s) + use_my = atoi(s); + else + use_my = 1; + } + if (!(_emx_env & 0x200) || !use_my) + return flock(handle, op); /* Delegate to EMX. */ + + // is this a file? + if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) || + (handle_type & 0xFF)) + { + errno = EBADF; + return -1; + } + // set lock/unlock ranges + rNull.lOffset = rNull.lRange = rFull.lOffset = 0; + rFull.lRange = 0x7FFFFFFF; + // set timeout for blocking + timeout = ((blocking = !(op & LOCK_NB))) ? 100 : 1; + // shared or exclusive? + shared = (op & LOCK_SH) ? 1 : 0; + // do not block the unlock + if (op & (LOCK_UN | LOCK_SH | LOCK_EX)) { + rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared); + switch (rc) { + case 0: + errno = 0; + return 0; + case ERROR_INVALID_HANDLE: + errno = EBADF; + return -1; + case ERROR_SHARING_BUFFER_EXCEEDED: + errno = ENOLCK; + return -1; + case ERROR_LOCK_VIOLATION: + break; // not an error + case ERROR_INVALID_PARAMETER: + case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: + case ERROR_READ_LOCKS_NOT_SUPPORTED: + errno = EINVAL; + return -1; + case ERROR_INTERRUPT: + errno = EINTR; + return -1; + default: + errno = EINVAL; + return -1; + } + } + // lock may block + if (op & (LOCK_SH | LOCK_EX)) { + // for blocking operations + for (;;) { + rc = + DosSetFileLocks( + handle, + &rNull, + &rFull, + timeout, + shared + ); + switch (rc) { + case 0: + errno = 0; + return 0; + case ERROR_INVALID_HANDLE: + errno = EBADF; + return -1; + case ERROR_SHARING_BUFFER_EXCEEDED: + errno = ENOLCK; + return -1; + case ERROR_LOCK_VIOLATION: + if (!blocking) { + errno = EWOULDBLOCK; + return -1; + } + break; + case ERROR_INVALID_PARAMETER: + case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: + case ERROR_READ_LOCKS_NOT_SUPPORTED: + errno = EINVAL; + return -1; + case ERROR_INTERRUPT: + errno = EINTR; + return -1; + default: + errno = EINVAL; + return -1; + } + // give away timeslice + DosSleep(1); + } + } + + errno = 0; + return 0; + } Index: perl5.004_01_02/os2/os2ish.h *** perl5.004_01/os2/os2ish.h Thu Apr 10 17:31:36 1997 --- perl5.004_01_02/os2/os2ish.h Tue Jul 29 01:44:50 1997 *************** *** 15,20 **** --- 15,21 ---- #define HAS_KILL #define HAS_WAIT #define HAS_DLERROR + #define HAS_WAITPID_RUNTIME (_emx_env & 0x200) /* USEMYBINMODE * This symbol, if defined, indicates that the program should *************** *** 125,130 **** --- 126,132 ---- #define fwrite1 fwrite #define my_getenv(var) getenv(var) + #define flock my_flock void *emx_calloc (size_t, size_t); void emx_free (void *); Index: perl5.004_01_02/perl.c *** perl5.004_01/perl.c Tue Jun 10 01:52:05 1997 --- perl5.004_01_02/perl.c Thu Jul 31 20:09:10 1997 *************** *** 527,532 **** --- 527,533 ---- /* my_exit() was called */ while (scopestack_ix > oldscope) LEAVE; + FREETMPS; curstash = defstash; if (endav) call_list(oldscope, endav); *************** *** 771,777 **** boot_core_UNIVERSAL(); if (xsinit) (*xsinit)(); /* in case linked C routines want magical variables */ ! #ifdef VMS init_os_extras(); #endif --- 772,778 ---- boot_core_UNIVERSAL(); if (xsinit) (*xsinit)(); /* in case linked C routines want magical variables */ ! #if defined(VMS) || defined(WIN32) init_os_extras(); #endif *************** *** 815,821 **** LEAVE; FREETMPS; ! #ifdef DEBUGGING_MSTATS if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2) dump_mstats("after compilation:"); #endif --- 816,822 ---- LEAVE; FREETMPS; ! #ifdef MYMALLOC if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2) dump_mstats("after compilation:"); #endif *************** *** 848,858 **** /* my_exit() was called */ while (scopestack_ix > oldscope) LEAVE; curstash = defstash; if (endav) call_list(oldscope, endav); ! FREETMPS; ! #ifdef DEBUGGING_MSTATS if (getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif --- 849,859 ---- /* my_exit() was called */ while (scopestack_ix > oldscope) LEAVE; + FREETMPS; curstash = defstash; if (endav) call_list(oldscope, endav); ! #ifdef MYMALLOC if (getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif *************** *** 1017,1022 **** --- 1018,1024 ---- bool oldcatch = CATCH_GET; dJMPENV; int ret; + OP* oldop = op; if (flags & G_DISCARD) { ENTER; *************** *** 1139,1144 **** --- 1141,1147 ---- FREETMPS; LEAVE; } + op = oldop; return retval; } *************** *** 1156,1162 **** I32 oldscope; dJMPENV; int ret; ! if (flags & G_DISCARD) { ENTER; SAVETMPS; --- 1159,1166 ---- I32 oldscope; dJMPENV; int ret; ! OP* oldop = op; ! if (flags & G_DISCARD) { ENTER; SAVETMPS; *************** *** 1227,1232 **** --- 1231,1237 ---- FREETMPS; LEAVE; } + op = oldop; return retval; } *************** *** 1595,1600 **** --- 1600,1607 ---- defgv = gv_fetchpv("_",TRUE, SVt_PVAV); errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV)); GvMULTI_on(errgv); + (void)form("%240s",""); /* Preallocate temp - for immediate signals. */ + sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */ sv_setpvn(GvSV(errgv), "", 0); curstash = defstash; compiling.cop_stash = defstash; *************** *** 1630,1640 **** /* additional extensions to try in each dir if scriptname not found */ #ifdef SEARCH_EXTS char *ext[] = { SEARCH_EXTS }; ! int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */ #else # define MAX_EXT_LEN 0 #endif #ifdef VMS if (dosearch) { int hasdir, idx = 0, deftypes = 1; --- 1637,1667 ---- /* additional extensions to try in each dir if scriptname not found */ #ifdef SEARCH_EXTS char *ext[] = { SEARCH_EXTS }; ! int extidx = 0, i = 0; ! char *curext = Nullch; #else # define MAX_EXT_LEN 0 #endif + /* + * If dosearch is true and if scriptname does not contain path + * delimiters, search the PATH for scriptname. + * + * If SEARCH_EXTS is also defined, will look for each + * scriptname{SEARCH_EXTS} whenever scriptname is not found + * while searching the PATH. + * + * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search + * proceeds as follows: + * If DOSISH: + * + look for ./scriptname{,.foo,.bar} + * + search the PATH for scriptname{,.foo,.bar} + * + * If !DOSISH: + * + look *only* in the PATH for scriptname{,.foo,.bar} (note + * this will not look in '.' if it's not in the PATH) + */ + #ifdef VMS if (dosearch) { int hasdir, idx = 0, deftypes = 1; *************** *** 1654,1691 **** continue; /* don't search dir with too-long name */ strcat(tokenbuf, scriptname); #else /* !VMS */ ! if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) { ! bufend = s + strlen(s); ! while (s < bufend) { ! #ifndef atarist ! s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend, #ifdef DOSISH ! ';', ! #else ! ':', #endif ! &len); ! #else /* atarist */ ! for (len = 0; *s && *s != ',' && *s != ';'; len++, s++) { if (len < sizeof tokenbuf) tokenbuf[len] = *s; } if (len < sizeof tokenbuf) tokenbuf[len] = '\0'; ! #endif /* atarist */ if (s < bufend) s++; if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf) continue; /* don't search dir with too-long name */ if (len - #if defined(atarist) && !defined(DOSISH) - && tokenbuf[len - 1] != '/' - #endif #if defined(atarist) || defined(DOSISH) && tokenbuf[len - 1] != '\\' #endif ) tokenbuf[len++] = '/'; (void)strcpy(tokenbuf + len, scriptname); #endif /* !VMS */ --- 1681,1760 ---- continue; /* don't search dir with too-long name */ strcat(tokenbuf, scriptname); #else /* !VMS */ ! #ifdef DOSISH ! if (strEQ(scriptname, "-")) ! dosearch = 0; ! if (dosearch) { /* Look in '.' first. */ ! char *cur = scriptname; ! #ifdef SEARCH_EXTS ! if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ ! while (ext[i]) ! if (strEQ(ext[i++],curext)) { ! extidx = -1; /* already has an ext */ ! break; ! } ! do { #endif ! DEBUG_p(PerlIO_printf(Perl_debug_log, ! "Looking for %s\n",cur)); ! if (Stat(cur,&statbuf) >= 0) { ! dosearch = 0; ! scriptname = cur; ! break; ! } ! #ifdef SEARCH_EXTS ! if (cur == scriptname) { ! len = strlen(scriptname); ! if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf)) ! break; ! cur = strcpy(tokenbuf, scriptname); ! } ! } while (extidx >= 0 && ext[extidx] /* try an extension? */ ! && strcpy(tokenbuf+len, ext[extidx++])); ! #endif ! } ! #endif ! ! if (dosearch && !strchr(scriptname, '/') ! #ifdef DOSISH ! && !strchr(scriptname, '\\') ! && Stat(scriptname,&statbuf) < 0 /* Look in '.' first. */ ! #endif ! && (s = getenv("PATH"))) { ! bool seen_dot = 0; ! ! bufend = s + strlen(s); ! while (s < bufend) { ! #if defined(atarist) || defined(DOSISH) ! for (len = 0; *s ! # ifdef atarist ! && *s != ',' ! # endif ! && *s != ';'; len++, s++) { if (len < sizeof tokenbuf) tokenbuf[len] = *s; } if (len < sizeof tokenbuf) tokenbuf[len] = '\0'; ! #else /* ! (atarist || DOSISH) */ ! s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend, ! ':', ! &len); ! #endif /* ! (atarist || DOSISH) */ if (s < bufend) s++; if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf) continue; /* don't search dir with too-long name */ if (len #if defined(atarist) || defined(DOSISH) + && tokenbuf[len - 1] != '/' && tokenbuf[len - 1] != '\\' #endif ) tokenbuf[len++] = '/'; + if (len == 2 && tokenbuf[0] == '.') + seen_dot = 1; (void)strcpy(tokenbuf + len, scriptname); #endif /* !VMS */ *************** *** 2573,2582 **** /* my_exit() was called */ while (scopestack_ix > oldscope) LEAVE; curstash = defstash; if (endav) call_list(oldscope, endav); - FREETMPS; JMPENV_POP; curcop = &compiling; curcop->cop_line = oldline; --- 2642,2651 ---- /* my_exit() was called */ while (scopestack_ix > oldscope) LEAVE; + FREETMPS; curstash = defstash; if (endav) call_list(oldscope, endav); JMPENV_POP; curcop = &compiling; curcop->cop_line = oldline; Index: perl5.004_01_02/perl.h *** perl5.004_01/perl.h Tue Jun 10 01:48:58 1997 --- perl5.004_01_02/perl.h Thu Jul 31 19:19:13 1997 *************** *** 1277,1287 **** # ifndef register # define register # endif - # ifdef MYMALLOC - # ifndef DEBUGGING_MSTATS - # define DEBUGGING_MSTATS - # endif - # endif # define PAD_SV(po) pad_sv(po) #else # define PAD_SV(po) curpad[po] --- 1277,1282 ---- Index: perl5.004_01_02/pod/perlapio.pod *** perl5.004_01/pod/perlapio.pod Sat Mar 29 23:37:24 1997 --- perl5.004_01_02/pod/perlapio.pod Thu Jul 31 21:05:39 1997 *************** *** 99,110 **** =item B ! =item B, B These correspond to fputs() and fputc(). Note that arguments have been revised to have "file" first. ! =item B This corresponds to ungetc(). Note that arguments have been revised to have "file" first. --- 99,110 ---- =item B ! =item B, B These correspond to fputs() and fputc(). Note that arguments have been revised to have "file" first. ! =item B This corresponds to ungetc(). Note that arguments have been revised to have "file" first. Index: perl5.004_01_02/pod/perldebug.pod *** perl5.004_01/pod/perldebug.pod Thu Jun 12 00:37:33 1997 --- perl5.004_01_02/pod/perldebug.pod Thu Jul 31 21:56:41 1997 *************** *** 8,13 **** --- 8,22 ---- =head1 The Perl Debugger + "As soon as we started programming, we found to our + surprise that it wasn't as easy to get programs right + as we had thought. Debugging had to be discovered. + I can remember the exact instant when I realized that + a large part of my life from then on was going to be + spent in finding mistakes in my own programs." + + I< --Maurice Wilkes, 1949> + If you invoke Perl with the B<-d> switch, your script runs under the Perl source debugger. This works like an interactive Perl environment, prompting for debugger commands that let you examine Index: perl5.004_01_02/pod/perldelta.pod *** perl5.004_01/pod/perldelta.pod Wed Jun 11 03:03:22 1997 --- perl5.004_01_02/pod/perldelta.pod Thu Jul 31 23:36:45 1997 *************** *** 147,152 **** --- 147,159 ---- old (broken) way inside strings; but it generates this message as a warning. And in Perl 5.005, this special treatment will cease. + =head2 Fixed localization of $, $&, etc. + + Perl versions before 5.004 did not always properly localize the + regex-related special variables. Perl 5.004 does localize them, as + the documentation has always said it should. This may result in $1, + $2, etc. no longer being set where existing programs use them. + =head2 No resetting of $. on implicit close The documentation for Perl 5.0 has always stated that C<$.> is I *************** *** 495,500 **** --- 502,522 ---- $i . + However, it still fails (without a warning) if the foreach is within a + subroutine: + + my $i; + sub foo { + foreach $i ( 1 .. 10 ) { + write; + } + } + foo; + format = + my i is @# + $i + . + =back =head2 New builtin methods *************** *** 631,653 **** =head2 Malloc enhancements ! Four new compilation flags are recognized by malloc.c. (They have no ! effect if perl is compiled with system malloc().) ! ! =over ! ! =item -DDEBUGGING_MSTATS ! ! If perl is compiled with C defined, you can print memory statistics at runtime by running Perl thusly: env PERL_DEBUG_MSTATS=2 perl your_script_here The value of 2 means to print statistics after compilation and on ! exit; with a value of 1, the statistics ares printed only on exit. (If you want the statistics at an arbitrary time, you'll need to install the optional module Devel::Peek.) =item -DEMERGENCY_SBRK If this macro is defined, running out of memory need not be a fatal --- 653,674 ---- =head2 Malloc enhancements ! If perl is compiled with the malloc included with the perl distribution ! (that is, if C is 'define') then you can print memory statistics at runtime by running Perl thusly: env PERL_DEBUG_MSTATS=2 perl your_script_here The value of 2 means to print statistics after compilation and on ! exit; with a value of 1, the statistics are printed only on exit. (If you want the statistics at an arbitrary time, you'll need to install the optional module Devel::Peek.) + Three new compilation flags are recognized by malloc.c. (They have no + effect if perl is compiled with system malloc().) + + =over + =item -DEMERGENCY_SBRK If this macro is defined, running out of memory need not be a fatal *************** *** 705,711 **** Perl 5.004 now includes support for building a "native" perl under Windows NT, using the Microsoft Visual C++ compiler (versions 2.0 ! and above). The resulting perl can be used under Windows 95 (if it is installed in the same directory locations as it got installed in Windows NT). This port includes support for perl extension building tools like L and L, so that many extensions --- 726,733 ---- Perl 5.004 now includes support for building a "native" perl under Windows NT, using the Microsoft Visual C++ compiler (versions 2.0 ! and above) or the Borland C++ compiler (versions 5.02 and above). ! The resulting perl can be used under Windows 95 (if it is installed in the same directory locations as it got installed in Windows NT). This port includes support for perl extension building tools like L and L, so that many extensions *************** *** 719,726 **** many UNIX programs under Windows NT by providing a mostly UNIX-like interface for compilation and execution. See L for more details on this port, and how to obtain the Cygwin32 toolkit. - This port has not been as well tested as the "native" port described - above (which is not as well tested as we'd like either :) =head2 Plan 9 --- 741,746 ---- Index: perl5.004_01_02/pod/perldiag.pod *** perl5.004_01/pod/perldiag.pod Tue Jun 10 02:11:59 1997 --- perl5.004_01_02/pod/perldiag.pod Thu Jul 31 21:05:08 1997 *************** *** 23,29 **** Some of these messages are generic. Spots that vary are denoted with a %s, just as in a printf format. Note that some messages start with a %s! ! The symbols C<"%-?@> sort before the letters, while C<[> and C<\> sort after. =over 4 --- 23,29 ---- Some of these messages are generic. Spots that vary are denoted with a %s, just as in a printf format. Note that some messages start with a %s! ! The symbols C<"%(-?@> sort before the letters, while C<[> and C<\> sort after. =over 4 *************** *** 143,148 **** --- 143,154 ---- instead of Perl. Check the #! line, or manually feed your script into Perl yourself. + =item (Missing semicolon on previous line?) + + (S) This is an educated guess made in conjunction with the message "%s + found where operator expected". Don't automatically put a semicolon on + the previous line just because you saw this message. + =item B<-P> not allowed for setuid/setgid script (F) The script would have to be opened by the C preprocessor by name, *************** *** 153,158 **** --- 159,170 ---- (F) Perl can't peek at the stdio buffer of filehandles when it doesn't know about your kind of stdio. You'll have to use a filename instead. + =item C<-p> destination: %s + + (F) An error occurred during the implicit output invoked by the C<-p> + command-line switch. (This output goes to STDOUT unless you've + redirected it with select().) + =item 500 Server error See Server error. *************** *** 374,379 **** --- 386,396 ---- occurs if you tried to jump out of a sort() block or subroutine, which is a no-no. See L. + =item Can't "goto" into the middle of a foreach loop + + (F) A "goto" statement was executed to jump into the middle of a + foreach loop. You can't get there from here. See L. + =item Can't "last" outside a block (F) A "last" statement was executed to break out of the current block, *************** *** 543,550 **** =item Can't execute %s (F) You used the B<-S> switch, but the script to execute could not be found ! in the PATH, or at least not with the correct permissions. =item Can't find label %s --- 560,578 ---- =item Can't execute %s + (F) You used the B<-S> switch, but the copies of the script to execute found + in the PATH did not have correct permissions. + + =item Can't find %s on PATH, '.' not in PATH + (F) You used the B<-S> switch, but the script to execute could not be found ! in the PATH, or at least not with the correct permissions. The script ! exists in the current directory, but PATH prohibits running it. ! ! =item Can't find %s on PATH ! ! (F) You used the B<-S> switch, but the script to execute could not be found ! in the PATH. =item Can't find label %s *************** *** 597,608 **** you should be calling it out of only an AUTOLOAD routine anyway. See L. ! =item Can't localize a reference ! (F) You said something like C, which is not allowed because ! the compiler can't determine whether $ref will end up pointing to anything ! with a symbol table entry, and a symbol table entry is necessary to ! do a local. =item Can't localize lexical variable %s --- 625,636 ---- you should be calling it out of only an AUTOLOAD routine anyway. See L. ! =item Can't localize through a reference ! (F) You said something like C, which Perl can't currently ! handle, because when it goes to restore the old value of whatever $ref ! pointed to after the scope of the local() is finished, it can't be ! sure that $ref will still be a reference. =item Can't localize lexical variable %s *************** *** 611,616 **** --- 639,651 ---- localize a package variable of the same name, qualify it with the package name. + =item Can't locate auto/%s.al in @INC + + (F) A function (or method) was called in a package which allows autoload, + but there is no function to autoload. Most probable causes are a misprint + in a function/method name or a failure to C the file, say, by + doing C. + =item Can't locate %s in @INC (F) You said to do (or require, or use) a file that couldn't be found *************** *** 656,663 **** =item Can't open %s: %s ! (S) An inplace edit couldn't open the original file for the indicated reason. ! Usually this is because you don't have read permission for the file. =item Can't open bidirectional pipe --- 691,701 ---- =item Can't open %s: %s ! (S) The implicit opening of a file through use of the CE> ! filehandle, either implicitly under the C<-n> or C<-p> command-line ! switches, or explicitly, failed for the indicated reason. Usually this ! is because you don't have read permission for a file which you named ! on the command line. =item Can't open bidirectional pipe *************** *** 1342,1353 **** As a general rule, you'll find it's missing near the place you were last editing. - =item Missing semicolon on previous line? - - (S) This is an educated guess made in conjunction with the message "%s - found where operator expected". Don't automatically put a semicolon on - the previous line just because you saw this message. - =item Modification of a read-only value attempted (F) You tried, directly or indirectly, to change the value of a --- 1380,1385 ---- *************** *** 2069,2074 **** --- 2101,2110 ---- (W) The filehandle you're sending to got itself closed sometime before now. Check your logic flow. + + =item Sequence (? incomplete + (F) A regular expression ended with an incomplete extension (?. + See L. =item Sequence (?#... not terminated Index: perl5.004_01_02/pod/perlembed.pod *** perl5.004_01/pod/perlembed.pod Fri Jun 6 23:44:47 1997 --- perl5.004_01_02/pod/perlembed.pod Thu Jul 31 22:53:30 1997 *************** *** 332,486 **** =head2 Performing Perl pattern matches and substitutions from your C program ! The I function lets us evaluate strings of Perl code, so we can define some functions that use it to "specialize" in matches and substitutions: I, I, and I. ! char match(char *string, char *pattern); Given a string and a pattern (e.g., C or C, which in your C program might appear as "/\\b\\w*\\b/"), match() returns 1 if the string matches the pattern and 0 otherwise. ! int substitute(char *string[], char *pattern); ! Given a pointer to a string and an C<=~> operation (e.g., C or C), substitute() modifies the string ! according to the operation, returning the number of substitutions made. ! int matches(char *string, char *pattern, char **matches[]); ! Given a string, a pattern, and a pointer to an empty array of strings, matches() evaluates C<$string =~ $pattern> in an array context, and ! fills in I with the array elements (allocating memory as it ! does so), returning the number of matches found. Here's a sample program, I, that uses all three (long lines have been wrapped here): ! #include ! #include ! ! static PerlInterpreter *my_perl; ! ! /** match(string, pattern) ! ** ! ** Used for matches in a scalar context. ! ** ! ** Returns 1 if the match was successful; 0 otherwise. ! **/ ! char match(char *string, char *pattern) ! { ! char *command; ! command = malloc(sizeof(char) * strlen(string) + strlen(pattern) + 37); ! sprintf(command, "$string = '%s'; $return = $string =~ %s", ! string, pattern); ! perl_eval_pv(command, TRUE); ! free(command); ! return SvIV(perl_get_sv("return", FALSE)); ! } ! /** substitute(string, pattern) ! ** ! ** Used for =~ operations that modify their left-hand side (s/// and tr///) ! ** ! ** Returns the number of successful matches, and ! ** modifies the input string if there were any. ! **/ ! int substitute(char *string[], char *pattern) ! { ! char *command; ! STRLEN length; ! command = malloc(sizeof(char) * strlen(*string) + strlen(pattern) + 35); ! sprintf(command, "$string = '%s'; $ret = ($string =~ %s)", ! *string, pattern); ! perl_eval_pv(command, TRUE); ! free(command); ! *string = SvPV(perl_get_sv("string", FALSE), length); ! return SvIV(perl_get_sv("ret", FALSE)); ! } ! /** matches(string, pattern, matches) ! ** ! ** Used for matches in an array context. ! ** ! ** Returns the number of matches, ! ** and fills in **matches with the matching substrings (allocates memory!) ! **/ ! int matches(char *string, char *pattern, char **match_list[]) ! { ! char *command; ! SV *current_match; ! AV *array; I32 num_matches; ! STRLEN length; ! int i; ! command = malloc(sizeof(char) * strlen(string) + strlen(pattern) + 38); ! sprintf(command, "$string = '%s'; @array = ($string =~ %s)", ! string, pattern); ! perl_eval_pv(command, TRUE); ! free(command); ! array = perl_get_av("array", FALSE); ! num_matches = av_len(array) + 1; /** assume $[ is 0 **/ ! *match_list = (char **) malloc(sizeof(char *) * num_matches); ! for (i = 0; i <= num_matches; i++) { ! current_match = av_shift(array); ! (*match_list)[i] = SvPV(current_match, length); ! } return num_matches; ! } ! main (int argc, char **argv, char **env) ! { char *embedding[] = { "", "-e", "0" }; ! char *text, **match_list; ! int num_matches, i; ! int j; ! my_perl = perl_alloc(); ! perl_construct( my_perl ); perl_parse(my_perl, NULL, 3, embedding, NULL); ! perl_run(my_perl); ! ! text = (char *) malloc(sizeof(char) * 486); /** A long string follows! **/ ! sprintf(text, "%s", "When he is at a convenience store and the bill \ ! comes to some amount like 76 cents, Maynard is aware that there is \ ! something he *should* do, something that will enable him to get back \ ! a quarter, but he has no idea *what*. He fumbles through his red \ ! squeezey changepurse and gives the boy three extra pennies with his \ ! dollar, hoping that he might luck into the correct amount. The boy \ ! gives him back two of his own pennies and then the big shiny quarter \ ! that is his prize. -RICHH"); if (match(text, "m/quarter/")) /** Does text contain 'quarter'? **/ ! printf("match: Text contains the word 'quarter'.\n\n"); else ! printf("match: Text doesn't contain the word 'quarter'.\n\n"); if (match(text, "m/eighth/")) /** Does text contain 'eighth'? **/ ! printf("match: Text contains the word 'eighth'.\n\n"); else ! printf("match: Text doesn't contain the word 'eighth'.\n\n"); /** Match all occurrences of /wi../ **/ num_matches = matches(text, "m/(wi..)/g", &match_list); printf("matches: m/(wi..)/g found %d matches...\n", num_matches); for (i = 0; i < num_matches; i++) ! printf("match: %s\n", match_list[i]); printf("\n"); ! for (i = 0; i < num_matches; i++) { ! free(match_list[i]); ! } ! free(match_list); /** Remove all vowels from text **/ num_matches = substitute(&text, "s/[aeiou]//gi"); if (num_matches) { ! printf("substitute: s/[aeiou]//gi...%d substitutions made.\n", ! num_matches); ! printf("Now text is: %s\n\n", text); } /** Attempt a substitution **/ if (!substitute(&text, "s/Perl/C/")) { ! printf("substitute: s/Perl/C...No substitution made.\n\n"); } ! free(text); perl_destruct(my_perl); perl_free(my_perl); ! } which produces the output (again, long lines have been wrapped here) --- 332,504 ---- =head2 Performing Perl pattern matches and substitutions from your C program ! The I function lets us evaluate chunks of Perl code, so we can define some functions that use it to "specialize" in matches and substitutions: I, I, and I. ! char match(SV *string, char *pattern); Given a string and a pattern (e.g., C or C, which in your C program might appear as "/\\b\\w*\\b/"), match() returns 1 if the string matches the pattern and 0 otherwise. ! int substitute(SV **string, char *pattern); ! Given a pointer to an C and an C<=~> operation (e.g., C or C), substitute() modifies the string ! within the C at according to the operation, returning the number of substitutions made. ! int matches(SV *string, char *pattern, AV **matches); ! Given an C, a pattern, and a pointer to an empty C, matches() evaluates C<$string =~ $pattern> in an array context, and ! fills in I with the array elements, returning the number of matches found. Here's a sample program, I, that uses all three (long lines have been wrapped here): ! #include ! #include ! ! /** my_perl_eval_sv(code, error_check) ! ** kinda like perl_eval_sv(), ! ** but we pop the return value off the stack ! **/ ! SV* my_perl_eval_sv(SV *sv, I32 croak_on_error) ! { ! dSP; ! SV* retval; ! ! PUSHMARK(sp); ! perl_eval_sv(sv, G_SCALAR); ! ! SPAGAIN; ! retval = POPs; ! PUTBACK; ! ! if (croak_on_error && SvTRUE(GvSV(errgv))) ! croak(SvPVx(GvSV(errgv), na)); ! ! return retval; ! } ! ! /** match(string, pattern) ! ** ! ** Used for matches in a scalar context. ! ** ! ** Returns 1 if the match was successful; 0 otherwise. ! **/ ! ! I32 match(SV *string, char *pattern) ! { ! SV *command = newSV(0), *retval; ! ! sv_setpvf(command, "my $string = '%s'; $string =~ %s", ! SvPV(string,na), pattern); ! ! retval = my_perl_eval_sv(command, TRUE); ! SvREFCNT_dec(command); ! ! return SvIV(retval); ! } ! ! /** substitute(string, pattern) ! ** ! ** Used for =~ operations that modify their left-hand side (s/// and tr///) ! ** ! ** Returns the number of successful matches, and ! ** modifies the input string if there were any. ! **/ ! ! I32 substitute(SV **string, char *pattern) ! { ! SV *command = newSV(0), *retval; ! ! sv_setpvf(command, "$string = '%s'; ($string =~ %s)", ! SvPV(*string,na), pattern); ! ! retval = my_perl_eval_sv(command, TRUE); ! SvREFCNT_dec(command); ! ! *string = perl_get_sv("string", FALSE); ! return SvIV(retval); ! } ! ! /** matches(string, pattern, matches) ! ** ! ** Used for matches in an array context. ! ** ! ** Returns the number of matches, ! ** and fills in **matches with the matching substrings ! **/ ! ! I32 matches(SV *string, char *pattern, AV **match_list) ! { ! SV *command = newSV(0); I32 num_matches; ! ! sv_setpvf(command, "my $string = '%s'; @array = ($string =~ %s)", ! SvPV(string,na), pattern); ! ! my_perl_eval_sv(command, TRUE); ! SvREFCNT_dec(command); ! ! *match_list = perl_get_av("array", FALSE); ! num_matches = av_len(*match_list) + 1; /** assume $[ is 0 **/ ! return num_matches; ! } ! ! main (int argc, char **argv, char **env) ! { ! PerlInterpreter *my_perl = perl_alloc(); char *embedding[] = { "", "-e", "0" }; ! AV *match_list; ! I32 num_matches, i; ! SV *text = newSV(0); ! ! perl_construct(my_perl); perl_parse(my_perl, NULL, 3, embedding, NULL); ! ! sv_setpv(text, "When he is at a convenience store and the bill comes to some amount like 76 cents, Maynard is aware that there is something he *should* do, something that will enable him to get back a quarter, but he has no idea *what*. He fumbles through his red squeezey changepurse and gives the boy three extra pennies with his dollar, hoping that he might luck into the correct amount. The boy gives him back two of his own pennies and then the big shiny quarter that is his prize. -RICHH"); ! if (match(text, "m/quarter/")) /** Does text contain 'quarter'? **/ ! printf("match: Text contains the word 'quarter'.\n\n"); else ! printf("match: Text doesn't contain the word 'quarter'.\n\n"); ! if (match(text, "m/eighth/")) /** Does text contain 'eighth'? **/ ! printf("match: Text contains the word 'eighth'.\n\n"); else ! printf("match: Text doesn't contain the word 'eighth'.\n\n"); ! /** Match all occurrences of /wi../ **/ num_matches = matches(text, "m/(wi..)/g", &match_list); printf("matches: m/(wi..)/g found %d matches...\n", num_matches); + for (i = 0; i < num_matches; i++) ! printf("match: %s\n", SvPV(*av_fetch(match_list, i, FALSE),na)); printf("\n"); ! /** Remove all vowels from text **/ num_matches = substitute(&text, "s/[aeiou]//gi"); if (num_matches) { ! printf("substitute: s/[aeiou]//gi...%d substitutions made.\n", ! num_matches); ! printf("Now text is: %s\n\n", SvPV(text,na)); } + /** Attempt a substitution **/ if (!substitute(&text, "s/Perl/C/")) { ! printf("substitute: s/Perl/C...No substitution made.\n\n"); } ! ! SvREFCNT_dec(text); ! perl_destruct_level = 1; perl_destruct(my_perl); perl_free(my_perl); ! } which produces the output (again, long lines have been wrapped here) *************** *** 560,574 **** int main (int argc, char **argv, char **env) { ! char *my_argv[2]; my_perl = perl_alloc(); perl_construct( my_perl ); ! my_argv[1] = (char *) malloc(10); ! sprintf(my_argv[1], "power.pl"); ! ! perl_parse(my_perl, NULL, argc, my_argv, NULL); perl_run(my_perl); PerlPower(3, 4); /*** Compute 3 ** 4 ***/ --- 578,589 ---- int main (int argc, char **argv, char **env) { ! char *my_argv[] = { "", "power.pl" }; my_perl = perl_alloc(); perl_construct( my_perl ); ! perl_parse(my_perl, NULL, 2, my_argv, (char **)NULL); perl_run(my_perl); PerlPower(3, 4); /*** Compute 3 ** 4 ***/ *************** *** 995,1001 **** Check out Doug's article on embedding in Volume 1, Issue 4 of The Perl Journal. Info about TPJ is available from http://tpj.com. ! April 14, 1997 Some of this material is excerpted from Jon Orwant's book: I, Waite Group Press, 1996 (ISBN 1-57169-064-6) and appears --- 1010,1016 ---- Check out Doug's article on embedding in Volume 1, Issue 4 of The Perl Journal. Info about TPJ is available from http://tpj.com. ! July 17, 1997 Some of this material is excerpted from Jon Orwant's book: I, Waite Group Press, 1996 (ISBN 1-57169-064-6) and appears Index: perl5.004_01_02/pod/perlfunc.pod *** perl5.004_01/pod/perlfunc.pod Thu Jun 12 22:52:45 1997 --- perl5.004_01_02/pod/perlfunc.pod Thu Jul 31 21:06:57 1997 *************** *** 1032,1048 **** The exec() function executes a system command I, unless the command does not exist and is executed directly instead of ! via C (see below). Use system() instead of exec() if you ! want it to return. 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 ! metacharacters. If there are any, the entire argument is passed to ! C for parsing. If there are none, the argument is split ! into words and passed directly to execvp(), which is more efficient. ! Note: exec() and system() do not flush your output buffer, so you may ! need to set C<$|> to avoid lost output. Examples: exec '/bin/echo', 'Your arguments are: ', @ARGV; exec "sort $outfile | uniq"; --- 1032,1050 ---- The exec() function executes a system command I, unless the command does not exist and is executed directly instead of ! via your system's command shell (see below). Use system() instead of ! exec() if you want it to return. 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 ! metacharacters, and if there are any, the entire argument is passed to ! the system's command shell for parsing (this is C on Unix ! platforms, but varies on other platforms). If there are no shell ! metacharacters in the argument, it is split into words and passed ! directly to execvp(), which is more efficient. Note: exec() and ! system() do not flush your output buffer, so you may need to set C<$|> ! to avoid lost output. Examples: exec '/bin/echo', 'Your arguments are: ', @ARGV; exec "sort $outfile | uniq"; *************** *** 1061,1066 **** --- 1063,1072 ---- exec {'/bin/csh'} '-sh'; # pretend it's a login shell + When the arguments get executed via the system shell, results will + be subject to its quirks and capabilities. See L + for details. + =item exists EXPR Returns TRUE if the specified hash key exists in its hash array, even *************** *** 2371,2376 **** --- 2377,2392 ---- @dots = grep { /^\./ && -f "$some_dir/$_" } readdir(DIR); closedir DIR; + =item readline EXPR + + Reads from the file handle EXPR. In scalar context, a single line + is read and returned. In list context, reads until end-of-file is + reached and returns a list of lines (however you've defined lines + with $/ or $INPUT_RECORD_SEPARATOR). + This is the internal function implementing the CEXPRE> + operator, but you can use it directly. The CEXPRE> + operator is discussed in more detail in L. + =item readlink EXPR =item readlink *************** *** 2380,2385 **** --- 2396,2412 ---- error, returns the undefined value and sets C<$!> (errno). If EXPR is omitted, uses $_. + =item readpipe EXPR + + EXPR is interpolated and then executed as a system command. + The collected standard output of the command is returned. + In scalar context, it comes back as a single (potentially + multi-line) string. In list context, returns a list of lines + (however you've defined lines with $/ or $INPUT_RECORD_SEPARATOR). + This is the internal function implementing the C + operator, but you can use it directly. The C + operator is discussed in more detail in L. + =item recv SOCKET,SCALAR,LEN,FLAGS Receives a message on a socket. Attempts to receive LENGTH bytes of *************** *** 3336,3346 **** Extracts a substring out of EXPR and returns it. First character is at offset 0, or whatever you've set C<$[> to (but don't do that). ! If OFFSET is negative, starts that far from the end of the string. If LEN is omitted, returns everything to the end of the string. If LEN is negative, leaves that many characters off the end of the string. You can use the substr() function as an lvalue, in which case EXPR must be an lvalue. If you assign something shorter than LEN, the string will shrink, and if you assign --- 3363,3377 ---- Extracts a substring out of EXPR and returns it. First character is at offset 0, or whatever you've set C<$[> to (but don't do that). ! If OFFSET is negative (or more precisely, less than C<$[>), starts that far from the end of the string. If LEN is omitted, returns everything to the end of the string. If LEN is negative, leaves that many characters off the end of the string. + If you specify a substring which is partly outside the string, the part + within the string is returned. If the substring is totally outside + the string a warning is produced. + You can use the substr() function as an lvalue, in which case EXPR must be an lvalue. If you assign something shorter than LEN, the string will shrink, and if you assign *************** *** 3479,3484 **** --- 3510,3519 ---- print "signal $rc\n" } $ok = ($rc != 0); + + When the arguments get executed via the system shell, results will + be subject to its quirks and capabilities. See L + for details. =item syswrite FILEHANDLE,SCALAR,LENGTH,OFFSET Index: perl5.004_01_02/pod/perlguts.pod *** perl5.004_01/pod/perlguts.pod Fri Jun 6 23:58:12 1997 --- perl5.004_01_02/pod/perlguts.pod Thu Jul 31 19:36:37 1997 *************** *** 765,816 **** The current kinds of Magic Virtual Tables are: ! mg_type MGVTBL Type of magical ------- ------ ---------------------------- ! \0 vtbl_sv Regexp??? ! A vtbl_amagic Operator Overloading ! a vtbl_amagicelem Operator Overloading ! c 0 Used in Operator Overloading ! B vtbl_bm Boyer-Moore??? E vtbl_env %ENV hash e vtbl_envelem %ENV hash element ! g vtbl_mglob Regexp /g flag??? I vtbl_isa @ISA array i vtbl_isaelem @ISA array element ! L 0 (but sets RMAGICAL) Perl Module/Debugger??? ! l vtbl_dbline Debugger? o vtbl_collxfrm Locale transformation ! P vtbl_pack Tied Array or Hash ! p vtbl_packelem Tied Array or Hash element ! q vtbl_packelem Tied Scalar or Handle ! S vtbl_sig Signal Hash ! s vtbl_sigelem Signal Hash element t vtbl_taint Taintedness ! U vtbl_uvar ??? ! v vtbl_vec Vector ! x vtbl_substr Substring??? ! y vtbl_itervar Shadow "foreach" iterator variable ! * vtbl_glob GV??? ! # vtbl_arylen Array Length ! . vtbl_pos $. scalar variable ! ~ None Used by certain extensions When an uppercase and lowercase letter both exist in the table, then the uppercase letter is used to represent some kind of composite type (a list or a hash), and the lowercase letter is used to represent an element of that composite type. ! The '~' magic type is defined specifically for use by extensions and ! will not be used by perl itself. Extensions can use ~ magic to 'attach' ! private information to variables (typically objects). This is especially ! useful because there is no way for normal perl code to corrupt this ! private information (unlike using extra elements of a hash object). ! ! Note that because multiple extensions may be using ~ magic it is ! important for extensions to take extra care with it. Typically only ! using it on objects blessed into the same class as the extension ! is sufficient. It may also be appropriate to add an I32 'signature' ! at the top of the private data area and check that. =head2 Finding Magic --- 765,835 ---- The current kinds of Magic Virtual Tables are: ! mg_type MGVTBL Type of magic ------- ------ ---------------------------- ! \0 vtbl_sv Special scalar variable ! A vtbl_amagic %OVERLOAD hash ! a vtbl_amagicelem %OVERLOAD hash element ! c (none) Holds overload table (AMT) on stash ! B vtbl_bm Boyer-Moore (fast string search) E vtbl_env %ENV hash e vtbl_envelem %ENV hash element ! f vtbl_fm Formline ('compiled' format) ! g vtbl_mglob m//g target / study()ed string I vtbl_isa @ISA array i vtbl_isaelem @ISA array element ! k vtbl_nkeys scalar(keys()) lvalue ! L (none) Debugger %_'s ! C field points to a C structure: ! ! struct ufuncs { ! I32 (*uf_val)(IV, SV*); ! I32 (*uf_set)(IV, SV*); ! IV uf_index; ! }; ! ! When the SV is read from or written to, the C or C ! function will be called with C as the first arg and a ! pointer to the SV as the second. ! ! Note that because multiple extensions may be using '~' or 'U' magic, ! it is important for extensions to take extra care to avoid conflict. ! Typically only using the magic on objects blessed into the same class ! as the extension is sufficient. For '~' magic, it may also be ! appropriate to add an I32 'signature' at the top of the private data ! area and check that. =head2 Finding Magic *************** *** 885,890 **** --- 904,1053 ---- substantial, but if they are only a few statements long, the overhead will not be insignificant. + =head2 Localizing changes + + Perl has a very handy construction + + { + local $var = 2; + ... + } + + This construction is I equivalent to + + { + my $oldvar = $var; + $var = 2; + ... + $var = $oldvar; + } + + The biggest difference is that the first construction would + reinstate the initial value of $var, irrespective of how control exits + the block: C, C, C/C etc. It is a little bit + more efficient as well. + + There is a way to achieve a similar task from C via Perl API: create a + I, and arrange for some changes to be automatically + undone at the end of it, either explicit, or via a non-local exit (via + die()). A I-like construct is created by a pair of + C/C macros (see L). Such a construct may be created specially for some + important localized task, or an existing one (like boundaries of + enclosing Perl subroutine/block, or an existing pair for freeing TMPs) + may be used. (In the second case the overhead of additional + localization must be almost negligible.) Note that any XSUB is + automatically enclosed in an C/C pair. + + Inside such a I the following service is available: + + =over + + =item C + + =item C + + =item C + + =item C + + These macros arrange things to restore the value of integer variable + C at the end of enclosing I. + + =item C + + =item C + + These macros arrange things to restore the value of pointers C and + C

. C must be a pointer of a type which survives conversion to + C and back, C

should be able to survive conversion to C + and back. + + =item C + + The refcount of C would be decremented at the end of + I. This is similar to C, which should (?) be + used instead. + + =item C + + The C is op_free()ed at the end of I. + + =item C + + The chunk of memory which is pointed to by C

is Safefree()ed at the + end of I. + + =item C + + Clears a slot in the current scratchpad which corresponds to C at + the end of I. + + =item C + + The key C of C is deleted at the end of I. The + string pointed to by C is Safefree()ed. If one has a I in + short-lived storage, the corresponding string may be reallocated like + this: + + SAVEDELETE(defstash, savepv(tmpbuf), strlen(tmpbuf)); + + =item C + + At the end of I the function C is called with the + only argument (of type C) C

. + + =item C + + The current offset on the Perl internal stack (cf. C) is restored + at the end of I. + + =back + + The following API list contains functions, thus one needs to + provide pointers to the modifiable data explicitly (either C pointers, + or Perlish Cs). Where the above macros take C, a similar + function takes C. + + =over + + =item C + + Equivalent to Perl code C. + + =item C + + =item C + + Similar to C, but localize C<@gv> and C<%gv>. + + =item C + + Duplicates the current value of C, on the exit from the current + C/C I will restore the value of C + using the stored value. + + =item C + + A variant of C which takes multiple arguments via an array + C of C of length C. + + =item C + + Similar to C, but will reinstate a C. + + =item C + + =item C + + Similar to C, but localize C and C. + + =back + + The C module implements localization of the basic types within the + I. People who are interested in how to localize things in + the containing scope should take a look there too. + =head1 Subroutines =head2 XSUBs and the Argument Stack *************** *** 1405,1415 **** Sets up the C variable for an XSUB which has aliases. This is usually handled automatically by C. - =item dXSI32 - - Sets up the C variable for an XSUB which has aliases. This is usually - handled automatically by C. - =item ENTER Opening bracket on a callback. See C and L. --- 1568,1573 ---- *************** *** 2364,2377 **** I32 sv_cmp _((SV* sv1, SV* sv2)); - =item sv_cmp - - Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the - string in C is less than, equal to, or greater than the string in - C. - - I32 sv_cmp _((SV* sv1, SV* sv2)); - =item SvCUR Returns the length of the string which is in the SV. See C. --- 2522,2527 ---- *************** *** 2390,2401 **** void sv_dec _((SV* sv)); - =item sv_dec - - Auto-decrement of the value in the SV. - - void sv_dec _((SV* sv)); - =item SvEND Returns a pointer to the last character in the string which is in the SV. --- 2540,2545 ---- *************** *** 2453,2464 **** SvIOK_on (SV* sv) - =item SvIOK_only - - Tells an SV that it is an integer and disables all other OK bits. - - SvIOK_on (SV* sv) - =item SvIOKp Returns a boolean indicating whether the SV contains an integer. Checks the --- 2597,2602 ---- *************** *** 2506,2517 **** STRLEN sv_len _((SV* sv)); - =item sv_len - - Returns the length of the string in the SV. Use C. - - STRLEN sv_len _((SV* sv)); - =item sv_magic Adds magic to an SV. --- 2644,2649 ---- *************** *** 2585,2596 **** SvNOK_on (SV* sv) - =item SvNOK_only - - Tells an SV that it is a double and disables all other OK bits. - - SvNOK_on (SV* sv) - =item SvNOKp Returns a boolean indicating whether the SV contains a double. Checks the --- 2717,2722 ---- *************** *** 2634,2645 **** SvPOK_on (SV* sv) - =item SvPOK_only - - Tells an SV that it is a string and disables all other OK bits. - - SvPOK_on (SV* sv) - =item SvPOKp Returns a boolean indicating whether the SV contains a character string. --- 2760,2765 ---- *************** *** 3050,3056 **** With lots of help and suggestions from Dean Roehrich, Malcolm Beattie, Andreas Koenig, Paul Hudson, Ilya Zakharevich, Paul Marquess, Neil ! Bowers, Matthew Green, Tim Bunce, Spider Boardman, and Ulrich Pfeifer. API Listing by Dean Roehrich >. --- 3170,3177 ---- With lots of help and suggestions from Dean Roehrich, Malcolm Beattie, Andreas Koenig, Paul Hudson, Ilya Zakharevich, Paul Marquess, Neil ! Bowers, Matthew Green, Tim Bunce, Spider Boardman, Ulrich Pfeifer, and ! Stephen McCamant. API Listing by Dean Roehrich >. Index: perl5.004_01_02/pod/perlop.pod *** perl5.004_01/pod/perlop.pod Fri Jun 6 23:55:21 1997 --- perl5.004_01_02/pod/perlop.pod Thu Jul 31 18:41:21 1997 *************** *** 808,813 **** --- 808,831 ---- $today = qx{ date }; + Note that how the string gets evaluated is entirely subject to the + command interpreter on your system. On most platforms, you will have + to protect shell metacharacters if you want them treated literally. + On some platforms (notably DOS-like ones), the shell may not be + capable of dealing with multiline commands, so putting newlines in + the string may not get you what you want. You may be able to evaluate + multiple commands in a single line by separating them with the command + separator character, if your shell supports that (e.g. C<;> on many Unix + shells; C<&> on the Windows NT C shell). + + Beware that some command shells may place restrictions on the length + of the command line. You must ensure your strings don't exceed this + limit after any necessary interpolations. See the platform-specific + release notes for more details about your particular environment. + + Also realize that using this operator frequently leads to unportable + programs. + See L<"I/O Operators"> for more discussion. =item qw/STRING/ Index: perl5.004_01_02/pod/perlre.pod *** perl5.004_01/pod/perlre.pod Thu May 8 18:26:25 1997 --- perl5.004_01_02/pod/perlre.pod Thu Jul 31 21:08:25 1997 *************** *** 515,521 **** first character after the "[" is "^", the class matches any character not in the list. Within a list, the "-" character is used to specify a range, so that C represents all the characters between "a" and "z", ! inclusive. Characters may be specified using a metacharacter syntax much like that used in C: "\n" matches a newline, "\t" a tab, "\r" a carriage return, --- 515,525 ---- first character after the "[" is "^", the class matches any character not in the list. Within a list, the "-" character is used to specify a range, so that C represents all the characters between "a" and "z", ! inclusive. If you want "-" itself to be a member of a class, put it ! at the start or end of the list, or escape it with a backslash. (The ! following all specify the same class of three characters: C<[-az]>, ! C<[az-]>, and C<[a\-z]>. All are different from C<[a-z]>, which ! specifies a class containing twenty-six characters.) Characters may be specified using a metacharacter syntax much like that used in C: "\n" matches a newline, "\t" a tab, "\r" a carriage return, Index: perl5.004_01_02/pod/perlrun.pod *** perl5.004_01/pod/perlrun.pod Fri Jun 6 22:50:00 1997 --- perl5.004_01_02/pod/perlrun.pod Thu Jul 31 20:52:32 1997 *************** *** 376,383 **** } Note that the lines are not printed by default. See B<-p> to have ! lines printed. Here is an efficient way to delete all files older than ! a week: find . -mtime +7 -print | perl -nle 'unlink;' --- 376,385 ---- } Note that the lines are not printed by default. See B<-p> to have ! lines printed. If a file named by an argument cannot be opened for ! some reason, Perl warns you about it, and moves on to the next file. ! ! Here is an efficient way to delete all files older than a week: find . -mtime +7 -print | perl -nle 'unlink;' *************** *** 396,406 **** while (<>) { ... # your script goes here } continue { ! print; } ! Note that the lines are printed automatically. To suppress printing ! use the B<-n> switch. A B<-p> overrides a B<-n> switch. C and C blocks may be used to capture control before or after the implicit loop, just as in awk. --- 398,411 ---- while (<>) { ... # your script goes here } continue { ! print or die "-p destination: $!\n"; } ! If a file named by an argument cannot be opened for some reason, Perl ! warns you about it, and moves on to the next file. Note that the ! lines are printed automatically. An error occuring during printing is ! treated as fatal. To suppress printing use the B<-n> switch. A B<-p> ! overrides a B<-n> switch. C and C blocks may be used to capture control before or after the implicit loop, just as in awk. *************** *** 426,434 **** =item B<-S> makes Perl use the PATH environment variable to search for the ! script (unless the name of the script starts with a slash). Typically ! this is used to emulate #! startup on machines that don't support #!, ! in the following manner: #!/usr/bin/perl eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' --- 431,457 ---- =item B<-S> makes Perl use the PATH environment variable to search for the ! script (unless the name of the script contains directory separators). ! On some platforms, this also makes Perl append suffixes to the ! filename while searching for it. For example, on Win32 platforms, ! the ".bat" and ".cmd" suffixes are appended if a lookup for the ! original name fails, and if the name does not already end in one ! of those suffixes. If your Perl was compiled with DEBUGGING turned ! on, using the -Dp switch to Perl shows how the search progresses. ! ! If the file supplied contains directory separators (i.e. it is an ! absolute or relative pathname), and if the file is not found, ! platforms that append file extensions will do so and try to look ! for the file with those extensions added, one by one. ! ! On DOS-like platforms, if the script does not contain directory ! separators, it will first be searched for in the current directory ! before being searched for on the PATH. On Unix platforms, the ! script will be searched for strictly on the PATH. ! ! Typically this is used to emulate #! startup on platforms that ! don't support #!. This example works on many platforms that ! have a shell compatible with Bourne shell: #!/usr/bin/perl eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' Index: perl5.004_01_02/pod/perltrap.pod *** perl5.004_01/pod/perltrap.pod Tue Apr 8 06:21:29 1997 --- perl5.004_01_02/pod/perltrap.pod Thu Jul 31 21:06:29 1997 *************** *** 438,443 **** --- 438,449 ---- # perl4 prints: x=10 # perl5 prints: Can't find string terminator "'" anywhere before EOF + You can avoid this problem, and remain compatible with perl4, if you + always explicitly include the package name: + + $x = 10 ; + print "x=${main'x}\n" ; + Also see precedence traps, for parsing C<$:>. =item * BugFix *************** *** 923,929 **** =item * Precedence ! LHS vs. RHS when both sides are getting an op. @arr = ( 'left', 'right' ); $a{shift @arr} = shift @arr; --- 929,937 ---- =item * Precedence ! LHS vs. RHS of any assignment operator. LHS is evaluated first ! in perl4, second in perl5; this can affect the relationship ! between side-effects in sub-expressions. @arr = ( 'left', 'right' ); $a{shift @arr} = shift @arr; *************** *** 998,1015 **** # perl4 prints: no output # perl5 prints: Can't modify -e in concatenation - - =item * Precedence - - Assignment to value takes precedence over assignment to key in - perl5 when using the shift operator on both sides. - - @arr = ( 'left', 'right' ); - $a{shift @arr} = shift @arr; - print join( ' ', keys %a ); - - # perl4 prints: left - # perl5 prints: right =back --- 1006,1011 ---- Index: perl5.004_01_02/pod/perlxstut.pod *** perl5.004_01/pod/perlxstut.pod Sat Mar 29 23:37:29 1997 --- perl5.004_01_02/pod/perlxstut.pod Thu Jul 31 20:55:00 1997 *************** *** 529,540 **** sub MY::postamble { ' $(MYEXTLIB): mylib/Makefile ! cd mylib && $(MAKE) '; } (Note: Most makes will require that there be a tab character that indents ! the line "cd mylib && $(MAKE)", similarly for the Makefile in the subdirectory.) Let's also fix the MANIFEST file so that it accurately reflects the contents --- 529,540 ---- sub MY::postamble { ' $(MYEXTLIB): mylib/Makefile ! cd mylib && $(MAKE) $(PASTHRU) '; } (Note: Most makes will require that there be a tab character that indents ! the line C, similarly for the Makefile in the subdirectory.) Let's also fix the MANIFEST file so that it accurately reflects the contents Index: perl5.004_01_02/pod/pod2man.PL Prereq: 1.5 *** perl5.004_01/pod/pod2man.PL Mon Jun 9 20:23:30 1997 --- perl5.004_01_02/pod/pod2man.PL Thu Jul 31 22:03:43 1997 *************** *** 727,735 **** # trofficate backslashes; must do it before what happens below s/\\/noremap('\\e')/ge; ! # protect leading periods and quotes against *roff ! # mistaking them for directives ! s/^(?:[A-Z]<)?[.']/\\&$&/gm; # first hide the escapes in case we need to # intuit something and get it wrong due to fmting --- 727,735 ---- # trofficate backslashes; must do it before what happens below s/\\/noremap('\\e')/ge; ! # protect leading periods and quotes against *roff ! # mistaking them for directives ! s/^(?:[A-Z]<)?[.']/\\&$&/gm; # first hide the escapes in case we need to # intuit something and get it wrong due to fmting *************** *** 1101,1106 **** --- 1101,1107 ---- sub internal_lrefs { local($_) = shift; + local $trailing_and = s/and\s+$// ? "and " : ""; s{L]+)>}{$1}g; my(@items) = split( /(?:,?\s+(?:and\s+)?)/ ); *************** *** 1114,1119 **** --- 1115,1121 ---- $retstr .= " entr" . ( @items > 1 ? "ies" : "y" ) . " elsewhere in this document "; # terminal space to avoid words running together (pattern used strips terminal spaces) + $retstr .= $trailing_and; return $retstr; Index: perl5.004_01_02/pod/splitpod *** perl5.004_01/pod/splitpod Thu Jun 12 21:28:41 1997 --- perl5.004_01_02/pod/splitpod Tue Jul 29 00:14:59 1997 *************** *** 12,34 **** if (s/=item (\S+)/$1/) { #$cur = "POSIX::" . $1; $cur = $1; $syn{$cur} .= $_; next; } else { #s,Lop_flags & OPf_MOD; char *tmps; I32 arybase = curcop->cop_arybase; if (MAXARG > 2) len = POPi; ! pos = POPi - arybase; sv = POPs; tmps = SvPV(sv, curlen); ! if (pos < 0) { ! pos += curlen + arybase; ! if (pos < 0 && MAXARG < 3) ! pos = 0; } ! if (pos < 0 || pos > curlen) { ! if (dowarn || lvalue) warn("substr outside of string"); RETPUSHUNDEF; } else { - if (MAXARG < 3) - len = curlen; - else if (len < 0) { - len += curlen - pos; - if (len < 0) - len = 0; - } tmps += pos; - rem = curlen - pos; /* rem=how many bytes left*/ - if (rem > len) - rem = len; sv_setpvn(TARG, tmps, rem); if (lvalue) { /* it's an lvalue! */ if (!SvGMAGICAL(sv)) { --- 1630,1685 ---- STRLEN curlen; I32 pos; I32 rem; + I32 fail; I32 lvalue = op->op_flags & OPf_MOD; char *tmps; I32 arybase = curcop->cop_arybase; if (MAXARG > 2) len = POPi; ! pos = POPi; sv = POPs; tmps = SvPV(sv, curlen); ! if (pos >= arybase) { ! pos -= arybase; ! rem = curlen-pos; ! fail = rem; ! if (MAXARG > 2) { ! if (len < 0) { ! rem += len; ! if (rem < 0) ! rem = 0; ! } ! else if (rem > len) ! rem = len; ! } ! } ! else { ! pos += curlen; ! if (MAXARG < 3) ! rem = curlen; ! else if (len >= 0) { ! rem = pos+len; ! if (rem > (I32)curlen) ! rem = curlen; ! } ! else { ! rem = curlen+len; ! if (rem < pos) ! rem = pos; ! } ! if (pos < 0) ! pos = 0; ! fail = rem; ! rem -= pos; } ! if (fail < 0) { ! if (dowarn || lvalue) warn("substr outside of string"); RETPUSHUNDEF; } else { tmps += pos; sv_setpvn(TARG, tmps, rem); if (lvalue) { /* it's an lvalue! */ if (!SvGMAGICAL(sv)) { *************** *** 2320,2330 **** SP++; if (++MARK < SP) { ! offset = SvIVx(*MARK); if (offset < 0) offset += AvFILL(ary) + 1; else offset -= curcop->cop_arybase; if (++MARK < SP) { length = SvIVx(*MARK++); if (length < 0) --- 2350,2362 ---- SP++; if (++MARK < SP) { ! offset = i = SvIVx(*MARK); if (offset < 0) offset += AvFILL(ary) + 1; else offset -= curcop->cop_arybase; + if (offset < 0) + DIE(no_aelem, i); if (++MARK < SP) { length = SvIVx(*MARK++); if (length < 0) *************** *** 2337,2348 **** offset = 0; length = AvMAX(ary) + 1; } - if (offset < 0) { - length += offset; - offset = 0; - if (length < 0) - length = 0; - } if (offset > AvFILL(ary) + 1) offset = AvFILL(ary) + 1; after = AvFILL(ary) + 1 - (offset + length); --- 2369,2374 ---- *************** *** 3717,3723 **** --- 3743,3753 ---- #ifdef BW_BITS adouble <= BW_MASK #else + #ifdef CXUX_BROKEN_CONSTANT_CONVERT + adouble <= UV_MAX_cxux + #else adouble <= UV_MAX + #endif #endif ) { Index: perl5.004_01_02/pp_ctl.c *** perl5.004_01/pp_ctl.c Tue Jun 10 18:18:04 1997 --- perl5.004_01_02/pp_ctl.c Tue Jul 29 01:42:56 1997 *************** *** 1940,1945 **** --- 1940,1950 ---- OP *oldop = op; for (ix = 1; enterops[ix]; ix++) { op = enterops[ix]; + /* Eventually we may want to stack the needed arguments + * for each op. For now, we punt on the hard ones. */ + if (op->op_type == OP_ENTERITER) + DIE("Can't \"goto\" into the middle of a foreach loop", + label); (*op->op_ppaddr)(); } op = oldop; *************** *** 2262,2267 **** --- 2267,2275 ---- #ifdef DOSISH || (name[0] && name[1] == ':') #endif + #ifdef WIN32 + || (name[0] == '\\' && name[1] == '\\') /* UNC path */ + #endif #ifdef VMS || (strchr(name,':') || ((*name == '[' || *name == '<') && (isALNUM(name[1]) || strchr("$-_]>",name[1])))) *************** *** 2408,2414 **** save_lines(GvAV(compiling.cop_filegv), linestr); PUTBACK; ret = doeval(gimme); ! if (perldb && was != sub_generation) { /* Some subs defined here. */ strcpy(safestr, "_<(eval )"); /* Anything fake and short. */ } return DOCATCH(ret); --- 2416,2423 ---- save_lines(GvAV(compiling.cop_filegv), linestr); PUTBACK; ret = doeval(gimme); ! if (perldb && was != sub_generation /* Some subs defined here. */ ! && ret != op->op_next) { /* Successive compilation. */ strcpy(safestr, "_<(eval )"); /* Anything fake and short. */ } return DOCATCH(ret); *************** *** 2456,2461 **** --- 2465,2500 ---- } } curpm = newpm; /* Don't pop $1 et al till now */ + + /* + * Closures mentioned at top level of eval cannot be referenced + * again, and their presence indirectly causes a memory leak. + * (Note that the fact that compcv and friends are still set here + * is, AFAIK, an accident.) --Chip + */ + if (AvFILL(comppad_name) >= 0) { + SV **svp = AvARRAY(comppad_name); + I32 ix; + for (ix = AvFILL(comppad_name); ix >= 0; ix--) { + SV *sv = svp[ix]; + if (sv && sv != &sv_undef && *SvPVX(sv) == '&') { + SvREFCNT_dec(sv); + svp[ix] = &sv_undef; + + sv = curpad[ix]; + if (CvCLONE(sv)) { + SvREFCNT_dec(CvOUTSIDE(sv)); + CvOUTSIDE(sv) = Nullcv; + } + else { + SvREFCNT_dec(sv); + sv = NEWSV(0,0); + SvPADTMP_on(sv); + curpad[ix] = sv; + } + } + } + } #ifdef DEBUGGING assert(CvDEPTH(compcv) == 1); Index: perl5.004_01_02/pp_hot.c *** perl5.004_01/pp_hot.c Fri Jun 6 22:45:32 1997 --- perl5.004_01_02/pp_hot.c Tue Jul 29 01:38:16 1997 *************** *** 426,433 **** av = (AV*)SvRV(sv); if (SvTYPE(av) != SVt_PVAV) DIE("Not an ARRAY reference"); - if (op->op_private & OPpLVAL_INTRO) - av = (AV*)save_svref((SV**)sv); if (op->op_flags & OPf_REF) { PUSHs((SV*)av); RETURN; --- 426,431 ---- *************** *** 503,510 **** hv = (HV*)SvRV(sv); if (SvTYPE(hv) != SVt_PVHV) DIE("Not a HASH reference"); - if (op->op_private & OPpLVAL_INTRO) - hv = (HV*)save_svref((SV**)sv); if (op->op_flags & OPf_REF) { SETs((SV*)hv); RETURN; --- 501,506 ---- Index: perl5.004_01_02/pp_sys.c *** perl5.004_01/pp_sys.c Fri Jun 6 23:21:10 1997 --- perl5.004_01_02/pp_sys.c Mon Jul 28 22:30:21 1997 *************** *** 4374,4379 **** --- 4374,4383 ---- int operation; { int i; + int e = errno; + Off_t pos = lseek (fd, (Off_t)0, SEEK_SET); + errno = e; + switch (operation) { /* LOCK_SH - get a shared lock */ *************** *** 4405,4410 **** --- 4409,4418 ---- errno = EINVAL; break; } + + if (pos != -1) + (void) lseek (fd, pos, SEEK_SET); + return (i); } Index: perl5.004_01_02/proto.h *** perl5.004_01/proto.h Tue Jun 10 17:40:06 1997 --- perl5.004_01_02/proto.h Tue Jul 29 02:14:30 1997 *************** *** 489,494 **** --- 489,495 ---- void sv_reset _((char* s, HV* stash)); void sv_setpvf _((SV* sv, const char* pat, ...)); void sv_setiv _((SV* sv, IV num)); + void sv_setpviv _((SV* sv, IV num)); void sv_setuv _((SV* sv, UV num)); void sv_setnv _((SV* sv, double num)); SV* sv_setref_iv _((SV* rv, char* classname, IV iv)); Index: perl5.004_01_02/regcomp.c *** perl5.004_01/regcomp.c Sat Jun 7 01:42:22 1997 --- perl5.004_01_02/regcomp.c Thu Jul 31 19:18:44 1997 *************** *** 467,472 **** --- 467,475 ---- nextchar(); *flagp = TRYAGAIN; return NULL; + case 0: + croak("Sequence (? incomplete"); + break; default: --regparse; while (*regparse && strchr("iogcmsx", *regparse)) Index: perl5.004_01_02/regexec.c *** perl5.004_01/regexec.c Sat Jun 7 01:42:22 1997 --- perl5.004_01_02/regexec.c Mon Jul 28 22:16:23 1997 *************** *** 134,139 **** --- 134,167 ---- return input; } + /* After a successful match in WHILEM, we want to restore paren matches + * that have been overwritten by a failed match attempt in the process + * of reaching this success. We do this by restoring regstartp[i] + * wherever regendp[i] has not changed; if OPEN is changed to modify + * regendp[], the '== endp' test below should be changed to match. + * This corrects the error of: + * 0 > length [ "foobar" =~ / ( (foo) | (bar) )* /x ]->[1] + */ + static void + regcppartblow() + { + I32 i = SSPOPINT; + U32 paren; + char *startp; + char *endp; + assert(i == SAVEt_REGCONTEXT); + i = SSPOPINT; + /* input, lastparen, size */ + SSPOPPTR; SSPOPINT; SSPOPINT; + for (i -= 3; i > 0; i -= 3) { + paren = (U32)SSPOPINT; + startp = (char *) SSPOPPTR; + endp = (char *) SSPOPPTR; + if (paren <= *reglastparen && regendp[paren] == endp) + regstartp[paren] = startp; + } + } + #define regcpblow(cp) leave_scope(cp) /* *************** *** 944,950 **** ln = regcc->cur; cp = regcppush(cc->parenfloor); if (regmatch(cc->next)) { ! regcpblow(cp); sayYES; /* All done. */ } regcppop(); --- 972,978 ---- ln = regcc->cur; cp = regcppush(cc->parenfloor); if (regmatch(cc->next)) { ! regcppartblow(cp); sayYES; /* All done. */ } regcppop(); *************** *** 960,966 **** cc->lastloc = locinput; cp = regcppush(cc->parenfloor); if (regmatch(cc->scan)) { ! regcpblow(cp); sayYES; } regcppop(); --- 988,994 ---- cc->lastloc = locinput; cp = regcppush(cc->parenfloor); if (regmatch(cc->scan)) { ! regcppartblow(cp); sayYES; } regcppop(); *************** *** 975,981 **** cc->cur = n; cc->lastloc = locinput; if (regmatch(cc->scan)) { ! regcpblow(cp); sayYES; } regcppop(); /* Restore some previous $s? */ --- 1003,1009 ---- cc->cur = n; cc->lastloc = locinput; if (regmatch(cc->scan)) { ! regcppartblow(cp); sayYES; } regcppop(); /* Restore some previous $s? */ Index: perl5.004_01_02/scope.c *** perl5.004_01/scope.c Sat May 10 01:15:05 1997 --- perl5.004_01_02/scope.c Tue Jul 29 01:24:50 1997 *************** *** 536,542 **** case SAVEt_CLEARSV: ptr = (void*)&curpad[SSPOPLONG]; sv = *(SV**)ptr; ! if (SvREFCNT(sv) <= 1) { /* Can clear pad variable in place. */ if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) croak("panic: leave_scope clearsv"); --- 536,543 ---- case SAVEt_CLEARSV: ptr = (void*)&curpad[SSPOPLONG]; sv = *(SV**)ptr; ! /* Can clear pad variable in place? */ ! if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) { if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) croak("panic: leave_scope clearsv"); Index: perl5.004_01_02/sv.c *** perl5.004_01/sv.c Sat Jun 7 02:32:44 1997 --- perl5.004_01_02/sv.c Thu Jul 31 19:19:48 1997 *************** *** 952,958 **** case SVt_NULL: sv_catpv(t, "UNDEF"); ! return tokenbuf; case SVt_IV: sv_catpv(t, "IV"); break; --- 952,958 ---- case SVt_NULL: sv_catpv(t, "UNDEF"); ! goto finish; case SVt_IV: sv_catpv(t, "IV"); break; *************** *** 1497,1504 **** { I32 numtype = looks_like_number(sv); if (numtype == 1) ! return atol(SvPVX(sv)); if (!numtype && dowarn) not_a_number(sv); SET_NUMERIC_STANDARD(); --- 1497,1506 ---- { I32 numtype = looks_like_number(sv); + #ifdef HAS_STRTOUL if (numtype == 1) ! return strtoul(SvPVX(sv), Null(char**), 10); ! #endif if (!numtype && dowarn) not_a_number(sv); SET_NUMERIC_STANDARD(); *************** *** 1710,1721 **** #endif } else if (SvIOKp(sv)) { if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); olderrno = errno; /* some Xenix systems wipe out errno here */ ! sv_setpvf(sv, "%Vd", SvIVX(sv)); errno = olderrno; s = SvEND(sv); } else { if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) --- 1712,1728 ---- #endif } else if (SvIOKp(sv)) { + U32 oldIOK = SvIOK(sv); if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); olderrno = errno; /* some Xenix systems wipe out errno here */ ! sv_setpviv(sv, SvIVX(sv)); errno = olderrno; s = SvEND(sv); + if (oldIOK) + SvIOK_on(sv); + else + SvIOKp_on(sv); } else { if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) *************** *** 4115,4120 **** --- 4122,4163 ---- return FALSE; } + void + sv_setpviv(sv, iv) + SV *sv; + IV iv; + { + STRLEN len; + char buf[TYPE_DIGITS(UV)]; + char *ptr = buf + sizeof(buf); + int sign; + UV uv; + char *p; + int i; + + sv_setpvn(sv, "", 0); + if (iv >= 0) { + uv = iv; + sign = 0; + } else { + uv = -iv; + sign = 1; + } + do { + *--ptr = '0' + (uv % 10); + } while (uv /= 10); + len = (buf + sizeof(buf)) - ptr; + /* taking advantage of SvCUR(sv) == 0 */ + SvGROW(sv, sign + len + 1); + p = SvPVX(sv); + if (sign) + *p++ = '-'; + memcpy(p, ptr, len); + p += len; + *p = '\0'; + SvCUR(sv) = p - SvPVX(sv); + } + #ifdef I_STDARG void sv_setpvf(SV *sv, const char* pat, ...) *************** *** 4560,4565 **** --- 4603,4610 ---- } if (fill == '0') *--eptr = fill; + if (left) + *--eptr = '-'; if (plus) *--eptr = plus; if (alt) *************** *** 4625,4631 **** need = (have > width ? have : width); gap = need - have; ! SvGROW(sv, SvLEN(sv) + need); p = SvEND(sv); if (esignlen && fill == '0') { for (i = 0; i < esignlen; i++) --- 4670,4676 ---- need = (have > width ? have : width); gap = need - have; ! SvGROW(sv, SvCUR(sv) + need + 1); p = SvEND(sv); if (esignlen && fill == '0') { for (i = 0; i < esignlen; i++) Index: perl5.004_01_02/t/TEST *** perl5.004_01/t/TEST Thu Mar 6 20:51:40 1997 --- perl5.004_01_02/t/TEST Thu Jul 31 19:13:26 1997 *************** *** 101,107 **** } } else { $next += 1; ! print "FAILED on test $next\n"; $bad = $bad + 1; $_ = $test; if (/^base/) { --- 101,107 ---- } } else { $next += 1; ! print "FAILED at test $next\n"; $bad = $bad + 1; $_ = $test; if (/^base/) { Index: perl5.004_01_02/t/base/lex.t *** perl5.004_01/t/base/lex.t Wed Jan 22 05:14:53 1997 --- perl5.004_01_02/t/base/lex.t Thu Jul 31 19:26:21 1997 *************** *** 2,8 **** # $RCSfile: lex.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:04 $ ! print "1..26\n"; $x = 'x'; --- 2,8 ---- # $RCSfile: lex.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:04 $ ! print "1..27\n"; $x = 'x'; *************** *** 103,105 **** --- 103,107 ---- print "FOO:" =~ /$foo[:]/ ? "ok 24\n" : "not ok 24\n"; print "ABC" =~ /^$ary[$A]$/ ? "ok 25\n" : "not ok 25\n"; print "FOOZ" =~ /^$foo[$A-Z]$/ ? "ok 26\n" : "not ok 26\n"; + + print (((q{{\{\(}} . q{{\)\}}}) eq '{{\(}{\)}}') ? "ok 27\n" : "not ok 27\n"); Index: perl5.004_01_02/t/comp/cmdopt.t *** perl5.004_01/t/comp/cmdopt.t Tue Oct 18 17:43:27 1994 --- perl5.004_01_02/t/comp/cmdopt.t Mon Jul 28 22:24:43 1997 *************** *** 2,8 **** # $RCSfile: cmdopt.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:17 $ ! print "1..40\n"; # test the optimization of constants --- 2,8 ---- # $RCSfile: cmdopt.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:17 $ ! print "1..44\n"; # test the optimization of constants *************** *** 81,83 **** --- 81,90 ---- $x = ''; if ($a =~ /a/ || $x) { print "ok 39\n";} else { print "not ok 39\n";} if ($a !~ /a/ || $x) { print "not ok 40\n";} else { print "ok 40\n";} + + $x = 1; + if ($a eq 'a' xor $x) { print "not ok 41\n";} else { print "ok 41\n";} + if ($a ne 'a' xor $x) { print "ok 42\n";} else { print "not ok 42\n";} + $x = ''; + if ($a eq 'a' xor $x) { print "ok 43\n";} else { print "not ok 43\n";} + if ($a ne 'a' xor $x) { print "not ok 44\n";} else { print "ok 44\n";} Index: perl5.004_01_02/t/comp/term.t *** perl5.004_01/t/comp/term.t Tue Oct 18 17:43:40 1994 --- perl5.004_01_02/t/comp/term.t Tue Jul 29 01:31:22 1997 *************** *** 4,10 **** # tests that aren't important enough for base.term ! print "1..14\n"; $x = "\\n"; print "#1\t:$x: eq " . ':\n:' . "\n"; --- 4,10 ---- # tests that aren't important enough for base.term ! print "1..22\n"; $x = "\\n"; print "#1\t:$x: eq " . ':\n:' . "\n"; *************** *** 33,35 **** --- 33,70 ---- if ("@foo[0..1]b" eq "1 2b") { print "ok 13\n";} else {print "not ok 13\n";} $" = '::'; if ("@foo[0..1]b" eq "1::2b") { print "ok 14\n";} else {print "not ok 14\n";} + + # test if C distinguishes between blocks and hashrefs + + $a = "{ '\\'' , 'foo' }"; + $a = eval $a; + if (ref($a) eq 'HASH') {print "ok 15\n";} else {print "not ok 15\n";} + + $a = "{ '\\\\\\'abc' => 'foo' }"; + $a = eval $a; + if (ref($a) eq 'HASH') {print "ok 16\n";} else {print "not ok 16\n";} + + $a = "{'a\\\n\\'b','foo'}"; + $a = eval $a; + if (ref($a) eq 'HASH') {print "ok 17\n";} else {print "not ok 17\n";} + + $a = "{'\\\\\\'\\\\'=>'foo'}"; + $a = eval $a; + if (ref($a) eq 'HASH') {print "ok 18\n";} else {print "not ok 18\n";} + + $a = "{q,a'b,,'foo'}"; + $a = eval $a; + if (ref($a) eq 'HASH') {print "ok 19\n";} else {print "not ok 19\n";} + + $a = "{q[[']]=>'foo'}"; + $a = eval $a; + if (ref($a) eq 'HASH') {print "ok 20\n";} else {print "not ok 20\n";} + + # needs disambiguation if first term is a variable + $a = "+{ \$a , 'foo'}"; + $a = eval $a; + if (ref($a) eq 'HASH') {print "ok 21\n";} else {print "not ok 21\n";} + + $a = "+{ \$a=>'foo'}"; + $a = eval $a; + if (ref($a) eq 'HASH') {print "ok 22\n";} else {print "not ok 22\n";} Index: perl5.004_01_02/t/lib/db-btree.t *** perl5.004_01/t/lib/db-btree.t Thu May 1 02:24:48 1997 --- perl5.004_01_02/t/lib/db-btree.t Thu Jul 31 20:53:33 1997 *************** *** 12,18 **** use DB_File; use Fcntl; ! print "1..92\n"; sub ok { --- 12,18 ---- use DB_File; use Fcntl; ! print "1..102\n"; sub ok { *************** *** 91,97 **** ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); ! ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos'); while (($key,$value) = each(%h)) { $i++; --- 91,97 ---- ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); ! ok(20, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos'); while (($key,$value) = each(%h)) { $i++; *************** *** 511,516 **** --- 511,608 ---- eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE ; } ; ok(92, $@ =~ /^DB_File can only tie an associative array to a DB_BTREE database/) ; unlink $filename ; + } + + + { + # sub-class test + + package Another ; + + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; + EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok(93, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE ); + ' ; + + main::ok(94, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(95, $@ eq "") ; + main::ok(96, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; + main::ok(97, $@ eq "") ; + main::ok(98, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(99, $@ eq "" ) ; + main::ok(100, $ret == 1) ; + + $ret = eval '$X->A_new_method("joe") ' ; + main::ok(101, $@ eq "") ; + main::ok(102, $ret eq "[[11]]") ; + + unlink "SubDB.pm", "dbbtree.tmp" ; + } exit ; Index: perl5.004_01_02/t/lib/db-hash.t *** perl5.004_01/t/lib/db-hash.t Thu May 1 02:24:48 1997 --- perl5.004_01_02/t/lib/db-hash.t Thu Jul 31 20:53:33 1997 *************** *** 12,18 **** use DB_File; use Fcntl; ! print "1..52\n"; sub ok { --- 12,18 ---- use DB_File; use Fcntl; ! print "1..62\n"; sub ok { *************** *** 70,76 **** ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); ! ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos'); while (($key,$value) = each(%h)) { $i++; --- 70,76 ---- ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); ! ok(16, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos'); while (($key,$value) = each(%h)) { $i++; *************** *** 318,323 **** --- 318,414 ---- eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ; ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ; unlink $filename ; + } + + { + # sub-class test + + package Another ; + + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; + EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok(53, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH ); + ' ; + + main::ok(54, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(55, $@ eq "") ; + main::ok(56, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; + main::ok(57, $@ eq "") ; + main::ok(58, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(59, $@ eq "" ) ; + main::ok(60, $ret == 1) ; + + $ret = eval '$X->A_new_method("joe") ' ; + main::ok(61, $@ eq "") ; + main::ok(62, $ret eq "[[11]]") ; + + unlink "SubDB.pm", "dbhash.tmp" ; + } exit ; Index: perl5.004_01_02/t/lib/db-recno.t *** perl5.004_01/t/lib/db-recno.t Thu May 1 02:24:48 1997 --- perl5.004_01_02/t/lib/db-recno.t Thu Jul 31 20:53:33 1997 *************** *** 41,47 **** EOM } ! print "1..56\n"; my $Dfile = "recno.tmp"; unlink $Dfile ; --- 41,47 ---- EOM } ! print "1..66\n"; my $Dfile = "recno.tmp"; unlink $Dfile ; *************** *** 93,99 **** my @h ; ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; ! ok(18, ((stat($Dfile))[2] & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos') ; #my $l = @h ; --- 93,99 ---- my @h ; ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; ! ok(18, ((stat($Dfile))[2] & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos') ; #my $l = @h ; *************** *** 198,203 **** --- 198,214 ---- unlink $Dfile; + sub docat + { + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file:$!"; + my $result = ; + close(CAT); + return $result; + } + + { # Check bval defaults to \n *************** *** 208,214 **** $h[1] = "def" ; $h[3] = "ghi" ; untie @h ; ! my $x = `cat $Dfile` ; unlink $Dfile; ok(49, $x eq "abc\ndef\n\nghi\n") ; } --- 219,225 ---- $h[1] = "def" ; $h[3] = "ghi" ; untie @h ; ! my $x = docat($Dfile) ; unlink $Dfile; ok(49, $x eq "abc\ndef\n\nghi\n") ; } *************** *** 224,230 **** $h[1] = "def" ; $h[3] = "ghi" ; untie @h ; ! my $x = `cat $Dfile` ; unlink $Dfile; my $ok = ($x eq "abc-def--ghi-") ; bad_one() unless $ok ; --- 235,241 ---- $h[1] = "def" ; $h[3] = "ghi" ; untie @h ; ! my $x = docat($Dfile) ; unlink $Dfile; my $ok = ($x eq "abc-def--ghi-") ; bad_one() unless $ok ; *************** *** 243,249 **** $h[1] = "def" ; $h[3] = "ghi" ; untie @h ; ! my $x = `cat $Dfile` ; unlink $Dfile; my $ok = ($x eq "abc def ghi ") ; bad_one() unless $ok ; --- 254,260 ---- $h[1] = "def" ; $h[3] = "ghi" ; untie @h ; ! my $x = docat($Dfile) ; unlink $Dfile; my $ok = ($x eq "abc def ghi ") ; bad_one() unless $ok ; *************** *** 263,269 **** $h[1] = "def" ; $h[3] = "ghi" ; untie @h ; ! my $x = `cat $Dfile` ; unlink $Dfile; my $ok = ($x eq "abc--def-------ghi--") ; bad_one() unless $ok ; --- 274,280 ---- $h[1] = "def" ; $h[3] = "ghi" ; untie @h ; ! my $x = docat($Dfile) ; unlink $Dfile; my $ok = ($x eq "abc--def-------ghi--") ; bad_one() unless $ok ; *************** *** 278,283 **** --- 289,385 ---- eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ; ok(56, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ; unlink $filename ; + } + + { + # sub-class test + + package Another ; + + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; + EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok(57, $@ eq "") ; + my @h ; + my $X ; + eval ' + $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO ); + ' ; + + main::ok(58, $@ eq "") ; + + my $ret = eval '$h[3] = 3 ; return $h[3] ' ; + main::ok(59, $@ eq "") ; + main::ok(60, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ; + main::ok(61, $@ eq "") ; + main::ok(62, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(63, $@ eq "" ) ; + main::ok(64, $ret == 1) ; + + $ret = eval '$X->A_new_method(1) ' ; + main::ok(65, $@ eq "") ; + main::ok(66, $ret eq "[[11]]") ; + + unlink "SubDB.pm", "recno.tmp" ; + } exit ; Index: perl5.004_01_02/t/lib/gdbm.t *** perl5.004_01/t/lib/gdbm.t Fri Apr 4 17:03:30 1997 --- perl5.004_01_02/t/lib/gdbm.t Thu Jul 31 19:50:24 1997 *************** *** 13,19 **** use GDBM_File; ! print "1..12\n"; unlink ; --- 13,19 ---- use GDBM_File; ! print "1..20\n"; unlink ; *************** *** 121,123 **** --- 121,206 ---- untie %h; unlink 'Op.dbmx.dir', $Dfile; + + sub ok + { + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; + } + + { + # sub-class test + + package Another ; + + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw(@ISA @EXPORT) ; + + require Exporter ; + use GDBM_File; + @ISA=qw(GDBM_File); + @EXPORT = @GDBM_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; + EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + + eval 'use SubDB ; '; + main::ok(13, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash.tmp", &GDBM_WRCREAT, 0640 ); + ' ; + + main::ok(14, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(15, $@ eq "") ; + main::ok(16, $ret == 5) ; + + $ret = eval ' &GDBM_WRCREAT eq &main::GDBM_WRCREAT ' ; + main::ok(17, $@ eq "" ) ; + main::ok(18, $ret == 1) ; + + $ret = eval '$X->A_new_method("fred") ' ; + main::ok(19, $@ eq "") ; + main::ok(20, $ret eq "[[5]]") ; + + unlink "SubDB.pm", "dbhash.tmp" ; + + } Index: perl5.004_01_02/t/lib/ndbm.t *** perl5.004_01/t/lib/ndbm.t Fri Apr 4 17:03:27 1997 --- perl5.004_01_02/t/lib/ndbm.t Thu Jul 31 19:50:24 1997 *************** *** 16,22 **** #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; ! print "1..12\n"; unlink ; --- 16,22 ---- #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; ! print "1..18\n"; unlink ; *************** *** 124,126 **** --- 124,205 ---- untie %h; unlink 'Op.dbmx.dir', $Dfile; + + sub ok + { + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; + } + + { + # sub-class test + + package Another ; + + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw(@ISA @EXPORT) ; + + require Exporter ; + use NDBM_File; + @ISA=qw(NDBM_File); + @EXPORT = @NDBM_File::EXPORT if defined @NDBM_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; + EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + + eval 'use SubDB ; use Fcntl ; '; + main::ok(13, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 ); + ' ; + + main::ok(14, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(15, $@ eq "") ; + main::ok(16, $ret == 5) ; + + $ret = eval '$X->A_new_method("fred") ' ; + main::ok(17, $@ eq "") ; + main::ok(18, $ret eq "[[5]]") ; + + unlink "SubDB.pm", "dbhash.tmp" ; + + } Index: perl5.004_01_02/t/lib/odbm.t *** perl5.004_01/t/lib/odbm.t Fri Apr 4 17:03:24 1997 --- perl5.004_01_02/t/lib/odbm.t Thu Jul 31 19:50:24 1997 *************** *** 16,22 **** #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; ! print "1..12\n"; unlink ; --- 16,22 ---- #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; ! print "1..18\n"; unlink ; *************** *** 124,126 **** --- 124,205 ---- untie %h; unlink 'Op.dbmx.dir', $Dfile; + + sub ok + { + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; + } + + { + # sub-class test + + package Another ; + + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw(@ISA @EXPORT) ; + + require Exporter ; + use ODBM_File; + @ISA=qw(ODBM_File); + @EXPORT = @ODBM_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; + EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + + eval 'use SubDB ; use Fcntl ;'; + main::ok(13, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 ); + ' ; + + main::ok(14, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(15, $@ eq "") ; + main::ok(16, $ret == 5) ; + + $ret = eval '$X->A_new_method("fred") ' ; + main::ok(17, $@ eq "") ; + main::ok(18, $ret eq "[[5]]") ; + + unlink "SubDB.pm", "dbhash.tmp" ; + + } Index: perl5.004_01_02/t/lib/sdbm.t *** perl5.004_01/t/lib/sdbm.t Fri Apr 4 17:03:19 1997 --- perl5.004_01_02/t/lib/sdbm.t Thu Jul 31 19:50:25 1997 *************** *** 15,21 **** #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; ! print "1..12\n"; unlink ; --- 15,21 ---- #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; ! print "1..18\n"; unlink ; *************** *** 124,126 **** --- 124,205 ---- untie %h; unlink 'Op.dbmx.dir', $Dfile; + + sub ok + { + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; + } + + { + # sub-class test + + package Another ; + + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use SDBM_File; + @ISA=qw(SDBM_File); + @EXPORT = @SDBM_File::EXPORT if defined @SDBM_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; + EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + + eval 'use SubDB ; use Fcntl ;'; + main::ok(13, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 ); + ' ; + + main::ok(14, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(15, $@ eq "") ; + main::ok(16, $ret == 5) ; + + $ret = eval '$X->A_new_method("fred") ' ; + main::ok(17, $@ eq "") ; + main::ok(18, $ret eq "[[5]]") ; + + unlink "SubDB.pm", "dbhash.tmp" ; + + } Index: perl5.004_01_02/t/op/local.t *** perl5.004_01/t/op/local.t Tue Oct 18 17:45:23 1994 --- perl5.004_01_02/t/op/local.t Tue Jul 29 01:38:16 1997 *************** *** 2,8 **** # $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $ ! print "1..20\n"; sub foo { local($a, $b) = @_; --- 2,8 ---- # $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $ ! print "1..23\n"; sub foo { local($a, $b) = @_; *************** *** 43,45 **** --- 43,54 ---- print &foo2("ok 11\n","ok 12\n"); print $a,@b,@c,%d,$x,$y; + + eval 'local($$e)'; + print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 21\n"; + + eval 'local(@$e)'; + print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 22\n"; + + eval 'local(%$e)'; + print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 23\n"; Index: perl5.004_01_02/t/op/magic.t *** perl5.004_01/t/op/magic.t Thu Jun 12 13:33:11 1997 --- perl5.004_01_02/t/op/magic.t Thu Jul 31 23:48:24 1997 *************** *** 46,54 **** $| = 1; # command buffering ! $SIG{"INT"} = "ok3"; kill "INT",$$; ! $SIG{"INT"} = "IGNORE"; kill 2,$$; print "ok 4\n"; ! $SIG{"INT"} = "DEFAULT"; kill 2,$$; print "not ok\n"; sub ok3 { if (($x = pop(@_)) eq "INT") { --- 46,54 ---- $| = 1; # command buffering ! $SIG{"INT"} = "ok3"; kill "INT",$$; ! $SIG{"INT"} = "IGNORE"; kill "INT",$$; print "ok 4\n"; ! $SIG{"INT"} = "DEFAULT"; kill "INT",$$; print "not ok\n"; sub ok3 { if (($x = pop(@_)) eq "INT") { *************** *** 106,129 **** ok 18, $$ > 0, $$; # $^X and $0 ! if ($Is_MSWin32) { ! for (19 .. 25) { ok $_, 1 } ! } ! else { if ($^O eq 'qnx') { chomp($wd = `pwd`); } else { $wd = '.'; } $script = "$wd/show-shebang"; ! $s1 = $s2 = "\$^X is $wd/perl, \$0 is $script\n"; if ($^O eq 'os2') { # Started by ksh, which adds suffixes '.exe' and '.' to perl and script $s2 = "\$^X is $wd/perl.exe, \$0 is $script.\n"; } ok 19, open(SCRIPT, ">$script"), $!; ! ok 20, print(SCRIPT < 0, $$; # $^X and $0 ! { if ($^O eq 'qnx') { chomp($wd = `pwd`); } else { $wd = '.'; } + my $perl = "$wd/perl"; + my $headmaybe = ''; + my $tailmaybe = ''; $script = "$wd/show-shebang"; ! if ($Is_MSWin32) { ! chomp($wd = `cd`); ! $perl = "$wd\\perl.exe"; ! $script = "$wd\\show-shebang.bat"; ! $headmaybe = <$script"), $!; ! ok 20, print(SCRIPT $headmaybe . <. # # Column 4 contains a string, usually C<$&>. # --- 14,20 ---- # n expect no match # c expect an error # ! # Columns 4 and 5 are used only if column 3 contains C or C. # # Column 4 contains a string, usually C<$&>. # *************** *** 35,45 **** while () { ($pat, $subject, $result, $repl, $expect) = split(/[\t\n]/,$_); $input = join(':',$pat,$subject,$result,$repl,$expect); ! $pat = "'$pat'" unless $pat =~ /^'/; for $study ("", "study \$subject") { eval "$study; \$match = (\$subject =~ m$pat); \$got = \"$repl\";"; if ($result eq 'c') { ! if ($@ eq '') { print "not ok $.\n"; next TEST } last; # no need to study a syntax error } elsif ($result eq 'n') { --- 35,45 ---- while () { ($pat, $subject, $result, $repl, $expect) = split(/[\t\n]/,$_); $input = join(':',$pat,$subject,$result,$repl,$expect); ! $pat = "'$pat'" unless $pat =~ /^[:']/; for $study ("", "study \$subject") { eval "$study; \$match = (\$subject =~ m$pat); \$got = \"$repl\";"; if ($result eq 'c') { ! if ($@ !~ m!^\Q$expect!) { print "not ok $.\n"; next TEST } last; # no need to study a syntax error } elsif ($result eq 'n') { Index: perl5.004_01_02/t/op/substr.t *** perl5.004_01/t/op/substr.t Wed Aug 28 20:32:42 1996 --- perl5.004_01_02/t/op/substr.t Tue Jul 29 03:01:09 1997 *************** *** 2,26 **** # $RCSfile: substr.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:31 $ ! print "1..25\n"; $a = 'abcdefxyz'; ! print (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n"); ! print (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n"); ! print (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n"); ! print (substr($a,999,999) eq '' ? "ok 4\n" : "not ok 4\n"); ! print (substr($a,0,-6) eq 'abc' ? "ok 5\n" : "not ok 5\n"); ! print (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n"); $[ = 1; ! print (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n"); ! print (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n"); ! print (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n"); ! print (substr($a,999,999) eq '' ? "ok 10\n" : "not ok 10\n"); ! print (substr($a,1,-6) eq 'abc' ? "ok 11\n" : "not ok 11\n"); ! print (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n"); $[ = 0; --- 2,41 ---- # $RCSfile: substr.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:31 $ ! print "1..97\n"; ! ! #P = start of string Q = start of substr R = end of substr S = end of string $a = 'abcdefxyz'; + BEGIN { $^W = 1 }; ! $SIG{__WARN__} = sub { ! if ($_[0] =~ /^substr outside of string/) { ! $w++; ! } elsif ($_[0] =~ /^Attempt to use reference as lvalue in substr/) { ! $w += 2; ! } else { ! warn @_; ! } ! }; ! ! sub fail { !defined(shift) && $w-- }; ! ! print (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n"); # P=Q R S ! print (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n"); # P Q R S ! print (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n"); # P Q S R ! print (fail(substr($a,999,999)) ? "ok 4\n" : "not ok 4\n"); # P R Q S ! print (substr($a,0,-6) eq 'abc' ? "ok 5\n" : "not ok 5\n"); # P=Q R S ! print (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n"); # P Q R S $[ = 1; ! print (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n"); # P=Q R S ! print (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n"); # P Q R S ! print (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n"); # P Q S R ! print (fail(substr($a,999,999)) ? "ok 10\n" : "not ok 10\n");# P R Q S ! print (substr($a,1,-6) eq 'abc' ? "ok 11\n" : "not ok 11\n");# P=Q R S ! print (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n"); # P Q R S $[ = 0; *************** *** 28,34 **** print $a eq 'abcXYZxyz' ? "ok 13\n" : "not ok 13\n"; substr($a,0,2) = ''; print $a eq 'cXYZxyz' ? "ok 14\n" : "not ok 14\n"; - y/a/a/; substr($a,0,0) = 'ab'; print $a eq 'abcXYZxyz' ? "ok 15\n" : "not ok 15 $a\n"; substr($a,0,0) = '12345678'; --- 43,48 ---- *************** *** 42,50 **** $a = 'abcdefxyz'; ! print (substr($a,6) eq 'xyz' ? "ok 20\n" : "not ok 20\n"); ! print (substr($a,-3) eq 'xyz' ? "ok 21\n" : "not ok 21\n"); ! print (substr($a,999) eq '' ? "ok 22\n" : "not ok 22\n"); # with lexicals (and in re-entered scopes) for (0,1) { --- 56,158 ---- $a = 'abcdefxyz'; ! print (substr($a,6) eq 'xyz' ? "ok 20\n" : "not ok 20\n"); # P Q R=S ! print (substr($a,-3) eq 'xyz' ? "ok 21\n" : "not ok 21\n"); # P Q R=S ! print (fail(substr($a,999)) ? "ok 22\n" : "not ok 22\n"); # P R=S Q ! print (substr($a,0) eq 'abcdefxyz' ? "ok 23\n" : "not ok 23\n");# P=Q R=S ! print (substr($a,9) eq '' ? "ok 24\n" : "not ok 24\n"); # P Q=R=S ! print (substr($a,-11) eq 'abcdefxyz' ? "ok 25\n" : "not ok 25\n");# Q P R=S ! print (substr($a,-9) eq 'abcdefxyz' ? "ok 26\n" : "not ok 26\n"); # P=Q R=S ! ! $a = '54321'; ! ! print (fail(substr($a,-7, 1)) ? "ok 27\n" : "not ok 27\n"); # Q R P S ! print (fail(substr($a,-7,-6)) ? "ok 28\n" : "not ok 28\n"); # Q R P S ! print (substr($a,-5,-7) eq '' ? "ok 29\n" : "not ok 29\n"); # R P=Q S ! print (substr($a, 2,-7) eq '' ? "ok 30\n" : "not ok 30\n"); # R P Q S ! print (substr($a,-3,-7) eq '' ? "ok 31\n" : "not ok 31\n"); # R P Q S ! print (substr($a, 2,-5) eq '' ? "ok 32\n" : "not ok 32\n"); # P=R Q S ! print (substr($a,-3,-5) eq '' ? "ok 33\n" : "not ok 33\n"); # P=R Q S ! print (substr($a, 2,-4) eq '' ? "ok 34\n" : "not ok 34\n"); # P R Q S ! print (substr($a,-3,-4) eq '' ? "ok 35\n" : "not ok 35\n"); # P R Q S ! print (substr($a, 5,-6) eq '' ? "ok 36\n" : "not ok 36\n"); # R P Q=S ! print (substr($a, 5,-5) eq '' ? "ok 37\n" : "not ok 37\n"); # P=R Q S ! print (substr($a, 5,-3) eq '' ? "ok 38\n" : "not ok 38\n"); # P R Q=S ! print (fail(substr($a, 7,-7)) ? "ok 39\n" : "not ok 39\n"); # R P S Q ! print (fail(substr($a, 7,-5)) ? "ok 40\n" : "not ok 40\n"); # P=R S Q ! print (fail(substr($a, 7,-3)) ? "ok 41\n" : "not ok 41\n"); # P R S Q ! print (fail(substr($a, 7, 0)) ? "ok 42\n" : "not ok 42\n"); # P S Q=R ! ! print (substr($a,-7,2) eq '' ? "ok 43\n" : "not ok 43\n"); # Q P=R S ! print (substr($a,-7,4) eq '54' ? "ok 44\n" : "not ok 44\n"); # Q P R S ! print (substr($a,-7,7) eq '54321' ? "ok 45\n" : "not ok 45\n");# Q P R=S ! print (substr($a,-7,9) eq '54321' ? "ok 46\n" : "not ok 46\n");# Q P S R ! print (substr($a,-5,0) eq '' ? "ok 47\n" : "not ok 47\n"); # P=Q=R S ! print (substr($a,-5,3) eq '543' ? "ok 48\n" : "not ok 48\n");# P=Q R S ! print (substr($a,-5,5) eq '54321' ? "ok 49\n" : "not ok 49\n");# P=Q R=S ! print (substr($a,-5,7) eq '54321' ? "ok 50\n" : "not ok 50\n");# P=Q S R ! print (substr($a,-3,0) eq '' ? "ok 51\n" : "not ok 51\n"); # P Q=R S ! print (substr($a,-3,3) eq '321' ? "ok 52\n" : "not ok 52\n");# P Q R=S ! print (substr($a,-2,3) eq '21' ? "ok 53\n" : "not ok 53\n"); # P Q S R ! print (substr($a,0,-5) eq '' ? "ok 54\n" : "not ok 54\n"); # P=Q=R S ! print (substr($a,2,-3) eq '' ? "ok 55\n" : "not ok 55\n"); # P Q=R S ! print (substr($a,0,0) eq '' ? "ok 56\n" : "not ok 56\n"); # P=Q=R S ! print (substr($a,0,5) eq '54321' ? "ok 57\n" : "not ok 57\n");# P=Q R=S ! print (substr($a,0,7) eq '54321' ? "ok 58\n" : "not ok 58\n");# P=Q S R ! print (substr($a,2,0) eq '' ? "ok 59\n" : "not ok 59\n"); # P Q=R S ! print (substr($a,2,3) eq '321' ? "ok 60\n" : "not ok 60\n"); # P Q R=S ! print (substr($a,5,0) eq '' ? "ok 61\n" : "not ok 61\n"); # P Q=R=S ! print (substr($a,5,2) eq '' ? "ok 62\n" : "not ok 62\n"); # P Q=S R ! print (substr($a,-7,-5) eq '' ? "ok 63\n" : "not ok 63\n"); # Q P=R S ! print (substr($a,-7,-2) eq '543' ? "ok 64\n" : "not ok 64\n");# Q P R S ! print (substr($a,-5,-5) eq '' ? "ok 65\n" : "not ok 65\n"); # P=Q=R S ! print (substr($a,-5,-2) eq '543' ? "ok 66\n" : "not ok 66\n");# P=Q R S ! print (substr($a,-3,-3) eq '' ? "ok 67\n" : "not ok 67\n"); # P Q=R S ! print (substr($a,-3,-1) eq '32' ? "ok 68\n" : "not ok 68\n");# P Q R S ! ! $a = ''; ! ! print (substr($a,-2,2) eq '' ? "ok 69\n" : "not ok 69\n"); # Q P=R=S ! print (substr($a,0,0) eq '' ? "ok 70\n" : "not ok 70\n"); # P=Q=R=S ! print (substr($a,0,1) eq '' ? "ok 71\n" : "not ok 71\n"); # P=Q=S R ! print (substr($a,-2,3) eq '' ? "ok 72\n" : "not ok 72\n"); # Q P=S R ! print (substr($a,-2) eq '' ? "ok 73\n" : "not ok 73\n"); # Q P=R=S ! print (substr($a,0) eq '' ? "ok 74\n" : "not ok 74\n"); # P=Q=R=S ! ! ! print (substr($a,0,-1) eq '' ? "ok 75\n" : "not ok 75\n"); # R P=Q=S ! print (fail(substr($a,-2,0)) ? "ok 76\n" : "not ok 76\n"); # Q=R P=S ! print (fail(substr($a,-2,1)) ? "ok 77\n" : "not ok 77\n"); # Q R P=S ! print (fail(substr($a,-2,-1)) ? "ok 78\n" : "not ok 78\n"); # Q R P=S ! print (fail(substr($a,-2,-2)) ? "ok 79\n" : "not ok 79\n"); # Q=R P=S ! print (fail(substr($a,1,-2)) ? "ok 80\n" : "not ok 81\n"); # R P=S Q ! print (fail(substr($a,1,1)) ? "ok 81\n" : "not ok 81\n"); # P=S Q R ! print (fail(substr($a,1,0)) ? "ok 82\n" : "not ok 82\n"); # P=S Q=R ! print (fail(substr($a,1)) ? "ok 83\n" : "not ok 83\n"); # P=R=S Q ! ! ! my $a = 'zxcvbnm'; ! substr($a,2,0) = ''; ! print $a eq 'zxcvbnm' ? "ok 84\n" : "not ok 84\n"; ! substr($a,7,0) = ''; ! print $a eq 'zxcvbnm' ? "ok 85\n" : "not ok 85\n"; ! substr($a,5,0) = ''; ! print $a eq 'zxcvbnm' ? "ok 86\n" : "not ok 86\n"; ! substr($a,0,2) = 'pq'; ! print $a eq 'pqcvbnm' ? "ok 87\n" : "not ok 87\n"; ! substr($a,2,0) = 'r'; ! print $a eq 'pqrcvbnm' ? "ok 88\n" : "not ok 88\n"; ! substr($a,8,0) = 'asd'; ! print $a eq 'pqrcvbnmasd' ? "ok 89\n" : "not ok 89\n"; ! substr($a,0,2) = 'iop'; ! print $a eq 'ioprcvbnmasd' ? "ok 90\n" : "not ok 90\n"; ! substr($a,0,5) = 'fgh'; ! print $a eq 'fghvbnmasd' ? "ok 91\n" : "not ok 91\n"; ! substr($a,3,5) = 'jkl'; ! print $a eq 'fghjklsd' ? "ok 92\n" : "not ok 92\n"; ! substr($a,3,2) = '1234'; ! print $a eq 'fgh1234lsd' ? "ok 93\n" : "not ok 93\n"; ! # with lexicals (and in re-entered scopes) for (0,1) { *************** *** 52,68 **** unless ($_) { $txt = "Foo"; substr($txt, -1) = "X"; ! print $txt eq "FoX" ? "ok 23\n" : "not ok 23\n"; } else { substr($txt, 0, 1) = "X"; ! print $txt eq "X" ? "ok 24\n" : "not ok 24\n"; } } ! # coersion of references { my $s = []; substr($s, 0, 1) = 'Foo'; ! print substr($s,0,7) eq "FooRRAY" ? "ok 25\n" : "not ok 25\n"; } --- 160,180 ---- unless ($_) { $txt = "Foo"; substr($txt, -1) = "X"; ! print $txt eq "FoX" ? "ok 94\n" : "not ok 94\n"; } else { + local $^W = 0; # because of (spurious?) "uninitialised value" substr($txt, 0, 1) = "X"; ! print $txt eq "X" ? "ok 95\n" : "not ok 95\n"; } } ! # coercion of references { my $s = []; substr($s, 0, 1) = 'Foo'; ! print substr($s,0,7) eq "FooRRAY" && !($w-=2) ? "ok 96\n" : "not ok 96\n"; } + + # check no spurious warnings + print $w ? "not ok 97\n" : "ok 97\n"; Index: perl5.004_01_02/t/op/universal.t *** perl5.004_01/t/op/universal.t Tue Feb 18 00:00:07 1997 --- perl5.004_01_02/t/op/universal.t Tue Jul 29 02:59:13 1997 *************** *** 3,9 **** # check UNIVERSAL # ! print "1..11\n"; $a = {}; bless $a, "Bob"; --- 3,14 ---- # check UNIVERSAL # ! BEGIN { ! chdir 't' if -d 't'; ! @INC = '../lib' if -d '../lib'; ! } ! ! print "1..72\n"; $a = {}; bless $a, "Bob"; *************** *** 21,55 **** sub drink {} sub new { bless {} } package main; $a = new Alice; ! print "not " unless $a->isa("Alice"); ! print "ok 2\n"; ! print "not " unless $a->isa("Bob"); ! print "ok 3\n"; ! print "not " unless $a->isa("Female"); ! print "ok 4\n"; ! print "not " unless $a->isa("Human"); ! print "ok 5\n"; ! print "not " if $a->isa("Male"); ! print "ok 6\n"; ! print "not " unless $a->can("drink"); ! print "ok 7\n"; ! print "not " unless $a->can("eat"); ! print "ok 8\n"; ! print "not " if $a->can("sleep"); ! print "ok 9\n"; ! print "not " unless UNIVERSAL::isa([], "ARRAY"); ! print "ok 10\n"; ! print "not " unless UNIVERSAL::isa({}, "HASH"); ! print "ok 11\n"; --- 26,96 ---- sub drink {} sub new { bless {} } + $Alice::VERSION = 2.718; + package main; + + my $i = 2; + sub test { print "not " unless shift; print "ok $i\n"; $i++; } + $a = new Alice; ! test $a->isa("Alice"); ! test $a->isa("Bob"); ! ! test $a->isa("Female"); ! ! test $a->isa("Human"); ! ! test ! $a->isa("Male"); ! ! test $a->can("drink"); ! ! test $a->can("eat"); ! ! test ! $a->can("sleep"); ! ! my $b = 'abc'; ! my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE); ! my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} ); ! for ($p=0; $p < @refs; $p++) { ! for ($q=0; $q < @vals; $q++) { ! test UNIVERSAL::isa($vals[$p], $refs[$q]) eq ($p==$q or $p+$q==1); ! }; ! }; ! ! test ! UNIVERSAL::can(23, "can"); ! ! test $a->can("VERSION"); ! ! test $a->can("can"); ! test ! $a->can("export_tags"); # a method in Exporter ! ! test (eval { $a->VERSION }) == 2.718; ! ! test ! (eval { $a->VERSION(2.719) }) && ! $@ =~ /^Alice version 2.719 required--this is only version 2.718 at /; ! ! test (eval { $a->VERSION(2.718) }) && ! $@; ! my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; ! test $subs eq "VERSION can isa"; ! test $a->isa("UNIVERSAL"); ! # now use UNIVERSAL.pm and see what changes ! eval "use UNIVERSAL"; ! test $a->isa("UNIVERSAL"); ! my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; ! # XXX import being here is really a bug ! test $sub2 eq "VERSION can import isa"; ! eval 'sub UNIVERSAL::sleep {}'; ! test $a->can("sleep"); ! test ! UNIVERSAL::can($b, "can"); ! test ! $a->can("export_tags"); # a method in Exporter Index: perl5.004_01_02/toke.c *** perl5.004_01/toke.c Tue May 13 20:07:02 1997 --- perl5.004_01_02/toke.c Thu Jul 31 20:51:36 1997 *************** *** 369,375 **** return s; if ((s = filter_gets(linestr, rsfp, (prevlen = SvCUR(linestr)))) == Nullch) { if (minus_n || minus_p) { ! sv_setpv(linestr,minus_p ? ";}continue{print" : ""); sv_catpv(linestr,";}"); minus_n = minus_p = 0; } --- 369,377 ---- return s; if ((s = filter_gets(linestr, rsfp, (prevlen = SvCUR(linestr)))) == Nullch) { if (minus_n || minus_p) { ! sv_setpv(linestr,minus_p ? ! ";}continue{print or die qq(-p destination: $!\\n)" : ! ""); sv_catpv(linestr,";}"); minus_n = minus_p = 0; } *************** *** 1990,2008 **** s = skipspace(s); if (*s == '}') OPERATOR(HASHBRACK); ! if (isALPHA(*s)) { ! for (t = s; t < bufend && isALNUM(*t); t++) ; } ! else if (*s == '\'' || *s == '"') { ! t = strchr(s+1,*s); ! if (!t++) ! t = s; } - else - t = s; while (t < bufend && isSPACE(*t)) t++; ! if ((*t == ',' && !isLOWER(*s)) || (*t == '=' && t[1] == '>')) OPERATOR(HASHBRACK); if (expect == XREF) expect = XTERM; --- 1992,2064 ---- s = skipspace(s); if (*s == '}') OPERATOR(HASHBRACK); ! /* This hack serves to disambiguate a pair of curlies ! * as being a block or an anon hash. Normally, expectation ! * determines that, but in cases where we're not in a ! * position to expect anything in particular (like inside ! * eval"") we have to resolve the ambiguity. This code ! * covers the case where the first term in the curlies is a ! * quoted string. Most other cases need to be explicitly ! * disambiguated by prepending a `+' before the opening ! * curly in order to force resolution as an anon hash. ! * ! * XXX should probably propagate the outer expectation ! * into eval"" to rely less on this hack, but that could ! * potentially break current behavior of eval"". ! * GSAR 97-07-21 ! */ ! t = s; ! if (*s == '\'' || *s == '"' || *s == '`') { ! /* common case: get past first string, handling escapes */ ! for (t++; t < bufend && *t != *s;) ! if (*t++ == '\\' && (*t == '\\' || *t == *s)) ! t++; ! t++; } ! else if (*s == 'q') { ! if (++t < bufend ! && (!isALNUM(*t) ! || ((*t == 'q' || *t == 'x') && ++t < bufend ! && !isALNUM(*t)))) { ! char *tmps; ! char open, close, term; ! I32 brackets = 1; ! ! while (t < bufend && isSPACE(*t)) ! t++; ! term = *t; ! open = term; ! if (term && (tmps = strchr("([{< )]}> )]}>",term))) ! term = tmps[5]; ! close = term; ! if (open == close) ! for (t++; t < bufend; t++) { ! if (*t == '\\' && t+1 < bufend && open != '\\') ! t++; ! else if (*t == open) ! break; ! } ! else ! for (t++; t < bufend; t++) { ! if (*t == '\\' && t+1 < bufend) ! t++; ! else if (*t == close && --brackets <= 0) ! break; ! else if (*t == open) ! brackets++; ! } ! } ! t++; ! } ! else if (isALPHA(*s)) { ! for (t++; t < bufend && isALNUM(*t); t++) ; } while (t < bufend && isSPACE(*t)) t++; ! /* if comma follows first term, call it an anon hash */ ! /* XXX it could be a comma expression with loop modifiers */ ! if (t < bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s))) ! || (*t == '=' && t[1] == '>'))) OPERATOR(HASHBRACK); if (expect == XREF) expect = XTERM; *************** *** 2260,2267 **** else if (isIDFIRST(*s)) { char tmpbuf[sizeof tokenbuf]; scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); ! if (keyword(tmpbuf, len)) ! expect = XTERM; /* e.g. print $fh length() */ else { GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV); if (gv && GvCVu(gv)) --- 2316,2338 ---- else if (isIDFIRST(*s)) { char tmpbuf[sizeof tokenbuf]; scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); ! if (tmp = keyword(tmpbuf, len)) { ! /* binary operators exclude handle interpretations */ ! switch (tmp) { ! case -KEY_x: ! case -KEY_eq: ! case -KEY_ne: ! case -KEY_gt: ! case -KEY_lt: ! case -KEY_ge: ! case -KEY_le: ! case -KEY_cmp: ! break; ! default: ! expect = XTERM; /* e.g. print $fh length() */ ! break; ! } ! } else { GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV); if (gv && GvCVu(gv)) *************** *** 4293,4299 **** } if (*w) for (; *w && isSPACE(*w); w++) ; ! if (!*w || !strchr(";|})]oa!=", *w)) /* an advisory hack only... */ warn("%s (...) interpreted as function",name); } while (s < bufend && isSPACE(*s)) --- 4364,4370 ---- } if (*w) for (; *w && isSPACE(*w); w++) ; ! if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */ warn("%s (...) interpreted as function",name); } while (s < bufend && isSPACE(*s)) *************** *** 4459,4465 **** lex_state = LEX_INTERPEND; if (funny == '#') funny = '@'; ! if (dowarn && (keyword(dest, d - dest) || perl_get_cv(dest, FALSE))) warn("Ambiguous use of %c{%s} resolved to %c%s", funny, dest, funny, dest); --- 4530,4536 ---- lex_state = LEX_INTERPEND; if (funny == '#') funny = '@'; ! if (dowarn && lex_state == LEX_NORMAL && (keyword(dest, d - dest) || perl_get_cv(dest, FALSE))) warn("Ambiguous use of %c{%s} resolved to %c%s", funny, dest, funny, dest); *************** *** 4875,4882 **** register char *to; I32 brackets = 1; ! if (isSPACE(*s)) ! s = skipspace(s); CLINE; term = *s; multi_start = curcop->cop_line; --- 4946,4958 ---- register char *to; I32 brackets = 1; ! if (isSPACE(*s)) { ! /* "#" is allowed as delimiter if on same line */ ! while (*s == ' ' || *s == '\t') ! s++; ! if (isSPACE(*s)) ! s = skipspace(s); ! } CLINE; term = *s; multi_start = curcop->cop_line; *************** *** 4912,4924 **** for (; s < bufend; s++,to++) { if (*s == '\n' && !rsfp) curcop->cop_line++; ! if (*s == '\\' && s+1 < bufend && term != '\\') { ! if (s[1] == term) s++; else *to++ = *s++; } ! else if (*s == term && --brackets <= 0) break; else if (*s == multi_open) brackets++; --- 4988,5000 ---- for (; s < bufend; s++,to++) { if (*s == '\n' && !rsfp) curcop->cop_line++; ! if (*s == '\\' && s+1 < bufend) { ! if ((s[1] == multi_open) || (s[1] == multi_close)) s++; else *to++ = *s++; } ! else if (*s == multi_close && --brackets <= 0) break; else if (*s == multi_open) brackets++; Index: perl5.004_01_02/universal.c *** perl5.004_01/universal.c Wed Apr 2 01:39:21 1997 --- perl5.004_01_02/universal.c Mon Jul 28 22:11:59 1997 *************** *** 71,77 **** } } ! return &sv_no; } bool --- 71,77 ---- } } ! return boolSV(strEQ(name, "UNIVERSAL")); } bool Index: perl5.004_01_02/util.c *** perl5.004_01/util.c Tue Jun 10 01:52:06 1997 --- perl5.004_01_02/util.c Tue Jul 29 01:44:50 1997 *************** *** 2085,2095 **** } } #ifdef HAS_WAITPID return waitpid(pid,statusp,flags); ! #else ! #ifdef HAS_WAIT4 return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); ! #else { I32 result; if (flags) --- 2085,2101 ---- } } #ifdef HAS_WAITPID + # ifdef HAS_WAITPID_RUNTIME + if (!HAS_WAITPID_RUNTIME) + goto hard_way; + # endif return waitpid(pid,statusp,flags); ! #endif ! #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); ! #endif ! #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) ! hard_way: { I32 result; if (flags) *************** *** 2102,2108 **** } return result; } - #endif #endif } #endif /* !DOSISH */ --- 2108,2113 ---- Index: perl5.004_01_02/utils/h2ph.PL *** perl5.004_01/utils/h2ph.PL Fri Apr 18 20:59:25 1997 --- perl5.004_01_02/utils/h2ph.PL Thu Jul 31 22:08:54 1997 *************** *** 116,125 **** if ($t ne '') { $new =~ s/(['\\])/\\$1/g; print OUT $t, ! "eval 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}';\n"; } else { ! print OUT "sub $name $proto\{\n ${args}eval \"$new\";\n}\n"; } %curargs = (); } --- 116,125 ---- if ($t ne '') { $new =~ s/(['\\])/\\$1/g; print OUT $t, ! "eval 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n"; } else { ! print OUT "unless defined(\&$name) {\nsub $name $proto\{\n ${args}eval \"$new\";\n}\n}\n"; } %curargs = (); } *************** *** 129,138 **** $new = 1 if $new eq ''; if ($t ne '') { $new =~ s/(['\\])/\\$1/g; ! print OUT $t,"eval 'sub $name () {",$new,";}';\n"; } else { ! print OUT $t,"sub $name () {",$new,";}\n"; } } } --- 129,138 ---- $new = 1 if $new eq ''; if ($t ne '') { $new =~ s/(['\\])/\\$1/g; ! print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n"; } else { ! print OUT $t,"unless(defined(\&$name) {\nsub $name () {",$new,";}\n}\n"; } } } Index: perl5.004_01_02/utils/perlbug.PL *** perl5.004_01/utils/perlbug.PL Sat Jun 7 00:35:41 1997 --- perl5.004_01_02/utils/perlbug.PL Tue Jul 29 00:34:25 1997 *************** *** 49,55 **** sub paraprint; ! my($Version) = "1.17"; # 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. --- 49,55 ---- sub paraprint; ! my($Version) = "1.18"; # 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. *************** *** 69,82 **** # Also report selected environment variables. # Changed in 1.16 to include @INC, and allow user to re-edit if no changes. # Changed in 1.17 Win32 support added. GSAR 97-04-12 ! # TODO: Allow the user to re-name the file on mail failure, and # make sure failure (transmission-wise) of Mail::Send is # accounted for. my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename, $subject, $from, $verbose, $ed, ! $fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP); Init(); --- 69,84 ---- # Also report selected environment variables. # Changed in 1.16 to include @INC, and allow user to re-edit if no changes. # Changed in 1.17 Win32 support added. GSAR 97-04-12 + # Changed in 1.18 add '-ok' option for reporting build success. CFR 97-06-18 ! # TODO: - Allow the user to re-name the file on mail failure, and # 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, ! $fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP, $ok); Init(); *************** *** 106,112 **** $Is_MSWin32 = $^O eq 'MSWin32'; $Is_VMS = $^O eq 'VMS'; ! getopts("dhva:s:b:f:r:e:SCc:t"); # This comment is needed to notify metaconfig that we are --- 108,114 ---- $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 *************** *** 117,122 **** --- 119,125 ---- # perlbug address $perlbug = 'perlbug@perl.com'; + # Test address $testaddress = 'perlbug-test@perl.com'; *************** *** 124,136 **** # Target address $address = $::opt_a || ($::opt_t ? $testaddress : $perlbug); - # 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.) - $cc = ($::opt_C ? "" : ( - $::opt_c || $::Config{perladmin} || $::Config{cf_email} || $::Config{cf_by} - )); - # Users address, used in message and in Reply-To header $from = $::opt_r || ""; --- 127,132 ---- *************** *** 154,162 **** ($Is_VMS ? "edit/tpu" : $Is_MSWin32 ? "notepad" : "vi") ); # My username ! $me = ($Is_MSWin32 ? $ENV{'USERNAME'} : getpwuid($<)); } --- 150,191 ---- ($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' ) { + # force these options + $::opt_S = 1; # don't prompt for send + $::opt_C = 1; # don't send a copy to the local admin + $::opt_v = 1; $verbose = 1; + $::opt_s = 1; $subject = "OK: perl $] on " + . $::Config{'osname'} . ' ' + . $::Config{'osvers'}; + $::opt_b = 1; $body = "Perl reported to build OK on this system\n"; + $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 } *************** *** 164,170 **** sub Query { # Explain what perlbug is ! paraprint <; ! chop $from; ! ! if($from eq "") { $from = $guess } } --- 286,305 ---- EOF } ! ! if ( $ok && $guess ne '' ) { ! # use it ! $from = $guess; ! } ! else { ! # verify it ! print "Your address [$guess]: "; ! ! $from = <>; ! chop $from; ! ! if($from eq "") { $from = $guess } ! } } *************** *** 350,356 **** { my($dir) = ($Is_VMS ? 'sys$scratch:' : ! ($Is_MSWin32 and $ENV{'TEMP'} ? $ENV{'TEMP'} : '/tmp/')); $filename = "bugrep0$$"; $filename++ while -e "$dir$filename"; $filename = "$dir$filename"; --- 390,396 ---- { my($dir) = ($Is_VMS ? 'sys$scratch:' : ! (($Is_MSWin32 && $ENV{'TEMP'}) ? $ENV{'TEMP'} : '/tmp/')); $filename = "bugrep0$$"; $filename++ while -e "$dir$filename"; $filename = "$dir$filename"; *************** *** 543,548 **** --- 583,589 ---- } } + return if $ok; # Check that we have a report that has some, eh, report in it. my $unseen = 0; *************** *** 680,685 **** --- 721,727 ---- $fh->close; + print "\nMessage sent.\n"; } else { if ($Is_VMS) { if ( ($address =~ /@/ and $address !~ /^\w+%"/) or *************** *** 701,706 **** --- 743,760 ---- { $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" and die "\n" if $sendmail eq ""; *************** *** 713,719 **** EOF ! open(SENDMAIL,"|$sendmail -t"); print SENDMAIL "To: $address\n"; print SENDMAIL "Subject: $subject\n"; print SENDMAIL "Cc: $cc\n" if $cc; --- 767,773 ---- 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; *************** *** 723,734 **** while() { print SENDMAIL $_ } close(REP); ! close(SENDMAIL); } } - - print "\nMessage sent.\n"; 1 while unlink($filename); # remove all versions under VMS --- 777,790 ---- while() { 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 *************** *** 767,772 **** --- 823,829 ---- -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 sytem to perl porters (use alone). -h Print this help message. EOF *************** *** 802,807 **** --- 859,866 ---- S<[ B<-e> I ]> S<[ B<-c> I | B<-C> ]> S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-h> ]> + B S<[ B<-r> I ]> B<-ok> + =head1 DESCRIPTION A program to help generate bug reports about perl or the modules that *************** *** 906,913 **** Having done your bit, please be prepared to wait, to be told the bug is in your code, or even to get no reply at all. The perl maintainers ! are busy folks, so if your problem is a small one or if it is ! difficult to understand, they may not respond with a personal reply. If it is important to you that your bug be fixed, do monitor the C file in any development releases since the time you submitted the bug, and encourage the maintainers with kind words (but never any --- 965,972 ---- Having done your bit, please be prepared to wait, to be told the bug is in your code, or even to get no reply at all. The perl maintainers ! are busy folks, so if your problem is a small one or if it is difficult ! to understand or already known, they may not respond with a personal reply. If it is important to you that your bug be fixed, do monitor the C file in any development releases since the time you submitted the bug, and encourage the maintainers with kind words (but never any *************** *** 955,960 **** --- 1014,1026 ---- Prints a brief summary of the options. + =item B<-ok> + + Report successful build on this system to perl porters. Forces B<-S>, + B<-C>, and B<-v>. Forces and supplies values for B<-s> and B<-b>. Only + prompts for a return address if it cannot guess it (for use with + B). Honors return address specified with B<-r>. + =item B<-r> Your return address. The program will ask you to confirm its default *************** *** 983,990 **** Kenneth Albanowski (Ekjahds@kjahds.comE), subsequently Itored by Gurusamy Sarathy (Egsar@umich.eduE), Tom Christiansen ! (Etchrist@perl.comE), and Nathan Torkington ! (Egnat@frii.comE). =head1 SEE ALSO --- 1049,1056 ---- Kenneth Albanowski (Ekjahds@kjahds.comE), subsequently Itored by Gurusamy Sarathy (Egsar@umich.eduE), Tom Christiansen ! (Etchrist@perl.comE), Nathan Torkington (Egnat@frii.comE), ! and Charles F. Randall (Ecfr@pobox.comE). =head1 SEE ALSO Index: perl5.004_01_02/utils/perldoc.PL *** perl5.004_01/utils/perldoc.PL Mon Apr 14 03:23:56 1997 --- perl5.004_01_02/utils/perldoc.PL Tue Jul 29 01:23:32 1997 *************** *** 56,61 **** --- 56,63 ---- } use Getopt::Std; + use Config '%Config'; + $Is_VMS = $^O eq 'VMS'; $Is_MSWin32 = $^O eq 'MSWin32'; *************** *** 132,148 **** return 0; } ! sub minus_f_nocase { my($file) = @_; local *DIR; local($")="/"; my(@p,$p,$cip); foreach $p (split(/\//, $file)){ - if (($Is_VMS or $Is_MSWin32 or $^O eq 'os2') and not scalar @p) { - # VMSish filesystems don't begin at '/' - push(@p,$p); - next; - } if (-d ("@p/$p")){ push @p, $p; } elsif (-f ("@p/$p")) { --- 134,149 ---- return 0; } ! sub minus_f_nocase { my($file) = @_; + # on a case-forgiving file system we can simply use -f $file + if ($Is_VMS or $Is_MSWin32 or $^O eq 'os2') { + return ( -f $file ) ? $file : ''; + } local *DIR; local($")="/"; my(@p,$p,$cip); foreach $p (split(/\//, $file)){ if (-d ("@p/$p")){ push @p, $p; } elsif (-f ("@p/$p")) { *************** *** 152,158 **** my $lcp = lc $p; opendir DIR, "@p"; while ($cip=readdir(DIR)) { - $cip =~ s/\.dir$// if $Is_VMS; if (lc $cip eq $lcp){ $found++; last; --- 153,158 ---- *************** *** 184,190 **** or ( $ret = minus_f_nocase "$dir/$s" and containspod($ret)) or ( $Is_VMS and $ret = minus_f_nocase "$dir/$s.com" and containspod($ret)) ! or ( $Is_MSWin32 and $ret = minus_f_nocase "$dir/$s.bat" and containspod($ret)) or ( $ret = minus_f_nocase "$dir/pod/$s.pod") or ( $ret = minus_f_nocase "$dir/pod/$s" and containspod($ret))) --- 184,192 ---- or ( $ret = minus_f_nocase "$dir/$s" and containspod($ret)) or ( $Is_VMS and $ret = minus_f_nocase "$dir/$s.com" and containspod($ret)) ! or ( $^O eq 'os2' and ! $ret = minus_f_nocase "$dir/$s.cmd" and containspod($ret)) ! or ( ($Is_MSWin32 or $^O eq 'os2') and $ret = minus_f_nocase "$dir/$s.bat" and containspod($ret)) or ( $ret = minus_f_nocase "$dir/pod/$s.pod") or ( $ret = minus_f_nocase "$dir/pod/$s" and containspod($ret))) *************** *** 215,224 **** for ($i = 0; $trn = $ENV{'DCL$PATH'.$i}; $i++) { push(@searchdirs,$trn); } - } elsif ($Is_MSWin32) { - push(@searchdirs, grep(-d, split(';', $ENV{'PATH'}))); } else { ! push(@searchdirs, grep(-d, split(':', $ENV{'PATH'}))); } @files= searchfor(0,$_,@searchdirs); } --- 217,225 ---- for ($i = 0; $trn = $ENV{'DCL$PATH'.$i}; $i++) { push(@searchdirs,$trn); } } else { ! push(@searchdirs, grep(-d, split($Config{path_sep}, ! $ENV{'PATH'}))); } @files= searchfor(0,$_,@searchdirs); } *************** *** 259,265 **** $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$; push @pagers, qw( most more less type/page ); } else { ! $tmp = "/tmp/perldoc1.$$"; push @pagers, qw( more less pg view cat ); unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; } --- 260,271 ---- $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$; push @pagers, qw( most more less type/page ); } else { ! if ($^O eq 'os2') { ! require POSIX; ! $tmp = POSIX::tmpnam(); ! } else { ! $tmp = "/tmp/perldoc1.$$"; ! } push @pagers, qw( more less pg view cat ); unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; } Index: perl5.004_01_02/vms/config.vms *** perl5.004_01/vms/config.vms Thu May 15 22:10:34 1997 --- perl5.004_01_02/vms/config.vms Thu Jul 31 19:38:51 1997 *************** *** 112,118 **** * This symbol is defined if the bcmp() routine is available to * compare blocks of memory. */ ! #undef HAS_BCMP /**/ #include /* Check whether new DECC has #defined bcopy and bzero */ /* HAS_BCOPY: --- 112,122 ---- * This symbol is defined if the bcmp() routine is available to * compare blocks of memory. */ ! #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) ! #define HAS_BCMP /**/ ! #else ! #undef HAS_BCMP /*config-skip*/ ! #endif #include /* Check whether new DECC has #defined bcopy and bzero */ /* HAS_BCOPY: *************** *** 233,239 **** * needs to be included (see I_SYS_RESOURCE). * The type "Timeval" should be used to refer to "struct timeval". */ ! #undef HAS_GETTIMEOFDAY /**/ #ifdef HAS_GETTIMEOFDAY # define Timeval struct timeval /*config-skip*/ #endif --- 237,247 ---- * needs to be included (see I_SYS_RESOURCE). * The type "Timeval" should be used to refer to "struct timeval". */ ! #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) ! #define HAS_GETTIMEOFDAY /**/ ! #else ! #undef HAS_GETTIMEOFDAY /*config-skip*/ ! #endif #ifdef HAS_GETTIMEOFDAY # define Timeval struct timeval /*config-skip*/ #endif *************** *** 256,262 **** * uname() routine to derive the host name. See also HAS_GETHOSTNAME * and PHOSTNAME. */ ! #undef HAS_UNAME /**/ /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is --- 264,274 ---- * uname() routine to derive the host name. See also HAS_GETHOSTNAME * and PHOSTNAME. */ ! #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) ! #define HAS_UNAME /**/ ! #else ! #undef HAS_UNAME /*config-skip*/ ! #endif /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is *************** *** 492,498 **** * This symbol, if defined, indicates that Vr4's sigaction() routine * is available. */ ! #undef HAS_SIGACTION /**/ /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring --- 504,514 ---- * This symbol, if defined, indicates that Vr4's sigaction() routine * is available. */ ! #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) ! #define HAS_SIGACTION /**/ ! #else ! #undef HAS_SIGACTION /*config-skip*/ ! #endif /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring *************** *** 622,628 **** * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ ! #undef HAS_TRUNCATE /**/ /* HAS_VFORK: --- 638,648 ---- * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ ! #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) ! #define HAS_TRUNCATE /**/ ! #else ! #undef HAS_TRUNCATE /*config-skip*/ ! #endif /* HAS_VFORK: *************** *** 664,670 **** /* HAS_WAIT4: * This symbol, if defined, indicates that wait4() exists. */ ! #undef HAS_WAIT4 /**/ /* HAS_WAITPID: * This symbol, if defined, indicates that the waitpid routine is --- 684,694 ---- /* HAS_WAIT4: * This symbol, if defined, indicates that wait4() exists. */ ! #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) ! #define HAS_WAIT4 /**/ ! #else ! #undef HAS_WAIT4 /*config-skip*/ ! #endif /* HAS_WAITPID: * This symbol, if defined, indicates that the waitpid routine is *************** *** 962,971 **** * is defined, and 'int *' otherwise. This is only useful if you * have select(), of course. */ ! #if defined(__DECC) && defined(__DECC_VER) && (__DECC_VER >= 50200000) ! #define Select_fd_set_t fd_set * /* config-skip */ #else ! #define Select_fd_set_t int * /**/ #endif /* STDCHAR: --- 986,995 ---- * is defined, and 'int *' otherwise. This is only useful if you * have select(), of course. */ ! #if defined(__DECC) && defined(__DECC_VER) && (__DECC_VER >= 50200000) && defined(DECCRTL_SOCKETS) ! #define Select_fd_set_t fd_set * /**/ #else ! #define Select_fd_set_t int * /* config-skip */ #endif /* STDCHAR: *************** *** 1161,1167 **** * functions are available for string searching. */ #define HAS_STRCHR /**/ ! #undef HAS_INDEX /**/ /* HAS_STRCOLL: * This symbol, if defined, indicates that the strcoll routine is --- 1185,1195 ---- * functions are available for string searching. */ #define HAS_STRCHR /**/ ! #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) ! #define HAS_INDEX /**/ ! #else ! #undef HAS_INDEX /*config-skip*/ ! #endif /* HAS_STRCOLL: * This symbol, if defined, indicates that the strcoll routine is *************** *** 1347,1355 **** * corresponds to the 0 at the end of the sig_num list. * See SIG_NUM and SIG_MAX. */ #define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","IOT","EMT","FPE",\ "KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM",\ ! "ABRT","USR1","USR2",0 /* SIG_NUM: * This symbol contains a list of signal number, in the same order as the --- 1375,1391 ---- * corresponds to the 0 at the end of the sig_num list. * See SIG_NUM and SIG_MAX. */ + #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) + #define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","IOT","EMT","FPE",\ + "KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM",\ + "ABRT","USR1","USR2","SPARE18","SPARE19","CHLD","CONT",\ + "STOP","TSTP","TTIN","TTOU","DEBUG","SPARE27","SPARE28",\ + "SPARE29","SPARE30","SPARE31","SPARE32","RTMIN","RTMAX",0 /**/ + #else #define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","IOT","EMT","FPE",\ "KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM",\ ! "ABRT","USR1","USR2",0 /*config-skip*/ ! #endif /* SIG_NUM: * This symbol contains a list of signal number, in the same order as the *************** *** 1364,1370 **** * The last element is 0, corresponding to the 0 at the end of * the sig_name list. */ ! #define SIG_NUM 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,6,16,17,0 /**/ /* Mode_t: * This symbol holds the type used to declare file modes --- 1400,1410 ---- * The last element is 0, corresponding to the 0 at the end of * the sig_name list. */ ! #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) ! #define SIG_NUM 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,6,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,64,0 /**/ ! #else ! #define SIG_NUM 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,6,16,17,0 /*config-skip*/ ! #endif /* Mode_t: * This symbol holds the type used to declare file modes *************** *** 1598,1605 **** * to determine file-system related limits and options associated * with a given open file descriptor. */ ! #undef HAS_PATHCONF /**/ ! #undef HAS_FPATHCONF /**/ /* HAS_SAFE_BCOPY: * This symbol, if defined, indicates that the bcopy routine is available --- 1638,1650 ---- * to determine file-system related limits and options associated * with a given open file descriptor. */ ! #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) ! #define HAS_PATHCONF /**/ ! #define HAS_FPATHCONF /**/ ! #else ! #undef HAS_PATHCONF /*config-skip*/ ! #undef HAS_FPATHCONF /*config-skip*/ ! #endif /* HAS_SAFE_BCOPY: * This symbol, if defined, indicates that the bcopy routine is available *************** *** 1658,1664 **** * This symbol, if defined, indicates that sysconf() is available * to determine system related limits and options. */ ! #undef HAS_SYSCONF /**/ /* Gconvert: * This preprocessor macro is defined to convert a floating point --- 1703,1713 ---- * This symbol, if defined, indicates that sysconf() is available * to determine system related limits and options. */ ! #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) ! #define HAS_SYSCONF /**/ ! #else ! #undef HAS_SYSCONF /*config-skip*/ ! #endif /* Gconvert: * This preprocessor macro is defined to convert a floating point *************** *** 1718,1724 **** * This macro is used in the same way as siglongjmp(), but will invoke * traditional longjmp() if siglongjmp isn't available. */ ! #undef HAS_SIGSETJMP /**/ #ifdef HAS_SIGSETJMP #define Sigjmp_buf sigjmp_buf /* config-skip */ #define Sigsetjmp(buf,save_mask) sigsetjmp(buf,save_mask) /* config-skip */ --- 1767,1777 ---- * This macro is used in the same way as siglongjmp(), but will invoke * traditional longjmp() if siglongjmp isn't available. */ ! #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) ! #define HAS_SIGSETJMP /**/ ! #else ! #undef HAS_SIGSETJMP /*config-skip*/ ! #endif #ifdef HAS_SIGSETJMP #define Sigjmp_buf sigjmp_buf /* config-skip */ #define Sigsetjmp(buf,save_mask) sigsetjmp(buf,save_mask) /* config-skip */ Index: perl5.004_01_02/vms/descrip.mms *** perl5.004_01/vms/descrip.mms Thu May 15 15:41:48 1997 --- perl5.004_01_02/vms/descrip.mms Thu Jul 31 19:42:52 1997 *************** *** 24,30 **** #: To each of the above, add /Macro="__AXP__=1" if building on an AXP, #: /Macro="__DEBUG__=1" to build a debug version #: (i.e. VMS debugger, not perl -D), and ! #: /Macro="SOCKET=1" to include socket support. # # tidy -- purge files generated by executing this file # clean -- remove all intermediate (e.g. object files, C files generated --- 24,33 ---- #: To each of the above, add /Macro="__AXP__=1" if building on an AXP, #: /Macro="__DEBUG__=1" to build a debug version #: (i.e. VMS debugger, not perl -D), and ! #: /Macro="SOCKETSHR_SOCKETS=1" to include ! #: SOCKETSHR socket support. ! #: /Macro="DECC_SOCKETS=1" to include UCX (or ! #: compatible) socket support # # tidy -- purge files generated by executing this file # clean -- remove all intermediate (e.g. object files, C files generated *************** *** 67,72 **** --- 70,94 ---- # Updated by fndvers.com -- do not edit by hand PERL_VERSION = 5_004 # + .ifdef DECC_SOCKETS + SOCKET=1 + .endif + + .ifdef SOCKETSHR_SOCKETS + SOCKET=1 + .endif + + # If they defined SOCKET but didn't choose a stack, default to SOCKETSHR + .ifdef DECC_SOCKETS + .else + .ifdef SOCKETSHR_SOCKETS + .else + .ifdef SOCKET + SOCKETSHR_SOCKETS=1 + .endif + .endif + .endif + ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)] ARCHCORE = [.lib.$(ARCH).$(PERL_VERSION).CORE] *************** *** 78,83 **** --- 100,108 ---- PIPES_BROKEN = 1 .endif + .ifdef __DEBUG__ + NOX2P = 1 + .endif #: >>>>>Compiler-specific options <<<<< .ifdef GNUC *************** *** 142,148 **** DBG = DBG .else DBGCCFLAGS = /NoList ! DBGLINKFLAGS = /NoMap DBG = .endif --- 167,173 ---- DBG = DBG .else DBGCCFLAGS = /NoList ! DBGLINKFLAGS = /NoTrace/NoMap DBG = .endif *************** *** 150,157 **** --- 175,187 ---- #: By default, used SOCKETSHR library; see ReadMe.VMS #: for information on changing socket support .ifdef SOCKET + .ifdef DECC_SOCKETS + SOCKDEF = ,VMS_DO_SOCKETS,DECCRTL_SOCKETS + SOCKLIB = + .else SOCKDEF = ,VMS_DO_SOCKETS SOCKLIB = SocketShr/Share + .endif # N.B. the targets for $(SOCKC) and $(SOCKH) assume that the permanent # copies live in [.vms], and the `clean' target will delete copies of # these files in the current default directory. *************** *** 272,279 **** --- 302,314 ---- utils1 = [.lib.pod]perldoc.com [.lib.ExtUtils]Miniperl.pm [.utils]c2ph.com [.utils]h2ph.com [.utils]h2xs.com [.lib]perlbug.com utils2 = [.lib]splain.com [.utils]pl2pm.com + .ifdef NOX2P + all : base extras archcorefiles preplibrary perlpods + @ $(NOOP) + .else all : base extras x2p archcorefiles preplibrary perlpods @ $(NOOP) + .endif base : miniperl perl @ $(NOOP) extras : Fcntl IO Opcode $(POSIX) libmods utils podxform *************** *** 330,336 **** .endif $(DBG)perlshr$(E) : $(DBG)libperl$(OLB) $(extobj) $(DBG)perlshr_xtras.ts ! Link /NoTrace$(LINKFLAGS)/Share=$(MMS$TARGET) $(extobj) []$(DBG)perlshr_bld.opt/Option, perlshr_attr.opt/Option # The following files are built in one go by gen_shrfls.pl: # perlshr_attr.opt, $(DBG)perlshr_bld.opt - VAX and AXP --- 365,371 ---- .endif $(DBG)perlshr$(E) : $(DBG)libperl$(OLB) $(extobj) $(DBG)perlshr_xtras.ts ! Link $(LINKFLAGS)/Share=$(MMS$TARGET) $(extobj) []$(DBG)perlshr_bld.opt/Option, perlshr_attr.opt/Option # The following files are built in one go by gen_shrfls.pl: # perlshr_attr.opt, $(DBG)perlshr_bld.opt - VAX and AXP Index: perl5.004_01_02/vms/ext/filespec.t *** perl5.004_01/vms/ext/filespec.t Thu Feb 20 16:52:54 1997 --- perl5.004_01_02/vms/ext/filespec.t Thu Jul 31 19:42:53 1997 *************** *** 25,35 **** } } ! print +(rmsexpand('[]') eq "\U$ENV{DEFAULT}" ? 'ok ' : 'not ok '),++$idx,"\n"; ! print +(rmsexpand('from.here') eq "\L$ENV{DEFAULT}from.here" ? ! 'ok ' : 'not ok '),++$idx,"\n"; ! print +(rmsexpand('from.here','cant:[get.there];2') eq ! 'cant:[get.there]from.here;2' ? 'ok ' : 'not ok '),++$idx,"\n"; __DATA__ --- 25,57 ---- } } ! if (rmsexpand('[]') eq "\U$ENV{DEFAULT}") { print 'ok ',++$idx,"\n"; } ! else { ! print 'not ok ', ++$idx, ": rmsexpand('[]') = |", rmsexpand('[]'), ! "|, \$ENV{DEFAULT} = |\U$ENV{DEFAULT}|\n"; ! print "# Note: This failure may have occurred because your default device\n"; ! print "# was set using a non-concealed logical name. If this is the case,\n"; ! print "# you will need to determine by inspection that the two resultant\n"; ! print "# file specifications shwn above are in fact equivalent.\n"; ! } ! if (rmsexpand('from.here') eq "\L$ENV{DEFAULT}from.here") { ! print 'ok ', ++$idx, "\n"; ! } ! else { ! print 'not ok ', ++$idx, ": rmsexpand('from.here') = |", ! rmsexpand('from.here'), ! "|, \$ENV{DEFAULT}from.here = |\L$ENV{DEFAULT}from.here|\n"; ! print "# Note: This failure may have occurred because your default device\n"; ! print "# was set using a non-concealed logical name. If this is the case,\n"; ! print "# you will need to determine by inspection that the two resultant\n"; ! print "# file specifications shwn above are in fact equivalent.\n"; ! } ! if (rmsexpand('from.here','cant:[get.there];2') eq ! 'cant:[get.there]from.here;2') { print 'ok ',++$idx,"\n"; } ! else { ! print 'not ok ', ++$idx, ': expected |cant:[get.there]from.here;2|, got |', ! rmsexpand('from.here','cant:[get.there];2'),"|\n"; ! } __DATA__ Index: perl5.004_01_02/vms/sockadapt.c *** perl5.004_01/vms/sockadapt.c Thu Mar 6 14:55:00 1997 --- perl5.004_01_02/vms/sockadapt.c Thu Jul 31 19:38:30 1997 *************** *** 29,46 **** --- 29,53 ---- # define __sockadapt_my_name_t char * #endif + /* We have these on VMS 7.0 and above, or on Dec C 5.6 if it's providing */ + /* the 7.0 DECC RTL */ + #if ((((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)) && defined(DECCRTL_SOCKETS)) + #else void setnetent(int stayopen) { croak("Function \"setnetent\" not implemented in this version of perl"); } void endnetent() { croak("Function \"endnetent\" not implemented in this version of perl"); } + #endif #if defined(DECCRTL_SOCKETS) /* Use builtin socket interface in DECCRTL and * UCX emulation in whatever TCP/IP stack is present. */ + #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) + #else void sethostent(int stayopen) { croak("Function \"sethostent\" not implemented in this version of perl"); } *************** *** 67,72 **** --- 74,80 ---- croak("Function \"getservent\" not implemented in this version of perl"); return (__sockadapt_my_servent_t )NULL; /* Avoid MISSINGRETURN warning, not reached */ } + #endif #else /* Work around things missing/broken in SOCKETSHR. */ Index: perl5.004_01_02/vms/sockadapt.h *** perl5.004_01/vms/sockadapt.h Thu May 15 20:08:39 1997 --- perl5.004_01_02/vms/sockadapt.h Thu Jul 31 19:38:30 1997 *************** *** 24,29 **** --- 24,31 ---- # include # include # include + #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) + #else void sethostent(int); void endhostent(void); void setnetent(int); *************** *** 32,37 **** --- 34,40 ---- void endprotoent(void); void setservent(int); void endservent(void); + #endif # if defined(__DECC) && defined(__DECC_VER) && (__DECC_VER >= 50200000) # define Sock_size_t unsigned int # endif Index: perl5.004_01_02/vms/test.com *** perl5.004_01/vms/test.com Mon Feb 17 23:59:36 1997 --- perl5.004_01_02/vms/test.com Thu Jul 31 19:43:40 1997 *************** *** 6,11 **** --- 6,12 ---- $! A little basic setup $ On Error Then Goto wrapup $ olddef = F$Environment("Default") + $ oldmsg = F$Environment("Message") $ If F$Search("t.dir").nes."" $ Then $ Set Default [.t] *************** *** 18,23 **** --- 19,25 ---- $ Exit 44 $ EndIf $ EndIf + $ Set Message /Facility/Severity/Identification/Text $ $ exe = ".Exe" $ If p1.nes."" Then exe = p1 *************** *** 87,98 **** # but the tests may use other operators which don't.) use Config; ! @compexcl=('cpp.t','script.t'); @ioexcl=('argv.t','dup.t','fs.t','inplace.t','pipe.t'); @libexcl=('anydbm.t','db-btree.t','db-hash.t','db-recno.t', 'gdbm.t','io_dup.t', 'io_pipe.t', 'io_sel.t', 'io_sock.t', 'ndbm.t','odbm.t','open2.t','open3.t','posix.t', ! 'sdbm.t','soundex.t'); # Note: POSIX is not part of basic build, but can be built # separately if you're using DECC --- 89,100 ---- # but the tests may use other operators which don't.) use Config; ! @compexcl=('cpp.t'); @ioexcl=('argv.t','dup.t','fs.t','inplace.t','pipe.t'); @libexcl=('anydbm.t','db-btree.t','db-hash.t','db-recno.t', 'gdbm.t','io_dup.t', 'io_pipe.t', 'io_sel.t', 'io_sock.t', 'ndbm.t','odbm.t','open2.t','open3.t','posix.t', ! 'sdbm.t'); # Note: POSIX is not part of basic build, but can be built # separately if you're using DECC *************** *** 218,221 **** --- 220,224 ---- $ wrapup: $ If F$Search("Echo.Exe").nes."" Then Delete/Log/NoConfirm Echo.Exe;* $ Set Default &olddef + $ Set Message 'oldmsg' $ Exit Index: perl5.004_01_02/vms/vms.c Prereq: 2.2 *** perl5.004_01/vms/vms.c Thu May 15 22:09:43 1997 --- perl5.004_01_02/vms/vms.c Thu Jul 31 19:42:53 1997 *************** *** 456,464 **** /*}}}*/ ! /*{{{int my_mkdir(char *,mode_t)*/ int ! my_mkdir(char *dir, mode_t mode) { STRLEN dirlen = strlen(dir); --- 456,464 ---- /*}}}*/ ! /*{{{int my_mkdir(char *,Mode_t)*/ int ! my_mkdir(char *dir, Mode_t mode) { STRLEN dirlen = strlen(dir); *************** *** 1759,1765 **** static void pipe_and_fork(char **cmargv); /*{{{ void getredirection(int *ac, char ***av)*/ ! void getredirection(int *ac, char ***av) /* * Process vms redirection arg's. Exit if any error is seen. --- 1759,1765 ---- static void pipe_and_fork(char **cmargv); /*{{{ void getredirection(int *ac, char ***av)*/ ! static void getredirection(int *ac, char ***av) /* * Process vms redirection arg's. Exit if any error is seen. *************** *** 2220,2225 **** --- 2220,2253 ---- } /*}}}*/ /***** End of code taken from Mark Pizzolato's argproc.c package *****/ + + + /* OS-specific initialization at image activation (not thread startup) */ + /*{{{void vms_image_init(int *, char ***)*/ + void + vms_image_init(int *argcp, char ***argvp) + { + unsigned long int *mask, iosb[2], i; + unsigned short int dummy; + union prvdef iprv; + struct itmlst_3 jpilist[2] = { {sizeof iprv, JPI$_IMAGPRIV, &iprv, &dummy}, + { 0, 0, 0, 0} }; + + _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL)); + _ckvmssts(iosb[0]); + mask = (unsigned long int *) &iprv; /* Quick change of view */; + for (i = 0; i < (sizeof iprv + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i++) { + if (mask[i]) { /* Running image installed with privs? */ + _ckvmssts(sys$setprv(0,&iprv,0,NULL)); /* Turn 'em off. */ + tainting = TRUE; + break; + } + } + getredirection(argcp,argvp); + return; + } + /*}}}*/ + /* trim_unixpath() * Trim Unix-style prefix off filespec, so it looks like what a shell Index: perl5.004_01_02/vms/vmsish.h *** perl5.004_01/vms/vmsish.h Tue May 13 18:15:10 1997 --- perl5.004_01_02/vms/vmsish.h Thu Jul 31 19:42:54 1997 *************** *** 104,117 **** # define tounixpath_ts Perl_tounixpath_ts # define tovmspath Perl_tovmspath # define tovmspath_ts Perl_tovmspath_ts ! # define getredirection Perl_getredirection # define opendir Perl_opendir # define readdir Perl_readdir # define telldir Perl_telldir # define seekdir Perl_seekdir # define closedir Perl_closedir # define vmsreaddirversions Perl_vmsreaddirversions - # define getredirection Perl_getredirection # define my_gmtime Perl_my_gmtime # define my_localtime Perl_my_localtime # define my_time Perl_my_time --- 104,116 ---- # define tounixpath_ts Perl_tounixpath_ts # define tovmspath Perl_tovmspath # define tovmspath_ts Perl_tovmspath_ts ! # define vms_image_init Perl_vms_image_init # define opendir Perl_opendir # define readdir Perl_readdir # define telldir Perl_telldir # define seekdir Perl_seekdir # define closedir Perl_closedir # define vmsreaddirversions Perl_vmsreaddirversions # define my_gmtime Perl_my_gmtime # define my_localtime Perl_my_localtime # define my_time Perl_my_time *************** *** 226,232 **** #endif #define BIT_BUCKET "_NLA0:" ! #define PERL_SYS_INIT(c,v) getredirection((c),(v)) #define PERL_SYS_TERM() #define dXSUB_SYS #define HAS_KILL --- 225,231 ---- #endif #define BIT_BUCKET "_NLA0:" ! #define PERL_SYS_INIT(c,v) vms_image_init((c),(v)) #define PERL_SYS_TERM() #define dXSUB_SYS #define HAS_KILL *************** *** 500,506 **** #endif void prime_env_iter _((void)); - void getredirection _((int *, char ***)); void init_os_extras _(()); /* prototype section start marker; `typedef' passes through cpp */ typedef char __VMS_PROTOTYPES__; --- 499,504 ---- *************** *** 511,517 **** char * my_gconvert _((double, int, int, char *)); int do_rmdir _((char *)); int kill_file _((char *)); ! int my_mkdir _((char *, mode_t)); int my_utime _((char *, struct utimbuf *)); char * rmsexpand _((char *, char *, char *, unsigned)); char * rmsexpand_ts _((char *, char *, char *, unsigned)); --- 509,515 ---- char * my_gconvert _((double, int, int, char *)); int do_rmdir _((char *)); int kill_file _((char *)); ! int my_mkdir _((char *, Mode_t)); int my_utime _((char *, struct utimbuf *)); char * rmsexpand _((char *, char *, char *, unsigned)); char * rmsexpand_ts _((char *, char *, char *, unsigned)); *************** *** 527,533 **** char * tounixpath_ts _((char *, char *)); char * tovmspath _((char *, char *)); char * tovmspath_ts _((char *, char *)); ! void getredirection _(()); DIR * opendir _((char *)); struct dirent * readdir _((DIR *)); long telldir _((DIR *)); --- 525,531 ---- char * tounixpath_ts _((char *, char *)); char * tovmspath _((char *, char *)); char * tovmspath_ts _((char *, char *)); ! void vms_image_init _((int *, char ***)); DIR * opendir _((char *)); struct dirent * readdir _((DIR *)); long telldir _((DIR *)); Index: perl5.004_01_02/win32/Makefile *** perl5.004_01/win32/Makefile Sat Jun 7 01:19:44 1997 --- perl5.004_01_02/win32/Makefile Tue Jul 29 01:02:36 1997 *************** *** 294,300 **** ..\config.sh : config.w32 $(MINIPERL) config_sh.PL $(MINIPERL) -I..\lib config_sh.PL "INST_DRV=$(INST_DRV)" \ "INST_TOP=$(INST_TOP)" "cc=$(CC)" "ccflags=$(RUNTIME) -DWIN32" \ ! "cf_email=$(EMAIL)" "libs=$(LIBFILES)" \ "libpth=$(CCLIBDIR)" "libc=$(LIBC)" \ config.w32 > ..\config.sh --- 294,300 ---- ..\config.sh : config.w32 $(MINIPERL) config_sh.PL $(MINIPERL) -I..\lib config_sh.PL "INST_DRV=$(INST_DRV)" \ "INST_TOP=$(INST_TOP)" "cc=$(CC)" "ccflags=$(RUNTIME) -DWIN32" \ ! "cf_email=$(EMAIL)" "libs=$(LIBFILES)" "incpath=$(CCINCDIR)" \ "libpth=$(CCLIBDIR)" "libc=$(LIBC)" \ config.w32 > ..\config.sh *************** *** 403,408 **** --- 403,413 ---- cd ..\..\win32 doc: $(PERLEXE) + cd ..\pod + $(MAKE) -f ..\win32\pod.mak checkpods pod2html pod2latex \ + pod2man pod2text + $(XCOPY) *.bat ..\win32\bin\*.* + cd ..\win32 copy ..\README.win32 ..\pod\perlwin32.pod $(PERLEXE) ..\installhtml --podroot=.. --htmldir=./html \ --podpath=pod:lib:ext:utils --htmlroot="//$(INST_HTML::=|)" \ Index: perl5.004_01_02/win32/bin/pl2bat.bat *** perl5.004_01/win32/bin/pl2bat.bat Sat Mar 29 23:43:42 1997 --- perl5.004_01_02/win32/bin/pl2bat.bat Wed Jul 30 19:11:20 1997 *************** *** 1,6 **** @rem = '--*-Perl-*-- @echo off ! perl -x -S %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9 goto endofperl @rem '; #!perl -w --- 1,6 ---- @rem = '--*-Perl-*-- @echo off ! perl -x -S %0 %* goto endofperl @rem '; #!perl -w *************** *** 8,14 **** (my $head = <<'--end--') =~ s/^\t//gm; @rem = '--*-Perl-*-- @echo off ! perl -x -S %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9 goto endofperl @rem '; --end-- --- 8,14 ---- (my $head = <<'--end--') =~ s/^\t//gm; @rem = '--*-Perl-*-- @echo off ! perl -x -S %0 %* goto endofperl @rem '; --end-- *************** *** 43,54 **** s/\.pl$//; $_ .= '.bat' unless /\.bat$/ or /^-$/; open( FILE, ">$_" ) or die "Can't open $_: $!"; - $myhead =~ s/perl -x/perl/ unless $linedone; print FILE $myhead; ! print FILE "#line $headlines\n" unless $linedone; print FILE @file, $tail; close( FILE ); } } __END__ :endofperl --- 43,101 ---- s/\.pl$//; $_ .= '.bat' unless /\.bat$/ or /^-$/; open( FILE, ">$_" ) or die "Can't open $_: $!"; print FILE $myhead; ! print FILE "#!perl\n#line " . ($headlines+1) . "\n" unless $linedone; print FILE @file, $tail; close( FILE ); } } __END__ :endofperl + + =head1 NAME + + pl2bat.bat - a batch file to wrap perl code into a batch file + + =head1 SYNOPSIS + + C:\> pl2bat foo.pl bar + [..creates foo.bat, bar.bat..] + + C:\> pl2bat < somefile > another.bat + + C:\> pl2bat > another.bat + print scalar reverse "rekcah lrep rehtona tsuj\n"; + ^Z + [..another.bat is now a certified japh application..] + + =head1 DESCRIPTION + + This utility converts a perl script into a batch file that can be + executed on DOS-like operating systems. + + Note that the ".pl" suffix will be stripped before adding a + ".bat" suffix to the supplied file names. + + The batch file created makes use of the C<%*> construct to refer + to all the command line arguments that were given to the batch file, + so you'll need to make sure that works on your variant of the + command shell. It is known to work in the cmd.exe shell under + WindowsNT. 4DOS/NT users will want to put a C + line in their initialization file, or execute C in + the shell startup file. + + =head1 BUGS + + C<$0> will contain the full name, including the ".bat" suffix. + If you don't like this, see runperl.bat for an alternative way to + invoke perl scripts. + + Perl is invoked with the -S flag, so it will search the PATH to find + the script. This may have undesirable effects. + + =head1 SEE ALSO + + perl, perlwin32, runperl.bat + + =cut + Index: perl5.004_01_02/win32/bin/runperl.bat *** perl5.004_01/win32/bin/runperl.bat Fri Aug 1 00:28:52 1997 --- perl5.004_01_02/win32/bin/runperl.bat Tue Jul 29 01:03:19 1997 *************** *** 0 **** --- 1,74 ---- + @rem = '--*-Perl-*-- + @echo off + perl -x -S %0 %* + goto endofperl + @rem '; + #!perl -w + #line 8 + $0 =~ s|\.bat||i; + unless (-f $0) { + $0 =~ s|.*[/\\]||; + for (".", split ';', $ENV{PATH}) { + $_ = "." if $_ eq ""; + $0 = "$_/$0" , goto doit if -f "$_/$0"; + } + die "`$0' not found.\n"; + } + doit: exec "perl", "-x", $0, @ARGV; + die "Failed to exec `$0': $!"; + __END__ + :endofperl + + =head1 NAME + + runperl.bat - an "universal" batch file to run perl scripts + + =head1 SYNOPSIS + + C:\> copy runperl.bat foo.bat + C:\> foo + [..runs the perl script `foo'..] + + C:\> foo.bat + [..runs the perl script `foo'..] + + + =head1 DESCRIPTION + + This file can be copied to any file name ending in the ".bat" suffix. + When executed on a DOS-like operating system, it will invoke the perl + script of the same name, but without the ".bat" suffix. It will + look for the script in the same directory as itself, and then in + the current directory, and then search the directories in your PATH. + + It relies on the C operator, so you will need to make sure + that works in your perl. + + This method of invoking perl scripts has some advantages over + batch-file wrappers like C: it avoids duplication + of all the code; it ensures C<$0> contains the same name as the + executing file, without any egregious ".bat" suffix; it allows + you to separate your perl scripts from the wrapper used to + run them; since the wrapper is generic, you can use symbolic + links to simply link to C, if you are serving your + files on a filesystem that supports that. + + On the other hand, if the batch file is invoked with the ".bat" + suffix, it does an extra C. This may be a performance + issue. You can avoid this by running it without specifying + the ".bat" suffix. + + Perl is invoked with the -x flag, so the script must contain + a C<#!perl> line. Any flags found on that line will be honored. + + =head1 BUGS + + Perl is invoked with the -S flag, so it will search the PATH to find + the script. This may have undesirable effects. + + =head1 SEE ALSO + + perl, perlwin32, pl2bat.bat + + =cut + Index: perl5.004_01_02/win32/config.bc *** perl5.004_01/win32/config.bc Thu Jun 12 22:06:19 1997 --- perl5.004_01_02/win32/config.bc Thu Jul 31 18:38:07 1997 *************** *** 58,64 **** byteorder='1234' c='' castflags='0' ! cat='cat' cccdlflags='' ccdlflags=' ' cf_by='garyng' --- 58,64 ---- byteorder='1234' c='' castflags='0' ! cat='type' cccdlflags='' ccdlflags=' ' cf_by='garyng' *************** *** 68,77 **** chmod='' chown='' clocktype='clock_t' ! comm='comm' compress='' contains='grep' ! cp='cp' cpio='' cpp='cpp32' cpp_stuff='42' --- 68,77 ---- chmod='' chown='' clocktype='clock_t' ! comm='' compress='' contains='grep' ! cp='copy' cpio='' cpp='cpp32' cpp_stuff='42' *************** *** 81,87 **** cppstdin='' cryptlib='' csh='undef' ! d_Gconvert='sprintf((b),"%.*g",(n),(x))' d_access='define' d_alarm='undef' d_archlib='define' --- 81,87 ---- cppstdin='' cryptlib='' csh='undef' ! d_Gconvert='gcvt((x),(n),(b))' d_access='define' d_alarm='undef' d_archlib='define' *************** *** 371,383 **** lint='' lkflags='' ln='' ! lns='' locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include' loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib' longsize='4' lp='' lpr='' ! ls='ls' lseektype='off_t' mail='' mailx='' --- 371,383 ---- lint='' lkflags='' ln='' ! lns='copy' locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include' loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib' longsize='4' lp='' lpr='' ! ls='dir' lseektype='off_t' mail='' mailx='' *************** *** 421,427 **** perl='perl' perladmin='' perlpath='~INST_TOP~\bin\perl.exe' ! pg='pg' phostname='hostname' plibpth='' pmake='' --- 421,427 ---- perl='perl' perladmin='' perlpath='~INST_TOP~\bin\perl.exe' ! pg='' phostname='hostname' plibpth='' pmake='' *************** *** 432,438 **** randbits='15' ranlib='' rd_nodata='-1' ! rm='rm' rmail='' runnm='true' scriptdir='~INST_TOP~\bin' --- 432,438 ---- randbits='15' ranlib='' rd_nodata='-1' ! rm='del' rmail='' runnm='true' scriptdir='~INST_TOP~\bin' *************** *** 459,465 **** socketlib='' sort='sort' spackage='Perl5' ! spitshell='cat' split='' ssizetype='int' startperl='#perl' --- 459,465 ---- socketlib='' sort='sort' spackage='Perl5' ! spitshell='' split='' ssizetype='int' startperl='#perl' *************** *** 474,484 **** tail='' tar='' tbl='' ! test='test' timeincl='/usr/include/sys/time.h ' timetype='time_t' touch='touch' ! tr='tr' troff='' uidtype='uid_t' uname='uname' --- 474,484 ---- tail='' tar='' tbl='' ! test='' timeincl='/usr/include/sys/time.h ' timetype='time_t' touch='touch' ! tr='' troff='' uidtype='uid_t' uname='uname' Index: perl5.004_01_02/win32/config.vc *** perl5.004_01/win32/config.vc Fri Jun 6 22:50:49 1997 --- perl5.004_01_02/win32/config.vc Tue Jul 29 01:02:37 1997 *************** *** 58,64 **** byteorder='1234' c='' castflags='0' ! cat='cat' cccdlflags='' ccdlflags=' ' cf_by='garyng' --- 58,64 ---- byteorder='1234' c='' castflags='0' ! cat='type' cccdlflags='' ccdlflags=' ' cf_by='garyng' *************** *** 68,77 **** chmod='' chown='' clocktype='clock_t' ! comm='comm' compress='' contains='grep' ! cp='cp' cpio='' cpp='cpp' cpp_stuff='42' --- 68,77 ---- chmod='' chown='' clocktype='clock_t' ! comm='' compress='' contains='grep' ! cp='copy' cpio='' cpp='cpp' cpp_stuff='42' *************** *** 371,383 **** lint='' lkflags='' ln='' ! lns='' locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include' loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib' longsize='4' lp='' lpr='' ! ls='ls' lseektype='off_t' mail='' mailx='' --- 371,383 ---- lint='' lkflags='' ln='' ! lns='copy' locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include' loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib' longsize='4' lp='' lpr='' ! ls='dir' lseektype='off_t' mail='' mailx='' *************** *** 421,427 **** perl='perl' perladmin='' perlpath='~INST_TOP~\bin\perl.exe' ! pg='pg' phostname='hostname' plibpth='' pmake='' --- 421,427 ---- perl='perl' perladmin='' perlpath='~INST_TOP~\bin\perl.exe' ! pg='' phostname='hostname' plibpth='' pmake='' *************** *** 432,438 **** randbits='15' ranlib='' rd_nodata='-1' ! rm='rm' rmail='' runnm='true' scriptdir='~INST_TOP~\bin' --- 432,438 ---- randbits='15' ranlib='' rd_nodata='-1' ! rm='del' rmail='' runnm='true' scriptdir='~INST_TOP~\bin' *************** *** 459,465 **** socketlib='' sort='sort' spackage='Perl5' ! spitshell='cat' split='' ssizetype='int' startperl='#perl' --- 459,465 ---- socketlib='' sort='sort' spackage='Perl5' ! spitshell='' split='' ssizetype='int' startperl='#perl' *************** *** 474,484 **** tail='' tar='' tbl='' ! test='test' timeincl='/usr/include/sys/time.h ' timetype='time_t' touch='touch' ! tr='tr' troff='' uidtype='uid_t' uname='uname' --- 474,484 ---- tail='' tar='' tbl='' ! test='' timeincl='/usr/include/sys/time.h ' timetype='time_t' touch='touch' ! tr='' troff='' uidtype='uid_t' uname='uname' Index: perl5.004_01_02/win32/config_H.bc Prereq: 3.0.1.4 *** perl5.004_01/win32/config_H.bc Fri Jun 6 22:45:38 1997 --- perl5.004_01_02/win32/config_H.bc Thu Jul 31 18:38:07 1997 *************** *** 1511,1517 **** * d_Gconvert='sprintf((b),"%.*g",(n),(x))' * The last two assume trailing zeros should not be kept. */ ! #define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x)) /* HAS_GETPGID: * This symbol, if defined, indicates to the C program that --- 1511,1517 ---- * d_Gconvert='sprintf((b),"%.*g",(n),(x))' * The last two assume trailing zeros should not be kept. */ ! #define Gconvert(x,n,t,b) gcvt((x),(n),(b)) /* HAS_GETPGID: * This symbol, if defined, indicates to the C program that *************** *** 1687,1693 **** * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ ! #define SH_PATH "cmd /x /c" /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of --- 1687,1693 ---- * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ ! #define SH_PATH "cmd.exe" /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of Index: perl5.004_01_02/win32/config_H.vc Prereq: 3.0.1.4 *** perl5.004_01/win32/config_H.vc Fri Jun 6 22:45:38 1997 --- perl5.004_01_02/win32/config_H.vc Tue Jul 29 00:48:34 1997 *************** *** 1687,1693 **** * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ ! #define SH_PATH "cmd /x /c" /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of --- 1687,1693 ---- * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ ! #define SH_PATH "cmd.exe" /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of Index: perl5.004_01_02/win32/config_h.PL *** perl5.004_01/win32/config_h.PL Thu May 15 23:14:27 1997 --- perl5.004_01_02/win32/config_h.PL Tue Jul 29 00:44:23 1997 *************** *** 37,43 **** s#/[ *\*]*\*/#/**/#; if (/^\s*#define\s+ARCHLIB_EXP/) { ! $_ = "#define ARCHLIB_EXP (win32PerlLibPath())\t/**/\n"; } print H; } --- 37,44 ---- s#/[ *\*]*\*/#/**/#; if (/^\s*#define\s+ARCHLIB_EXP/) { ! $_ = "#define ARCHLIB_EXP (win32PerlLibPath())\t/**/\n" ! . "#define APPLLIB_EXP (win32SiteLibPath())\t/**/\n"; } print H; } Index: perl5.004_01_02/win32/makedef.pl *** perl5.004_01/win32/makedef.pl Tue Jun 10 01:52:06 1997 --- perl5.004_01_02/win32/makedef.pl Thu Jul 31 18:38:07 1997 *************** *** 12,18 **** # There is some symbol defined in global.sym and interp.sym # that does not present in the WIN32 port but there is no easy ! # way to find them so I just put a exeception list here my $CCTYPE = shift || "MSVC"; --- 12,18 ---- # There is some symbol defined in global.sym and interp.sym # that does not present in the WIN32 port but there is no easy ! # way to find them so I just put a exception list here my $CCTYPE = shift || "MSVC"; *************** *** 191,202 **** chomp $symbol; if ($CCTYPE eq "BORLAND") { # workaround Borland quirk by exporting both the straight ! # name and a name with leading underscore ! #print "\t$symbol = _$symbol\n"; print "\t_$symbol\n"; } else { print "\t$symbol\n"; } } --- 191,207 ---- chomp $symbol; if ($CCTYPE eq "BORLAND") { # workaround Borland quirk by exporting both the straight ! # name and a name with leading underscore. Note the ! # alias *must* come after the symbol itself, if both ! # are to be exported. (Linker bug?) print "\t_$symbol\n"; + print "\t$symbol = _$symbol\n"; } else { + # for binary coexistence, export both the symbol and + # alias with leading underscore print "\t$symbol\n"; + print "\t_$symbol = $symbol\n"; } } *************** *** 275,280 **** --- 280,286 ---- win32_rmdir win32_chdir win32_flock + win32_execvp win32_htons win32_ntohs win32_htonl *************** *** 317,319 **** --- 323,347 ---- win32_setnetent win32_setprotoent win32_setservent + win32_getenv + win32_perror + win32_setbuf + win32_setvbuf + win32_flushall + win32_fcloseall + win32_fgets + win32_gets + win32_fgetc + win32_putc + win32_puts + win32_getchar + win32_putchar + win32_malloc + win32_calloc + win32_realloc + win32_free + win32stdio + Perl_win32_init + RunPerl + SetIOSubSystem + GetIOSubSystem Index: perl5.004_01_02/win32/makefile.mk *** perl5.004_01/win32/makefile.mk Sat Jun 7 01:19:45 1997 --- perl5.004_01_02/win32/makefile.mk Tue Jul 29 01:02:37 1997 *************** *** 367,373 **** ..\config.sh : config.w32 $(MINIPERL) config_sh.PL $(MINIPERL) -I..\lib config_sh.PL "INST_DRV=$(INST_DRV)" \ "INST_TOP=$(INST_TOP)" "cc=$(CC)" "ccflags=$(RUNTIME) -DWIN32" \ ! "cf_email=$(EMAIL)" "libs=$(LIBFILES:f)" \ "libpth=$(strip $(CCLIBDIR) $(LIBFILES:d))" "libc=$(LIBC)" \ config.w32 > ..\config.sh --- 367,373 ---- ..\config.sh : config.w32 $(MINIPERL) config_sh.PL $(MINIPERL) -I..\lib config_sh.PL "INST_DRV=$(INST_DRV)" \ "INST_TOP=$(INST_TOP)" "cc=$(CC)" "ccflags=$(RUNTIME) -DWIN32" \ ! "cf_email=$(EMAIL)" "libs=$(LIBFILES:f)" "incpath=$(CCINCDIR)" \ "libpth=$(strip $(CCLIBDIR) $(LIBFILES:d))" "libc=$(LIBC)" \ config.w32 > ..\config.sh *************** *** 498,503 **** --- 498,506 ---- cd $(EXTDIR)\$(*B) && $(MAKE) doc: $(PERLEXE) + cd ..\pod && $(MAKE) -f ..\win32\pod.mak checkpods \ + pod2html pod2latex pod2man pod2text + cd ..\pod && $(XCOPY) *.bat ..\win32\bin\*.* copy ..\README.win32 ..\pod\perlwin32.pod $(PERLEXE) ..\installhtml --podroot=.. --htmldir=./html \ --podpath=pod:lib:ext:utils --htmlroot="//$(INST_HTML:s,:,|,)" \ Index: perl5.004_01_02/win32/perllib.c *** perl5.004_01/win32/perllib.c Fri Jun 6 22:45:35 1997 --- perl5.004_01_02/win32/perllib.c Thu Jul 31 18:38:07 1997 *************** *** 103,386 **** EXTERN_C void boot_DynaLoader _((CV* cv)); - static - XS(w32_GetCwd) - { - dXSARGS; - SV *sv = sv_newmortal(); - /* Make one call with zero size - return value is required size */ - DWORD len = GetCurrentDirectory((DWORD)0,NULL); - SvUPGRADE(sv,SVt_PV); - SvGROW(sv,len); - SvCUR(sv) = GetCurrentDirectory((DWORD) SvLEN(sv), SvPVX(sv)); - /* - * If result != 0 - * then it worked, set PV valid, - * else leave it 'undef' - */ - if (SvCUR(sv)) - SvPOK_on(sv); - EXTEND(sp,1); - ST(0) = sv; - XSRETURN(1); - } - - static - XS(w32_SetCwd) - { - dXSARGS; - if (items != 1) - croak("usage: Win32::SetCurrentDirectory($cwd)"); - if (SetCurrentDirectory(SvPV(ST(0),na))) - XSRETURN_YES; - - XSRETURN_NO; - } - - static - XS(w32_GetNextAvailDrive) - { - dXSARGS; - char ix = 'C'; - char root[] = "_:\\"; - while (ix <= 'Z') { - root[0] = ix++; - if (GetDriveType(root) == 1) { - root[2] = '\0'; - XSRETURN_PV(root); - } - } - XSRETURN_UNDEF; - } - - static - XS(w32_GetLastError) - { - dXSARGS; - XSRETURN_IV(GetLastError()); - } - - static - XS(w32_LoginName) - { - dXSARGS; - char name[256]; - DWORD size = sizeof(name); - if (GetUserName(name,&size)) { - /* size includes NULL */ - ST(0) = sv_2mortal(newSVpv(name,size-1)); - XSRETURN(1); - } - XSRETURN_UNDEF; - } - - static - XS(w32_NodeName) - { - dXSARGS; - char name[MAX_COMPUTERNAME_LENGTH+1]; - DWORD size = sizeof(name); - if (GetComputerName(name,&size)) { - /* size does NOT include NULL :-( */ - ST(0) = sv_2mortal(newSVpv(name,size)); - XSRETURN(1); - } - XSRETURN_UNDEF; - } - - - static - XS(w32_DomainName) - { - dXSARGS; - char name[256]; - DWORD size = sizeof(name); - if (GetUserName(name,&size)) { - char sid[1024]; - DWORD sidlen = sizeof(sid); - char dname[256]; - DWORD dnamelen = sizeof(dname); - SID_NAME_USE snu; - if (LookupAccountName(NULL, name, &sid, &sidlen, - dname, &dnamelen, &snu)) { - XSRETURN_PV(dname); /* all that for this */ - } - } - XSRETURN_UNDEF; - } - - static - XS(w32_FsType) - { - dXSARGS; - char fsname[256]; - DWORD flags, filecomplen; - if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen, - &flags, fsname, sizeof(fsname))) { - if (GIMME == G_ARRAY) { - XPUSHs(sv_2mortal(newSVpv(fsname,0))); - XPUSHs(sv_2mortal(newSViv(flags))); - XPUSHs(sv_2mortal(newSViv(filecomplen))); - PUTBACK; - return; - } - XSRETURN_PV(fsname); - } - XSRETURN_UNDEF; - } - - static - XS(w32_GetOSVersion) - { - dXSARGS; - OSVERSIONINFO osver; - - osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); - if (GetVersionEx(&osver)) { - XPUSHs(newSVpv(osver.szCSDVersion, 0)); - XPUSHs(newSViv(osver.dwMajorVersion)); - XPUSHs(newSViv(osver.dwMinorVersion)); - XPUSHs(newSViv(osver.dwBuildNumber)); - XPUSHs(newSViv(osver.dwPlatformId)); - PUTBACK; - return; - } - XSRETURN_UNDEF; - } - - static - XS(w32_IsWinNT) - { - dXSARGS; - XSRETURN_IV(IsWinNT()); - } - - static - XS(w32_IsWin95) - { - dXSARGS; - XSRETURN_IV(IsWin95()); - } - - static - XS(w32_FormatMessage) - { - dXSARGS; - DWORD source = 0; - char msgbuf[1024]; - - if (items != 1) - croak("usage: Win32::FormatMessage($errno)"); - - if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, - &source, SvIV(ST(0)), 0, - msgbuf, sizeof(msgbuf)-1, NULL)) - XSRETURN_PV(msgbuf); - - XSRETURN_UNDEF; - } - - static - XS(w32_Spawn) - { - dXSARGS; - char *cmd, *args; - PROCESS_INFORMATION stProcInfo; - STARTUPINFO stStartInfo; - BOOL bSuccess = FALSE; - - if(items != 3) - croak("usage: Win32::Spawn($cmdName, $args, $PID)"); - - cmd = SvPV(ST(0),na); - args = SvPV(ST(1), na); - - memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */ - stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */ - stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */ - stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */ - - if(CreateProcess( - cmd, /* Image path */ - args, /* Arguments for command line */ - NULL, /* Default process security */ - NULL, /* Default thread security */ - FALSE, /* Must be TRUE to use std handles */ - NORMAL_PRIORITY_CLASS, /* No special scheduling */ - NULL, /* Inherit our environment block */ - NULL, /* Inherit our currrent directory */ - &stStartInfo, /* -> Startup info */ - &stProcInfo)) /* <- Process info (if OK) */ - { - CloseHandle(stProcInfo.hThread);/* library source code does this. */ - sv_setiv(ST(2), stProcInfo.dwProcessId); - bSuccess = TRUE; - } - XSRETURN_IV(bSuccess); - } - - static - XS(w32_GetTickCount) - { - dXSARGS; - XSRETURN_IV(GetTickCount()); - } - - static - XS(w32_GetShortPathName) - { - dXSARGS; - SV *shortpath; - - if(items != 1) - croak("usage: Win32::GetShortPathName($longPathName)"); - - shortpath = sv_mortalcopy(ST(0)); - SvUPGRADE(shortpath, SVt_PV); - /* src == target is allowed */ - if (GetShortPathName(SvPVX(shortpath), SvPVX(shortpath), SvCUR(shortpath))) - ST(0) = shortpath; - else - ST(0) = &sv_undef; - XSRETURN(1); - } - static void xs_init() { char *file = __FILE__; dXSUB_SYS; newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); - - /* XXX should be removed after checking with Nick */ - newXS("Win32::GetCurrentDirectory", w32_GetCwd, file); - - /* these names are Activeware compatible */ - newXS("Win32::GetCwd", w32_GetCwd, file); - newXS("Win32::SetCwd", w32_SetCwd, file); - newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file); - newXS("Win32::GetLastError", w32_GetLastError, file); - newXS("Win32::LoginName", w32_LoginName, file); - newXS("Win32::NodeName", w32_NodeName, file); - newXS("Win32::DomainName", w32_DomainName, file); - newXS("Win32::FsType", w32_FsType, file); - newXS("Win32::GetOSVersion", w32_GetOSVersion, file); - newXS("Win32::IsWinNT", w32_IsWinNT, file); - newXS("Win32::IsWin95", w32_IsWin95, file); - newXS("Win32::FormatMessage", w32_FormatMessage, file); - newXS("Win32::Spawn", w32_Spawn, file); - newXS("Win32::GetTickCount", w32_GetTickCount, file); - newXS("Win32::GetShortPathName", w32_GetShortPathName, file); - - /* XXX Bloat Alert! The following Activeware preloads really - * ought to be part of Win32::Sys::*, so they're not included - * here. - */ - /* LookupAccountName - * LookupAccountSID - * InitiateSystemShutdown - * AbortSystemShutdown - * ExpandEnvrironmentStrings - */ } --- 103,113 ---- Index: perl5.004_01_02/win32/win32.c *** perl5.004_01/win32/win32.c Tue Jun 10 01:52:07 1997 --- perl5.004_01_02/win32/win32.c Thu Jul 31 18:38:07 1997 *************** *** 22,43 **** #include "EXTERN.h" #include "perl.h" #include #include #include #include #include #define CROAK croak #define WARN warn static DWORD IdOS(void); extern WIN32_IOSUBSYSTEM win32stdio; ! #ifndef __BORLANDC__ /* pointers cannot be declared TLS! */ ! __declspec(thread) ! #endif ! PWIN32_IOSUBSYSTEM pIOSubSystem = &win32stdio; BOOL ProbeEnv = FALSE; DWORD Win32System = (DWORD)-1; --- 22,46 ---- #include "EXTERN.h" #include "perl.h" + #include "XSUB.h" #include #include #include #include #include + #include #define CROAK croak #define WARN warn + #define EXECF_EXEC 1 + #define EXECF_SPAWN 2 + #define EXECF_SPAWN_NOWAIT 3 + static DWORD IdOS(void); extern WIN32_IOSUBSYSTEM win32stdio; ! static PWIN32_IOSUBSYSTEM pIOSubSystem = &win32stdio; BOOL ProbeEnv = FALSE; DWORD Win32System = (DWORD)-1; *************** *** 45,50 **** --- 48,55 ---- char szPerlLibRoot[MAX_PATH+1]; HANDLE PerlDllHandle = INVALID_HANDLE_VALUE; + static int do_spawn2(char *cmd, int exectype); + int IsWin95(void) { return (IdOS() == VER_PLATFORM_WIN32_WINDOWS); *************** *** 55,61 **** return (IdOS() == VER_PLATFORM_WIN32_NT); } ! void * SetIOSubSystem(void *p) { PWIN32_IOSUBSYSTEM old = pIOSubSystem; --- 60,66 ---- return (IdOS() == VER_PLATFORM_WIN32_NT); } ! DllExport PWIN32_IOSUBSYSTEM SetIOSubSystem(void *p) { PWIN32_IOSUBSYSTEM old = pIOSubSystem; *************** *** 72,77 **** --- 77,88 ---- return old; } + DllExport PWIN32_IOSUBSYSTEM + GetIOSubSystem(void) + { + return pIOSubSystem; + } + char * win32PerlLibPath(void) { *************** *** 89,94 **** --- 100,114 ---- return (szPerlLibRoot); } + char * + win32SiteLibPath(void) + { + static char szPerlSiteLib[MAX_PATH+1]; + strcpy(szPerlSiteLib, win32PerlLibPath()); + strcat(szPerlSiteLib, "\\site"); + return (szPerlSiteLib); + } + BOOL HasRedirection(char *ptr) { *************** *** 384,390 **** } int ! do_spawn(char *cmd) { char **a; char *s; --- 404,410 ---- } int ! do_spawn2(char *cmd, int exectype) { char **a; char *s; *************** *** 414,420 **** } *a = Nullch; if(argv[0]) { ! status = win32_spawnvp(P_WAIT, argv[0], (const char* const*)argv); if(status != -1 || errno == 0) needToTry = FALSE; } --- 434,452 ---- } *a = Nullch; if(argv[0]) { ! switch (exectype) { ! case EXECF_SPAWN: ! status = win32_spawnvp(P_WAIT, argv[0], ! (const char* const*)argv); ! break; ! case EXECF_SPAWN_NOWAIT: ! status = win32_spawnvp(P_NOWAIT, argv[0], ! (const char* const*)argv); ! break; ! case EXECF_EXEC: ! status = win32_execvp(argv[0], (const char* const*)argv); ! break; ! } if(status != -1 || errno == 0) needToTry = FALSE; } *************** *** 425,441 **** char *argv[5]; argv[0] = shell; argv[1] = "/x"; argv[2] = "/c"; argv[3] = cmd; argv[4] = Nullch; ! status = win32_spawnvp(P_WAIT, argv[0], (const char* const*)argv); } if (status < 0) { if (dowarn) ! warn("Can't spawn \"%s\": %s", needToTry ? shell : argv[0], strerror(errno)); status = 255 << 8; } return (status); } #define PATHLEN 1024 --- 457,500 ---- char *argv[5]; argv[0] = shell; argv[1] = "/x"; argv[2] = "/c"; argv[3] = cmd; argv[4] = Nullch; ! switch (exectype) { ! case EXECF_SPAWN: ! status = win32_spawnvp(P_WAIT, argv[0], ! (const char* const*)argv); ! break; ! case EXECF_SPAWN_NOWAIT: ! status = win32_spawnvp(P_NOWAIT, argv[0], ! (const char* const*)argv); ! break; ! case EXECF_EXEC: ! status = win32_execvp(argv[0], (const char* const*)argv); ! break; ! } } if (status < 0) { if (dowarn) ! warn("Can't %s \"%s\": %s", ! (exectype == EXECF_EXEC ? "exec" : "spawn"), ! needToTry ? shell : argv[0], strerror(errno)); status = 255 << 8; } return (status); } + int + do_spawn(char *cmd) + { + return do_spawn2(cmd, EXECF_SPAWN); + } + + bool + do_exec(char *cmd) + { + do_spawn2(cmd, EXECF_EXEC); + return FALSE; + } + #define PATHLEN 1024 *************** *** 726,731 **** --- 785,812 ---- return stat(p, buffer); } + #ifndef USE_WIN32_RTL_ENV + + DllExport char * + win32_getenv(const char *name) + { + static char *curitem = Nullch; + static DWORD curlen = 512; + DWORD needlen; + if (!curitem) + New(1305,curitem,curlen,char); + if (!(needlen = GetEnvironmentVariable(name,curitem,curlen))) + return Nullch; + while (needlen > curlen) { + Renew(curitem,needlen,char); + curlen = needlen; + needlen = GetEnvironmentVariable(name,curitem,curlen); + } + return curitem; + } + + #endif + #undef times int mytimes(struct tms *timebuf) *************** *** 1101,1106 **** --- 1182,1289 ---- return pIOSubSystem->pfnspawnvp(mode, cmdname, argv); } + DllExport int + win32_execvp(const char *cmdname, const char *const *argv) + { + return pIOSubSystem->pfnexecvp(cmdname, argv); + } + + DllExport void + win32_perror(const char *str) + { + pIOSubSystem->pfnperror(str); + } + + DllExport void + win32_setbuf(FILE *pf, char *buf) + { + pIOSubSystem->pfnsetbuf(pf, buf); + } + + DllExport int + win32_setvbuf(FILE *pf, char *buf, int type, size_t size) + { + return pIOSubSystem->pfnsetvbuf(pf, buf, type, size); + } + + DllExport int + win32_flushall(void) + { + return pIOSubSystem->pfnflushall(); + } + + DllExport int + win32_fcloseall(void) + { + return pIOSubSystem->pfnfcloseall(); + } + + DllExport char* + win32_fgets(char *s, int n, FILE *pf) + { + return pIOSubSystem->pfnfgets(s, n, pf); + } + + DllExport char* + win32_gets(char *s) + { + return pIOSubSystem->pfngets(s); + } + + DllExport int + win32_fgetc(FILE *pf) + { + return pIOSubSystem->pfnfgetc(pf); + } + + DllExport int + win32_putc(int c, FILE *pf) + { + return pIOSubSystem->pfnputc(c,pf); + } + + DllExport int + win32_puts(const char *s) + { + return pIOSubSystem->pfnputs(s); + } + + DllExport int + win32_getchar(void) + { + return pIOSubSystem->pfngetchar(); + } + + DllExport int + win32_putchar(int c) + { + return pIOSubSystem->pfnputchar(c); + } + + DllExport void* + win32_malloc(size_t size) + { + return pIOSubSystem->pfnmalloc(size); + } + + DllExport void* + win32_calloc(size_t numitems, size_t size) + { + return pIOSubSystem->pfncalloc(numitems,size); + } + + DllExport void* + win32_realloc(void *block, size_t size) + { + return pIOSubSystem->pfnrealloc(block,size); + } + + DllExport void + win32_free(void *block) + { + pIOSubSystem->pfnfree(block); + } + int stolen_open_osfhandle(long handle, int flags) { *************** *** 1127,1129 **** --- 1310,1603 ---- return pIOSubSystem->pfnflock(fd, oper); } + static + XS(w32_GetCwd) + { + dXSARGS; + SV *sv = sv_newmortal(); + /* Make one call with zero size - return value is required size */ + DWORD len = GetCurrentDirectory((DWORD)0,NULL); + SvUPGRADE(sv,SVt_PV); + SvGROW(sv,len); + SvCUR(sv) = GetCurrentDirectory((DWORD) SvLEN(sv), SvPVX(sv)); + /* + * If result != 0 + * then it worked, set PV valid, + * else leave it 'undef' + */ + if (SvCUR(sv)) + SvPOK_on(sv); + EXTEND(sp,1); + ST(0) = sv; + XSRETURN(1); + } + + static + XS(w32_SetCwd) + { + dXSARGS; + if (items != 1) + croak("usage: Win32::SetCurrentDirectory($cwd)"); + if (SetCurrentDirectory(SvPV(ST(0),na))) + XSRETURN_YES; + + XSRETURN_NO; + } + + static + XS(w32_GetNextAvailDrive) + { + dXSARGS; + char ix = 'C'; + char root[] = "_:\\"; + while (ix <= 'Z') { + root[0] = ix++; + if (GetDriveType(root) == 1) { + root[2] = '\0'; + XSRETURN_PV(root); + } + } + XSRETURN_UNDEF; + } + + static + XS(w32_GetLastError) + { + dXSARGS; + XSRETURN_IV(GetLastError()); + } + + static + XS(w32_LoginName) + { + dXSARGS; + char name[256]; + DWORD size = sizeof(name); + if (GetUserName(name,&size)) { + /* size includes NULL */ + ST(0) = sv_2mortal(newSVpv(name,size-1)); + XSRETURN(1); + } + XSRETURN_UNDEF; + } + + static + XS(w32_NodeName) + { + dXSARGS; + char name[MAX_COMPUTERNAME_LENGTH+1]; + DWORD size = sizeof(name); + if (GetComputerName(name,&size)) { + /* size does NOT include NULL :-( */ + ST(0) = sv_2mortal(newSVpv(name,size)); + XSRETURN(1); + } + XSRETURN_UNDEF; + } + + + static + XS(w32_DomainName) + { + dXSARGS; + char name[256]; + DWORD size = sizeof(name); + if (GetUserName(name,&size)) { + char sid[1024]; + DWORD sidlen = sizeof(sid); + char dname[256]; + DWORD dnamelen = sizeof(dname); + SID_NAME_USE snu; + if (LookupAccountName(NULL, name, &sid, &sidlen, + dname, &dnamelen, &snu)) { + XSRETURN_PV(dname); /* all that for this */ + } + } + XSRETURN_UNDEF; + } + + static + XS(w32_FsType) + { + dXSARGS; + char fsname[256]; + DWORD flags, filecomplen; + if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen, + &flags, fsname, sizeof(fsname))) { + if (GIMME == G_ARRAY) { + XPUSHs(sv_2mortal(newSVpv(fsname,0))); + XPUSHs(sv_2mortal(newSViv(flags))); + XPUSHs(sv_2mortal(newSViv(filecomplen))); + PUTBACK; + return; + } + XSRETURN_PV(fsname); + } + XSRETURN_UNDEF; + } + + static + XS(w32_GetOSVersion) + { + dXSARGS; + OSVERSIONINFO osver; + + osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + if (GetVersionEx(&osver)) { + XPUSHs(newSVpv(osver.szCSDVersion, 0)); + XPUSHs(newSViv(osver.dwMajorVersion)); + XPUSHs(newSViv(osver.dwMinorVersion)); + XPUSHs(newSViv(osver.dwBuildNumber)); + XPUSHs(newSViv(osver.dwPlatformId)); + PUTBACK; + return; + } + XSRETURN_UNDEF; + } + + static + XS(w32_IsWinNT) + { + dXSARGS; + XSRETURN_IV(IsWinNT()); + } + + static + XS(w32_IsWin95) + { + dXSARGS; + XSRETURN_IV(IsWin95()); + } + + static + XS(w32_FormatMessage) + { + dXSARGS; + DWORD source = 0; + char msgbuf[1024]; + + if (items != 1) + croak("usage: Win32::FormatMessage($errno)"); + + if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, + &source, SvIV(ST(0)), 0, + msgbuf, sizeof(msgbuf)-1, NULL)) + XSRETURN_PV(msgbuf); + + XSRETURN_UNDEF; + } + + static + XS(w32_Spawn) + { + dXSARGS; + char *cmd, *args; + PROCESS_INFORMATION stProcInfo; + STARTUPINFO stStartInfo; + BOOL bSuccess = FALSE; + + if(items != 3) + croak("usage: Win32::Spawn($cmdName, $args, $PID)"); + + cmd = SvPV(ST(0),na); + args = SvPV(ST(1), na); + + memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */ + stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */ + stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */ + stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */ + + if(CreateProcess( + cmd, /* Image path */ + args, /* Arguments for command line */ + NULL, /* Default process security */ + NULL, /* Default thread security */ + FALSE, /* Must be TRUE to use std handles */ + NORMAL_PRIORITY_CLASS, /* No special scheduling */ + NULL, /* Inherit our environment block */ + NULL, /* Inherit our currrent directory */ + &stStartInfo, /* -> Startup info */ + &stProcInfo)) /* <- Process info (if OK) */ + { + CloseHandle(stProcInfo.hThread);/* library source code does this. */ + sv_setiv(ST(2), stProcInfo.dwProcessId); + bSuccess = TRUE; + } + XSRETURN_IV(bSuccess); + } + + static + XS(w32_GetTickCount) + { + dXSARGS; + XSRETURN_IV(GetTickCount()); + } + + static + XS(w32_GetShortPathName) + { + dXSARGS; + SV *shortpath; + + if(items != 1) + croak("usage: Win32::GetShortPathName($longPathName)"); + + shortpath = sv_mortalcopy(ST(0)); + SvUPGRADE(shortpath, SVt_PV); + /* src == target is allowed */ + if (GetShortPathName(SvPVX(shortpath), SvPVX(shortpath), SvCUR(shortpath))) + ST(0) = shortpath; + else + ST(0) = &sv_undef; + XSRETURN(1); + } + + void + init_os_extras() + { + char *file = __FILE__; + dXSUB_SYS; + + /* XXX should be removed after checking with Nick */ + newXS("Win32::GetCurrentDirectory", w32_GetCwd, file); + + /* these names are Activeware compatible */ + newXS("Win32::GetCwd", w32_GetCwd, file); + newXS("Win32::SetCwd", w32_SetCwd, file); + newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file); + newXS("Win32::GetLastError", w32_GetLastError, file); + newXS("Win32::LoginName", w32_LoginName, file); + newXS("Win32::NodeName", w32_NodeName, file); + newXS("Win32::DomainName", w32_DomainName, file); + newXS("Win32::FsType", w32_FsType, file); + newXS("Win32::GetOSVersion", w32_GetOSVersion, file); + newXS("Win32::IsWinNT", w32_IsWinNT, file); + newXS("Win32::IsWin95", w32_IsWin95, file); + newXS("Win32::FormatMessage", w32_FormatMessage, file); + newXS("Win32::Spawn", w32_Spawn, file); + newXS("Win32::GetTickCount", w32_GetTickCount, file); + newXS("Win32::GetShortPathName", w32_GetShortPathName, file); + + /* XXX Bloat Alert! The following Activeware preloads really + * ought to be part of Win32::Sys::*, so they're not included + * here. + */ + /* LookupAccountName + * LookupAccountSID + * InitiateSystemShutdown + * AbortSystemShutdown + * ExpandEnvrironmentStrings + */ + } + + void + Perl_win32_init(int *argcp, char ***argvp) + { + /* Disable floating point errors, Perl will trap the ones we + * care about. VC++ RTL defaults to switching these off + * already, but the Borland RTL doesn't. Since we don't + * want to be at the vendor's whim on the default, we set + * it explicitly here. + */ + _control87(MCW_EM, MCW_EM); + } Index: perl5.004_01_02/win32/win32.h *** perl5.004_01/win32/win32.h Tue Jun 10 01:52:07 1997 --- perl5.004_01_02/win32/win32.h Thu Jul 31 18:38:08 1997 *************** *** 31,36 **** --- 31,40 ---- #define _chdir chdir #include + #ifndef DllMain + #define DllMain DllEntryPoint + #endif + #pragma warn -ccc #pragma warn -rch #pragma warn -sig *************** *** 64,69 **** --- 68,86 ---- * facilities for accessing the same. See note in util.c/my_setenv(). */ /*#define USE_WIN32_RTL_ENV */ + + #ifndef USE_WIN32_RTL_ENV + #include + #ifndef EXT + #include "EXTERN.h" + #endif + #undef getenv + #define getenv win32_getenv + EXT char *win32_getenv(const char *name); + #endif + + EXT void Perl_win32_init(int *argcp, char ***argvp); + #define USE_SOCKETS_AS_HANDLES #ifndef USE_SOCKETS_AS_HANDLES extern FILE *myfdopen(int, char *); *************** *** 99,108 **** --- 116,128 ---- unsigned int sleep(unsigned int); char *win32PerlLibPath(void); + char *win32SiteLibPath(void); int mytimes(struct tms *timebuf); unsigned int myalarm(unsigned int sec); int do_aspawn(void* really, void** mark, void** arglast); int do_spawn(char *cmd); + char do_exec(char *cmd); + void init_os_extras(void); typedef char * caddr_t; /* In malloc.c (core address). */ Index: perl5.004_01_02/win32/win32io.c *** perl5.004_01/win32/win32io.c Tue Jun 10 01:52:07 1997 --- perl5.004_01_02/win32/win32io.c Thu Jul 31 18:36:11 1997 *************** *** 293,302 **** my_open_osfhandle, my_get_osfhandle, spawnvp, ! _mkdir, ! _rmdir, ! _chdir, my_flock, /* (*pfunc_flock)(int fd, int oper) */ 87654321L, /* end of structure */ }; --- 293,321 ---- my_open_osfhandle, my_get_osfhandle, spawnvp, ! mkdir, ! rmdir, ! chdir, my_flock, /* (*pfunc_flock)(int fd, int oper) */ + execvp, + perror, + setbuf, + setvbuf, + flushall, + fcloseall, + fgets, + gets, + fgetc, + putc, + puts, + getchar, + putchar, + fscanf, + scanf, + malloc, + calloc, + realloc, + free, 87654321L, /* end of structure */ }; Index: perl5.004_01_02/win32/win32io.h *** perl5.004_01/win32/win32io.h Tue Jun 10 01:52:08 1997 --- perl5.004_01_02/win32/win32io.h Thu Jul 31 18:36:11 1997 *************** *** 60,66 **** int (*pfnrmdir)(const char *path); int (*pfnchdir)(const char *path); int (*pfnflock)(int fd, int oper); ! int signature_end; } WIN32_IOSUBSYSTEM; typedef WIN32_IOSUBSYSTEM *PWIN32_IOSUBSYSTEM; --- 60,85 ---- int (*pfnrmdir)(const char *path); int (*pfnchdir)(const char *path); int (*pfnflock)(int fd, int oper); ! int (*pfnexecvp)(const char *cmdname, const char *const *argv); ! void (*pfnperror)(const char *str); ! void (*pfnsetbuf)(FILE *pf, char *buf); ! int (*pfnsetvbuf)(FILE *pf, char *buf, int type, size_t size); ! int (*pfnflushall)(void); ! int (*pfnfcloseall)(void); ! char* (*pfnfgets)(char *s, int n, FILE *pf); ! char* (*pfngets)(char *s); ! int (*pfnfgetc)(FILE *pf); ! int (*pfnputc)(int c, FILE *pf); ! int (*pfnputs)(const char *s); ! int (*pfngetchar)(void); ! int (*pfnputchar)(int c); ! int (*pfnfscanf)(FILE *pf, const char *format, ...); ! int (*pfnscanf)(const char *format, ...); ! void* (*pfnmalloc)(size_t size); ! void* (*pfncalloc)(size_t numitems, size_t size); ! void* (*pfnrealloc)(void *block, size_t size); ! void (*pfnfree)(void *block); ! int signature_end; } WIN32_IOSUBSYSTEM; typedef WIN32_IOSUBSYSTEM *PWIN32_IOSUBSYSTEM; Index: perl5.004_01_02/win32/win32iop.h *** perl5.004_01/win32/win32iop.h Tue Jun 10 01:52:08 1997 --- perl5.004_01_02/win32/win32iop.h Thu Jul 31 18:36:11 1997 *************** *** 63,68 **** --- 63,85 ---- EXT int win32_rmdir(const char *dir); EXT int win32_chdir(const char *dir); EXT int win32_flock(int fd, int oper); + EXT int win32_execvp(const char *cmdname, const char *const *argv); + EXT void win32_perror(const char *str); + EXT void win32_setbuf(FILE *pf, char *buf); + EXT int win32_setvbuf(FILE *pf, char *buf, int type, size_t size); + EXT int win32_flushall(void); + EXT int win32_fcloseall(void); + EXT char* win32_fgets(char *s, int n, FILE *pf); + EXT char* win32_gets(char *s); + EXT int win32_fgetc(FILE *pf); + EXT int win32_putc(int c, FILE *pf); + EXT int win32_puts(const char *s); + EXT int win32_getchar(void); + EXT int win32_putchar(int c); + EXT void* win32_malloc(size_t size); + EXT void* win32_calloc(size_t numitems, size_t size); + EXT void* win32_realloc(void *block, size_t size); + EXT void win32_free(void *block); /* * these two are win32 specific but still io related *************** *** 80,86 **** #include /* pull in the io sub system structure */ ! void * SetIOSubSystem(void *piosubsystem); /* * the following six(6) is #define in stdio.h --- 97,104 ---- #include /* pull in the io sub system structure */ ! EXT PWIN32_IOSUBSYSTEM SetIOSubSystem(void *piosubsystem); ! EXT PWIN32_IOSUBSYSTEM GetIOSubSystem(void); /* * the following six(6) is #define in stdio.h *************** *** 97,102 **** --- 115,123 ---- #ifdef __BORLANDC__ #undef ungetc #undef getc + #undef putc + #undef getchar + #undef putchar #undef fileno #endif *************** *** 154,159 **** --- 175,199 ---- #define rmdir win32_rmdir #define chdir win32_chdir #define flock(fd,o) win32_flock(fd,o) + #define execvp win32_execvp + #define perror win32_perror + #define setbuf win32_setbuf + #define setvbuf win32_setvbuf + #define flushall win32_flushall + #define fcloseall win32_fcloseall + #define fgets win32_fgets + #define gets win32_gets + #define fgetc win32_fgetc + #define putc win32_putc + #define puts win32_puts + #define getchar win32_getchar + #define putchar win32_putchar + #define fscanf (GetIOSubSystem()->pfnfscanf) + #define scanf (GetIOSubSystem()->pfnscanf) + #define malloc win32_malloc + #define calloc win32_calloc + #define realloc win32_realloc + #define free win32_free #endif /* WIN32IO_IS_STDIO */ #endif /* WIN32IOP_H */ Index: perl5.004_01_02/win32/win32sck.c *** perl5.004_01/win32/win32sck.c Fri Jun 6 22:45:36 1997 --- perl5.004_01_02/win32/win32sck.c Tue Jul 29 00:58:47 1997 *************** *** 694,702 **** d->s_name = s->s_name; d->s_aliases = s->s_aliases; d->s_port = s->s_port; if (!IsWin95() && s->s_proto && strlen(s->s_proto)) d->s_proto = s->s_proto; ! else if (proto && strlen(proto)) d->s_proto = (char *)proto; else d->s_proto = "tcp"; --- 694,705 ---- d->s_name = s->s_name; d->s_aliases = s->s_aliases; d->s_port = s->s_port; + #ifndef __BORLANDC__ /* Buggy on Win95 and WinNT-with-Borland-WSOCK */ if (!IsWin95() && s->s_proto && strlen(s->s_proto)) d->s_proto = s->s_proto; ! else ! #endif ! if (proto && strlen(proto)) d->s_proto = (char *)proto; else d->s_proto = "tcp"; End of Patch.