This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate with Sarathy.
authorJarkko Hietaniemi <jhi@iki.fi>
Sun, 27 Feb 2000 18:57:12 +0000 (18:57 +0000)
committerJarkko Hietaniemi <jhi@iki.fi>
Sun, 27 Feb 2000 18:57:12 +0000 (18:57 +0000)
p4raw-id: //depot/cfgperl@5291

21 files changed:
README.dos
djgpp/config.over
djgpp/configure.bat
djgpp/djgpp.c
ext/File/Glob/Glob.pm
hints/dos_djgpp.sh
lib/File/Spec/OS2.pm
lib/File/Spec/Unix.pm
lib/File/Spec/VMS.pm
lib/File/Spec/Win32.pm
op.c
pod/perldelta.pod
pod/perlfaq5.pod
pod/perlfunc.pod
pod/perlop.pod
pod/perlsec.pod
pod/perltodo.pod
pp_sys.c
sv.c
vms/perlvms.pod
vms/vms.c

index 95ab911..e6fc8a9 100644 (file)
@@ -46,7 +46,7 @@ the world. Like:
 
 You need the following files to build perl (or add new modules):
 
-        v2/djdev201.zip
+        v2/djdev202.zip
         v2/bnu27b.zip
         v2gnu/gcc2721b.zip
         v2gnu/bsh1147b.zip
@@ -60,17 +60,11 @@ You need the following files to build perl (or add new modules):
         v2gnu/gawk303b.zip
         v2misc/csdpmi4b.zip 
 
-or any newer version.
+or possibly any newer version.
 
 =item Pthreads
 
-If you want multithreading support in perl, you need a pthread library
-that supports DJGPP. One of them can be found at:
-
-        ftp://ftp.cs.fsu.edu/pub/PART/PTHREADS/pthreads.zip
-
-But thread support is still in alpha, it may be unstable. For more information
-see below.
+Thread support is not tested in this version of the djgpp perl.
 
 =back
 
@@ -105,7 +99,7 @@ sockets
 
 =item *
 
-Unpack the source package F<perl5.00?_??.tar.gz> with djtarx. If you want
+Unpack the source package F<perl5.6*.tar.gz> with djtarx. If you want
 to use long file names under w95, don't forget to use
 
         set LFN=y
@@ -160,7 +154,7 @@ with: C<stubedit cc1.exe>).
 You can use the Configure script in non-interactive mode too.
 When I built my F<perl.exe>, I used something like this:
 
-        configure.bat -Uuseposix -des
+        configure.bat -des
 
 You can find more info about Configure's command line switches in
 the F<INSTALL> file.
@@ -191,9 +185,10 @@ Type:
 
         make test
 
-You should see "All tests successful" if you configured a database
-manager, and 1 failed test script if not (F<lib/anydbm.t>). If you
-configured POSIX you will see 1 additional failed subtest in F<lib/posix.t>.
+If you're lucky you should see "All tests successful". But there can be
+a few failed subtests (less than 5 hopefully) depending on some external
+conditions (e.g. some subtests fail under linux/dosemu or plain dos
+with short filenames only).
 
 =head2 Installation
 
@@ -206,64 +201,6 @@ directory structure. Perl.exe and the utilities go into C<($DJDIR)/bin>,
 and the library goes under C<($DJDIR)/lib/perl5>. The pod documentation
 goes under C<($DJDIR)/lib/perl5/pod>.
 
-=head2 Threaded perl under dos-djgpp
-
-Multithreading support is considered alpha, because some of the
-tests in C<ext/Thread> still die with SIGSEGV (patches are welcome). But
-if you want to give it a try, here are the necessary steps:
-
-=over 4
-
-=item
-
-1. You will need a pthread library which supports djgpp. Go, and download
-FSU's version from:
-
-      ftp://ftp.cs.fsu.edu/pub/PART/PTHREADS/pthreads.zip
-
-The latest version is 3.5, released in Feb 98.
-
-=item 
-
-2. Unzip the file, cd to C<threads\src> and run F<configur.bat>.
-
-=item 
-
-3. Add C<RAND_SWITCH> or C<MUTEX_SWITCH> or C<RR_SWITCH> to C<CFLAGS>
-in the F<makefile>. Note that using these values, multithreading will
-NOT be preemptive. This is necessary, since djgpp's libc is not thread safe.
-
-=item 
-
-4. Apply the following patch:
-
-    *** include/pthread/signal.h~      Wed Feb  4 10:51:24 1998
-    --- include/pthread/signal.h       Tue Feb 10 22:40:32 1998
-    ***************
-    *** 364,368 ****
-    --- 364,370 ----
-      
-      #ifndef SA_ONSTACK
-    + #ifdef  SV_ONSTACK
-      #define SA_ONSTACK SV_ONSTACK
-    + #endif
-      #endif /* !SA_ONSTACK */
-
-=item
-
-5. run make (before you do this, you must make sure your C<SHELL> environment 
-variable does NOT point to bash).
-
-=item
-
-6. Install the library and header files into your djgpp directory structure.
-
-=item
-
-7. Add C<-Dusethreads> to the commmand line of perl's F<configure.bat>.
-
-=back
-
 =head1 AUTHOR
 
 Laszlo Molnar, F<laszlo.molnar@eth.ericsson.se>
