diff options
| author | Jarkko Hietaniemi <jhi@iki.fi> | 2000-05-29 03:01:38 +0000 |
|---|---|---|
| committer | Jarkko Hietaniemi <jhi@iki.fi> | 2000-05-29 03:01:38 +0000 |
| commit | 0af2a2907a21f2e6ff6ca5f8df976d75a98b9794 (patch) | |
| tree | 822de246c205c41c606a4c905ae610c6158e3f9a | |
| parent | d67bf1d95495fd9f41cabf2a1f9dc1f266c1575d (diff) | |
| parent | 413e5597fa15080977e13a1ad58f104914a75a31 (diff) | |
| download | perl-0af2a2907a21f2e6ff6ca5f8df976d75a98b9794.tar.gz | |
Integrate with Sarathy.
p4raw-id: //depot/cfgperl@6156
38 files changed, 703 insertions, 284 deletions
@@ -3275,6 +3275,7 @@ while test "$type"; do true) case "$ansexp" in /*) value="$ansexp" ;; + [a-zA-Z]:/*) value="$ansexp" ;; *) redo=true case "$already" in @@ -239,6 +239,7 @@ ext/DynaLoader/dl_dld.xs GNU dld style implementation ext/DynaLoader/dl_dlopen.xs BSD/SunOS4&5 dlopen() style implementation ext/DynaLoader/dl_dyld.xs NeXT/Apple dyld implementation ext/DynaLoader/dl_hpux.xs HP-UX implementation +ext/DynaLoader/dl_mac.xs MacOS implementation ext/DynaLoader/dl_mpeix.xs MPE/iX implementation ext/DynaLoader/dl_next.xs NeXT implementation ext/DynaLoader/dl_none.xs Stub implementation diff --git a/ext/DB_File/Makefile.PL b/ext/DB_File/Makefile.PL index cac6578bb3..041416029a 100644 --- a/ext/DB_File/Makefile.PL +++ b/ext/DB_File/Makefile.PL @@ -17,6 +17,7 @@ WriteMakefile( OBJECT => 'version$(OBJ_EXT) DB_File$(OBJ_EXT)', XSPROTOARG => '-noprototypes', DEFINE => $OS2 || "", + INC => ($^O eq "MacOS" ? "-i ::::db:include" : "") ); sub MY::postamble { diff --git a/ext/DynaLoader/dl_mac.xs b/ext/DynaLoader/dl_mac.xs new file mode 100644 index 0000000000..136e6d58c3 --- /dev/null +++ b/ext/DynaLoader/dl_mac.xs @@ -0,0 +1,137 @@ +/* dl_mac.xs + * + * Platform: Macintosh CFM + * Author: Matthias Neeracher <neeri@iis.ee.ethz.ch> + * Adapted from dl_dlopen.xs reference implementation by + * Paul Marquess (pmarquess@bfsec.bt.co.uk) + * $Log: dl_mac.xs,v $ + * Revision 1.3 1998/04/07 01:47:24 neeri + * MacPerl 5.2.0r4b1 + * + * Revision 1.2 1997/08/08 16:39:18 neeri + * MacPerl 5.1.4b1 + time() fix + * + * Revision 1.1 1997/04/07 20:48:23 neeri + * Synchronized with MacPerl 5.1.4a1 + * + */ + +#define MAC_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <CodeFragments.h> + + +#include "dlutils.c" /* SaveError() etc */ + +typedef CFragConnectionID ConnectionID; + +static ConnectionID ** connections; + +static void terminate(void) +{ + int size = GetHandleSize((Handle) connections) / sizeof(ConnectionID); + HLock((Handle) connections); + while (size) + CloseConnection(*connections + --size); + DisposeHandle((Handle) connections); + connections = nil; +} + +static void +dl_private_init(pTHX) +{ + (void)dl_generic_private_init(aTHX); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(aTHX); + + +ConnectionID +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: + OSErr err; + FSSpec spec; + ConnectionID connID; + Ptr mainAddr; + Str255 errName; + CODE: + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + err = GUSIPath2FSp(filename, &spec); + if (!err) + err = + GetDiskFragment( + &spec, 0, 0, spec.name, kLoadCFrag, &connID, &mainAddr, errName); + if (!err) { + if (!connections) { + connections = (ConnectionID **)NewHandle(0); + atexit(terminate); + } + PtrAndHand((Ptr) &connID, (Handle) connections, sizeof(ConnectionID)); + RETVAL = connID; + } else + RETVAL = (ConnectionID) 0; + DLDEBUG(2,fprintf(stderr," libref=%d\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (err) + SaveError(aTHX_ "DynaLoader error [%d, %#s]", err, errName) ; + else + sv_setiv( ST(0), (IV)RETVAL); + +void * +dl_find_symbol(connID, symbol) + ConnectionID connID + Str255 symbol + CODE: + { + OSErr err; + Ptr symAddr; + CFragSymbolClass symClass; + DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%#s)\n", + connID, symbol)); + err = FindSymbol(connID, symbol, &symAddr, &symClass); + if (err) + symAddr = (Ptr) 0; + RETVAL = (void *) symAddr; + DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (err) + SaveError(aTHX_ "DynaLoader error [%d]!", err) ; + else + sv_setiv( ST(0), (IV)RETVAL); + } + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/ext/NDBM_File/Makefile.PL b/ext/NDBM_File/Makefile.PL index 6ceab55a4a..7b586017d7 100644 --- a/ext/NDBM_File/Makefile.PL +++ b/ext/NDBM_File/Makefile.PL @@ -5,4 +5,5 @@ WriteMakefile( MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'NDBM_File.pm', + INC => ($^O eq "MacOS" ? "-i ::::db:include" : "") ); diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index b33e9619a4..d309ecb134 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -55,6 +55,9 @@ #ifdef I_UNISTD #include <unistd.h> #endif +#ifdef MACOS_TRADITIONAL +#undef fdopen +#endif #include <fcntl.h> #if defined(__VMS) && !defined(__POSIX_SOURCE) @@ -142,7 +145,7 @@ #else # ifndef HAS_MKFIFO -# ifdef OS2 +# if defined(OS2) || defined(MACOS_TRADITIONAL) # define mkfifo(a,b) not_here("mkfifo") # else /* !( defined OS2 ) */ # ifndef mkfifo @@ -151,12 +154,19 @@ # endif # endif /* !HAS_MKFIFO */ -# include <grp.h> -# include <sys/times.h> -# ifdef HAS_UNAME -# include <sys/utsname.h> +# ifdef MACOS_TRADITIONAL + struct tms { time_t tms_utime, tms_stime, tms_cutime, tms_cstime; }; +# define times(a) not_here("times") +# define ttyname(a) (char*)not_here("ttyname") +# define tzset() not_here("tzset") +# else +# include <grp.h> +# include <sys/times.h> +# ifdef HAS_UNAME +# include <sys/utsname.h> +# endif +# include <sys/wait.h> # endif -# include <sys/wait.h> # ifdef I_UTIME # include <utime.h> # endif @@ -3352,7 +3362,7 @@ modf(x) PPCODE: double intvar; /* (We already know stack is long enough.) */ - PUSHs(sv_2mortal(newSVnv(modf(x,&intvar)))); + PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); PUSHs(sv_2mortal(newSVnv(intvar))); double diff --git a/hints/bsdos.sh b/hints/bsdos.sh index c54a0c1606..d3b1b703f2 100644 --- a/hints/bsdos.sh +++ b/hints/bsdos.sh @@ -3,8 +3,12 @@ # hints file for BSD/OS (adapted from bsd386.sh) # Original by Neil Bowers <neilb@khoros.unm.edu>; Tue Oct 4 12:01:34 EDT 1994 # Updated by Tony Sanders <sanders@bsdi.com>; Sat Aug 23 12:47:45 MDT 1997 -# Added 3.1 with ELF dynamic libraries (NOT in 3.1 yet. Estimated for 4.0) -# SYSV IPC tested Ok so I re-enabled. +# Added 3.1 with ELF dynamic libraries (NOT in 3.1 yet. +# Estimated for 4.0) SYSV IPC tested Ok so I re-enabled. +# +# Updated to work in post-4.0 by Todd C. Miller <millert@openbsd.org> +# +# Updated for threads by "Timur I. Bakeyev" <bsdi@listserv.bat.ru> # # To override the compiler on the command line: # ./Configure -Dcc=gcc2 @@ -18,7 +22,7 @@ d_voidsig='define' usemymalloc='n' # setre?[ug]id() have been replaced by the _POSIX_SAVED_IDS versions. -# See http://www.bsdi.com/bsdi-man?setuid(2) +# See <A HREF="http://www.bsdi.com/bsdi-man?setuid">http://www.bsdi.com/bsdi-man?setuid</A>(2) d_setregid='undef' d_setreuid='undef' d_setrgid='undef' @@ -85,8 +89,8 @@ case "$osvers" in libswanted="Xpm Xaw Xmu Xt SM ICE Xext X11 $libswanted" libswanted="rpc curses termcap $libswanted" ;; -4.0*) - # ELF dynamic link libraries starting in 4.0 (???) +4.*) + # ELF dynamic link libraries starting in 4.0 useshrplib='true' so='so' dlext='so' @@ -101,6 +105,26 @@ case "$osvers" in '') ld='ld' lddlflags="-shared -x $lddlflags" ;; esac - ;; + # Due usage of static pointer from crt.o + libswanted="util $libswanted" ;; esac +# This script UU/usethreads.cbu will get 'called-back' by Configure +# after it has prompted the user for whether to use threads. +cat > UU/usethreads.cbu <<'EOCBU' +case "$usethreads" in +$define|true|[yY]*) + case "$osvers" in + 3.*|4.*) ccflags="-D_REENTRANT $ccflags" + ;; + *) cat <<EOM >&4 +I did not know that BSD/OS $osvers supports POSIX threads. + +Feel free to tell perlbug@perl.com otherwise. +EOM + exit 1 + ;; + esac + ;; +esac +EOCBU diff --git a/hints/os2.sh b/hints/os2.sh index 1d9df3683f..0e9f786d25 100644 --- a/hints/os2.sh +++ b/hints/os2.sh @@ -93,7 +93,7 @@ if test "$libemx" = "X"; then echo "Cannot find C library!" >&2; fi libpth="`echo \"$LIBRARY_PATH\" | tr ';\\\' ' /'`" libpth="$libpth $libemx/mt $libemx" -set `emxrev -f emxlibcm` +set `cmd /c emxrev -f emxlibcm` emxcrtrev=$5 # indented to not put it into config.sh _defemxcrtrev=-D_EMX_CRT_REV_=$emxcrtrev diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index 0be3ae6765..bb20372792 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -6,6 +6,7 @@ use Config qw(%Config); use Carp qw(carp); use File::Basename (); use File::Path qw(mkpath); +use File::Spec::Functions qw(curdir catfile); use strict; our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen, $CheckForAutoloader, $CheckModTime); @@ -173,16 +174,20 @@ sub autosplit_lib_modules{ my(@modules) = @_; # list of Module names while(defined($_ = shift @modules)){ - s#::#/#g; # incase specified as ABC::XYZ + while (m#(.*?[^:])::([^:].*)#) { # in case specified as ABC::XYZ + $_ = catfile($1, $2); + } s|\\|/|g; # bug in ksh OS/2 s#^lib/##s; # incase specified as lib/*.pm + my($lib) = catfile(curdir(), "lib"); + s#^$lib\W+##s; # incase specified as ./lib/*.pm if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs my ($dir,$name) = (/(.*])(.*)/s); $dir =~ s/.*lib[\.\]]//s; $dir =~ s#[\.\]]#/#g; $_ = $dir . $name; } - autosplit_file("lib/$_", "lib/auto", + autosplit_file(catfile($lib, $_), catfile($lib, "auto"), $Keep, $CheckForAutoloader, $CheckModTime); } 0; @@ -199,7 +204,7 @@ sub autosplit_file { local($/) = "\n"; # where to write output files - $autodir ||= "lib/auto"; + $autodir ||= catfile(curdir(), "lib", "auto"); if ($Is_VMS) { ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||; $filename = VMS::Filespec::unixify($filename); # may have dirs @@ -264,11 +269,12 @@ sub autosplit_file { } } - print "AutoSplitting $filename ($autodir/$modpname)\n" + my($modnamedir) = catfile($autodir, $modpname); + print "AutoSplitting $filename ($modnamedir)\n" if $Verbose; - unless (-d "$autodir/$modpname"){ - mkpath("$autodir/$modpname",0,0777); + unless (-d "$modnamedir"){ + mkpath("$modnamedir",0,0777); } # We must try to deal with some SVR3 systems with a limit of 14 @@ -311,9 +317,10 @@ sub autosplit_file { push(@subnames, $fq_subname); my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3)); $modpname = _modpname($this_package); - mkpath("$autodir/$modpname",0,0777); - my($lpath) = "$autodir/$modpname/$lname.al"; - my($spath) = "$autodir/$modpname/$sname.al"; + my($modnamedir) = catfile($autodir, $modpname); + mkpath("$modnamedir",0,0777); + my($lpath) = catfile($modnamedir, "$lname.al"); + my($spath) = catfile($modnamedir, "$sname.al"); my $path; if (!$Is83 and open(OUT, ">$lpath")){ $path=$lpath; @@ -379,7 +386,7 @@ EOT opendir(OUTDIR,$dir); foreach (sort readdir(OUTDIR)){ next unless /\.al\z/; - my($file) = "$dir/$_"; + my($file) = catfile($dir, $_); $file = lc $file if $Is83 or $Is_VMS; next if $outfiles{$file}; print " deleting $file\n" if ($Verbose>=2); @@ -418,7 +425,9 @@ sub _modpname ($) { if ($^O eq 'MSWin32') { $modpname =~ s#::#\\#g; } else { - $modpname =~ s#::#/#g; + while ($modpname =~ m#(.*?[^:])::([^:].*)#) { + $modpname = catfile($1, $2); + } } $modpname; } diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index da2255271f..65b0bd91c4 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -1249,11 +1249,6 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' next; } my($dev,$ino,$mode) = stat FIXIN; - # If they override perm_rwx, we won't notice it during fixin, - # because fixin is run through a new instance of MakeMaker. - # That is why we must run another CHMOD later. - $mode = oct($self->perm_rwx) unless $dev; - chmod $mode, $file; # Print out the new #! line (or equivalent). local $\; @@ -1261,7 +1256,15 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' print FIXOUT $shb, <FIXIN>; close FIXIN; close FIXOUT; - # can't rename open files on some DOSISH platforms + + # can't rename/chmod open files on some DOSISH platforms + + # If they override perm_rwx, we won't notice it during fixin, + # because fixin is run through a new instance of MakeMaker. + # That is why we must run another CHMOD later. + $mode = oct($self->perm_rwx) unless $dev; + chmod $mode, $file; + unless ( rename($file, "$file.bak") ) { warn "Can't rename $file to $file.bak: $!"; next; @@ -1276,6 +1279,7 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' } unlink "$file.bak"; } continue { + close(FIXIN) if fileno(FIXIN); chmod oct($self->perm_rwx), $file or die "Can't reset permissions for $file: $!\n"; system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';; diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index 9906fd5383..bef12b54da 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -82,7 +82,7 @@ if ($Is_OS2) { require ExtUtils::MM_OS2; } if ($Is_Mac) { - require ExtUtils::MM_Mac; + require ExtUtils::MM_MacOS; } if ($Is_Win32) { require ExtUtils::MM_Win32; diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 5a71e89636..eb085f542f 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -847,7 +847,14 @@ EOM print("#line 1 \"$filename\"\n") if $WantLineNumbers; +firstmodule: while (<$FH>) { + if (/^=/) { + do { + next firstmodule if /^=cut\s*$/; + } while (<$FH>); + &Exit; + } last if ($Module, $Package, $Prefix) = /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; @@ -886,6 +893,16 @@ sub fetch_para { } for(;;) { + # Skip embedded PODs + while ($lastline =~ /^=/) { + while ($lastline = <$FH>) { + last if ($lastline =~ /^=cut\s*$/); + } + death ("Error: Unterminated pod") unless $lastline; + $lastline = <$FH>; + chomp $lastline; + $lastline =~ s/^\s+$//; + } if ($lastline !~ /^\s*#/ || # CPP directives: # ANSI: if ifdef ifndef elif else endif define undef diff --git a/lib/File/Find.pm b/lib/File/Find.pm index ac73f1b5eb..ef10e9d416 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -584,12 +584,24 @@ sub _find_dir_symlnk($$$) { while (defined $SE) { unless ($bydepth) { + # change to parent directory + unless ($no_chdir) { + my $udir = $pdir_loc; + if ($untaint) { + $udir = $1 if $pdir_loc =~ m|$untaint_pat|; + } + unless (chdir $udir) { + warn "Can't cd to $udir: $!\n"; + next; + } + } $dir= $p_dir; $name= $dir_name; $_= ($no_chdir ? $dir_name : $dir_rel ); $fullname= $dir_loc; # prune may happen here $prune= 0; + lstat($_); # make sure file tests with '_' work &$wanted_callback; next if $prune; } @@ -673,6 +685,7 @@ sub _find_dir_symlnk($$$) { s|/\.$||; } + lstat($_); # make sure file tests with '_' work &$wanted_callback; } else { push @Stack,[$dir_loc, $pdir_loc, $p_dir, $dir_rel,-1] if $bydepth; diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index 6d4e8b90b3..aded0e91d7 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -212,7 +212,7 @@ sub runtests { } if (@failed) { my ($txt, $canon) = canonfailed($max,$skipped,@failed); - print $txt; + print "${ml}$txt"; $failedtests{$test} = { canon => $canon, max => $max, failed => scalar @failed, name => $test, percent => 100*(scalar @failed)/$max, diff --git a/lib/warnings.pm b/lib/warnings.pm index 11558d50d4..ac6d919954 100644 --- a/lib/warnings.pm +++ b/lib/warnings.pm @@ -60,7 +60,7 @@ will be used. =back -See L<perlmod/Pragmatic Modules> and L<perllexwarn>. +See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>. =cut diff --git a/makedef.pl b/makedef.pl index 6fae88be9e..ae68674aa7 100644 --- a/makedef.pl +++ b/makedef.pl @@ -157,7 +157,7 @@ elsif ($PLATFORM eq 'os2') { # print STDERR "'$dll' <= '$define{PERL_DLL}'\n"; print <<"---EOP---"; LIBRARY '$dll' INITINSTANCE TERMINSTANCE -DESCRIPTION '\@#perl5-porters\@perl.org:$v#\@ Perl interpreter, configured as $CONFIG_ARGS' +DESCRIPTION '\@#perl5-porters\@perl.org:$v#\@ Perl interpreter' STACKSIZE 32768 CODE LOADONCALL DATA LOADONCALL NONSHARED MULTIPLE @@ -489,8 +489,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { char msg[256]; - sv_setnv(sv,(double)gLastMacOSErr); - sv_setpv(sv, gLastMacOSErr ? GetSysErrText(gLastMacOSErr, msg) : ""); + sv_setnv(sv,(double)gMacPerl_OSErr); + sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : ""); } #else #ifdef VMS @@ -1670,7 +1670,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '\005': /* ^E */ #ifdef MACOS_TRADITIONAL - gLastMacOSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); + gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); #else # ifdef VMS set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs index 3a50dc737c..f5a0c15634 100644 --- a/os2/Makefile.SHs +++ b/os2/Makefile.SHs @@ -66,7 +66,7 @@ $(PERL_DLL): $(obj) perl5.def perl$(OBJ_EXT) perl5.olddef: perl.linkexp echo "LIBRARY '$(PERL_DLL_BASE)' INITINSTANCE TERMINSTANCE" > $@ - echo DESCRIPTION "'Perl interpreter v$(PERL_FULLVERSION), export autogenerated, built with $(CONFIG_ARGS)'" >>$@ + echo DESCRIPTION "'Perl interpreter v$(PERL_FULLVERSION), export autogenerated'" >>$@ echo STACKSIZE 32768 >>$@ echo CODE LOADONCALL >>$@ echo DATA LOADONCALL NONSHARED MULTIPLE >>$@ diff --git a/os2/OS2/REXX/t/rx_dllld.t b/os2/OS2/REXX/t/rx_dllld.t index 15362d78e9..406bd63a33 100644 --- a/os2/OS2/REXX/t/rx_dllld.t +++ b/os2/OS2/REXX/t/rx_dllld.t @@ -12,11 +12,11 @@ use OS2::REXX; $path = $ENV{LIBPATH} || $ENV{PATH} or die; foreach $dir (split(';', $path)) { - next unless -f "$dir/YDBAUTIL.DLL"; - $found = "$dir/YDBAUTIL.DLL"; + next unless -f "$dir/RXU.DLL"; + $found = "$dir/RXU.DLL"; last; } -$found or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit; +$found or print "1..0 # skipped: cannot find RXU.DLL\n" and exit; print "1..5\n"; diff --git a/os2/OS2/REXX/t/rx_objcall.t b/os2/OS2/REXX/t/rx_objcall.t index 8bdf90564d..b1154757d4 100644 --- a/os2/OS2/REXX/t/rx_objcall.t +++ b/os2/OS2/REXX/t/rx_objcall.t @@ -13,22 +13,21 @@ use OS2::REXX; # # DLL # -$ydba = load OS2::REXX "ydbautil" - or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit; +$rxu = load OS2::REXX "rxu" + or print "1..0 # skipped: cannot find RXU.DLL\n" and exit; print "1..5\n", "ok 1\n"; # # function # -@pid = $ydba->RxProcId(); +@pid = $rxu->RxProcId(); @pid == 1 ? print "ok 2\n" : print "not ok 2\n"; @res = split " ", $pid[0]; print "ok 3\n" if $res[0] == $$; -@pid = $ydba->RxProcId(); +@pid = $rxu->RxProcId(); @res = split " ", $pid[0]; print "ok 4\n" if $res[0] == $$; print "# @pid\n"; -eval { $ydba->nixda(); }; +eval { $rxu->nixda(); }; print "ok 5\n" if $@ =~ /^Can't find entry 'nixda\'/; - diff --git a/os2/OS2/REXX/t/rx_tievar.t b/os2/OS2/REXX/t/rx_tievar.t index 5f43f4e5fc..9c9ea7d466 100644 --- a/os2/OS2/REXX/t/rx_tievar.t +++ b/os2/OS2/REXX/t/rx_tievar.t @@ -13,8 +13,8 @@ use OS2::REXX; # # DLL # -load OS2::REXX "ydbautil" - or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit; +load OS2::REXX "rxu" + or print "1..0 # skipped: cannot find RXU.DLL\n" and exit; print "1..19\n"; diff --git a/os2/OS2/REXX/t/rx_tieydb.t b/os2/OS2/REXX/t/rx_tieydb.t index 1653a2081c..ec6bfca20e 100644 --- a/os2/OS2/REXX/t/rx_tieydb.t +++ b/os2/OS2/REXX/t/rx_tieydb.t @@ -9,8 +9,8 @@ BEGIN { } use OS2::REXX; -$rx = load OS2::REXX "ydbautil" # from RXU17.ZIP - or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit; +$rx = load OS2::REXX "RXU" # from RXU1a.ZIP + or print "1..0 # skipped: cannot find RXU.DLL\n" and exit; print "1..7\n", "ok 1\n"; @@ -66,7 +66,7 @@ pthread_join(perl_os_thread tid, void **status) break; case pthreads_st_waited: MUTEX_UNLOCK(&start_thread_mutex); - croak("join with a thread with a waiter"); + Perl_croak_nocontext("join with a thread with a waiter"); break; case pthreads_st_run: thread_join_data[tid].state = pthreads_st_waited; @@ -79,7 +79,7 @@ pthread_join(perl_os_thread tid, void **status) break; default: MUTEX_UNLOCK(&start_thread_mutex); - croak("join: unknown thread state: '%s'", + Perl_croak_nocontext("join: unknown thread state: '%s'", pthreads_states[thread_join_data[tid].state]); break; } @@ -107,7 +107,7 @@ pthread_startit(void *arg) } } if (thread_join_data[tid].state != pthreads_st_none) - croak("attempt to reuse thread id %i", tid); + Perl_croak_nocontext("attempt to reuse thread id %i", tid); thread_join_data[tid].state = pthreads_st_run; /* Now that we copied/updated the guys, we may release the caller... */ MUTEX_UNLOCK(&start_thread_mutex); @@ -146,7 +146,7 @@ pthread_detach(perl_os_thread tid) switch (thread_join_data[tid].state) { case pthreads_st_waited: MUTEX_UNLOCK(&start_thread_mutex); - croak("detach on a thread with a waiter"); + Perl_croak_nocontext("detach on a thread with a waiter"); break; case pthreads_st_run: thread_join_data[tid].state = pthreads_st_detached; @@ -154,7 +154,7 @@ pthread_detach(perl_os_thread tid) break; default: MUTEX_UNLOCK(&start_thread_mutex); - croak("detach: unknown thread state: '%s'", + Perl_croak_nocontext("detach: unknown thread state: '%s'", pthreads_states[thread_join_data[tid].state]); break; } @@ -168,11 +168,11 @@ os2_cond_wait(perl_cond *c, perl_mutex *m) int rc; STRLEN n_a; if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET)) - croak("panic: COND_WAIT-reset: rc=%i", rc); + Perl_croak_nocontext("panic: COND_WAIT-reset: rc=%i", rc); if (m) MUTEX_UNLOCK(m); if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT)) && (rc != ERROR_INTERRUPT)) - croak("panic: COND_WAIT: rc=%i", rc); + Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc); if (rc == ERROR_INTERRUPT) errno = EINTR; if (m) MUTEX_LOCK(m); @@ -199,12 +199,12 @@ loadByOrd(char *modname, ULONG ord) if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf, modname, &hdosc))) || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn))) - croak("This version of OS/2 does not support %s.%i", + Perl_croak_nocontext("This version of OS/2 does not support %s.%i", modname, loadOrd[ord]); ExtFCN[ord] = fcn; } if ((long)ExtFCN[ord] == -1) - croak("panic queryaddr"); + Perl_croak_nocontext("panic queryaddr"); } void @@ -227,11 +227,11 @@ init_PMWIN_entries(void) return; if (CheckOSError(DosLoadModule(buf, sizeof buf, "pmwin", &hpmwin))) - croak("This version of OS/2 does not support pmwin: error in %s", buf); + Perl_croak_nocontext("This version of OS/2 does not support pmwin: error in %s", buf); while (i <= 5) { if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL, ((PFN*)&PMWIN_entries)+i))) - croak("This version of OS/2 does not support pmwin.%d", ords[i]); + Perl_croak_nocontext("This version of OS/2 does not support pmwin.%d", ords[i]); i++; } } @@ -277,7 +277,7 @@ sys_prio(pid) } if (pid != psi->procdata->pid) { Safefree(psi); - croak("panic: wrong pid in sysinfo"); + Perl_croak_nocontext("panic: wrong pid in sysinfo"); } prio = psi->procdata->threads->priority; Safefree(psi); @@ -373,8 +373,9 @@ spawn_sighandler(int sig) } static int -result(int flag, int pid) +result(pTHX_ int flag, int pid) { + dTHR; int r, status; Signal_t (*ihand)(); /* place to save signal during system() */ Signal_t (*qhand)(); /* place to save signal during system() */ @@ -441,7 +442,7 @@ file_type(char *path) ULONG apptype; if (!(_emx_env & 0x200)) - croak("file_type not implemented on DOS"); /* not OS/2. */ + Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */ if (CheckOSError(DosQueryAppType(path, &apptype))) { switch (rc) { case ERROR_FILE_NOT_FOUND: @@ -464,12 +465,7 @@ static ULONG os2_mytype; /* global PL_Argv[] contains arguments. */ int -do_spawn_ve(really, flag, execf, inicmd, addflag) -SV *really; -U32 flag; -U32 execf; -char *inicmd; -U32 addflag; +do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) { dTHR; int trueflag = flag; @@ -541,7 +537,7 @@ U32 addflag; if (flag == P_NOWAIT) flag = P_PM; else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION) - warn("Starting PM process with flag=%d, mytype=%d", + Perl_warner(aTHX_ WARN_EXEC, "Starting PM process with flag=%d, mytype=%d", flag, os2_mytype); } } @@ -552,7 +548,7 @@ U32 addflag; if (flag == P_NOWAIT) flag = P_SESSION; else if ((flag & 7) != P_SESSION) - warn("Starting Full Screen process with flag=%d, mytype=%d", + Perl_warner(aTHX_ WARN_EXEC, "Starting Full Screen process with flag=%d, mytype=%d", flag, os2_mytype); } } @@ -584,7 +580,7 @@ U32 addflag; } #if 0 - rc = result(trueflag, spawnvp(flag,tmps,PL_Argv)); + rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv)); #else if (execf == EXECF_TRUEEXEC) rc = execvp(tmps,PL_Argv); @@ -593,7 +589,7 @@ U32 addflag; else if (execf == EXECF_SPAWN_NOWAIT) rc = spawnvp(flag,tmps,PL_Argv); else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */ - rc = result(trueflag, + rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv)); #endif if (rc < 0 && pass == 1 @@ -618,7 +614,7 @@ U32 addflag; if (l >= sizeof scrbuf) { Safefree(scr); longbuf: - warn("Size of scriptname too big: %d", l); + Perl_warner(aTHX_ WARN_EXEC, "Size of scriptname too big: %d", l); rc = -1; goto finish; } @@ -654,7 +650,7 @@ U32 addflag; } if (fclose(file) != 0) { /* Failure */ panic_file: - warn("Error reading \"%s\": %s", + Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s", scr, Strerror(errno)); buf[0] = 0; /* Not #! */ goto doshell_args; @@ -698,7 +694,7 @@ U32 addflag; *s++ = 0; } if (nargs == -1) { - warn("Too many args on %.*s line of \"%s\"", + Perl_warner(aTHX_ WARN_EXEC, "Too many args on %.*s line of \"%s\"", s1 - buf, buf, scr); nargs = 4; argsp = fargs; @@ -820,8 +816,9 @@ U32 addflag; /* Try converting 1-arg form to (usually shell-less) multi-arg form. */ int -do_spawn3(char *cmd, int execf, int flag) +do_spawn3(pTHX_ char *cmd, int execf, int flag) { + dTHR; register char **a; register char *s; char flags[10]; @@ -905,7 +902,7 @@ do_spawn3(char *cmd, int execf, int flag) rc = spawnl(flag,shell,shell,copt,cmd,(char*)0); else { /* In the ak code internal P_NOWAIT is P_WAIT ??? */ - rc = result(P_WAIT, + rc = result(aTHX_ P_WAIT, spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); if (rc < 0 && ckWARN(WARN_EXEC)) Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s", @@ -936,7 +933,7 @@ do_spawn3(char *cmd, int execf, int flag) } *a = Nullch; if (PL_Argv[0]) - rc = do_spawn_ve(NULL, flag, execf, cmd, mergestderr); + rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr); else rc = -1; if (news) @@ -947,10 +944,7 @@ do_spawn3(char *cmd, int execf, int flag) /* Array spawn. */ int -do_aspawn(really,mark,sp) -SV *really; -register SV **mark; -register SV **sp; +os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp) { dTHR; register char **a; @@ -978,9 +972,9 @@ register SV **sp; *a = Nullch; if (flag_set && (a == PL_Argv + 1)) { /* One arg? */ - rc = do_spawn3(a[-1], EXECF_SPAWN_BYFLAG, flag); + rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag); } else - rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL, 0); + rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0); } else rc = -1; do_execfree(); @@ -988,38 +982,36 @@ register SV **sp; } int -do_spawn(cmd) -char *cmd; +os2_do_spawn(pTHX_ char *cmd) { - return do_spawn3(cmd, EXECF_SPAWN, 0); + dTHR; + return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0); } int -do_spawn_nowait(cmd) -char *cmd; +do_spawn_nowait(pTHX_ char *cmd) { - return do_spawn3(cmd, EXECF_SPAWN_NOWAIT,0); + dTHR; + return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0); } bool -do_exec(cmd) -char *cmd; +Perl_do_exec(pTHX_ char *cmd) { - do_spawn3(cmd, EXECF_EXEC, 0); + dTHR; + do_spawn3(aTHX_ cmd, EXECF_EXEC, 0); return FALSE; } bool -os2exec(cmd) -char *cmd; +os2exec(pTHX_ char *cmd) { - return do_spawn3(cmd, EXECF_TRUEEXEC, 0); + dTHR; + return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0); } PerlIO * -my_syspopen(cmd,mode) -char *cmd; -char *mode; +my_syspopen(pTHX_ char *cmd, char *mode) { #ifndef USE_POPEN @@ -1069,7 +1061,7 @@ char *mode; fcntl(p[this], F_SETFD, FD_CLOEXEC); if (newfd != -1) fcntl(newfd, F_SETFD, FD_CLOEXEC); - pid = do_spawn_nowait(cmd); + pid = do_spawn_nowait(aTHX_ cmd); if (newfd == -1) close(*mode == 'r'); /* It was closed initially */ else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */ @@ -1124,7 +1116,7 @@ char *mode; int fork(void) { - croak(PL_no_func, "Unsupported function fork"); + Perl_croak_nocontext(PL_no_func, "Unsupported function fork"); errno = EINVAL; return -1; } @@ -1150,7 +1142,7 @@ tcp0(char *name) static BYTE buf[20]; PFN fcn; - if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */ + if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */ if (!htcp) DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) @@ -1164,7 +1156,7 @@ tcp1(char *name, int arg) static BYTE buf[20]; PFN fcn; - if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */ + if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */ if (!htcp) DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) @@ -1230,7 +1222,7 @@ sys_alloc(int size) { if (rc == ERROR_NOT_ENOUGH_MEMORY) { return (void *) -1; } else if ( rc ) - croak("Got an error from DosAllocMem: %li", (long)rc); + Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc); return got; } @@ -1264,7 +1256,7 @@ XS(XS_File__Copy_syscopy) { dXSARGS; if (items < 2 || items > 3) - croak("Usage: File::Copy::syscopy(src,dst,flag=0)"); + Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)"); { STRLEN n_a; char * src = (char *)SvPV(ST(0),n_a); @@ -1288,8 +1280,7 @@ XS(XS_File__Copy_syscopy) #include "patchlevel.h" char * -mod2fname(sv) - SV *sv; +mod2fname(pTHX_ SV *sv) { static char fname[9]; int pos = 6, len, avlen; @@ -1299,14 +1290,14 @@ mod2fname(sv) char *s; STRLEN n_a; - if (!SvROK(sv)) croak("Not a reference given to mod2fname"); + if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname"); sv = SvRV(sv); if (SvTYPE(sv) != SVt_PVAV) - croak("Not array reference given to mod2fname"); + Perl_croak_nocontext("Not array reference given to mod2fname"); avlen = av_len((AV*)sv); if (avlen < 0) - croak("Empty array reference given to mod2fname"); + Perl_croak_nocontext("Empty array reference given to mod2fname"); s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); strncpy(fname, s, 8); @@ -1338,12 +1329,12 @@ XS(XS_DynaLoader_mod2fname) { dXSARGS; if (items != 1) - croak("Usage: DynaLoader::mod2fname(sv)"); + Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)"); { SV * sv = ST(0); char * RETVAL; - RETVAL = mod2fname(sv); + RETVAL = mod2fname(aTHX_ sv); ST(0) = sv_newmortal(); sv_setpv((SV*)ST(0), RETVAL); } @@ -1374,8 +1365,9 @@ os2error(int rc) } char * -os2_execname(void) +os2_execname(pTHX) { + dTHR; char buf[300], *p; if (_execname(buf, sizeof buf) != 0) @@ -1412,7 +1404,7 @@ perllib_mangle(char *s, unsigned int l) } newl = strlen(newp); if (newl == 0 || oldl == 0) { - croak("Malformed PERLLIB_PREFIX"); + Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); } strcpy(ret, newp); s = ret; @@ -1434,7 +1426,7 @@ perllib_mangle(char *s, unsigned int l) return s; } if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) { - croak("Malformed PERLLIB_PREFIX"); + Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); } strcpy(ret + newl, s + oldl); return ret; @@ -1467,7 +1459,7 @@ Perl_Register_MQ(int serve) static int cnt; if (cnt++) _exit(188); /* Panic can try to create a window. */ - croak("Cannot create a message queue, or morph to a PM application"); + Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application"); } return Perl_hmq; } @@ -1481,11 +1473,11 @@ Perl_Serve_Messages(int force) if (Perl_hmq_servers && !force) return 0; if (!Perl_hmq_refcnt) - croak("No message queue"); + Perl_croak_nocontext("No message queue"); while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) { cnt++; if (msg.msg == WM_QUIT) - croak("QUITing..."); + Perl_croak_nocontext("QUITing..."); (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); } return cnt; @@ -1499,7 +1491,7 @@ Perl_Process_Messages(int force, I32 *cntp) if (Perl_hmq_servers && !force) return 0; if (!Perl_hmq_refcnt) - croak("No message queue"); + Perl_croak_nocontext("No message queue"); while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) { if (cntp) (*cntp)++; @@ -1509,7 +1501,7 @@ Perl_Process_Messages(int force, I32 *cntp) if (msg.msg == WM_CREATE) return +1; } - croak("QUITing..."); + Perl_croak_nocontext("QUITing..."); } void @@ -1525,7 +1517,7 @@ Perl_Deregister_MQ(int serve) if (pib->pib_ultype == 3) /* 3 is PM */ pib->pib_ultype = Perl_os2_initial_mode; else - warn("Unexpected program mode %d when morphing back from PM", + Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM", pib->pib_ultype); } } @@ -1549,7 +1541,7 @@ XS(XS_OS2_Error) { dXSARGS; if (items != 2) - croak("Usage: OS2::Error(harderr, exception)"); + Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)"); { int arg1 = SvIV(ST(0)); int arg2 = SvIV(ST(1)); @@ -1559,7 +1551,7 @@ XS(XS_OS2_Error) unsigned long rc; if (CheckOSError(DosError(a))) - croak("DosError(%d) failed", a); + Perl_croak_nocontext("DosError(%d) failed", a); ST(0) = sv_newmortal(); if (DOS_harderr_state >= 0) sv_setiv(ST(0), DOS_harderr_state); @@ -1574,7 +1566,7 @@ XS(XS_OS2_Errors2Drive) { dXSARGS; if (items != 1) - croak("Usage: OS2::Errors2Drive(drive)"); + Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)"); { STRLEN n_a; SV *sv = ST(0); @@ -1584,12 +1576,12 @@ XS(XS_OS2_Errors2Drive) unsigned long rc; if (suppress && !isALPHA(drive)) - croak("Non-char argument '%c' to OS2::Errors2Drive()", drive); + Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive); if (CheckOSError(DosSuppressPopUps((suppress ? SPU_ENABLESUPPRESSION : SPU_DISABLESUPPRESSION), drive))) - croak("DosSuppressPopUps(%c) failed", drive); + Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive); ST(0) = sv_newmortal(); if (DOS_suppression_state > 0) sv_setpvn(ST(0), &DOS_suppression_state, 1); @@ -1632,7 +1624,7 @@ XS(XS_OS2_SysInfo) { dXSARGS; if (items != 0) - croak("Usage: OS2::SysInfo()"); + Perl_croak_nocontext("Usage: OS2::SysInfo()"); { ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */ APIRET rc = NO_ERROR; /* Return code */ @@ -1642,7 +1634,7 @@ XS(XS_OS2_SysInfo) QSV_MAX, /* information */ (PVOID)si, sizeof(si)))) - croak("DosQuerySysInfo() failed"); + Perl_croak_nocontext("DosQuerySysInfo() failed"); EXTEND(SP,2*QSV_MAX); while (i < QSV_MAX) { ST(j) = sv_newmortal(); @@ -1659,7 +1651,7 @@ XS(XS_OS2_BootDrive) { dXSARGS; if (items != 0) - croak("Usage: OS2::BootDrive()"); + Perl_croak_nocontext("Usage: OS2::BootDrive()"); { ULONG si[1] = {0}; /* System Information Data Buffer */ APIRET rc = NO_ERROR; /* Return code */ @@ -1667,7 +1659,7 @@ XS(XS_OS2_BootDrive) if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE, (PVOID)si, sizeof(si)))) - croak("DosQuerySysInfo() failed"); + Perl_croak_nocontext("DosQuerySysInfo() failed"); ST(0) = sv_newmortal(); c = 'a' - 1 + si[0]; sv_setpvn(ST(0), &c, 1); @@ -1679,7 +1671,7 @@ XS(XS_OS2_MorphPM) { dXSARGS; if (items != 1) - croak("Usage: OS2::MorphPM(serve)"); + Perl_croak_nocontext("Usage: OS2::MorphPM(serve)"); { bool serve = SvOK(ST(0)); unsigned long pmq = perl_hmq_GET(serve); @@ -1694,7 +1686,7 @@ XS(XS_OS2_UnMorphPM) { dXSARGS; if (items != 1) - croak("Usage: OS2::UnMorphPM(serve)"); + Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)"); { bool serve = SvOK(ST(0)); @@ -1707,7 +1699,7 @@ XS(XS_OS2_Serve_Messages) { dXSARGS; if (items != 1) - croak("Usage: OS2::Serve_Messages(force)"); + Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)"); { bool force = SvOK(ST(0)); unsigned long cnt = Perl_Serve_Messages(force); @@ -1722,7 +1714,7 @@ XS(XS_OS2_Process_Messages) { dXSARGS; if (items < 1 || items > 2) - croak("Usage: OS2::Process_Messages(force [, cnt])"); + Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])"); { bool force = SvOK(ST(0)); unsigned long cnt; @@ -1733,7 +1725,7 @@ XS(XS_OS2_Process_Messages) int fake = SvIV(sv); /* Force SvIVX */ if (!SvIOK(sv)) - croak("Can't upgrade count to IV"); + Perl_croak_nocontext("Can't upgrade count to IV"); cntp = &SvIVX(sv); } cnt = Perl_Process_Messages(force, cntp); @@ -1747,7 +1739,7 @@ XS(XS_Cwd_current_drive) { dXSARGS; if (items != 0) - croak("Usage: Cwd::current_drive()"); + Perl_croak_nocontext("Usage: Cwd::current_drive()"); { char RETVAL; @@ -1762,7 +1754,7 @@ XS(XS_Cwd_sys_chdir) { dXSARGS; if (items != 1) - croak("Usage: Cwd::sys_chdir(path)"); + Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)"); { STRLEN n_a; char * path = (char *)SvPV(ST(0),n_a); @@ -1779,7 +1771,7 @@ XS(XS_Cwd_change_drive) { dXSARGS; if (items != 1) - croak("Usage: Cwd::change_drive(d)"); + Perl_croak_nocontext("Usage: Cwd::change_drive(d)"); { STRLEN n_a; char d = (char)*SvPV(ST(0),n_a); @@ -1796,7 +1788,7 @@ XS(XS_Cwd_sys_is_absolute) { dXSARGS; if (items != 1) - croak("Usage: Cwd::sys_is_absolute(path)"); + Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)"); { STRLEN n_a; char * path = (char *)SvPV(ST(0),n_a); @@ -1813,7 +1805,7 @@ XS(XS_Cwd_sys_is_rooted) { dXSARGS; if (items != 1) - croak("Usage: Cwd::sys_is_rooted(path)"); + Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)"); { STRLEN n_a; char * path = (char *)SvPV(ST(0),n_a); @@ -1830,7 +1822,7 @@ XS(XS_Cwd_sys_is_relative) { dXSARGS; if (items != 1) - croak("Usage: Cwd::sys_is_relative(path)"); + Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)"); { STRLEN n_a; char * path = (char *)SvPV(ST(0),n_a); @@ -1847,7 +1839,7 @@ XS(XS_Cwd_sys_cwd) { dXSARGS; if (items != 0) - croak("Usage: Cwd::sys_cwd()"); + Perl_croak_nocontext("Usage: Cwd::sys_cwd()"); { char p[MAXPATHLEN]; char * RETVAL; @@ -1862,7 +1854,7 @@ XS(XS_Cwd_sys_abspath) { dXSARGS; if (items < 1 || items > 2) - croak("Usage: Cwd::sys_abspath(path, dir = NULL)"); + Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)"); { STRLEN n_a; char * path = (char *)SvPV(ST(0),n_a); @@ -1987,7 +1979,7 @@ XS(XS_Cwd_extLibpath) { dXSARGS; if (items < 0 || items > 1) - croak("Usage: Cwd::extLibpath(type = 0)"); + Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)"); { bool type; char to[1024]; @@ -2011,7 +2003,7 @@ XS(XS_Cwd_extLibpath_set) { dXSARGS; if (items < 1 || items > 2) - croak("Usage: Cwd::extLibpath_set(s, type = 0)"); + Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)"); { STRLEN n_a; char * s = (char *)SvPV(ST(0),n_a); @@ -2033,7 +2025,7 @@ XS(XS_Cwd_extLibpath_set) } int -Xs_OS2_init() +Xs_OS2_init(pTHX) { char *file = __FILE__; { diff --git a/os2/os2ish.h b/os2/os2ish.h index 76d1b8c4f3..23857ac532 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -82,6 +82,9 @@ #ifdef USE_THREADS +#define do_spawn(a) os2_do_spawn(aTHX_ (a)) +#define do_aspawn(a,b,c) os2_do_aspawn(aTHX_ (a),(b),(c)) + #define OS2_ERROR_ALREADY_POSTED 299 /* Avoid os2.h */ extern int rc; @@ -90,49 +93,49 @@ extern int rc; STMT_START { \ int rc; \ if ((rc = _rmutex_create(m,0))) \ - croak("panic: MUTEX_INIT: rc=%i", rc); \ + Perl_croak_nocontext("panic: MUTEX_INIT: rc=%i", rc); \ } STMT_END #define MUTEX_LOCK(m) \ STMT_START { \ int rc; \ if ((rc = _rmutex_request(m,_FMR_IGNINT))) \ - croak("panic: MUTEX_LOCK: rc=%i", rc); \ + Perl_croak_nocontext("panic: MUTEX_LOCK: rc=%i", rc); \ } STMT_END #define MUTEX_UNLOCK(m) \ STMT_START { \ int rc; \ if ((rc = _rmutex_release(m))) \ - croak("panic: MUTEX_UNLOCK: rc=%i", rc); \ + Perl_croak_nocontext("panic: MUTEX_UNLOCK: rc=%i", rc); \ } STMT_END #define MUTEX_DESTROY(m) \ STMT_START { \ int rc; \ if ((rc = _rmutex_close(m))) \ - croak("panic: MUTEX_DESTROY: rc=%i", rc); \ + Perl_croak_nocontext("panic: MUTEX_DESTROY: rc=%i", rc); \ } STMT_END #define COND_INIT(c) \ STMT_START { \ int rc; \ if ((rc = DosCreateEventSem(NULL,c,0,0))) \ - croak("panic: COND_INIT: rc=%i", rc); \ + Perl_croak_nocontext("panic: COND_INIT: rc=%i", rc); \ } STMT_END #define COND_SIGNAL(c) \ STMT_START { \ int rc; \ - if ((rc = DosPostEventSem(*(c))) && rc != OS2_ERROR_ALREADY_POSTED) \ - croak("panic: COND_SIGNAL, rc=%ld", rc); \ + if ((rc = DosPostEventSem(*(c))) && rc != OS2_ERROR_ALREADY_POSTED)\ + Perl_croak_nocontext("panic: COND_SIGNAL, rc=%ld", rc); \ } STMT_END #define COND_BROADCAST(c) \ STMT_START { \ int rc; \ if ((rc = DosPostEventSem(*(c))) && rc != OS2_ERROR_ALREADY_POSTED)\ - croak("panic: COND_BROADCAST, rc=%i", rc); \ + Perl_croak_nocontext("panic: COND_BROADCAST, rc=%i", rc); \ } STMT_END /* #define COND_WAIT(c, m) \ STMT_START { \ if (WaitForSingleObject(*(c),INFINITE) == WAIT_FAILED) \ - croak("panic: COND_WAIT"); \ + Perl_croak_nocontext("panic: COND_WAIT"); \ } STMT_END */ #define COND_WAIT(c, m) os2_cond_wait(c,m) @@ -140,8 +143,8 @@ extern int rc; #define COND_WAIT_win32(c, m) \ STMT_START { \ int rc; \ - if ((rc = SignalObjectAndWait(*(m),*(c),INFINITE,FALSE)))\ - croak("panic: COND_WAIT"); \ + if ((rc = SignalObjectAndWait(*(m),*(c),INFINITE,FALSE))) \ + Perl_croak_nocontext("panic: COND_WAIT"); \ else \ MUTEX_LOCK(m); \ } STMT_END @@ -149,7 +152,7 @@ extern int rc; STMT_START { \ int rc; \ if ((rc = DosCloseEventSem(*(c)))) \ - croak("panic: COND_DESTROY, rc=%i", rc); \ + Perl_croak_nocontext("panic: COND_DESTROY, rc=%i", rc); \ } STMT_END /*#define THR ((struct thread *) TlsGetValue(PL_thr_key)) #define dTHR struct thread *thr = THR @@ -159,11 +162,15 @@ extern int rc; # define pthread_getspecific(k) (*_threadstore()) # define pthread_setspecific(k,v) (*_threadstore()=v,0) # define pthread_key_create(keyp,flag) (*keyp=_gettid(),0) -#else +#else /* USE_SLOW_THREAD_SPECIFIC */ # define pthread_getspecific(k) (*(k)) # define pthread_setspecific(k,v) (*(k)=(v),0) -# define pthread_key_create(keyp,flag) (DosAllocThreadLocalMemory(1,(U32*)keyp) ? croak("LocalMemory"),1 : 0) -#endif +# define pthread_key_create(keyp,flag) \ + ( DosAllocThreadLocalMemory(1,(U32*)keyp) \ + ? Perl_croak_nocontext("LocalMemory"),1 \ + : 0 \ + ) +#endif /* USE_SLOW_THREAD_SPECIFIC */ #define pthread_key_delete(keyp) #define pthread_self() _gettid() #define YIELD DosSleep(0) @@ -173,11 +180,16 @@ int pthread_join(pthread_t tid, void **status); int pthread_detach(pthread_t tid); int pthread_create(pthread_t *tid, const pthread_attr_t *attr, void *(*start_routine)(void*), void *arg); -#endif +#endif /* PTHREAD_INCLUDED */ #define THREADS_ELSEWHERE -#endif +#else /* USE_THREADS */ + +#define do_spawn(a) os2_do_spawn(a) +#define do_aspawn(a,b,c) os2_do_aspawn((a),(b),(c)) + +#endif /* USE_THREADS */ void Perl_OS2_init(char **); @@ -231,9 +243,21 @@ void *sys_alloc(int size); # define PerlIO FILE #endif +/* os2ish is used from a2p/a2p.h without pTHX/pTHX_ first being + * defined. Hack around this to get us to compile. +*/ +#ifdef PTHX_UNUSED +# ifndef pTHX +# define pTHX +# endif +# ifndef pTHX_ +# define pTHX_ +# endif +#endif + #define TMPPATH1 "plXXXXXX" extern char *tmppath; -PerlIO *my_syspopen(char *cmd, char *mode); +PerlIO *my_syspopen(pTHX_ char *cmd, char *mode); /* Cannot prototype with I32 at this point. */ int my_syspclose(PerlIO *f); FILE *my_tmpfile (void); @@ -352,7 +376,7 @@ void Perl_Deregister_MQ(int serve); int Perl_Serve_Messages(int force); /* Cannot prototype with I32 at this point. */ int Perl_Process_Messages(int force, long *cntp); -char *os2_execname(void); +char *os2_execname(pTHX); struct _QMSG; struct PMWIN_entries_t { @@ -373,7 +397,7 @@ void init_PMWIN_entries(void); #define perl_hmq_GET(serve) Perl_Register_MQ(serve) #define perl_hmq_UNSET(serve) Perl_Deregister_MQ(serve) -#define OS2_XS_init() (*OS2_Perl_data.xs_init)() +#define OS2_XS_init() (*OS2_Perl_data.xs_init)(aTHX) #if _EMX_CRT_REV_ >= 60 # define os2_setsyserrno(rc) (Perl_rc = rc, errno = errno_isOS2_set, \ @@ -969,6 +969,11 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) goto reswitch; case 'e': +#ifdef MACOS_TRADITIONAL + /* ignore -e for Dev:Pseudo argument */ + if (argv[1] && !strcmp(argv[1], "Dev:Pseudo")) + break; +#endif if (PL_euid != PL_uid || PL_egid != PL_gid) Perl_croak(aTHX_ "No -e allowed in setuid scripts"); if (!PL_e_script) { @@ -1190,7 +1195,11 @@ print \" \\@INC:\\n @INC\\n\";"); } #endif +#ifdef MACOS_TRADITIONAL + if (PL_doextract || gMacPerl_AlwaysExtract) { +#else if (PL_doextract) { +#endif find_beginning(); if (cddir && PerlDir_chdir(cddir) < 0) Perl_croak(aTHX_ "Can't chdir to %s",cddir); @@ -1251,6 +1260,16 @@ print \" \\@INC:\\n @INC\\n\";"); SETERRNO(0,SS$_NORMAL); PL_error_count = 0; +#ifdef MACOS_TRADITIONAL + if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) { + if (PL_minus_c) + Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename)); + else { + Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n", + MacPerl_MPWFileName(PL_origfilename)); + } + } +#else if (yyparse() || PL_error_count) { if (PL_minus_c) Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename); @@ -1259,6 +1278,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_origfilename); } } +#endif CopLINE_set(PL_curcop, 0); PL_curstash = PL_defstash; PL_preprocess = FALSE; @@ -1384,7 +1404,11 @@ S_run_body(pTHX_ I32 oldscope) PTR2UV(thr))); if (PL_minus_c) { +#ifdef MACOS_TRADITIONAL + PerlIO_printf(Perl_error_log, "%s syntax OK\n", MacPerl_MPWFileName(PL_origfilename)); +#else PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); +#endif my_exit(0); } if (PERLDB_SINGLE && PL_DBsingle) @@ -1633,7 +1657,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) method_op.op_next = PL_op; method_op.op_ppaddr = PL_ppaddr[OP_METHOD]; myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; - PL_op = &method_op; + PL_op = (OP*)&method_op; } if (!(flags & G_EVAL)) { @@ -2177,6 +2201,9 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 'u': +#ifdef MACOS_TRADITIONAL + Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh"); +#endif PL_do_undump = TRUE; s++; return s; @@ -2982,9 +3009,30 @@ S_find_beginning(pTHX) /* skip forward in input to the real script? */ forbid_setid("-x"); +#ifdef MACOS_TRADITIONAL + /* Since the Mac OS does not honor !# arguments for us, we do it ourselves */ + + while (PL_doextract || gMacPerl_AlwaysExtract) { + if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) { + if (!gMacPerl_AlwaysExtract) + Perl_croak(aTHX_ "No Perl script found in input\n"); + + if (PL_doextract) /* require explicit override ? */ + if (!OverrideExtract(PL_origfilename)) + Perl_croak(aTHX_ "User aborted script\n"); + else + PL_doextract = FALSE; + + /* Pater peccavi, file does not have #! */ + PerlIO_rewind(PL_rsfp); + + break; + } +#else while (PL_doextract) { if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) Perl_croak(aTHX_ "No Perl script found in input\n"); +#endif if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) { PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */ PL_doextract = FALSE; @@ -3166,8 +3214,9 @@ S_init_predump_symbols(pTHX) PL_statname = NEWSV(66,0); /* last filename we did stat on */ - if (!PL_osname) - PL_osname = savepv(OSNAME); + if (PL_osname) + Safefree(PL_osname); + PL_osname = savepv(OSNAME); } STATIC void @@ -3205,12 +3254,17 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register TAINT; if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) { +#ifdef MACOS_TRADITIONAL + /* $0 is not majick on a Mac */ + sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename)); +#else sv_setpv(GvSV(tmpgv),PL_origfilename); magicname("0", "0", 1); +#endif } if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) #ifdef OS2 - sv_setpv(GvSV(tmpgv), os2_execname()); + sv_setpv(GvSV(tmpgv), os2_execname(aTHX)); #else sv_setpv(GvSV(tmpgv),PL_origargv[0]); #endif @@ -3230,7 +3284,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register GvMULTI_on(PL_envgv); hv = GvHVn(PL_envgv); hv_magic(hv, PL_envgv, 'E'); -#if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */ +#if !defined( VMS) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) /* VMS doesn't have environ array */ /* Note that if the supplied env parameter is actually a copy of the global environ then it may now point to free'd memory if the environment has been modified since. To avoid this @@ -3300,6 +3354,27 @@ S_init_perllib(pTHX) #ifdef ARCHLIB_EXP incpush(ARCHLIB_EXP, FALSE, FALSE); #endif +#ifdef MACOS_TRADITIONAL + { + struct stat tmpstatbuf; + SV * privdir = NEWSV(55, 0); + char * macperl = PerlEnv_getenv("MACPERL"); + + if (!macperl) + macperl = ""; + + Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl); + if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) + incpush(SvPVX(privdir), TRUE, FALSE); + Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl); + if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) + incpush(SvPVX(privdir), TRUE, FALSE); + + SvREFCNT_dec(privdir); + } + if (!PL_tainting) + incpush(":", FALSE, FALSE); +#else #ifndef PRIVLIB_EXP # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" #endif @@ -3355,6 +3430,7 @@ S_init_perllib(pTHX) if (!PL_tainting) incpush(".", FALSE, FALSE); +#endif /* MACOS_TRADITIONAL */ } #if defined(DOSISH) @@ -3363,7 +3439,11 @@ S_init_perllib(pTHX) # if defined(VMS) # define PERLLIB_SEP '|' # else -# define PERLLIB_SEP ':' +# if defined(MACOS_TRADITIONAL) +# define PERLLIB_SEP ',' +# else +# define PERLLIB_SEP ':' +# endif # endif #endif #ifndef PERLLIB_MANGLE @@ -3403,6 +3483,12 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) sv_setpv(libdir, PERLLIB_MANGLE(p, 0)); p = Nullch; /* break out */ } +#ifdef MACOS_TRADITIONAL + if (!strchr(SvPVX(libdir), ':')) + sv_insert(libdir, 0, 0, ":", 1); + if (SvPVX(libdir)[SvCUR(libdir)-1] != ':') + sv_catpv(libdir, ":"); +#endif /* * BEFORE pushing libdir onto @INC we may first push version- and @@ -3430,8 +3516,15 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) SvPV(libdir,len)); #endif if (addsubdirs) { +#ifdef MACOS_TRADITIONAL +#define PERL_AV_SUFFIX_FMT "" +#define PERL_ARCH_FMT ":%s" +#else +#define PERL_AV_SUFFIX_FMT "/" +#define PERL_ARCH_FMT "/%s" +#endif /* .../version/archname if -d .../version/archname */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT PERL_ARCH_FMT, libdir, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION, ARCHNAME); @@ -3440,7 +3533,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) av_push(GvAVn(PL_incgv), newSVsv(subdir)); /* .../version if -d .../version */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir, + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT, libdir, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION); if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && @@ -3448,7 +3541,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) av_push(GvAVn(PL_incgv), newSVsv(subdir)); /* .../archname if -d .../archname */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME); + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME); if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) av_push(GvAVn(PL_incgv), newSVsv(subdir)); @@ -3458,7 +3551,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) if (addoldvers) { for (incver = incverlist; *incver; incver++) { /* .../xxx if -d .../xxx */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver); + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver); if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) av_push(GvAVn(PL_incgv), newSVsv(subdir)); diff --git a/perlsfio.h b/perlsfio.h index c4ed5c7650..00568d1d59 100644 --- a/perlsfio.h +++ b/perlsfio.h @@ -49,7 +49,7 @@ extern int _stdprintf _ARG_((const char*, ...)); #define PerlIO_get_cnt(f) ((f)->endr - (f)->next) #define PerlIO_canset_cnt(f) 1 #define PerlIO_fast_gets(f) 1 -#define PerlIO_set_ptrcnt(f,p,c) ((f)->next = (p)) +#define PerlIO_set_ptrcnt(f,p,c) ((f)->next = (unsigned char *)(p)) #define PerlIO_set_cnt(f,c) 1 #define PerlIO_has_base(f) 1 diff --git a/pod/perlfaq4.pod b/pod/perlfaq4.pod index e997a8fcb9..ecbd65243e 100644 --- a/pod/perlfaq4.pod +++ b/pod/perlfaq4.pod @@ -1746,7 +1746,7 @@ if you just want to say, ``Is this a float?'' Or you could check out the String::Scanf module on CPAN instead. The POSIX module (part of the standard Perl distribution) provides the -C<strtol> and C<strtod> for converting strings to double and longs, +C<strtod> and C<strtol> for converting strings to double and longs, respectively. =head2 How do I keep persistent data across program calls? diff --git a/pod/perlrequick.pod b/pod/perlrequick.pod index d151e26a0c..a14229c303 100644 --- a/pod/perlrequick.pod +++ b/pod/perlrequick.pod @@ -5,22 +5,23 @@ perlrequick - Perl regular expressions quick start =head1 DESCRIPTION This page covers the very basics of understanding, creating and -using regular expressions ('regexps') in Perl. +using regular expressions ('regexes') in Perl. + =head1 The Guide =head2 Simple word matching -The simplest regexp is simply a word, or more generally, a string of -characters. A regexp consisting of a word matches any string that +The simplest regex is simply a word, or more generally, a string of +characters. A regex consisting of a word matches any string that contains that word: "Hello World" =~ /World/; # matches -In this statement, C<World> is a regexp and the C<//> enclosing +In this statement, C<World> is a regex and the C<//> enclosing C</World/> tells perl to search a string for a match. The operator -C<=~> associates the string with the regexp match and produces a true -value if the regexp matched, or false if the regexp did not match. In +C<=~> associates the string with the regex match and produces a true +value if the regex matched, or false if the regex did not match. In our case, C<World> matches the second word in C<"Hello World">, so the expression is true. This idea has several variations. @@ -32,7 +33,7 @@ The sense of the match can be reversed by using C<!~> operator: print "It doesn't match\n" if "Hello World" !~ /World/; -The literal string in the regexp can be replaced by a variable: +The literal string in the regex can be replaced by a variable: $greeting = "World"; print "It matches\n" if "Hello World" =~ /$greeting/; @@ -50,7 +51,7 @@ arbitrary delimiters by putting an C<'m'> out front: "/usr/bin/perl" =~ m"/perl"; # matches after '/usr/bin', # '/' becomes an ordinary char -Regexps must match a part of the string I<exactly> in order for the +Regexes must match a part of the string I<exactly> in order for the statement to be true: "Hello World" =~ /world/; # doesn't match, case sensitive @@ -63,7 +64,7 @@ perl will always match at the earliest possible point in the string: "That hat is red" =~ /hat/; # matches 'hat' in 'That' Not all characters can be used 'as is' in a match. Some characters, -called B<metacharacters>, are reserved for use in regexp notation. +called B<metacharacters>, are reserved for use in regex notation. The metacharacters are {}[]()^$.|*+?\ @@ -75,8 +76,8 @@ A metacharacter can be matched by putting a backslash before it: 'C:\WIN32' =~ /C:\\WIN/; # matches "/usr/bin/perl" =~ /\/usr\/local\/bin\/perl/; # matches -In the last regexp, the forward slash C<'/'> is also backslashed, -because it is used to delimit the regexp. +In the last regex, the forward slash C<'/'> is also backslashed, +because it is used to delimit the regex. Non-printable ASCII characters are represented by B<escape sequences>. Common examples are C<\t> for a tab, C<\n> for a newline, and C<\r> @@ -87,38 +88,39 @@ e.g., C<\x1B>: "1000\t2000" =~ m(0\t2) # matches "cat" =~ /\143\x61\x74/ # matches, but a weird way to spell cat -Regexps are treated mostly as double quoted strings, so variable +Regexes are treated mostly as double quoted strings, so variable substitution works: $foo = 'house'; 'cathouse' =~ /cat$foo/; # matches 'housecat' =~ /${foo}cat/; # matches -With all of the regexps above, if the regexp matched anywhere in the +With all of the regexes above, if the regex matched anywhere in the string, it was considered a match. To specify I<where> it should match, we would use the B<anchor> metacharacters C<^> and C<$>. The anchor C<^> means match at the beginning of the string and the anchor C<$> means match at the end of the string, or before a newline at the end of the string. Some examples: - "housekeeper" =~ /keeper/; # matches - "housekeeper" =~ /^keeper/; # doesn't match - "housekeeper" =~ /keeper$/; # matches - "housekeeper\n" =~ /keeper$/; # matches + "housekeeper" =~ /keeper/; # matches + "housekeeper" =~ /^keeper/; # doesn't match + "housekeeper" =~ /keeper$/; # matches + "housekeeper\n" =~ /keeper$/; # matches + "housekeeper" =~ /^housekeeper$/; # matches =head2 Using character classes A B<character class> allows a set of possible characters, rather than -just a single character, to match at a particular point in a regexp. +just a single character, to match at a particular point in a regex. Character classes are denoted by brackets C<[...]>, with the set of characters to be possibly matched inside. Here are some examples: /cat/; # matches 'cat' - /[bcr]at/; # matches 'bat, 'cat', or 'rat' + /[bcr]at/; # matches 'bat', 'cat', or 'rat' "abc" =~ /[cab]/; # matches 'a' In the last statement, even though C<'c'> is the first character in -the class, the earliest point at which the regexp can match is C<'a'>. +the class, the earliest point at which the regex can match is C<'a'>. /[yY][eE][sS]/; # match 'yes' in a case-insensitive way # 'yes', 'Yes', 'YES', etc. @@ -151,7 +153,7 @@ treated as an ordinary character. The special character C<^> in the first position of a character class denotes a B<negated character class>, which matches any character but -those in the bracket. Both C<[...]> and C<[^...]> must match a +those in the brackets. Both C<[...]> and C<[^...]> must match a character, or the match fails. Then /[^a]at/; # doesn't match 'aat' or 'at', but matches @@ -211,8 +213,8 @@ boundary. =head2 Matching this or that We can match match different character strings with the B<alternation> -metacharacter C<'|'>. To match C<dog> or C<cat>, we form the regexp -C<dog|cat>. As before, perl will try to match the regexp at the +metacharacter C<'|'>. To match C<dog> or C<cat>, we form the regex +C<dog|cat>. As before, perl will try to match the regex at the earliest possible point in the string. At each character position, perl will first try to match the the first alternative, C<dog>. If C<dog> doesn't match, perl will then try the next alternative, C<cat>. @@ -222,21 +224,21 @@ the next position in the string. Some examples: "cats and dogs" =~ /cat|dog|bird/; # matches "cat" "cats and dogs" =~ /dog|cat|bird/; # matches "cat" -Even though C<dog> is the first alternative in the second regexp, +Even though C<dog> is the first alternative in the second regex, C<cat> is able to match earlier in the string. "cats" =~ /c|ca|cat|cats/; # matches "c" "cats" =~ /cats|cat|ca|c/; # matches "cats" At a given character position, the first alternative that allows the -regexp match to succeed wil be the one that matches. Here, all the +regex match to succeed wil be the one that matches. Here, all the alternatives match at the first string position, so th first matches. =head2 Grouping things and hierarchical matching -The B<grouping> metacharacters C<()> allow a part of a regexp to be -treated as a single unit. Parts of a regexp are grouped by enclosing -them in parentheses. The regexp C<house(cat|keeper)> means match +The B<grouping> metacharacters C<()> allow a part of a regex to be +treated as a single unit. Parts of a regex are grouped by enclosing +them in parentheses. The regex C<house(cat|keeper)> means match C<house> followed by either C<cat> or C<keeper>. Some more examples are @@ -263,14 +265,14 @@ They can be used just as ordinary variables: $minutes = $2; $seconds = $3; -In list context, a match C</regexp/ with groupings will return the +In list context, a match C</regex/> with groupings will return the list of matched values C<($1,$2,...)>. So we could rewrite it as ($hours, $minutes, $second) = ($time =~ /(\d\d):(\d\d):(\d\d)/); -If the groupings in a regexp are nested, C<$1> gets the group with the +If the groupings in a regex are nested, C<$1> gets the group with the leftmost opening parenthesis, C<$2> the next opening parenthesis, -etc. For example, here is a complex regexp and the matching variables +etc. For example, here is a complex regex and the matching variables indicated below it: /(ab(cd|ef)((gi)|j))/; @@ -278,17 +280,17 @@ indicated below it: Associated with the matching variables C<$1>, C<$2>, ... are the B<backreferences> C<\1>, C<\2>, ... Backreferences are -matching variables that can be used I<inside> a regexp: +matching variables that can be used I<inside> a regex: /(\w\w\w)\s\1/; # find sequences like 'the the' in string -C<$1>, C<$2>, ... should only be used outside of a regexp, and C<\1>, -C<\2>, ... only inside a regexp. +C<$1>, C<$2>, ... should only be used outside of a regex, and C<\1>, +C<\2>, ... only inside a regex. =head2 Matching repetitions The B<quantifier> metacharacters C<?>, C<*>, C<+>, and C<{}> allow us -to determine the number of repeats of a portion of a regexp we +to determine the number of repeats of a portion of a regex we consider to be a match. Quantifiers are put immediately after the character, character class, or grouping that we want to specify. They have the following meanings: @@ -320,15 +322,16 @@ Here are some examples: $year =~ /\d{4}|\d{2}/; # better match; throw out 3 digit dates These quantifiers will try to match as much of the string as possible, -while still allowing the regexp to match. So we have +while still allowing the regex to match. So we have + $x = 'the cat in the hat'; $x =~ /^(.*)(at)(.*)$/; # matches, # $1 = 'the cat in the h' # $2 = 'at' # $3 = '' (0 matches) The first quantifier C<.*> grabs as much of the string as possible -while still having the regexp match. The second quantifier C<.*> has +while still having the regex match. The second quantifier C<.*> has no string left to it, so it matches 0 times. =head2 More matching @@ -369,10 +372,10 @@ prints A failed match or changing the target string resets the position. If you don't want the position reset after failure to match, add the -C<//c>, as in C</regexp/gc>. +C<//c>, as in C</regex/gc>. In list context, C<//g> returns a list of matched groupings, or if -there are no groupings, a list of matches to the whole regexp. So +there are no groupings, a list of matches to the whole regex. So @words = ($x =~ /(\w+)/g); # matches, # $word[0] = 'cat' @@ -381,9 +384,9 @@ there are no groupings, a list of matches to the whole regexp. So =head2 Search and replace -Search and replace is perform using C<s/regexp/replacement/modifiers>. +Search and replace is performed using C<s/regex/replacement/modifiers>. The C<replacement> is a Perl double quoted string that replaces in the -string whatever is matched with the C<regexp>. The operator C<=~> is +string whatever is matched with the C<regex>. The operator C<=~> is also used here to associate a string with C<s///>. If matching against C<$_>, the S<C<$_ =~> > can be dropped. If there is a match, C<s///> returns the number of substitutions made, otherwise it returns @@ -398,7 +401,7 @@ false. Here are a few examples: With the C<s///> operator, the matched variables C<$1>, C<$2>, etc. are immediately available for use in the replacement expression. With the global modifier, C<s///g> will search and replace all occurrences -of the regexp in the string: +of the regex in the string: $x = "I batted 4 for 4"; $x =~ s/4/four/; # $x contains "I batted four for 4" @@ -407,40 +410,42 @@ of the regexp in the string: The evaluation modifier C<s///e> wraps an C<eval{...}> around the replacement string and the evaluated result is substituted for the -matched substring. This counts character frequencies in a line: - - $x = "the cat"; - $x =~ s/(.)/$chars{$1}++;$1/eg; # final $1 replaces char with itself - print "frequency of '$_' is $chars{$_}\n" - foreach (sort {$chars{$b} <=> $chars{$a}} keys %chars); +matched substring. Some examples: -This prints + # reverse all the words in a string + $x = "the cat in the hat"; + $x =~ s/(\w+)/reverse $1/ge; # $x contains "eht tac ni eht tah" - frequency of 't' is 2 - frequency of 'e' is 1 - frequency of ' ' is 1 - frequency of 'h' is 1 - frequency of 'a' is 1 - frequency of 'c' is 1 + # convert percentage to decimal + $x = "A 39% hit rate"; + $x =~ s!(\d+)%!$1/100!e; # $x contains "A 0.39 hit rate" -C<s///> can use other delimiters, such as C<s!!!> and C<s{}{}>, and -even C<s{}//>. If single quotes are used C<s'''>, then the regexp and -replacement are treated as single quoted strings. +The last example shows that C<s///> can use other delimiters, such as +C<s!!!> and C<s{}{}>, and even C<s{}//>. If single quotes are used +C<s'''>, then the regex and replacement are treated as single quoted +strings. =head2 The split operator -C<split /regexp/, string> splits C<string> into a list of substrings -and returns that list. The regexp determines the character sequence +C<split /regex/, string> splits C<string> into a list of substrings +and returns that list. The regex determines the character sequence that C<string> is split with respect to. For example, to split a string into words, use $x = "Calvin and Hobbes"; - @words = split /\s+/, $x; # $word[0] = 'Calvin' - # $word[1] = 'and' - # $word[2] = 'Hobbes' + @word = split /\s+/, $x; # $word[0] = 'Calvin' + # $word[1] = 'and' + # $word[2] = 'Hobbes' + +To extract a comma-delimited list of numbers, use -If the empty regexp C<//> is used, the string is split into individual -characters. If the regexp has groupings, then list produced contains + $x = "1.618,2.718, 3.142"; + @const = split /,\s*/, $x; # $const[0] = '1.618' + # $const[1] = '2.718' + # $const[2] = '3.142' + +If the empty regex C<//> is used, the string is split into individual +characters. If the regex has groupings, then list produced contains the matched substrings from the groupings as well: $x = "/usr/bin"; @@ -450,7 +455,7 @@ the matched substrings from the groupings as well: # $parts[3] = '/' # $parts[4] = 'bin' -Since the first character of $x matched the regexp, C<split> prepended +Since the first character of $x matched the regex, C<split> prepended an empty initial element to the list. =head1 BUGS @@ -460,7 +465,7 @@ None. =head1 SEE ALSO This is just a quick start guide. For a more in-depth tutorial on -regexps, see L<perlretut> and for the reference page, see L<perlre>. +regexes, see L<perlretut> and for the reference page, see L<perlre>. =head1 AUTHOR AND COPYRIGHT @@ -469,5 +474,11 @@ All rights reserved. This document may be distributed under the same terms as Perl itself. +=head2 Acknowledgments + +The author would like to thank Mark-Jason Dominus, Tom Christiansen, +Ilya Zakharevich, Brad Hughes, and Mike Giroux for all their helpful +comments. + =cut @@ -2996,8 +2996,19 @@ PP(pp_require) { tryname = name; tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE); +#ifdef MACOS_TRADITIONAL + /* We consider paths of the form :a:b ambiguous and interpret them first + as global then as local + */ + if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':')) + goto trylocal; + } + else +trylocal: { +#else } else { +#endif AV *ar = GvAVn(PL_incgv); I32 i; #ifdef VMS @@ -3115,6 +3126,10 @@ PP(pp_require) } else { char *dir = SvPVx(dirsv, n_a); +#ifdef MACOS_TRADITIONAL + /* We have ensured in incpush that library ends with ':' */ + Perl_sv_setpvf(aTHX_ namesv, "%s%s", dir, name+(name[0] == ':')); +#else #ifdef VMS char *unixdir; if ((unixdir = tounixpath(dir, Nullch)) == Nullch) @@ -3124,8 +3139,17 @@ PP(pp_require) #else Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); #endif +#endif TAINT_PROPER("require"); tryname = SvPVX(namesv); +#ifdef MACOS_TRADITIONAL + { + /* Convert slashes in the name part, but not the directory part, to colons */ + char * colon; + for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); ) + *colon++ = ':'; + } +#endif tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE); if (tryrsfp) { if (tryname[0] == '.' && tryname[1] == '/') @@ -280,7 +280,7 @@ PERL_CALLCONV char* Perl_vform(pTHX_ const char* pat, va_list* args); PERL_CALLCONV void Perl_free_tmps(pTHX); PERL_CALLCONV OP* Perl_gen_constant_list(pTHX_ OP* o); #if !defined(HAS_GETENV_LEN) -PERL_CALLCONV char* Perl_getenv_len(pTHX_ char* key, unsigned long *len); +PERL_CALLCONV char* Perl_getenv_len(pTHX_ const char* key, unsigned long *len); #endif PERL_CALLCONV void Perl_gp_free(pTHX_ GV* gv); PERL_CALLCONV GP* Perl_gp_ref(pTHX_ GP* gp); @@ -599,9 +599,10 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, find_anchor: while (t < strend - prog->minlen) { if (*t == '\n') { - if (t < s - prog->check_offset_min) { + if (t < check_at - prog->check_offset_min) { if (prog->anchored_substr) { - /* We definitely contradict the found anchored + /* Since we moved from the found position, + we definitely contradict the found anchored substr. Due to the above check we do not contradict "check" substr. Thus we can arrive here only if check substr @@ -612,12 +613,17 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, PL_colors[0],PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset))); goto do_other_anchored; } + /* We don't contradict the found floating substring. */ + /* XXXX Why not check for STCLASS? */ s = t + 1; DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n", PL_colors[0],PL_colors[1], (long)(s - i_strpos))); goto set_useful; } - DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting at offset %ld...\n", + /* Position contradicts check-string */ + /* XXXX probably better to look for check-string + than for "\n", so one should lower the limit for t? */ + DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n", PL_colors[0],PL_colors[1], (long)(t + 1 - i_strpos))); strpos = s = t + 1; goto restart; @@ -628,15 +634,20 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, PL_colors[0],PL_colors[1])); goto fail_finish; } + else { + DEBUG_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n", + PL_colors[0],PL_colors[1])); + } s = t; set_useful: ++BmUSEFUL(prog->check_substr); /* hooray/5 */ } else { PL_bostr = tmp; - /* The found string does not prohibit matching at beg-of-str + /* The found string does not prohibit matching at strpos, - no optimization of calling REx engine can be performed, - unless it was an MBOL and we are not after MBOL. */ + unless it was an MBOL and we are not after MBOL, + or a future STCLASS check will fail this. */ try_at_start: /* Even in this situation we may use MBOL flag if strpos is offset wrt the start of the string. */ @@ -649,8 +660,8 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, goto find_anchor; } DEBUG_r( if (ml_anch) - PerlIO_printf(Perl_debug_log, "Does not contradict /%s^%s/m...\n", - PL_colors[0],PL_colors[1]); + PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n", + (long)(strpos - i_strpos), PL_colors[0],PL_colors[1]); ); success_at_start: if (!(prog->reganch & ROPT_NAUGHTY) /* XXXX If strpos moved? */ @@ -659,6 +670,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, && prog->check_substr == prog->float_substr) { /* If flags & SOMETHING - do not do it many times on the same match */ + DEBUG_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n")); SvREFCNT_dec(prog->check_substr); prog->check_substr = Nullsv; /* disable */ prog->float_substr = Nullsv; /* clear */ @@ -725,7 +737,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, goto fail; } DEBUG_r( PerlIO_printf(Perl_debug_log, - "Trying %s substr starting at offset %ld...\n", + "Looking for %s substr starting at offset %ld...\n", what, (long)(s + start_shift - i_strpos)) ); goto restart; } @@ -735,7 +747,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, /* Recheck anchored substring, but not floating... */ s = check_at; DEBUG_r( PerlIO_printf(Perl_debug_log, - "Trying anchored substr starting at offset %ld...\n", + "Looking for anchored substr starting at offset %ld...\n", (long)(other_last - i_strpos)) ); goto do_other_anchored; } @@ -744,8 +756,8 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, if (ml_anch) { s = t = t + 1; DEBUG_r( PerlIO_printf(Perl_debug_log, - "Trying /^/m starting at offset %ld...\n", - (long)(t - i_strpos)) ); + "Looking for /%s^%s/m starting at offset %ld...\n", + PL_colors[0],PL_colors[1], (long)(t - i_strpos)) ); goto try_at_offset; } if (!prog->float_substr) /* Could have been deleted */ diff --git a/t/lib/filefind.t b/t/lib/filefind.t index e9a2916738..b4615cc6bb 100755 --- a/t/lib/filefind.t +++ b/t/lib/filefind.t @@ -57,8 +57,10 @@ sub wanted { print "# '$_' => 1\n"; s#\.$## if ($^O eq 'VMS' && $_ ne '.'); Check( $Expect{$_} ); - delete $Expect{$_}; + delete $Expect{$_} + unless ( $Expect_Dir{$_} && ! -d _ ); $File::Find::prune=1 if $_ eq 'faba'; + } sub dn_wanted { @@ -106,6 +108,9 @@ touch('fa/fab/faba/faba_ord'); %Expect = ('.' => 1, 'fsl' => 1, 'fa_ord' => 1, 'fab' => 1, 'fab_ord' => 1, 'faba' => 1, 'faa' => 1, 'faa_ord' => 1); delete $Expect{'fsl'} unless $symlink_exists; +%Expect_Dir = ('fa' => 1, 'faa' => 1, 'fab' => 1, 'faba' => 1, + 'fb' => 1, 'fba' => 1); +delete @Expect_Dir{'fb','fba'} unless $symlink_exists; File::Find::find( {wanted => \&wanted, },'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -113,6 +118,9 @@ Check( scalar(keys %Expect) == 0 ); 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); delete $Expect{'fa/fsl'} unless $symlink_exists; +%Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); +delete @Expect_Dir{'fb','fb/fba'} unless $symlink_exists; File::Find::find( {wanted => \&wanted, no_chdir => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -122,6 +130,9 @@ Check( scalar(keys %Expect) == 0 ); './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); delete $Expect{'./fa/fsl'} unless $symlink_exists; +%Expect_Dir = ('./fa' => 1, './fa/faa' => 1, '/fa/fab' => 1, './fa/fab/faba' => 1, + './fb' => 1, './fb/fba' => 1); +delete @Expect_Dir{'./fb','./fb/fba'} unless $symlink_exists; File::Find::finddepth( {wanted => \&dn_wanted },'.' ); Check( scalar(keys %Expect) == 0 ); @@ -130,6 +141,9 @@ Check( scalar(keys %Expect) == 0 ); './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); delete $Expect{'./fa/fsl'} unless $symlink_exists; +%Expect_Dir = ('./fa' => 1, './fa/faa' => 1, '/fa/fab' => 1, './fa/fab/faba' => 1, + './fb' => 1, './fb/fba' => 1); +delete @Expect_Dir{'./fb','./fb/fba'} unless $symlink_exists; File::Find::finddepth( {wanted => \&d_wanted, no_chdir => 1 },'.' ); Check( scalar(keys %Expect) == 0 ); @@ -137,6 +151,8 @@ if ( $symlink_exists ) { %Expect=('.' => 1, 'fa_ord' => 1, 'fsl' => 1, 'fb_ord' => 1, 'fba' => 1, 'fba_ord' => 1, 'fab' => 1, 'fab_ord' => 1, 'faba' => 1, 'faa' => 1, 'faa_ord' => 1); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::find( {wanted => \&wanted, follow_fast => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -145,6 +161,8 @@ if ( $symlink_exists ) { 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::find( {wanted => \&wanted, follow_fast => 1, no_chdir => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -152,6 +170,8 @@ if ( $symlink_exists ) { 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::finddepth( {wanted => \&dn_wanted, follow_fast => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -160,6 +180,8 @@ if ( $symlink_exists ) { 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::finddepth( {wanted => \&d_wanted, follow_fast => 1, no_chdir => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -39,6 +39,13 @@ static void restore_rsfp(pTHXo_ void *f); * 1999-02-27 mjd-perl-patch@plover.com */ #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x))) +/* On MacOS, respect nonbreaking spaces */ +#ifdef MACOS_TRADITIONAL +#define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t') +#else +#define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t') +#endif + /* LEX_* are values for PL_lex_state, the state of the lexer. * They are arranged oddly so that the guard on the switch statement * can get by with a single comparison (if the compiler is smart enough). @@ -463,7 +470,7 @@ S_incline(pTHX_ char *s) CopLINE_inc(PL_curcop); if (*s++ != '#') return; - while (*s == ' ' || *s == '\t') s++; + while (SPACE_OR_TAB(*s)) s++; if (strnEQ(s, "line", 4)) s += 4; else @@ -472,13 +479,13 @@ S_incline(pTHX_ char *s) s++; else return; - while (*s == ' ' || *s == '\t') s++; + while (SPACE_OR_TAB(*s)) s++; if (!isDIGIT(*s)) return; n = s; while (isDIGIT(*s)) s++; - while (*s == ' ' || *s == '\t') + while (SPACE_OR_TAB(*s)) s++; if (*s == '"' && (t = strchr(s+1, '"'))) { s++; @@ -488,7 +495,7 @@ S_incline(pTHX_ char *s) for (t = s; !isSPACE(*t); t++) ; e = t; } - while (*e == ' ' || *e == '\t' || *e == '\r' || *e == '\f') + while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f') e++; if (*e != '\n' && *e != '\0') return; /* false alarm */ @@ -512,7 +519,7 @@ S_skipspace(pTHX_ register char *s) { dTHR; if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { - while (s < PL_bufend && (*s == ' ' || *s == '\t')) + while (s < PL_bufend && SPACE_OR_TAB(*s)) s++; return s; } @@ -2024,6 +2031,9 @@ S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) if we already built the token before, use it. */ +#ifdef __SC__ +#pragma segment Perl_yylex +#endif int #ifdef USE_PURE_BISON Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp) @@ -2584,6 +2594,7 @@ Perl_yylex(pTHX) *s = '#'; /* Don't try to parse shebang line */ } #endif /* ALTERNATE_SHEBANG */ +#ifndef MACOS_TRADITIONAL if (!d && *s == '#' && ipathend > ipath && @@ -2611,13 +2622,14 @@ Perl_yylex(pTHX) PerlProc_execv(ipath, newargv); Perl_croak(aTHX_ "Can't exec %s", ipath); } +#endif if (d) { U32 oldpdb = PL_perldb; bool oldn = PL_minus_n; bool oldp = PL_minus_p; while (*d && !isSPACE(*d)) d++; - while (*d == ' ' || *d == '\t') d++; + while (SPACE_OR_TAB(*d)) d++; if (*d++ == '-') { do { @@ -2659,6 +2671,9 @@ Perl_yylex(pTHX) "\t(Maybe you didn't strip carriage returns after a network transfer?)\n"); #endif case ' ': case '\t': case '\f': case 013: +#ifdef MACOS_TRADITIONAL + case '\312': +#endif s++; goto retry; case '#': @@ -2692,7 +2707,7 @@ Perl_yylex(pTHX) PL_bufptr = s; tmp = *s++; - while (s < PL_bufend && (*s == ' ' || *s == '\t')) + while (s < PL_bufend && SPACE_OR_TAB(*s)) s++; if (strnEQ(s,"=>",2)) { @@ -2976,20 +2991,20 @@ Perl_yylex(pTHX) PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; OPERATOR(HASHBRACK); case XOPERATOR: - while (s < PL_bufend && (*s == ' ' || *s == '\t')) + while (s < PL_bufend && SPACE_OR_TAB(*s)) s++; d = s; PL_tokenbuf[0] = '\0'; if (d < PL_bufend && *d == '-') { PL_tokenbuf[0] = '-'; d++; - while (d < PL_bufend && (*d == ' ' || *d == '\t')) + while (d < PL_bufend && SPACE_OR_TAB(*d)) d++; } if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) { d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE, &len); - while (d < PL_bufend && (*d == ' ' || *d == '\t')) + while (d < PL_bufend && SPACE_OR_TAB(*d)) d++; if (*d == '}') { char minus = (PL_tokenbuf[0] == '-'); @@ -3206,9 +3221,9 @@ Perl_yylex(pTHX) if (PL_lex_brackets < PL_lex_formbrack) { char *t; #ifdef PERL_STRICT_CR - for (t = s; *t == ' ' || *t == '\t'; t++) ; + for (t = s; SPACE_OR_TAB(*t); t++) ; #else - for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ; + for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ; #endif if (*t == '\n' || *t == '#') { s--; @@ -3802,7 +3817,7 @@ Perl_yylex(pTHX) if (*s == '(') { CLINE; if (gv && GvCVu(gv)) { - for (d = s + 1; *d == ' ' || *d == '\t'; d++) ; + for (d = s + 1; SPACE_OR_TAB(*d); d++) ; if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) { s = d + 1; goto its_constant; @@ -4996,6 +5011,9 @@ Perl_yylex(pTHX) } }} } +#ifdef __SC__ +#pragma segment Main +#endif I32 Perl_keyword(pTHX_ register char *d, I32 len) @@ -5869,7 +5887,7 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des if (isSPACE(s[-1])) { while (s < send) { char ch = *s++; - if (ch != ' ' && ch != '\t') { + if (!SPACE_OR_TAB(ch)) { *d = ch; break; } @@ -5895,7 +5913,7 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des Perl_croak(aTHX_ ident_too_long); } *d = '\0'; - while (s < send && (*s == ' ' || *s == '\t')) s++; + while (s < send && SPACE_OR_TAB(*s)) s++; if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { dTHR; /* only for ckWARN */ if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) { @@ -6169,7 +6187,7 @@ S_scan_heredoc(pTHX_ register char *s) e = PL_tokenbuf + sizeof PL_tokenbuf - 1; if (!outer) *d++ = '\n'; - for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ; + for (peek = s; SPACE_OR_TAB(*peek); peek++) ; if (*peek && strchr("`'\"",*peek)) { s = peek; term = *s++; @@ -7134,9 +7152,9 @@ S_scan_formline(pTHX_ register char *s) if (*s == '.' || *s == '}') { /*SUPPRESS 530*/ #ifdef PERL_STRICT_CR - for (t = s+1;*t == ' ' || *t == '\t'; t++) ; + for (t = s+1;SPACE_OR_TAB(*t); t++) ; #else - for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ; + for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ; #endif if (*t == '\n' || t == PL_bufend) break; @@ -2319,7 +2319,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) PERL_FLUSHALL_FOR_CHILD; #ifdef OS2 if (doexec) { - return my_syspopen(cmd,mode); + return my_syspopen(aTHX_ cmd,mode); } #endif This = (*mode == 'w'); @@ -3666,7 +3666,7 @@ Perl_get_ppaddr(pTHX) #ifndef HAS_GETENV_LEN char * -Perl_getenv_len(pTHX_ char *env_elem, unsigned long *len) +Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) { char *env_trans = PerlEnv_getenv(env_elem); if (env_trans) @@ -26,7 +26,11 @@ (*(f) == '/' \ || ((f)[0] && (f)[1] == ':')) /* drive name */ # else /* !DOSISH */ -# define PERL_FILE_IS_ABSOLUTE(f) (*(f) == '/') +# ifdef MACOS_TRADITIONAL +# define PERL_FILE_IS_ABSOLUTE(f) (strchr(f, ':')) +# else /* !MACOS_TRADITIONAL */ +# define PERL_FILE_IS_ABSOLUTE(f) (*(f) == '/') +# endif /* MACOS_TRADITIONAL */ # endif /* DOSISH */ # endif /* WIN32 */ #endif /* VMS */ diff --git a/vms/subconfigure.com b/vms/subconfigure.com index 9a3ba725e9..00fbf3fc3f 100644 --- a/vms/subconfigure.com +++ b/vms/subconfigure.com @@ -4024,6 +4024,7 @@ $ WC "subversion='" + subversion + "'" $ WC "PERL_VERSION='" + patchlevel + "'" $ WC "PERL_SUBVERSION='" + subversion + "'" $ WC "pager='" + perl_pager + "'" +$ WC "make='" + make + "'" $ WC "uidtype='" + perl_uidtype + "'" $ WC "uidformat='" + perl_uidformat + "'" $ WC "uidsize='" + perl_uidsize + "'" diff --git a/warnings.pl b/warnings.pl index 791beed353..0e74f3de90 100644 --- a/warnings.pl +++ b/warnings.pl @@ -382,7 +382,7 @@ will be used. =back -See L<perlmod/Pragmatic Modules> and L<perllexwarn>. +See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>. =cut @@ -121,6 +121,7 @@ #ifdef DOSISH # if defined(OS2) +# define PTHX_UNUSED # include "../os2ish.h" # else # include "../dosish.h" |