index 1f567b4..5c25236 100644 (file)
@@ -30,6 +30,7 @@ repair()
      -e 's=devel/peek=Devel/Peek='\
      -e 's=devel/dprof=Devel/DProf='\
      -e 's=sys/sys=Sys/Sys='\
+     -e 's=sys/hos=Sys/Hos='\
      -e 's=file/=='\
      -e 's=File/=='\
      -e 's=glob=='\
index 370f5ed..e7d41d7 100644 (file)
@@ -33,5 +33,5 @@ echo Running sed...
 sh djgpp/djgppsed.sh
 
 echo Running Configure...
-sh Configure -DPERL_EXTERNAL_GLOB %1 %2 %3 %4 %5 %6 %7 %8 %9
+sh Configure %1 %2 %3 %4 %5 %6 %7 %8 %9
 :end
index 5a8fc5f..c928851 100644 (file)
@@ -122,11 +122,9 @@ convretcode (pTHX_ int rc,char *prog,int fl)
     if (rc < 0 && ckWARN(WARN_EXEC))
         Perl_warner(aTHX_ WARN_EXEC,"Can't %s \"%s\": %s",
                    fl ? "exec" : "spawn",prog,Strerror (errno));
-    if (rc > 0)
+    if (rc >= 0)
         return rc << 8;
-    if (rc < 0)
-        return 255 << 8;
-    return 0;
+    return -1;
 }
 
 int
index 6026499..f703a0b 100644 (file)
@@ -181,7 +181,8 @@ File::Glob - Perl extension for BSD glob routine
     # an error occurred reading $homedir
   }
 
-  ## override the core glob (even with -T)
+  ## override the core glob (core glob() does this automatically
+  ## by default anyway, since v5.6.0)
   use File::Glob ':globally';
   my @sources = <*.{c,h,y}>
 
index 7c59428..478c076 100644 (file)
@@ -3,6 +3,7 @@
 
 # 971015 - archname changed from 'djgpp' to 'dos-djgpp'
 # 971210 - threads support
+# 000222 - added -DPERL_EXTERNAL_GLOB to ccflags
 
 archname='dos-djgpp'
 archobjs='djgpp.o'
@@ -39,6 +40,7 @@ case "X$optimize" in
        optimize="-O2 -malign-loops=2 -malign-jumps=2 -malign-functions=2"
        ;;
 esac
+ccflags="$ccflags -DPERL_EXTERNAL_GLOB"
 ldflags='-s'
 usemymalloc='n'
 timetype='time_t'
index 985c411..07fc867 100644 (file)
@@ -9,6 +9,10 @@ sub devnull {
     return "/dev/nul";
 }
 
+sub case_tolerant {
+    return 1;
+}
+
 sub file_name_is_absolute {
     my ($self,$file) = @_;
     return scalar($file =~ m{^([a-z]:)?[\\/]}i);
index d47a60e..db49bb0 100644 (file)
@@ -149,6 +149,17 @@ sub no_upwards {
     return grep(!/^\.{1,2}$/, @_);
 }
 
+=item case_tolerant
+
+Returns a true or false value indicating, respectively, that alphabetic
+is not or is significant when comparing file specifications.
+
+=cut
+
+sub case_tolerant {
+    return 0;
+}
+
 =item file_name_is_absolute
 
 Takes as argument a path and returns true, if it is an absolute path.
@@ -341,29 +352,35 @@ sub abs2rel {
     }
 
     # Now, remove all leading components that are the same
-    my @pathchunks = $self->splitdir( $path);
-    my @basechunks = $self->splitdir( $base);
-
-    while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) {
+    my @pathchunks = $self->splitpath( $path );
+    my @basechunks = ($self->splitpath( $base, 1 ))[0,1];
+
+    # Insure same device; case-insensitive since those filesystems
+    # which use device semantics (VMS and Win32) are case-tolerant
+    return undef unless lc($pathchunks[0]) eq lc($basechunks[0]);
+    $path = $pathchunks[0] || '';
+    @pathchunks = ( $self->splitdir( $pathchunks[1] ), $pathchunks[2] );
+    @basechunks = $self->splitdir( $basechunks[1] );
+
+    # We do case-insensitive comparisons rather than just flattening case
+    # so caller gets back same case as was sent in
+    my $lc = $self->case_tolerant;
+    while (@pathchunks && @basechunks && 
+           ($lc ? lc($pathchunks[0]) eq lc($basechunks[0])
+                : $pathchunks[0] eq $basechunks[0]        ) ) {
         shift @pathchunks ;
         shift @basechunks ;
     }
 
-    $path = CORE::join( '/', @pathchunks );
-    $base = CORE::join( '/', @basechunks );
-
-    # $base now contains the directories the resulting relative path 
+    # @basechunks now contains the directories the resulting relative path 
     # must ascend out of before it can descend to $path_directory.  So, 
     # replace all names with $parentDir
-    $base =~ s|[^/]+|..|g ;
+    @basechunks = ($self->updir()) x @basechunks;
 
     # Glue the two together, using a separator if necessary, and preventing an
     # empty result.
-    if ( $path ne '' && $base ne '' ) {
-        $path = "$base/$path" ;
-    } else {
-        $path = "$base$path" ;
-    }
+    $path = $self->catfile($path,@basechunks,@pathchunks);
+    $path = $self->curdir unless $path;
 
     return $self->canonpath( $path ) ;
 }
@@ -411,7 +428,9 @@ sub rel2abs($;$;) {
         }
 
         # Glom them together
-        $path = $self->catdir( $base, $path ) ;
+        my($pdev,$pdir,$pfile) = $self->splitpath( $path );
+        my($bdev,$bdir,$bfile) = $self->splitpath( $base );
+        $path = $self->catpath( $bdev, $self->catdir( $bdir, $pdir ), $pfile );
     }
 
     return $self->canonpath( $path ) ;
index 71c38f2..54a5f1a 100644 (file)
@@ -108,8 +108,14 @@ sub fixpath {
     if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
         $fixedpath = vmspath($fixedpath) if -d $fixedpath;
     }
+
     # Trim off root dirname if it's had other dirs inserted in front of it.
     $fixedpath =~ s/\.000000([\]>])/$1/;
+    # Special case for VMS absolute directory specs: these will have had device
+    # prepended during trip through Unix syntax in eliminate_macros(), since
+    # Unix syntax has no way to express "absolute from the top of this device's
+    # directory tree".
+    if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
     $fixedpath;
 }
 
@@ -119,10 +125,35 @@ sub fixpath {
 
 =over
 
+=item canonpath (override)
+
+Removes redundant portions of file specifications according to VMS syntax
+
+=cut
+
+sub canonpath {
+    my($self,$path,$reduce_ricochet) = @_;
+
+    if ($path =~ m|/|) { # Fake Unix
+      my $pathify = $path =~ m|/$|;
+      $path = $self->SUPER::canonpath($path,$reduce_ricochet);
+      if ($pathify) { return vmspath($path); }
+      else          { return vmsify($path);  }
+    }
+    else {
+      $path =~ s-\]\[--g;  $path =~ s/><//g;    # foo.][bar       ==> foo.bar
+      $path =~ s/([\[<])000000\./$1/;           # [000000.foo     ==> foo
+      $path =~ s/[\[<\.]([^\[<\.]+)\.-\.\1//g;  # bar.foo.-.foo   ==> bar.
+      if ($reduce_ricochet) { $path =~ s/[^\[\-<.]+\.\-//g; }
+      return $path;
+    }
+}
+
 =item catdir
 
 Concatenates a list of file specifications, and returns the result as a
-VMS-syntax directory specification.
+VMS-syntax directory specification.  No check is made for "impossible"
+cases (e.g. elements other than the first being absolute filespecs).
 
 =cut
 
@@ -137,6 +168,12 @@ sub catdir {
        $spath =~ s/.dir$//; $sdir =~ s/.dir$//; 
        $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/;
        $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
+
+    # Special case for VMS absolute directory specs: these will have had device
+    # prepended during trip through Unix syntax in eliminate_macros(), since
+    # Unix syntax has no way to express "absolute from the top of this device's
+    # directory tree".
+    if ($spath =~ /^[\[<][^.\-]/) { $rslt =~ s/^[^\[<]+//; }
     }
     else {
        if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; }
@@ -148,7 +185,7 @@ sub catdir {
 =item catfile
 
 Concatenates a list of file specifications, and returns the result as a
-VMS-syntax directory specification.
+VMS-syntax file specification.
 
 =cut
 
@@ -173,6 +210,7 @@ sub catfile {
     return $rslt;
 }
 
+
 =item curdir (override)
 
 Returns a string representation of the current directory: '[]'
@@ -235,6 +273,16 @@ sub updir {
     return '[-]';
 }
 
+=item case_tolerant (override)
+
+VMS file specification syntax is case-tolerant.
+
+=cut
+
+sub case_tolerant {
+    return 1;
+}
+
 =item path (override)
 
 Translate logical name DCL$PATH as a searchlist, rather than trying
@@ -263,6 +311,49 @@ sub file_name_is_absolute {
                  $file =~ /:[^<\[]/);
 }
 
+=item splitpath (override)
+
+Splits using VMS syntax.
+
+=cut
+
+sub splitpath {
+    my($self,$path) = @_;
+    my($dev,$dir,$file) = ('','','');
+
+    vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/;
+    return ($1 || '',$2 || '',$3);
+}
+
+=item splitdir (override)
+
+Split dirspec using VMS syntax.
+
+=cut
+
+sub splitdir {
+    my($self,$dirspec) = @_;
+    $dirspec =~ s/\]\[//g;  $dirspec =~ s/\-\-/-.-/g;
+    my(@dirs) = split('\.', vmspath($dirspec));
+    $dirs[0] =~ s/^[\[<]//;  $dirs[-1] =~ s/[\]>]$//;
+    @dirs;
+}
+
+
+=item catpath (override)
+
+Construct a complete filespec using VMS syntax
+
+=cut
+
+sub catpath {
+    my($self,$dev,$dir,$file) = @_;
+    if ($dev =~ m|^/+([^/]+)|) { $dev =~ "$1:"; }
+    else { $dev .= ':' unless $dev eq '' or $dev =~ /:$/; }
+    $dir = vmspath($dir);
+    "$dev$dir$file";
+}
+
 =item splitpath
 
     ($volume,$directories,$file) = File::Spec->splitpath( $path );
index f1c6ccf..6ee2f3b 100644 (file)
@@ -59,6 +59,10 @@ sub tmpdir {
     return $tmpdir;
 }
 
+sub case_tolerant {
+    return 1;
+}
+
 sub file_name_is_absolute {
     my ($self,$file) = @_;
     return scalar($file =~ m{^([a-z]:)?[\\/]}i);
diff --git a/op.c b/op.c
index 592d16a..ed5a7eb 100644 (file)
--- a/op.c
+++ b/op.c
@@ -204,7 +204,7 @@ Perl_pad_allocmy(pTHX_ char *name)
     }
     if (PL_in_my == KEY_our) {
        (void)SvUPGRADE(sv, SVt_PVGV);
-       GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? PL_curstash : PL_defstash);
+       GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
        SvFLAGS(sv) |= SVpad_OUR;
     }
     av_store(PL_comppad_name, off, sv);
index 9f24e12..97db6cc 100644 (file)
@@ -1280,7 +1280,7 @@ detected at the end of the line containing the __END__ or __DATA__
 token; if not, the DATA filehandle will be left open in binary mode.
 Earlier versions always opened the DATA filehandle in text mode.
 
-The glob() operator is implemented via the L<File::Glob> extension,
+The glob() operator is implemented via the C<File::Glob> extension,
 which supports glob syntax of the C shell.  This increases the flexibility
 of the glob() operator, but there may be compatibility issues for
 programs that relied on the older globbing syntax.  If you want to
index 3869ff3..2209180 100644 (file)
@@ -559,14 +559,15 @@ See also the new L<perlopentut> if you have it (new for 5.6).
 =head2 Why do I sometimes get an "Argument list too long" when I use E<lt>*E<gt>?
 
 The C<E<lt>E<gt>> operator performs a globbing operation (see above).
-By default glob() forks csh(1) to do the actual glob expansion, but
+In Perl versions earlier than v5.6.0, the internal glob() operator forks
+csh(1) to do the actual glob expansion, but
 csh can't handle more than 127 items and so gives the error message
 C<Argument list too long>.  People who installed tcsh as csh won't
 have this problem, but their users may be surprised by it.
 
-To get around this, either do the glob yourself with readdir() and
-patterns, or use a module like Glob::KGlob, one that doesn't use the
-shell to do globbing.  This is expected to be fixed soon.
+To get around this, either upgrade to Perl v5.6.0 or later, do the glob
+yourself with readdir() and patterns, or use a module like Glob::KGlob,
+one that doesn't use the shell to do globbing.
 
 =head2 Is there a leak/bug in glob()?
 
index 525d26e..de7abdc 100644 (file)
@@ -1937,6 +1937,9 @@ implementing the C<E<lt>*.cE<gt>> operator, but you can use it directly.
 If EXPR is omitted, C<$_> is used.  The C<E<lt>*.cE<gt>> operator is
 discussed in more detail in L<perlop/"I/O Operators">.
 
+Beginning with v5.6.0, this operator is implemented using the standard
+C<File::Glob> extension.  See L<File::Glob> for details.
+
 =item gmtime EXPR
 
 Converts a time as returned by the time function to a 9-element list
index c5d7f3f..dfbdd19 100644 (file)
@@ -1696,7 +1696,7 @@ way to have done it in the first place.)  For example:
        chmod 0644, $_;
     }
 
-is equivalent to
+is roughly equivalent to:
 
     open(FOO, "echo *.c | tr -s ' \t\r\f' '\\012\\012\\012\\012'|");
     while (<FOO>) {
@@ -1704,20 +1704,11 @@ is equivalent to
        chmod 0644, $_;
     }
 
-In fact, it's currently implemented that way, but this is expected
-to be made completely internal in the near future.  (Which means
-it will not work on filenames with spaces in them unless you have
-csh(1) on your machine.)  Of course, the shortest way to do the
-above is:
+except that the globbing is actually done internally using the standard
+C<File::Glob> extension.  Of course, the shortest way to do the above is:
 
     chmod 0644, <*.c>;
 
-Because globbing currently invokes a shell, it's often faster to
-call readdir() yourself and do your own grep() on the filenames.
-Furthermore, due to its current implementation of using a shell,
-the glob() routine may get "Arg list too long" errors (unless you've
-installed tcsh(1L) as F</bin/csh> or hacked your F<config.sh>).
-
 A (file)glob evaluates its (embedded) argument only when it is
 starting a new list.  All values must be read before it will start
 over.  In list context, this isn't important because you automatically
index 212879a..4037487 100644 (file)
@@ -84,8 +84,8 @@ For example:
     exec "echo", $arg;         # Secure (doesn't use the shell)
     exec "sh", '-c', $arg;     # Considered secure, alas!
 
-    @files = <*.c>;            # Always insecure (uses csh)
-    @files = glob('*.c');      # Always insecure (uses csh)
+    @files = <*.c>;            # insecure (uses readdir() or similar)
+    @files = glob('*.c');      # insecure (uses readdir() or similar)
 
 If you try to do something insecure, you will get a fatal error saying
 something like "Insecure dependency" or "Insecure $ENV{PATH}".  Note that you
index 63997be..a6ca1f1 100644 (file)
@@ -147,14 +147,6 @@ lexically-scoped subs, e.g. my sub
 
 =back
 
-=head2 Built-in globbing
-
-Currently the C<E<lt>*.cE<gt>> syntax calls the c shell.  This causes
-problems on sites without csh, systems where fork() is expensive, and
-setuid environments.  Decide between Glob::BSD and File::KGlob, move
-it into the core, and make Perl use it for globbing.  Ben Holzman and
-Tye McQueen have claimed the pumpkin for this.
-
 =head1 Perl Internals
 
 =head2 magic_setisa
@@ -593,20 +585,12 @@ pointed out that perllib_mangle() is good for this.
 
 =head1 Win32 Stuff
 
-=head2 Get PERL_OBJECT building under gcc
-
-B<Part done>, according to Sarathy.  It builds under egcs on win32,
-but doesn't run for occult reasons.  If anyone knows the right
-breed of chicken to sacrifice, please speak up.
-
 =head2 Rename new headers to be consistent with the rest
 
 =head2 Sort out the spawnvp() mess
 
 =head2 Work out DLL versioning
 
-=head2 Get PERL_OBJECT building on non-win32
-
 =head2 Style-check
 
 =head1 Would be nice to have
@@ -853,13 +837,9 @@ Mark-Jason Dominus sent a patch which went into 5.005_56.
 
 =head2 Filenames
 
-Make filenames in the distribution and in the standard module set
+Keep filenames in the distribution and in the standard module set
 be 8.3 friendly where feasible.  Good luck changing the standard
-modules, though.  B<Done>.
-
-=head2 Proper tied array support
-
-This was B<done> in 5.005 by Nick Ing-Simmons.
+modules, though.
 
 =head2 Foreign lines
 
@@ -873,49 +853,18 @@ Mostly B<done> in 5.005.
 
     CPP-space:   stop malloc()/free() pollution unless asked
 
-=head2 Explain tool
-
-Given a piece of Perl code, say what it does.  B::Deparse is doing
-this.  B<Done>.
-
 =head2 ISA.pm
 
 Rename and alter ISA.pm.  B<Done>.  It is now base.pm.
 
-=head2 Automate maintenance of most PERL_OBJECT code
-
-B<Done>, says Sarathy.
-
-=head2 -iprefix.
-
-Added in 5.004_70.  B<Done>
-
 =head2 gettimeofday
 
 See Time::HiRes.
 
-=head2 reference to compiled regexp
-
-B<done>  This is the qr// support in 5.005.
-
-=head2 eval qw() at compile time
-
-qw() is presently compiled as a call to split.  This means the split
-happens at runtime.  Change this so qw() is compiled as a real list
-assignment.  This also avoids surprises like:
-
-    $a = () = qw(What will $a hold?);
-
-B<Done>.  Tom Hughes submitted a patch that went into 5.005_55.
-
 =head2 autocroak?
 
-B<Done>.  This is the Fatal.pm module, so any builtin that that does
+This is the Fatal.pm module, so any builtin that that does
 not return success automatically die()s.  If you're feeling brave, tie
 this in with the unified exceptions scheme.
 
-=head2 Status variable
-
-$^C to track compiler/checker status.  B<Done> in 5.005_54.
-
 =cut
index 6fa9c10..ee8605c 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -356,6 +356,10 @@ PP(pp_glob)
     OP *result;
     tryAMAGICunTARGET(iter, -1);
 
+    /* Note that we only ever get here if File::Glob fails to load
+     * without at the same time croaking, for some reason, or if
+     * perl was built with PERL_EXTERNAL_GLOB */
+
     ENTER;
 
 #ifndef VMS
@@ -3462,7 +3466,8 @@ PP(pp_readdir)
            sv = newSVpv(dp->d_name, 0);
 #endif
 #ifndef INCOMPLETE_TAINTS
-           SvTAINTED_on(sv);
+           if (!(IoFLAGS(io) & IOf_UNTAINT))
+               SvTAINTED_on(sv);
 #endif
            XPUSHs(sv_2mortal(sv));
        }
@@ -3476,7 +3481,8 @@ PP(pp_readdir)
        sv = newSVpv(dp->d_name, 0);
 #endif
 #ifndef INCOMPLETE_TAINTS
-       SvTAINTED_on(sv);
+       if (!(IoFLAGS(io) & IOf_UNTAINT))
+           SvTAINTED_on(sv);
 #endif
        XPUSHs(sv_2mortal(sv));
     }
diff --git a/sv.c b/sv.c
index 2f5ea0b..d62a145 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -2758,6 +2758,11 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
            SvPV_set(dstr, SvPVX(sstr));
            SvLEN_set(dstr, SvLEN(sstr));
            SvCUR_set(dstr, SvCUR(sstr));
+           if (SvUTF8(sstr))
+               SvUTF8_on(dstr);
+           else
+               SvUTF8_off(dstr);
+
            SvTEMP_off(dstr);
            (void)SvOK_off(sstr);
            SvPV_set(sstr, Nullch);
@@ -7237,13 +7242,13 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
            ptr = POPPTR(ss,ix);
            TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
            dptr = POPDPTR(ss,ix);
-           TOPDPTR(nss,ix) = (void (*)(void*))any_dup(dptr, proto_perl);
+           TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
            break;
        case SAVEt_DESTRUCTOR_X:
            ptr = POPPTR(ss,ix);
            TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
            dxptr = POPDXPTR(ss,ix);
-           TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup(dxptr, proto_perl);
+           TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
            break;
        case SAVEt_REGCONTEXT:
        case SAVEt_ALLOC:
index 1705bf8..53925b2 100644 (file)
@@ -194,11 +194,13 @@ so we can try to work around them.
 =head2 Wildcard expansion
 
 File specifications containing wildcards are allowed both on 
-the command line and within Perl globs (e.g. <CE<lt>*.cE<gt>>).  If 
+the command line and within Perl globs (e.g. <CE<lt>*.cE<gt>>).  If
 the wildcard filespec uses VMS syntax, the resultant 
 filespecs will follow VMS syntax; if a Unix-style filespec is 
 passed in, Unix-style filespecs will be returned.
 
+In both cases, VMS wildcard expansion is performed. (csh-style
+wildcard expansion is available if you use C<File::Glob::glob>.)
 If the wildcard filespec contains a device or directory 
 specification, then the resultant filespecs will also contain 
 a device and directory; otherwise, device and directory 
@@ -225,9 +227,9 @@ subprocesses around when Perl exits.
 
 You may also use backticks to invoke a DCL subprocess, whose 
 output is used as the return value of the expression.  The 
-string between the backticks is passed directly to lib$spawn 
-as the command to execute.  In this case, Perl will wait for 
-the subprocess to complete before continuing. 
+string between the backticks is handled as if it were the
+argument to the C<system> operator (see below).  In this case,
+Perl will wait for the subprocess to complete before continuing. 
 
 =head1 PERL5LIB and PERLLIB
 
@@ -456,7 +458,7 @@ handlers to the subprocess are limited.)
 If the call to C<exec> does not follow a call to C<fork>, it 
 will cause Perl to exit, and to invoke the command given as 
 an argument to C<exec> via C<lib$do_command>.  If the argument 
-begins with a '$' (other than as part of a filespec), then it 
+begins with '@' or '$' (other than as part of a filespec), then it 
 is executed as a DCL command.  Otherwise, the first token on 
 the command line is treated as the filespec of an image to 
 run, and an attempt is made to invoke it (using F<.Exe> and 
@@ -549,7 +551,14 @@ though, so caveat scriptor.
 The C<system> operator creates a subprocess, and passes its 
 arguments to the subprocess for execution as a DCL command.  
 Since the subprocess is created directly via C<lib$spawn()>, any 
-valid DCL command string may be specified.  If LIST consists
+valid DCL command string may be specified.  If the string begins with
+'@', it is treated as a DCL command unconditionally.  Otherwise, if
+the first token contains a character used as a delimiter in file
+specification (e.g. C<:> or C<]>), an attempt is made to expand it
+using  a default type of F<.Exe> and the process defaults, and if
+successful, the resulting file is invoked via C<MCR>. This allows you
+to invoke an image directly simply by passing the file specification
+to C<system>, a common Unixish idiom.  If LIST consists
 of the empty string, C<system> spawns an interactive DCL subprocess,
 in the same fashion as typiing B<SPAWN> at the DCL prompt.
 Perl waits for the subprocess to complete before continuing
@@ -846,11 +855,10 @@ problems.
 
 =head1 Revision date
 
-This document was last updated on 26-Feb-1998, for Perl 5, 
-patchlevel 5.
+This document was last updated on 26-Feb-2000, for Perl 5, 
+patchlevel 6.
 
 =head1 AUTHOR
 
-Charles Bailey  bailey@cor.newman.upenn.edu
-
-Last revision by Dan Sugalski  sugalskd@ous.edu
+Charles Bailey  <bailey@cor.newman.upenn.edu>
+Dan Sugalski  <dan@sidhe.org>
index fac9243..deae32f 100644 (file)
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -2,7 +2,7 @@
  *
  * VMS-specific routines for perl5
  *
- * Last revised: 15-Aug-1999 by Charles Bailey  bailey@newman.upenn.edu
+ * Last revised: 24-Feb-2000 by Charles Bailey  bailey@newman.upenn.edu
  * Version: 5.5.60
  */
 
@@ -95,6 +95,9 @@ static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 /* munching */ 
 static int no_translate_barewords;
 
+/* Temp for subprocess commands */
+static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
+
 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 int
 vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
@@ -270,6 +273,8 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys)
         idx = strtoul(cp2+1,NULL,0);
         lnm = uplnm;
       }
+      /* Impose security constraints only if tainting */
+      if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
       if (vmstrnenv(lnm,eqv,idx,
                     sys ? fildev : NULL,
 #ifdef SECURE_INTERNAL_GETENV
@@ -316,6 +321,8 @@ my_getenv_len(const char *lnm, unsigned long *len, bool sys)
         idx = strtoul(cp2+1,NULL,0);
         lnm = buf;
       }
+      /* Impose security constraints only if tainting */
+      if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
       if ((*len = vmstrnenv(lnm,buf,idx,
                            sys ? fildev : NULL,
 #ifdef SECURE_INTERNAL_GETENV
@@ -1025,13 +1032,16 @@ popen_completion_ast(struct pipe_details *thispipe)
   }
 }
 
+static unsigned long int setup_cmddsc(char *cmd, int check_img);
+static void vms_execfree();
+
 static PerlIO *
 safe_popen(char *cmd, char *mode)
 {
     static int handler_set_up = FALSE;
     char mbxname[64];
     unsigned short int chan;
-    unsigned long int flags=1;  /* nowait - gnu c doesn't allow &1 */
+    unsigned long int sts, flags=1;  /* nowait - gnu c doesn't allow &1 */
     dTHX;
     struct pipe_details *info;
     struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
@@ -1040,13 +1050,7 @@ safe_popen(char *cmd, char *mode)
                                       DSC$K_CLASS_S, 0};
                             
 
-    cmddsc.dsc$w_length=strlen(cmd);
-    cmddsc.dsc$a_pointer=cmd;
-    if (cmddsc.dsc$w_length > 255) {
-      set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
-      return Nullfp;
-    }
-
+    if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
     New(1301,info,1,struct pipe_details);
 
     /* create mailbox */
@@ -1066,16 +1070,17 @@ safe_popen(char *cmd, char *mode)
     info->completion=0;
         
     if (*mode == 'r') {
-      _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
+      _ckvmssts(lib$spawn(&VMScmd, &nl_desc, &namdsc, &flags,
                      0  /* name */, &info->pid, &info->completion,
                      0, popen_completion_ast,info,0,0,0));
     }
     else {
-      _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
+      _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags,
                      0  /* name */, &info->pid, &info->completion,
                      0, popen_completion_ast,info,0,0,0));
     }
 
+    vms_execfree();
     if (!handler_set_up) {
       _ckvmssts(sys$dclexh(&pipe_exitblock));
       handler_set_up = TRUE;
@@ -2116,16 +2121,12 @@ static char *do_tovmsspec(char *path, char *buf, int ts) {
     else if (!infront && *cp2 == '.') {
       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
-      else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
-        if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
+      else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { /* handle "../" */
+        if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; 
         else if (*(cp1-2) == '[') *(cp1-1) = '-';
-        else {  /* back up over previous directory name */
-          cp1--;
-          while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
-          if (*(cp1-1) == '[') {
-            memcpy(cp1,"000000.",7);
-            cp1 += 7;
-          }
+        else {
+/*          if (*(cp1-1) != '.') *(cp1++) = '.'; */
+          *(cp1++) = '-';
         }
         cp2 += 2;
         if (cp2 == dirend) break;
@@ -3286,12 +3287,10 @@ my_vfork()
 /*}}}*/
 
 
-static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
-
 static void
 vms_execfree() {
   if (PL_Cmd) {
-    Safefree(PL_Cmd);
+    if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
     PL_Cmd = Nullch;
   }
   if (VMScmd.dsc$a_pointer) {
@@ -3349,38 +3348,69 @@ setup_argstr(SV *really, SV **mark, SV **sp)
 static unsigned long int
 setup_cmddsc(char *cmd, int check_img)
 {
-  char resspec[NAM$C_MAXRSS+1];
+  char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
   $DESCRIPTOR(defdsc,".EXE");
   $DESCRIPTOR(resdsc,resspec);
   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
-  register char *s, *rest, *cp;
-  register int isdcl = 0;
+  register char *s, *rest, *cp, *wordbreak;
+  register int isdcl;
   dTHX;
 
+  if (strlen(cmd) >
+      (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
+    return LIB$_INVARG;
   s = cmd;
   while (*s && isspace(*s)) s++;
-  if (check_img) {
-    if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
-      isdcl = 1;     /* no dev/dir separators (i.e. not a foreign command) */
-      for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
-        if (*cp == ':' || *cp == '[' || *cp == '<') {
-          isdcl = 0;
-          break;
-        }
+
+  if (*s == '@' || *s == '$') {
+    vmsspec[0] = *s;  rest = s + 1;
+    for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
+  }
+  else { cp = vmsspec; rest = s; }
+  if (*rest == '.' || *rest == '/') {
+    char *cp2;
+    for (cp2 = resspec;
+         *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
+         rest++, cp2++) *cp2 = *rest;
+    *cp2 = '\0';
+    if (do_tovmsspec(resspec,cp,0)) { 
+      s = vmsspec;
+      if (*rest) {
+        for (cp2 = vmsspec + strlen(vmsspec);
+             *rest && cp2 - vmsspec < sizeof vmsspec;
+             rest++, cp2++) *cp2 = *rest;
+        *cp2 = '\0';
       }
     }
   }
-  else isdcl = 1;
+  /* Intuit whether verb (first word of cmd) is a DCL command:
+   *   - if first nonspace char is '@', it's a DCL indirection
+   * otherwise
+   *   - if verb contains a filespec separator, it's not a DCL command
+   *   - if it doesn't, caller tells us whether to default to a DCL
+   *     command, or to a local image unless told it's DCL (by leading '$')
+   */
+  if (*s == '@') isdcl = 1;
+  else {
+    register char *filespec = strpbrk(s,":<[.;");
+    rest = wordbreak = strpbrk(s," \"\t/");
+    if (!wordbreak) wordbreak = s + strlen(s);
+    if (*s == '$') check_img = 0;
+    if (filespec && (filespec < wordbreak)) isdcl = 0;
+    else isdcl = !check_img;
+  }
+
   if (!isdcl) {
-    cmd = s;
-    while (*s && !isspace(*s)) s++;
-    rest = *s ? s : 0;
-    imgdsc.dsc$a_pointer = cmd;
-    imgdsc.dsc$w_length = s - cmd;
+    imgdsc.dsc$a_pointer = s;
+    imgdsc.dsc$w_length = wordbreak - s;
     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
-    if (retsts & 1) {
+    if (!(retsts & 1) && *s == '$') {
+      imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
+      retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
       _ckvmssts(lib$find_file_end(&cxt));
+    }
+    if (retsts & 1) {
       s = resspec;
       while (*s && !isspace(*s)) s++;
       *s = '\0';
@@ -3397,10 +3427,7 @@ setup_cmddsc(char *cmd, int check_img)
   }
   /* It's either a DCL command or we couldn't find a suitable image */
   VMScmd.dsc$w_length = strlen(cmd);
-  if (cmd == PL_Cmd) {
-    VMScmd.dsc$a_pointer = PL_Cmd;
-    PL_Cmd = Nullch;  /* Don't try to free twice in vms_execfree() */
-  }
+  if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
   else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
   if (!(retsts & 1)) {
     /* just hand off status values likely to be due to user error */