Patch from Sarathy to integrate changes from mainline: 2751,
authorChip Salzenberg <chip@pobox.com>
Mon, 10 Jan 2000 17:08:48 +0000 (17:08 +0000)
committerchip <chip@pobox.com>
Mon, 10 Jan 2000 17:08:48 +0000 (17:08 +0000)
2821, 2916, 2930, 2931, 2937 2990, 3033, 3036, 3042, 3061, 3097,
3123, 3134, 3135, 3269, 3270, 3300, 3316, 3345 3350, 3353, 3362,
3363, 3396, 3419, 3423, 3445, 3446, 3447, 3449, 3450, 3451, 3487
3493, 3514, 3533, 3548, 3549, 3588, 3682, 3685, 3699, 3785,
3804, 3811, 3897, 4057 4102, 4103, 4230, 4401, 4420, 4504
--
enable better Win32::DomainName() by demand loading netapi32.dll
(from Jan Dubois)
--
win32_utime() on directories should use localtime() rather
than gmtime() (from Jan Dubois)
--
serious bug introduced by G_VOID changes in 5.003_96: scalar
eval"" did not pop stack correctly; C<$a = eval "(1,2)x1">
is one symptom of the problem
--
add $installarchlib/CORE to default linker search path on windows
--
fix memory leak in C<sub f { split ' ', "a b" } f() while 1>
--
fix memory leak in C<sub f { @_ = 1 } f() while 1>
--
avoid hiding child process window
--
optimizations could sometimes bypass bareword check
--
fix typo that caused INSTALLPRIVLIB to have doubled 'perl5'
--
Pod::Html tweak
From: jan.dubois@ibm.net (Jan Dubois)
To: perl5-porters@perl.org
Subject: [PATCH 5.005_58] pod2html: Missing chunk for VMS filenames
Date: Tue, 27 Jul 1999 22:14:12 +0200
Message-ID: <37a50af0.46171380@smtp1.ibm.net>
--
don't quit if =head* wasn't found (suggested by Roland Bauer
<roland.bauer@fff.at>)
--
avoid bug in win32_str_os_error() (from Jan Dubois)
--
applied suggested patch, along with later tweak
From: jan.dubois@ibm.net (Jan Dubois)
Date: Wed, 14 Jul 1999 23:53:43 +0200
Message-ID: <37a902e7.15977234@smtp1.ibm.net>
Subject: Merge ActivePerl Stylesheet support etc into Pod::Html.pm
--
use a better prefixify() heuristic than m/perl/ (prefix/lib/perl5
and prefix/lib/perl5/man are ass_u_med only if those directories
actually exist; else prefix/{lib,man} are used)
--
allow C<-foo> under C<use integer> (behavior of C<-$string>
is unchanged still)
--
avoid race condition in the CAPI extension bootstrap handler
--
sanity check to cover the case when perl is installed into the
X:\ (drive root)
--
truncate() has a peculiar exemption from strict barewords, even
though it has a non-filehandle prototype
--
change#3447 didn't do enough to exempt Foo->bar(qw/.../) from
strict 'subs'
--
change#3449 wasn't doing enough
--
make win32_spawnvp() inherit standard handles even when they
may be redirected
--
minor logic tweak for reserved word warning
--
oops, some files missing in change#3449
--
allow '*' prototype to autoquote even barewords that happen to be
function names; parens or ampersand continue to force the other
interpretation; makes C<sub Foo {'bar'} CORE::GLOBAL::require Foo;>
do the right thing, for example
--
redo change#2061 and parts of change#1169 with code in the
parser; PL_last_proto hackery gone, strict 'subs' in now
implemented in the optimizer where specifying the exceptional
cases is much more robust; '*' (bareword) prototype now works
reliably when used in second and subsequent arguments
--
remove redundant part of change#1169 superceded by change#2061;
avoid "future reserved word" warning on prototypical bearwords
--
s/isspace/isSPACE/g and make sure the CRT version is always
passed an unsigned char (fixes random occurrence of spaces in
arguments containing high-bit chars passed to spawned children,
on win32)
--
on win32, look for "site/5.XXX/lib" if "site/5.XXXYY/lib" isn't
found (brings sitelib intuition in line with privlib)
--
mortalize string allocations by win32_get_{priv,site}lib()
(fixes small memory leak in interpreter)
--
opendir(D,"x:") on win32 opens cwd() for drive rather than root;
stat() behaves similarly
--
documentation for Win32 builtins (somewhat modified)
From: jan.dubois@ibm.net (Jan Dubois)
Date: Tue, 30 Mar 1999 08:05:03 +0200
Message-ID: <37006783.1926460@smtp1.ibm.net>
Subject: Re: Issues with build 509
--
provide File::Copy::syscopy() via Win32::CopyFile() on win32
--
more bulletproof workaround for mangled paths;
provide Win32::GetLongPathName()
--
normalize $^X to full pathname on win32
--
work around mangled archname on win32 while finding privlib/sitelib;
normalize lib paths to forward slashes internally
--
avoid negative return value from Win32::GetTickCount()
From: jan.dubois@ibm.net (Jan Dubois)
Date: Sat, 03 Apr 1999 19:04:18 +0200
Message-ID: <37084742.22824479@smtp1.ibm.net>
Subject: Re: Win32::GetTickCount
--
adjust win32_stat() to cope with FindFirstFile() and stat() bugs
(makes opendir(D,"c:") work reliably)
--
fix buggy reference count on refs to SVs with autoviv magic
(resulted in C<my @a; $a[1] = 1; print \$_ for @a> and Data::Dumper
accessing free()d memory)
--
fix bug in change#3123 (off-by-one, caused C<qx[noargs]> to fail
on win32)
--
flip release & version in win32_uname()
--
support POSIX::uname() via win32_uname()
--
implement win32_spawnvp() internally, making it return true PIDs
for asynchronous spawns; fix win32_kill() to always deal with
PIDs
--
use yyerror() instead of croak() so that compile-time failures in
my(LIST) don't confuse globals with lexicals
--
allow custom comparison function in File::Compare::compare_text()
From: jan.dubois@ibm.net (Jan Dubois)
Date: Fri, 26 Feb 1999 21:56:09 +0100
Message-ID: <36db0838.8805651@smtp1.ibm.net>
Subject: Re: PodParser 1.07 (was: RE: C<stuff()> vs stuff())
--
slightly edited version of suggested patch
From: jan.dubois@ibm.net (Jan Dubois)
Date: Mon, 01 Mar 1999 00:32:05 +0100
Message-ID: <36dbcf2c.12325433@smtp1.ibm.net>
Subject: Re: [PATCH 5.005_55] Cleanup of File::Spec module
--
revert parts of change#2990 to preserve predictable usage of
Win32::Foo() as stacked list values
From: jan.dubois@ibm.net (Jan Dubois)
Date: Sat, 27 Feb 1999 18:24:17 +0100
Message-ID: <36e22849.36531259@smtp1.ibm.net>
Subject: Re: resend [PATCH 5.005_55] Various win32/win32.c cleanup
--
add File::Compare::compare_text()
From: jan.dubois@ibm.net (Jan Dubois)
Date: Fri, 26 Feb 1999 00:20:41 +0100
Message-ID: <36dcd8ab.20195659@smtp1.ibm.net>
Subject: Re: PodParser 1.07 (was: RE: C<stuff()> vs stuff())
--
From: jan.dubois@ibm.net (Jan Dubois)
Date: Thu, 18 Feb 1999 19:14:07 +0100
Message-ID: <36d15809.40853323@smtp1.ibm.net>
Subject: resend [PATCH 5.005_55] Various win32/win32.c cleanup
--
support Win32::GetFullPathName() and Win32::SetLastError()
From: jan.dubois@ibm.net (Jan Dubois)
Date: Tue, 09 Feb 1999 22:27:31 +0100
Message-ID: <36c1a2ed.8007554@smtp1.ibm.net>
Subject: [PATCH _54] Win32::GetFullPathName
--
backout change#2811 and add newer version based on File::Spec
From: Barrie Slaymaker <rbs@telerama.com>
Date: Thu, 11 Feb 1999 16:29:24 -0500
Message-ID: <36C34BB4.A62090E0@telerama.com>
Subject: (pod2html) Relative URLs using new File::Spec
--
From: Barrie Slaymaker <rbs@telerama.com>
Date: Thu, 11 Feb 1999 19:39:48 -0500
Message-ID: <36C37854.707D139@telerama.com>
Subject: Merging File::PathConvert in to File::Spec
--
back out change#2751, apply updated version
From: jan.dubois@ibm.net (Jan Dubois)
Date: Sat, 06 Feb 1999 01:06:29 +0100
Message-ID: <36bc844c.18763049@smtp1.ibm.net>
Subject: [PATCH] Cleanup of File::Spec module
--
pod2html misinterprets Foo::Bar as a URL
(fix suggested by Alexander Barilo
<Alexander.Barilo@aexp.com>)
--
devnull() support from Jan Dubois <jan.dubois@ibm.net> and others

p4raw-link: @3449 on //depot/perl: 18228614d1dac2db099ef3d8846e53f44accce72
p4raw-link: @3447 on //depot/perl: 7a52d87a7fbc7848e6b3e9e96db52d4070212cca
p4raw-link: @3123 on //depot/perl: 0aaad0ff610b01c0682abfc20594c83a6d49f148
p4raw-link: @2990 on //depot/perl: bb897dfcf82adc653513b0b92523fb44767a9837
p4raw-link: @2811 on //depot/cfgperl: 5a039dd3f529422cb070070772502cedaf09ae20
p4raw-link: @2751 on //depot/perl: 99804bbbf0b24ddc3b565419ea53f59e7410d1f4
p4raw-link: @2061 on //depot/perl: bf8481137c02593eb36f8d0e234a2ec41a1c92e4
p4raw-link: @1169 on //depot/perl: 2a841d1398ee9bbf30a942905192cc2591b3e92a

p4raw-id: //depot/maint-5.005/perl@4785

56 files changed:
MANIFEST
cop.h
dump.c
embed.h
ext/SDBM_File/sdbm/dbe.c
global.sym
iperlsys.h
lib/CGI.pm
lib/CGI/Carp.pm
lib/ExtUtils/MM_Unix.pm
lib/ExtUtils/xsubpp
lib/File/Compare.pm
lib/File/Copy.pm
lib/File/Spec.pm
lib/File/Spec/Functions.pm [new file with mode: 0644]
lib/File/Spec/Mac.pm
lib/File/Spec/OS2.pm
lib/File/Spec/Unix.pm
lib/File/Spec/VMS.pm
lib/File/Spec/Win32.pm
lib/Pod/Html.pm
objXSUB.h
objpp.h
op.c
op.h
perl.h
pod/Win32.pod [new file with mode: 0644]
pp.c
pp_ctl.c
pp_hot.c
proto.h
t/comp/proto.t
t/io/fs.t
t/lib/fatal.t
t/op/eval.t
t/op/magic.t
t/op/ref.t
t/pragma/strict-subs
toke.c
utils/perldoc.PL
win32/GenCAPI.pl
win32/Makefile
win32/config.bc
win32/config.gc
win32/config.vc
win32/config_H.bc
win32/config_H.gc
win32/config_H.vc
win32/makedef.pl
win32/makefile.mk
win32/perlhost.h
win32/runperl.c
win32/win32.c
win32/win32.h
win32/win32iop.h
win32/win32sck.c

index f42a832..c4e3063 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -502,6 +502,7 @@ lib/File/DosGlob.pm Win32 DOS-globbing module
 lib/File/Find.pm       Routines to do a find
 lib/File/Path.pm       Do things like `mkdir -p' and `rm -r'
 lib/File/Spec.pm       portable operations on file names
+lib/File/Spec/Functions.pm     Function interface to File::Spec object methods
 lib/File/Spec/Mac.pm   portable operations on Mac file names
 lib/File/Spec/OS2.pm   portable operations on OS2 file names
 lib/File/Spec/Unix.pm  portable operations on Unix file names
@@ -710,6 +711,7 @@ plan9/plan9ish.h    Plan9 port: Plan9-specific C header file
 plan9/setup.rc         Plan9 port: script for easy build+install
 plan9/versnum          Plan9 port: script to print version number
 pod/Makefile           Make pods into something else
+pod/Win32.pod          Documentation for Win32 extras
 pod/buildtoc           generate perltoc.pod
 pod/checkpods.PL       Tool to check for common errors in pods
 pod/perl.pod           Top level perl man page
diff --git a/cop.h b/cop.h
index 7d6730f..256c2e6 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -72,6 +72,7 @@ struct block_sub {
            /* destroy arg array */                                     \
            av_clear(cxsub.argarray);                                   \
            AvREAL_off(cxsub.argarray);                                 \
+           AvREIFY_on(cxsub.argarray);                                 \
        }                                                               \
        if (cxsub.cv) {                                                 \
            if (!(CvDEPTH(cxsub.cv) = cxsub.olddepth))                  \
diff --git a/dump.c b/dump.c
index 782c62d..c1346a4 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -219,6 +219,8 @@ dump_op(OP *o)
        else if (o->op_type == OP_CONST) {
            if (o->op_private & OPpCONST_BARE)
                sv_catpv(tmpsv, ",BARE");
+           if (o->op_private & OPpCONST_STRICT)
+               sv_catpv(tmpsv, ",STRICT");
        }
        else if (o->op_type == OP_FLIP) {
            if (o->op_private & OPpFLIP_LINENUM)
diff --git a/embed.h b/embed.h
index e7deb32..22b4f51 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define ninstr                 Perl_ninstr
 #define no_aelem               Perl_no_aelem
 #define no_dir_func            Perl_no_dir_func
+#define no_bareword_allowed    Perl_no_bareword_allowed
 #define no_fh_allowed          Perl_no_fh_allowed
 #define no_func                        Perl_no_func
 #define no_helem               Perl_no_helem
index 2a306f2..ff033d2 100644 (file)
@@ -138,7 +138,7 @@ datum db;
 
        putchar('"');
        for (i = 0; i < db.dsize; i++) {
-               if (isprint(db.dptr[i]))
+               if (isprint((unsigned char)db.dptr[i]))
                        putchar(db.dptr[i]);
                else {
                        putchar('\\');
@@ -171,7 +171,10 @@ char *s;
                                *p = '\f';
                        else if (*s == 't')
                                *p = '\t';
-                       else if (isdigit(*s) && isdigit(*(s + 1)) && isdigit(*(s + 2))) {
+                       else if (isdigit((unsigned char)*s)
+                                && isdigit((unsigned char)*(s + 1))
+                                && isdigit((unsigned char)*(s + 2)))
+                       {
                                i = (*s++ - '0') << 6;
                                i |= (*s++ - '0') << 3;
                                i |= *s - '0';
index 99edf17..cbe2606 100644 (file)
@@ -502,6 +502,7 @@ newXS
 newXSUB
 nextargv
 ninstr
+no_bareword_allowed
 no_fh_allowed
 no_op
 oopsAV
index da8c5d6..9786ec2 100644 (file)
@@ -450,10 +450,12 @@ public:
     virtual int                Putenv(const char *envstring, int &err) = 0;
     virtual char *     LibPath(char *patchlevel) =0;
     virtual char *     SiteLibPath(char *patchlevel) =0;
+    virtual int                Uname(struct utsname *name, int &err) =0;
 };
 
 #define PerlEnv_putenv(str)            PL_piENV->Putenv((str), ErrorNo())
 #define PerlEnv_getenv(str)            PL_piENV->Getenv((str), ErrorNo())
+#define PerlEnv_uname(name)            PL_piENV->Uname((name), ErrorNo())
 #ifdef WIN32
 #define PerlEnv_lib_path(str)          PL_piENV->LibPath((str))
 #define PerlEnv_sitelib_path(str)      PL_piENV->SiteLibPath((str))
@@ -463,6 +465,7 @@ public:
 
 #define PerlEnv_putenv(str)            putenv((str))
 #define PerlEnv_getenv(str)            getenv((str))
+#define PerlEnv_uname(name)            uname((name))
 
 #endif /* PERL_OBJECT */
 
index f5615f2..51f2874 100644 (file)
@@ -123,7 +123,7 @@ $IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
 # Turn on special checking for Doug MacEachern's modperl
 if (exists $ENV{'GATEWAY_INTERFACE'} 
     && 
-    ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/))
+    ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//))
 {
     $| = 1;
     require Apache;
index dfae1a6..d2be027 100644 (file)
@@ -242,11 +242,13 @@ sub warn {
 }
 
 # The mod_perl package Apache::Registry loads CGI programs by calling
-# eval.  These evals don't count when looking at the stack backtrace.
+# eval, as does PerlEx.  These evals don't count when looking at the 
+# stack backtrace.
 sub _longmess {
     my $message = Carp::longmess();
     my $mod_perl = exists $ENV{MOD_PERL};
-    $message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl;
+    my $PerlEx = exists($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
+    $message =~ s,eval[^\n]+(Apache/Registry\.pm|\s*PerlEx::Precompiler).*,,s if $mod_perl || $PerlEx;
     return( $message );    
 }
 
@@ -307,8 +309,10 @@ and the time and date of the error.
 END
     ;
     my $mod_perl = exists $ENV{MOD_PERL};
+    my $PerlEx = exists($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
+
     print STDOUT "Content-type: text/html\n\n" 
-       unless $mod_perl;
+       unless $mod_perl || $PerlEx;
 
     if ($CUSTOM_MSG) {
        if (ref($CUSTOM_MSG) eq 'CODE') {
index 38bb061..5b47972 100644 (file)
@@ -1695,8 +1695,7 @@ usually solves this kind of problem.
 
     my($install_variable,$search_prefix,$replace_prefix);
 
-    # The rule, taken from Configure, is that if prefix contains perl,
-    # we shape the tree
+    # If the prefix contains perl, Configure shapes the tree as follows:
     #    perlprefix/lib/                INSTALLPRIVLIB
     #    perlprefix/lib/pod/
     #    perlprefix/lib/site_perl/     INSTALLSITELIB
@@ -1708,6 +1707,11 @@ usually solves this kind of problem.
     #    prefix/lib/perl5/site_perl/   INSTALLSITELIB
     #    prefix/bin/                   INSTALLBIN
     #    prefix/lib/perl5/man/         INSTALLMAN1DIR
+    #
+    # The above results in various kinds of breakage on various
+    # platforms, so we cope with it as follows: if prefix/lib/perl5
+    # or prefix/lib/perl5/man exist, we'll replace those instead
+    # of /prefix/{lib,man}
 
     $replace_prefix = qq[\$\(PREFIX\)];
     for $install_variable (qw/
@@ -1716,36 +1720,45 @@ usually solves this kind of problem.
                           /) {
        $self->prefixify($install_variable,$configure_prefix,$replace_prefix);
     }
-    $search_prefix = $configure_prefix =~ /perl/ ?
-       $self->catdir($configure_prefix,"lib") :
-       $self->catdir($configure_prefix,"lib","perl5");
+    my $funkylibdir = $self->catdir($configure_prefix,"lib","perl5");
+    $funkylibdir = '' unless -d $funkylibdir;
+    $search_prefix = $funkylibdir || $self->catdir($configure_prefix,"lib");
     if ($self->{LIB}) {
        $self->{INSTALLPRIVLIB} = $self->{INSTALLSITELIB} = $self->{LIB};
        $self->{INSTALLARCHLIB} = $self->{INSTALLSITEARCH} = 
            $self->catdir($self->{LIB},$Config{'archname'});
-    } else {
-       $replace_prefix = $self->{PREFIX} =~ /perl/ ? 
-           $self->catdir(qq[\$\(PREFIX\)],"lib") :
-               $self->catdir(qq[\$\(PREFIX\)],"lib","perl5");
+    }
+    else {
+       if (-d $self->catdir($self->{PREFIX},"lib","perl5")) {
+           $replace_prefix = $self->catdir(qq[\$\(PREFIX\)],"lib", "perl5");
+       }
+       else {
+           $replace_prefix = $self->catdir(qq[\$\(PREFIX\)],"lib");
+       }
        for $install_variable (qw/
                               INSTALLPRIVLIB
                               INSTALLARCHLIB
                               INSTALLSITELIB
                               INSTALLSITEARCH
-                              /) {
+                              /)
+       {
            $self->prefixify($install_variable,$search_prefix,$replace_prefix);
        }
     }
-    $search_prefix = $configure_prefix =~ /perl/ ?
-       $self->catdir($configure_prefix,"man") :
-           $self->catdir($configure_prefix,"lib","perl5","man");
-    $replace_prefix = $self->{PREFIX} =~ /perl/ ? 
-       $self->catdir(qq[\$\(PREFIX\)],"man") :
-           $self->catdir(qq[\$\(PREFIX\)],"lib","perl5","man");
+    my $funkymandir = $self->catdir($configure_prefix,"lib","perl5","man");
+    $funkymandir = '' unless -d $funkymandir;
+    $search_prefix = $funkymandir || $self->catdir($configure_prefix,"man");
+    if (-d $self->catdir($self->{PREFIX},"lib","perl5", "man")) {
+       $replace_prefix = $self->catdir(qq[\$\(PREFIX\)],"lib", "perl5", "man");
+    }
+    else {
+       $replace_prefix = $self->catdir(qq[\$\(PREFIX\)],"man");
+    }
     for $install_variable (qw/
                           INSTALLMAN1DIR
                           INSTALLMAN3DIR
-                          /) {
+                          /)
+    {
        $self->prefixify($install_variable,$search_prefix,$replace_prefix);
     }
 
@@ -1846,7 +1859,7 @@ usually solves this kind of problem.
        push @defpath, $component if defined $component;
     }
     $self->{PERL} ||=
-        $self->find_perl(5.0, [ $^X, 'miniperl','perl','perl5',"perl$]" ],
+        $self->find_perl(5.0, [ $self->canonpath($^X), 'miniperl','perl','perl5',"perl$]" ],
            \@defpath, $Verbose );
     # don't check if perl is executable, maybe they have decided to
     # supply switches with perl
index 1ee7b29..a08707e 100755 (executable)
@@ -1327,8 +1327,7 @@ print Q<<"EOF";
 ##endif
 #XSCAPI(boot_$Module_cname)
 #[[
-#    SetCPerlObj(pPerl);
-#    boot__CAPI_entry(cv);
+#    boot_CAPI_handler(cv, boot__CAPI_entry, pPerl);
 #]]
 ##endif        /* PERL_CAPI */
 EOF
index 2f9c45c..dce78e2 100644 (file)
@@ -6,10 +6,10 @@ use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $Too_Big *FROM *TO);
 require Exporter;
 use Carp;
 
-$VERSION = '1.1001';
+$VERSION = '1.1002';
 @ISA = qw(Exporter);
 @EXPORT = qw(compare);
-@EXPORT_OK = qw(cmp);
+@EXPORT_OK = qw(cmp compare_text);
 
 $Too_Big = 1024 * 1024 * 2;
 
@@ -22,13 +22,11 @@ sub compare {
     croak("Usage: compare( file1, file2 [, buffersize]) ")
       unless(@_ == 2 || @_ == 3);
 
-    my $from = shift;
-    my $to = shift;
-    my $closefrom=0;
-    my $closeto=0;
-    my ($size, $fromsize, $status, $fr, $tr, $fbuf, $tbuf);
-    local(*FROM, *TO);
-    local($\) = '';
+    my ($from,$to,$size) = @_;
+    my $text_mode = defined($size) && (ref($size) eq 'CODE' || $size < 0);
+
+    my ($fromsize,$closefrom,$closeto);
+    local (*FROM, *TO);
 
     croak("from undefined") unless (defined $from);
     croak("to undefined") unless (defined $to);
@@ -40,9 +38,11 @@ sub compare {
        *FROM = $from;
     } else {
        open(FROM,"<$from") or goto fail_open1;
-       binmode FROM;
+       unless ($text_mode) {
+           binmode FROM;
+           $fromsize = -s FROM;
+       }
        $closefrom = 1;
-       $fromsize = -s FROM;
     }
 
     if (ref($to) &&
@@ -52,32 +52,45 @@ sub compare {
        *TO = $to;
     } else {
        open(TO,"<$to") or goto fail_open2;
-       binmode TO;
+       binmode TO unless $text_mode;
        $closeto = 1;
     }
 
-    if ($closefrom && $closeto) {
+    if (!$text_mode && $closefrom && $closeto) {
        # If both are opened files we know they differ if their size differ
        goto fail_inner if $fromsize != -s TO;
     }
 
-    if (@_) {
-       $size = shift(@_) + 0;
-       croak("Bad buffer size for compare: $size\n") unless ($size > 0);
-    } else {
-       $size = $fromsize;
-       $size = 1024 if ($size < 512);
-       $size = $Too_Big if ($size > $Too_Big);
+    if ($text_mode) {
+       local $/ = "\n";
+       my ($fline,$tline);
+       while (defined($fline = <FROM>)) {
+           goto fail_inner unless defined($tline = <TO>);
+           if (ref $size) {
+               # $size contains ref to comparison function
+               goto fail_inner if &$size($fline, $tline);
+           } else {
+               goto fail_inner if $fline ne $tline;
+           }
+       }
+       goto fail_inner if defined($tline = <TO>);
     }
+    else {
+       unless (defined($size) && $size > 0) {
+           $size = $fromsize;
+           $size = 1024 if $size < 512;
+           $size = $Too_Big if $size > $Too_Big;
+       }
 
-    $fbuf = '';
-    $tbuf = '';
-    while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) {
-       unless (defined($tr = read(TO,$tbuf,$fr)) and $tbuf eq $fbuf) {
-            goto fail_inner;
+       my ($fr,$tr,$fbuf,$tbuf);
+       $fbuf = $tbuf = '';
+       while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) {
+           unless (defined($tr = read(TO,$tbuf,$fr)) && $tbuf eq $fbuf) {
+               goto fail_inner;
+           }
        }
+       goto fail_inner if defined($tr = read(TO,$tbuf,$size)) && $tr > 0;
     }
-    goto fail_inner if (defined($tr = read(TO,$tbuf,$size)) && $tr > 0);
 
     close(TO) || goto fail_open2 if $closeto;
     close(FROM) || goto fail_open1 if $closefrom;
@@ -93,7 +106,7 @@ sub compare {
 
   fail_open2:
     if ($closefrom) {
-       $status = $!;
+       my $status = $!;
        $! = 0;
        close FROM;
        $! = $status unless $!;
@@ -104,6 +117,18 @@ sub compare {
 
 *cmp = \&compare;
 
+sub compare_text {
+    my ($from,$to,$cmp) = @_;
+    croak("Usage: compare_text( file1, file2 [, cmp-function])")
+       unless @_ == 2 || @_ == 3;
+    croak("Third arg to compare_text() function must be a code reference")
+       if @_ == 3 && ref($cmp) ne 'CODE';
+
+    # Using a negative buffer size puts compare into text_mode too
+    $cmp = -1 unless defined $cmp;
+    compare($from, $to, $cmp);
+}
+
 1;
 
 __END__
@@ -129,6 +154,18 @@ from File::Compare by default.
 File::Compare::cmp is a synonym for File::Compare::compare.  It is
 exported from File::Compare only by request.
 
+File::Compare::compare_text does a line by line comparison of the two
+files. It stops as soon as a difference is detected. compare_text()
+accepts an optional third argument: This must be a CODE reference to
+a line comparison function, which returns 0 when both lines are considered
+equal. For example:
+
+    compare_text($file1, $file2)
+
+is basically equivalent to
+
+    compare_text($file1, $file2, sub {$_[0] ne $_[1]} )
+
 =head1 RETURN
 
 File::Compare::compare return 0 if the files are equal, 1 if the
index e1da6b6..fd812bc 100644 (file)
@@ -64,6 +64,7 @@ sub copy {
        && !$to_a_handle
        && !($from_a_handle && $^O eq 'os2' )   # OS/2 cannot handle handles
        && !($from_a_handle && $^O eq 'mpeix')  # and neither can MPE/iX.
+       && !($from_a_handle && $^O eq 'MSWin32')
        )       
     {
        return syscopy($from, $to);
@@ -186,6 +187,11 @@ unless (defined &syscopy) {
            # preserve MPE file attributes.
            return system('/bin/cp', '-f', $_[0], $_[1]) == 0;
        };
+    } elsif ($^O eq 'MSWin32') {
+       *syscopy = sub {
+           return 0 unless @_ == 2;
+           return Win32::CopyFile(@_, 1);
+       };
     } else {
        *syscopy = \&copy;
     }
@@ -272,9 +278,9 @@ second parameter, preserving OS-specific attributes and file
 structure.  For Unix systems, this is equivalent to the simple
 C<copy> routine.  For VMS systems, this calls the C<rmscopy>
 routine (see below).  For OS/2 systems, this calls the C<syscopy>
-XSUB directly.
+XSUB directly. For Win32 systems, this calls C<Win32::CopyFile>.
 
-=head2 Special behaviour if C<syscopy> is defined (VMS and OS/2)
+=head2 Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)
 
 If both arguments to C<copy> are not file handles,
 then C<copy> will perform a "system copy" of
index 616dcbc..b71e357 100644 (file)
@@ -1,47 +1,18 @@
 package File::Spec;
 
-require Exporter;
-
-@ISA = qw(Exporter);
-# Items to export into callers namespace by default. Note: do not export
-# names by default without a very good reason. Use EXPORT_OK instead.
-# Do not simply export all your public functions/methods/constants.
-@EXPORT = qw(
-       
-);
-@EXPORT_OK = qw($Verbose);
-
 use strict;
-use vars qw(@ISA $VERSION $Verbose);
-
-$VERSION = '0.6';
-
-$Verbose = 0;
+use vars qw(@ISA $VERSION);
 
-require File::Spec::Unix;
+$VERSION = '0.8';
 
+my %module = (MacOS   => 'Mac',
+             MSWin32 => 'Win32',
+             os2     => 'OS2',
+             VMS     => 'VMS');
 
-sub load {
-       my($class,$OS) = @_;
-       if ($OS eq 'VMS') {
-               require File::Spec::VMS;
-               require VMS::Filespec;
-               'File::Spec::VMS'
-       } elsif ($OS eq 'os2') {
-               require File::Spec::OS2;
-               'File::Spec::OS2'
-       } elsif ($OS eq 'MacOS') {
-               require File::Spec::Mac;
-               'File::Spec::Mac'
-       } elsif ($OS eq 'MSWin32') {
-               require File::Spec::Win32;
-               'File::Spec::Win32'
-       } else {
-               'File::Spec::Unix'
-       }
-}
-
-@ISA = load('File::Spec', $^O);
+my $module = $module{$^O} || 'Unix';
+require "File/Spec/$module.pm";
+@ISA = ("File::Spec::$module");
 
 1;
 __END__
@@ -52,11 +23,15 @@ File::Spec - portably perform operations on file names
 
 =head1 SYNOPSIS
 
-C<use File::Spec;>
+       use File::Spec;
+
+       $x=File::Spec->catfile('a', 'b', 'c');
+
+which returns 'a/b/c' under Unix. Or:
 
-C<$x=File::Spec-E<gt>catfile('a','b','c');>
+       use File::Spec::Functions;
 
-which returns 'a/b/c' under Unix.
+       $x = catfile('a', 'b', 'c');
 
 =head1 DESCRIPTION
 
@@ -78,28 +53,31 @@ OS specific routines is available in a separate module, including:
        File::Spec::VMS
 
 The module appropriate for the current OS is automatically loaded by
-File::Spec. Since some modules (like VMS) make use of OS specific
-facilities, it may not be possible to load all modules under all operating
-systems.
+File::Spec. Since some modules (like VMS) make use of facilities available
+only under that OS, it may not be possible to load all modules under all
+operating systems.
 
 Since File::Spec is object oriented, subroutines should not called directly,
 as in:
 
        File::Spec::catfile('a','b');
-       
+
 but rather as class methods:
 
        File::Spec->catfile('a','b');
 
-For a reference of available functions, please consult L<File::Spec::Unix>,
-which contains the entire set, and inherited by the modules for other
-platforms. For further information, please see L<File::Spec::Mac>,
+For simple uses, L<File::Spec::Functions> provides convenient functional
+forms of these methods.
+
+For a list of available methods, please consult L<File::Spec::Unix>,
+which contains the entire set, and which is inherited by the modules for
+other platforms. For further information, please see L<File::Spec::Mac>,
 L<File::Spec::OS2>, L<File::Spec::Win32>, or L<File::Spec::VMS>.
 
 =head1 SEE ALSO
 
 File::Spec::Unix, File::Spec::Mac, File::Spec::OS2, File::Spec::Win32,
-File::Spec::VMS, ExtUtils::MakeMaker
+File::Spec::VMS, File::Spec::Functions, ExtUtils::MakeMaker
 
 =head1 AUTHORS
 
@@ -109,8 +87,3 @@ Kenneth Albanowski <F<kjahds@kjahds.com>>, Andy Dougherty
 support by Charles Bailey <F<bailey@newman.upenn.edu>>.  OS/2 support by
 Ilya Zakharevich <F<ilya@math.ohio-state.edu>>. Mac support by Paul Schinder
 <F<schinder@pobox.com>>.
-
-=cut
-
-
-1;
diff --git a/lib/File/Spec/Functions.pm b/lib/File/Spec/Functions.pm
new file mode 100644 (file)
index 0000000..ffc1199
--- /dev/null
@@ -0,0 +1,91 @@
+package File::Spec::Functions;
+
+use File::Spec;
+use strict;
+
+use vars qw(@ISA @EXPORT @EXPORT_OK);
+
+require Exporter;
+
+@ISA = qw(Exporter);
+
+@EXPORT = qw(
+       canonpath
+       catdir
+       catfile
+       curdir
+       rootdir
+       updir
+       no_upwards
+       file_name_is_absolute
+       path
+);
+
+@EXPORT_OK = qw(
+       devnull
+       tmpdir
+       splitpath
+       splitdir
+       catpath
+       abs2rel
+       rel2abs
+);
+
+foreach my $meth (@EXPORT, @EXPORT_OK) {
+    my $sub = File::Spec->can($meth);
+    no strict 'refs';
+    *{$meth} = sub {&$sub('File::Spec', @_)};
+}
+
+
+1;
+__END__
+
+=head1 NAME
+
+File::Spec::Functions - portably perform operations on file names
+
+=head1 SYNOPSIS
+
+       use File::Spec::Functions;
+       $x = catfile('a','b');
+
+=head1 DESCRIPTION
+
+This module exports convenience functions for all of the class methods
+provided by File::Spec.
+
+For a reference of available functions, please consult L<File::Spec::Unix>,
+which contains the entire set, and which is inherited by the modules for
+other platforms. For further information, please see L<File::Spec::Mac>,
+L<File::Spec::OS2>, L<File::Spec::Win32>, or L<File::Spec::VMS>.
+
+=head2 Exports
+
+The following functions are exported by default.
+
+       canonpath
+       catdir
+       catfile
+       curdir
+       rootdir
+       updir
+       no_upwards
+       file_name_is_absolute
+       path
+
+
+The following functions are exported only by request.
+
+       devnull
+       tmpdir
+       splitpath
+       splitdir
+       catpath
+       abs2rel
+       rel2abs
+
+=head1 SEE ALSO
+
+File::Spec, File::Spec::Unix, File::Spec::Mac, File::Spec::OS2,
+File::Spec::Win32, File::Spec::VMS, ExtUtils::MakeMaker
index 63a9e12..e1f3c17 100644 (file)
@@ -1,18 +1,9 @@
 package File::Spec::Mac;
 
-use Exporter ();
-use Config;
 use strict;
-use File::Spec;
-use vars qw(@ISA $VERSION $Is_Mac);
-
-$VERSION = '1.0';
-
+use vars qw(@ISA);
+require File::Spec::Unix;
 @ISA = qw(File::Spec::Unix);
-$Is_Mac = $^O eq 'MacOS';
-
-Exporter::import('File::Spec', '$Verbose');
-
 
 =head1 NAME
 
@@ -20,7 +11,7 @@ File::Spec::Mac - File::Spec for MacOS
 
 =head1 SYNOPSIS
 
-C<require File::Spec::Mac;>
+ require File::Spec::Mac; # Done internally by File::Spec if needed
 
 =head1 DESCRIPTION
 
@@ -37,8 +28,8 @@ On MacOS, there's nothing to be done.  Returns what it's given.
 =cut
 
 sub canonpath {
-    my($self,$path) = @_;
-    $path;
+    my ($self,$path) = @_;
+    return $path;
 }
 
 =item catdir
@@ -84,20 +75,17 @@ aren't done here. This routine will treat this as absolute.
 
 =cut
 
-# ';
-
 sub catdir {
     shift;
     my @args = @_;
-       $args[0] =~ s/:$//;
-       my $result = shift @args;
-       for (@args) {
-               s/:$//;
-               s/^://;
-               $result .= ":$_";
+    my $result = shift @args;
+    $result =~ s/:$//;
+    foreach (@args) {
+       s/:$//;
+       s/^://;
+       $result .= ":$_";
     }
-    $result .= ":";
-       $result;
+    return "$result:";
 }
 
 =item catfile
@@ -118,50 +106,69 @@ give the same answer, as one might expect.
 =cut
 
 sub catfile {
-    my $self = shift @_;
+    my $self = shift;
     my $file = pop @_;
     return $file unless @_;
     my $dir = $self->catdir(@_);
-       $file =~ s/^://;
+    $file =~ s/^://;
     return $dir.$file;
 }
 
 =item curdir
 
-Returns a string representing of the current directory.
+Returns a string representing the current directory.
 
 =cut
 
 sub curdir {
-    return ":" ;
+    return ":";
+}
+
+=item devnull
+
+Returns a string representing the null device.
+
+=cut
+
+sub devnull {
+    return "Dev:Null";
 }
 
 =item rootdir
 
 Returns a string representing the root directory.  Under MacPerl,
 returns the name of the startup volume, since that's the closest in
-concept, although other volumes aren't rooted there.  On any other
-platform returns '', since there's no common way to indicate "root
-directory" across all Macs.
+concept, although other volumes aren't rooted there.
 
 =cut
 
 sub rootdir {
 #
-#  There's no real root directory on MacOS.  If you're using MacPerl,
-#  the name of the startup volume is returned, since that's the closest in
-#  concept.  On other platforms, simply return '', because nothing better
-#  can be done.
+#  There's no real root directory on MacOS.  The name of the startup
+#  volume is returned, since that's the closest in concept.
 #
-       if($Is_Mac) {
-        require Mac::Files;
-               my $system =  Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk,
-                       &Mac::Files::kSystemFolderType);
-               $system =~ s/:.*$/:/;
-               return $system;
-       } else {
-               return '';
-    }
+    require Mac::Files;
+    my $system =  Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk,
+                                        &Mac::Files::kSystemFolderType);
+    $system =~ s/:.*$/:/;
+    return $system;
+}
+
+=item tmpdir
+
+Returns a string representation of the first existing directory
+from the following list or '' if none exist:
+
+    $ENV{TMPDIR}
+
+=cut
+
+my $tmpdir;
+sub tmpdir {
+    return $tmpdir if defined $tmpdir;
+    $tmpdir = $ENV{TMPDIR} if -d $ENV{TMPDIR};
+    $tmpdir = '' unless defined $tmpdir;
+    return $tmpdir;
 }
 
 =item updir
@@ -185,11 +192,11 @@ distinguish unambiguously.
 =cut
 
 sub file_name_is_absolute {
-    my($self,$file) = @_;
-       if ($file =~ /:/) {
-               return ($file !~ m/^:/);
-       } else {
-               return (! -e ":$file");
+    my ($self,$file) = @_;
+    if ($file =~ /:/) {
+       return ($file !~ m/^:/);
+    } else {
+       return (! -e ":$file");
     }
 }
 
@@ -207,14 +214,8 @@ sub path {
 #  The concept is meaningless under the MacPerl application.
 #  Under MPW, it has a meaning.
 #
-    my($self) = @_;
-       my @path;
-       if(exists $ENV{Commands}) {
-               @path = split /,/,$ENV{Commands};
-       } else {
-           @path = ();
-       }
-    @path;
+    return unless exists $ENV{Commands};
+    return split(/,/, $ENV{Commands});
 }
 
 =back
@@ -226,5 +227,3 @@ L<File::Spec>
 =cut
 
 1;
-__END__
-
index d602617..985c411 100644 (file)
@@ -1,34 +1,40 @@
 package File::Spec::OS2;
 
-#use Config;
-#use Cwd;
-#use File::Basename;
 use strict;
-require Exporter;
-
-use File::Spec;
 use vars qw(@ISA);
-
-Exporter::import('File::Spec',
-       qw( $Verbose));
-
+require File::Spec::Unix;
 @ISA = qw(File::Spec::Unix);
 
-$ENV{EMXSHELL} = 'sh'; # to run `commands`
+sub devnull {
+    return "/dev/nul";
+}
 
 sub file_name_is_absolute {
-    my($self,$file) = @_;
-    $file =~ m{^([a-z]:)?[\\/]}i ;
+    my ($self,$file) = @_;
+    return scalar($file =~ m{^([a-z]:)?[\\/]}i);
 }
 
 sub path {
-    my($self) = @_;
-    my $path_sep = ";";
     my $path = $ENV{PATH};
     $path =~ s:\\:/:g;
-    my @path = split $path_sep, $path;
-    foreach(@path) { $_ = '.' if $_ eq '' }
-    @path;
+    my @path = split(';',$path);
+    foreach (@path) { $_ = '.' if $_ eq '' }
+    return @path;
+}
+
+my $tmpdir;
+sub tmpdir {
+    return $tmpdir if defined $tmpdir;
+    my $self = shift;
+    foreach (@ENV{qw(TMPDIR TEMP TMP)}, qw(/tmp /)) {
+       next unless defined && -d;
+       $tmpdir = $_;
+       last;
+    }
+    $tmpdir = '' unless defined $tmpdir;
+    $tmpdir =~ s:\\:/:g;
+    $tmpdir = $self->canonpath($tmpdir);
+    return $tmpdir;
 }
 
 1;
@@ -40,12 +46,10 @@ File::Spec::OS2 - methods for OS/2 file specs
 
 =head1 SYNOPSIS
 
- use File::Spec::OS2; # Done internally by File::Spec if needed
+ require File::Spec::OS2; # Done internally by File::Spec if needed
 
 =head1 DESCRIPTION
 
 See File::Spec::Unix for a documentation of the methods provided
 there. This package overrides the implementation of these methods, not
 the semantics.
-
-=cut
index 77de73a..87ad643 100644 (file)
@@ -1,23 +1,8 @@
 package File::Spec::Unix;
 
-use Exporter ();
-use Config;
-use File::Basename qw(basename dirname fileparse);
-use DirHandle;
 use strict;
-use vars qw(@ISA $Is_Mac $Is_OS2 $Is_VMS $Is_Win32);
-use File::Spec;
 
-Exporter::import('File::Spec', '$Verbose');
-
-$Is_OS2 = $^O eq 'os2';
-$Is_Mac = $^O eq 'MacOS';
-$Is_Win32 = $^O eq 'MSWin32';
-
-if ($Is_VMS = $^O eq 'VMS') {
-    require VMS::Filespec;
-    import VMS::Filespec qw( &vmsify );
-}
+use Cwd;
 
 =head1 NAME
 
@@ -25,7 +10,7 @@ File::Spec::Unix - methods used by File::Spec
 
 =head1 SYNOPSIS
 
-C<require File::Spec::Unix;>
+ require File::Spec::Unix; # Done automatically by File::Spec
 
 =head1 DESCRIPTION
 
@@ -40,15 +25,31 @@ Methods for manipulating file specifications.
 No physical check on the filesystem, but a logical cleanup of a
 path. On UNIX eliminated successive slashes and successive "/.".
 
+    $cpath = File::Spec->canonpath( $path ) ;
+    $cpath = File::Spec->canonpath( $path, $reduce_ricochet ) ;
+
+If $reduce_ricochet is present and true, then "dirname/.." 
+constructs are eliminated from the path. Without $reduce_ricochet,
+if dirname is a symbolic link, then "a/dirname/../b" will often 
+take you to someplace other than "a/b". This is sometimes desirable.
+If it's not, setting $reduce_ricochet causes the "dirname/.." to
+be removed from this path, resulting in "a/b".  This may make
+your perl more portable and robust, unless you want to
+ricochet (some scripts depend on it).
+
 =cut
 
 sub canonpath {
-    my($self,$path) = @_;
-    $path =~ s|/+|/|g ;                            # xx////xx  -> xx/xx
-    $path =~ s|(/\.)+/|/|g ;                       # xx/././xx -> xx/xx
+    my ($self,$path,$reduce_ricochet) = @_;
+    $path =~ s|/+|/|g unless($^O =~ /cygwin/);     # xx////xx  -> xx/xx
+    $path =~ s|(/\.)+/|/|g;                        # xx/././xx -> xx/xx
     $path =~ s|^(\./)+|| unless $path eq "./";     # ./xx      -> xx
+    $path =~ s|^/(\.\./)+|/|;                      # /../../xx -> xx
+    if ( $reduce_ricochet ) {
+        while ( $path =~ s@[^/]+/\.\.(?:/|$)@@ ) {}# xx/..     -> xx
+    }
     $path =~ s|/$|| unless $path eq "/";           # xx/       -> xx
-    $path;
+    return $path;
 }
 
 =item catdir
@@ -61,20 +62,14 @@ trailing slash :-)
 
 =cut
 
-# ';
-
 sub catdir {
-    shift;
+    my $self = shift;
     my @args = @_;
-    for (@args) {
+    foreach (@args) {
        # append a slash to each argument unless it has one there
-       $_ .= "/" if $_ eq '' or substr($_,-1) ne "/";
+       $_ .= "/" if $_ eq '' || substr($_,-1) ne "/";
     }
-    my $result = join('', @args);
-    # remove a trailing slash unless we are root
-    substr($result,-1) = ""
-       if length($result) > 1 && substr($result,-1) eq "/";
-    $result;
+    return $self->canonpath(join('', @args));
 }
 
 =item catfile
@@ -85,29 +80,37 @@ complete path ending with a filename
 =cut
 
 sub catfile {
-    my $self = shift @_;
+    my $self = shift;
     my $file = pop @_;
     return $file unless @_;
     my $dir = $self->catdir(@_);
-    for ($dir) {
-       $_ .= "/" unless substr($_,length($_)-1,1) eq "/";
-    }
+    $dir .= "/" unless substr($dir,-1) eq "/";
     return $dir.$file;
 }
 
 =item curdir
 
-Returns a string representing of the current directory.  "." on UNIX.
+Returns a string representation of the current directory.  "." on UNIX.
 
 =cut
 
 sub curdir {
-    return "." ;
+    return ".";
+}
+
+=item devnull
+
+Returns a string representation of the null device. "/dev/null" on UNIX.
+
+=cut
+
+sub devnull {
+    return "/dev/null";
 }
 
 =item rootdir
 
-Returns a string representing of the root directory.  "/" on UNIX.
+Returns a string representation of the root directory.  "/" on UNIX.
 
 =cut
 
@@ -115,9 +118,31 @@ sub rootdir {
     return "/";
 }
 
+=item tmpdir
+
+Returns a string representation of the first writable directory
+from the following list or "" if none are writable:
+
+    $ENV{TMPDIR}
+    /tmp
+
+=cut
+
+my $tmpdir;
+sub tmpdir {
+    return $tmpdir if defined $tmpdir;
+    foreach ($ENV{TMPDIR}, "/tmp") {
+       next unless defined && -d && -w _;
+       $tmpdir = $_;
+       last;
+    }
+    $tmpdir = '' unless defined $tmpdir;
+    return $tmpdir;
+}
+
 =item updir
 
-Returns a string representing of the parent directory.  ".." on UNIX.
+Returns a string representation of the parent directory.  ".." on UNIX.
 
 =cut
 
@@ -133,7 +158,7 @@ directory. (Does not strip symlinks, only '.', '..', and equivalents.)
 =cut
 
 sub no_upwards {
-    my($self) = shift;
+    my $self = shift;
     return grep(!/^\.{1,2}$/, @_);
 }
 
@@ -144,8 +169,8 @@ Takes as argument a path and returns true, if it is an absolute path.
 =cut
 
 sub file_name_is_absolute {
-    my($self,$file) = @_;
-    $file =~ m:^/: ;
+    my ($self,$file) = @_;
+    return scalar($file =~ m:^/:);
 }
 
 =item path
@@ -155,12 +180,9 @@ Takes no argument, returns the environment variable PATH as an array.
 =cut
 
 sub path {
-    my($self) = @_;
-    my $path_sep = ":";
-    my $path = $ENV{PATH};
-    my @path = split $path_sep, $path;
-    foreach(@path) { $_ = '.' if $_ eq '' }
-    @path;
+    my @path = split(':', $ENV{PATH});
+    foreach (@path) { $_ = '.' if $_ eq '' }
+    return @path;
 }
 
 =item join
@@ -170,21 +192,245 @@ join is the same as catfile.
 =cut
 
 sub join {
-       my($self) = shift @_;
-       $self->catfile(@_);
+    my $self = shift;
+    return $self->catfile(@_);
 }
 
-=item nativename
+=item splitpath
+
+    ($volume,$directories,$file) = File::Spec->splitpath( $path );
+    ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
+
+Splits a path in to volume, directory, and filename portions. On systems
+with no concept of volume, returns undef for volume. 
+
+For systems with no syntax differentiating filenames from directories, 
+assumes that the last file is a path unless $no_file is true or a 
+trailing separator or /. or /.. is present. On Unix this means that $no_file
+true makes this return ( '', $path, '' ).
+
+The directory portion may or may not be returned with a trailing '/'.
 
-TBW.
+The results can be passed to L</catpath()> to get back a path equivalent to
+(usually identical to) the original path.
 
 =cut
 
-sub nativename {
-       my($self,$name) = shift @_;
-       $name;
+sub splitpath {
+    my ($self,$path, $nofile) = @_;
+
+    my ($volume,$directory,$file) = ('','','');
+
+    if ( $nofile ) {
+        $directory = $path;
+    }
+    else {
+        $path =~ m|^ ( (?: .* / (?: \.\.?$ )? )? ) ([^/]*) |x;
+        $directory = $1;
+        $file      = $2;
+    }
+
+    return ($volume,$directory,$file);
 }
 
+
+=item splitdir
+
+The opposite of L</catdir()>.
+
+    @dirs = File::Spec->splitdir( $directories );
+
+$directories must be only the directory portion of the path on systems 
+that have the concept of a volume or that have path syntax that differentiates
+files from directories.
+
+Unlike just splitting the directories on the separator, leading empty and 
+trailing directory entries can be returned, because these are significant
+on some OSs. So,
+
+    File::Spec->splitdir( "/a/b/c" );
+
+Yields:
+
+    ( '', 'a', 'b', '', 'c', '' )
+
+=cut
+
+sub splitdir {
+    my ($self,$directories) = @_ ;
+    #
+    # split() likes to forget about trailing null fields, so here we
+    # check to be sure that there will not be any before handling the
+    # simple case.
+    #
+    if ( $directories !~ m|/$| ) {
+        return split( m|/|, $directories );
+    }
+    else {
+        #
+        # since there was a trailing separator, add a file name to the end, 
+        # then do the split, then replace it with ''.
+        #
+        my( @directories )= split( m|/|, "${directories}dummy" ) ;
+        $directories[ $#directories ]= '' ;
+        return @directories ;
+    }
+}
+
+
+=item catpath
+
+Takes volume, directory and file portions and returns an entire path. Under
+Unix, $volume is ignored, and this is just like catfile(). On other OSs,
+the $volume become significant.
+
+=cut
+
+sub catpath {
+    my ($self,$volume,$directory,$file) = @_;
+
+    if ( $directory ne ''                && 
+         $file ne ''                     && 
+         substr( $directory, -1 ) ne '/' && 
+         substr( $file, 0, 1 ) ne '/' 
+    ) {
+        $directory .= "/$file" ;
+    }
+    else {
+        $directory .= $file ;
+    }
+
+    return $directory ;
+}
+
+=item abs2rel
+
+Takes a destination path and an optional base path returns a relative path
+from the base path to the destination path:
+
+    $rel_path = File::Spec->abs2rel( $destination ) ;
+    $rel_path = File::Spec->abs2rel( $destination, $base ) ;
+
+If $base is not present or '', then L<cwd()> is used. If $base is relative, 
+then it is converted to absolute form using L</rel2abs()>. This means that it
+is taken to be relative to L<cwd()>.
+
+On systems with the concept of a volume, this assumes that both paths 
+are on the $destination volume, and ignores the $base volume. 
+
+On systems that have a grammar that indicates filenames, this ignores the 
+$base filename as well. Otherwise all path components are assumed to be
+directories.
+
+If $path is relative, it is converted to absolute form using L</rel2abs()>.
+This means that it is taken to be relative to L<cwd()>.
+
+Based on code written by Shigio Yamaguchi.
+
+No checks against the filesystem are made. 
+
+=cut
+
+sub abs2rel {
+    my($self,$path,$base) = @_;
+
+    # Clean up $path
+    if ( ! $self->file_name_is_absolute( $path ) ) {
+        $path = $self->rel2abs( $path ) ;
+    }
+    else {
+        $path = $self->canonpath( $path ) ;
+    }
+
+    # Figure out the effective $base and clean it up.
+    if ( !defined( $base ) || $base eq '' ) {
+        $base = cwd() ;
+    }
+    elsif ( ! $self->file_name_is_absolute( $base ) ) {
+        $base = $self->rel2abs( $base ) ;
+    }
+    else {
+        $base = $self->canonpath( $base ) ;
+    }
+
+    # 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]) {
+        shift @pathchunks ;
+        shift @basechunks ;
+    }
+
+    $path = CORE::join( '/', @pathchunks );
+    $base = CORE::join( '/', @basechunks );
+
+    # $base 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 ;
+
+    # 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" ;
+    }
+
+    return $self->canonpath( $path ) ;
+}
+
+=item rel2abs
+
+Converts a relative path to an absolute path. 
+
+    $abs_path = $File::Spec->rel2abs( $destination ) ;
+    $abs_path = $File::Spec->rel2abs( $destination, $base ) ;
+
+If $base is not present or '', then L<cwd()> is used. If $base is relative, 
+then it is converted to absolute form using L</rel2abs()>. This means that it
+is taken to be relative to L<cwd()>.
+
+On systems with the concept of a volume, this assumes that both paths 
+are on the $base volume, and ignores the $destination volume. 
+
+On systems that have a grammar that indicates filenames, this ignores the 
+$base filename as well. Otherwise all path components are assumed to be
+directories.
+
+If $path is absolute, it is cleaned up and returned using L</canonpath()>.
+
+Based on code written by Shigio Yamaguchi.
+
+No checks against the filesystem are made. 
+
+=cut
+
+sub rel2abs($;$;) {
+    my ($self,$path,$base ) = @_;
+
+    # Clean up $path
+    if ( ! $self->file_name_is_absolute( $path ) ) {
+        # Figure out the effective $base and clean it up.
+        if ( !defined( $base ) || $base eq '' ) {
+            $base = cwd() ;
+        }
+        elsif ( ! $self->file_name_is_absolute( $base ) ) {
+            $base = $self->rel2abs( $base ) ;
+        }
+        else {
+            $base = $self->canonpath( $base ) ;
+        }
+
+        # Glom them together
+        $path = $self->catdir( $base, $path ) ;
+    }
+
+    return $self->canonpath( $path ) ;
+}
+
+
 =back
 
 =head1 SEE ALSO
@@ -194,4 +440,3 @@ L<File::Spec>
 =cut
 
 1;
-__END__
index c5269fd..d13f5e6 100644 (file)
@@ -1,19 +1,12 @@
-
 package File::Spec::VMS;
 
-use Carp qw( &carp );
-use Config;
-require Exporter;
-use VMS::Filespec;
-use File::Basename;
-
-use File::Spec;
-use vars qw($Revision);
-$Revision = '5.3901 (6-Mar-1997)';
-
+use strict;
+use vars qw(@ISA);
+require File::Spec::Unix;
 @ISA = qw(File::Spec::Unix);
 
-Exporter::import('File::Spec', '$Verbose');
+use File::Basename;
+use VMS::Filespec;
 
 =head1 NAME
 
@@ -21,7 +14,7 @@ File::Spec::VMS - methods for VMS file specs
 
 =head1 SYNOPSIS
 
- use File::Spec::VMS; # Done internally by File::Spec if needed
+ require File::Spec::VMS; # Done internally by File::Spec if needed
 
 =head1 DESCRIPTION
 
@@ -29,6 +22,74 @@ See File::Spec::Unix for a documentation of the methods provided
 there. This package overrides the implementation of these methods, not
 the semantics.
 
+=cut
+
+sub eliminate_macros {
+    my($self,$path) = @_;
+    return '' unless $path;
+    $self = {} unless ref $self;
+    my($npath) = unixify($path);
+    my($complex) = 0;
+    my($head,$macro,$tail);
+
+    # perform m##g in scalar context so it acts as an iterator
+    while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#g) { 
+        if ($self->{$2}) {
+            ($head,$macro,$tail) = ($1,$2,$3);
+            if (ref $self->{$macro}) {
+                if (ref $self->{$macro} eq 'ARRAY') {
+                    $macro = join ' ', @{$self->{$macro}};
+                }
+                else {
+                    print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
+                          "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
+                    $macro = "\cB$macro\cB";
+                    $complex = 1;
+                }
+            }
+            else { ($macro = unixify($self->{$macro})) =~ s#/$##; }
+            $npath = "$head$macro$tail";
+        }
+    }
+    if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#g; }
+    $npath;
+}
+
+sub fixpath {
+    my($self,$path,$force_path) = @_;
+    return '' unless $path;
+    $self = bless {} unless ref $self;
+    my($fixedpath,$prefix,$name);
+
+    if ($path =~ m#^\$\([^\)]+\)$# || $path =~ m#[/:>\]]#) { 
+        if ($force_path or $path =~ /(?:DIR\)|\])$/) {
+            $fixedpath = vmspath($self->eliminate_macros($path));
+        }
+        else {
+            $fixedpath = vmsify($self->eliminate_macros($path));
+        }
+    }
+    elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#)) && $self->{$prefix}) {
+        my($vmspre) = $self->eliminate_macros("\$($prefix)");
+        # is it a dir or just a name?
+        $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR$/) ? vmspath($vmspre) : '';
+        $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
+        $fixedpath = vmspath($fixedpath) if $force_path;
+    }
+    else {
+        $fixedpath = $path;
+        $fixedpath = vmspath($fixedpath) if $force_path;
+    }
+    # No hints, so we try to guess
+    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/;
+    $fixedpath;
+}
+
+
 =head2 Methods always loaded
 
 =over
@@ -41,23 +102,22 @@ VMS-syntax directory specification.
 =cut
 
 sub catdir {
-    my($self,@dirs) = @_;
-    my($dir) = pop @dirs;
+    my ($self,@dirs) = @_;
+    my $dir = pop @dirs;
     @dirs = grep($_,@dirs);
-    my($rslt);
+    my $rslt;
     if (@dirs) {
-      my($path) = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
-      my($spath,$sdir) = ($path,$dir);
-      $spath =~ s/.dir$//; $sdir =~ s/.dir$//; 
-      $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/;
-      $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
+       my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
+       my ($spath,$sdir) = ($path,$dir);
+       $spath =~ s/.dir$//; $sdir =~ s/.dir$//; 
+       $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/;
+       $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
     }
-    else { 
-      if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; }
-      else                          { $rslt = vmspath($dir); }
+    else {
+       if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; }
+       else                          { $rslt = vmspath($dir); }
     }
-    print "catdir(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3;
-    $rslt;
+    return $rslt;
 }
 
 =item catfile
@@ -68,28 +128,29 @@ VMS-syntax directory specification.
 =cut
 
 sub catfile {
-    my($self,@files) = @_;
-    my($file) = pop @files;
+    my ($self,@files) = @_;
+    my $file = pop @files;
     @files = grep($_,@files);
-    my($rslt);
+    my $rslt;
     if (@files) {
-      my($path) = (@files == 1 ? $files[0] : $self->catdir(@files));
-      my($spath) = $path;
-      $spath =~ s/.dir$//;
-      if ( $spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) { $rslt = "$spath$file"; }
-      else {
-          $rslt = $self->eliminate_macros($spath);
-          $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
-      }
+       my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
+       my $spath = $path;
+       $spath =~ s/.dir$//;
+       if ($spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) {
+           $rslt = "$spath$file";
+       }
+       else {
+           $rslt = $self->eliminate_macros($spath);
+           $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
+       }
     }
     else { $rslt = vmsify($file); }
-    print "catfile(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3;
-    $rslt;
+    return $rslt;
 }
 
 =item curdir (override)
 
-Returns a string representing of the current directory.
+Returns a string representation of the current directory: '[]'
 
 =cut
 
@@ -97,19 +158,51 @@ sub curdir {
     return '[]';
 }
 
+=item devnull (override)
+
+Returns a string representation of the null device: '_NLA0:'
+
+=cut
+
+sub devnull {
+    return "_NLA0:";
+}
+
 =item rootdir (override)
 
-Returns a string representing of the root directory.
+Returns a string representation of the root directory: 'SYS$DISK:[000000]'
 
 =cut
 
 sub rootdir {
-    return '';
+    return 'SYS$DISK:[000000]';
+}
+
+=item tmpdir (override)
+
+Returns a string representation of the first writable directory
+from the following list or '' if none are writable:
+
+    /sys$scratch
+    $ENV{TMPDIR}
+
+=cut
+
+my $tmpdir;
+sub tmpdir {
+    return $tmpdir if defined $tmpdir;
+    foreach ('/sys$scratch', $ENV{TMPDIR}) {
+       next unless defined && -d && -w _;
+       $tmpdir = $_;
+       last;
+    }
+    $tmpdir = '' unless defined $tmpdir;
+    return $tmpdir;
 }
 
 =item updir (override)
 
-Returns a string representing of the parent directory.
+Returns a string representation of the parent directory: '[-]'
 
 =cut
 
@@ -125,9 +218,9 @@ to C<split> string value of C<$ENV{'PATH'}>.
 =cut
 
 sub path {
-    my(@dirs,$dir,$i);
+    my (@dirs,$dir,$i);
     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
-    @dirs;
+    return @dirs;
 }
 
 =item file_name_is_absolute (override)
@@ -137,12 +230,20 @@ Checks for VMS directory spec as well as Unix separators.
 =cut
 
 sub file_name_is_absolute {
-    my($self,$file) = @_;
+    my ($self,$file) = @_;
     # If it's a logical name, expand it.
-    $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ and $ENV{$file};
-    $file =~ m!^/! or $file =~ m![<\[][^.\-\]>]! or $file =~ /:[^<\[]/;
+    $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ && $ENV{$file};
+    return scalar($file =~ m!^/!              ||
+                 $file =~ m![<\[][^.\-\]>]!  ||
+                 $file =~ /:[^<\[]/);
 }
 
-1;
-__END__
+=back
+
+=head1 SEE ALSO
 
+L<File::Spec>
+
+=cut
+
+1;
index 034a0cb..0ea4970 100644 (file)
@@ -1,12 +1,18 @@
 package File::Spec::Win32;
 
+use strict;
+use Cwd;
+use vars qw(@ISA);
+require File::Spec::Unix;
+@ISA = qw(File::Spec::Unix);
+
 =head1 NAME
 
 File::Spec::Win32 - methods for Win32 file specs
 
 =head1 SYNOPSIS
 
- use File::Spec::Win32; # Done internally by File::Spec if needed
+ require File::Spec::Win32; # Done internally by File::Spec if needed
 
 =head1 DESCRIPTION
 
@@ -16,37 +22,46 @@ the semantics.
 
 =over
 
-=cut 
+=item devnull
 
-#use Config;
-#use Cwd;
-use File::Basename;
-require Exporter;
-use strict;
+Returns a string representation of the null device.
 
-use vars qw(@ISA);
+=cut
 
-use File::Spec;
-Exporter::import('File::Spec', qw( $Verbose));
+sub devnull {
+    return "nul";
+}
 
-@ISA = qw(File::Spec::Unix);
+=item tmpdir
 
-$ENV{EMXSHELL} = 'sh'; # to run `commands`
+Returns a string representation of the first existing directory
+from the following list:
 
-sub file_name_is_absolute {
-    my($self,$file) = @_;
-    $file =~ m{^([a-z]:)?[\\/]}i ;
-}
+    $ENV{TMPDIR}
+    $ENV{TEMP}
+    $ENV{TMP}
+    /tmp
+    /
 
-sub catdir {
+=cut
+
+my $tmpdir;
+sub tmpdir {
+    return $tmpdir if defined $tmpdir;
     my $self = shift;
-    my @args = @_;
-    for (@args) {
-       # append a slash to each argument unless it has one there
-       $_ .= "\\" if $_ eq '' or substr($_,-1) ne "\\";
+    foreach (@ENV{qw(TMPDIR TEMP TMP)}, qw(/tmp /)) {
+       next unless defined && -d;
+       $tmpdir = $_;
+       last;
     }
-    my $result = $self->canonpath(join('', @args));
-    $result;
+    $tmpdir = '' unless defined $tmpdir;
+    $tmpdir = $self->canonpath($tmpdir);
+    return $tmpdir;
+}
+
+sub file_name_is_absolute {
+    my ($self,$file) = @_;
+    return scalar($file =~ m{^([a-z]:)?[\\/]}i);
 }
 
 =item catfile
@@ -57,22 +72,20 @@ complete path ending with a filename
 =cut
 
 sub catfile {
-    my $self = shift @_;
+    my $self = shift;
     my $file = pop @_;
     return $file unless @_;
     my $dir = $self->catdir(@_);
-    $dir =~ s/(\\\.)$//;
-    $dir .= "\\" unless substr($dir,length($dir)-1,1) eq "\\";
+    $dir .= "\\" unless substr($dir,-1) eq "\\";
     return $dir.$file;
 }
 
 sub path {
     local $^W = 1;
-    my($self) = @_;
     my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
     my @path = split(';',$path);
-    foreach(@path) { $_ = '.' if $_ eq '' }
-    @path;
+    foreach (@path) { $_ = '.' if $_ eq '' }
+    return @path;
 }
 
 =item canonpath
@@ -83,22 +96,303 @@ path. On UNIX eliminated successive slashes and successive "/.".
 =cut
 
 sub canonpath {
-    my($self,$path) = @_;
+    my ($self,$path,$reduce_ricochet) = @_;
     $path =~ s/^([a-z]:)/\u$1/;
     $path =~ s|/|\\|g;
-    $path =~ s|\\+|\\|g ;                          # xx////xx  -> xx/xx
-    $path =~ s|(\\\.)+\\|\\|g ;                    # xx/././xx -> xx/xx
+    $path =~ s|([^\\])\\+|$1\\|g;                  # xx////xx  -> xx/xx
+    $path =~ s|(\\\.)+\\|\\|g;                     # xx/././xx -> xx/xx
     $path =~ s|^(\.\\)+|| unless $path eq ".\\";   # ./xx      -> xx
-    $path =~ s|\\$|| 
-             unless $path =~ m#^([a-z]:)?\\#;      # xx/       -> xx
-    $path .= '.' if $path =~ m#\\$#;
-    $path;
+    $path =~ s|\\$||
+             unless $path =~ m#^([A-Z]:)?\\$#;     # xx/       -> xx
+    return $path;
 }
 
-1;
-__END__
+=item splitpath
+
+    ($volume,$directories,$file) = File::Spec->splitpath( $path );
+    ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
+
+Splits a path in to volume, directory, and filename portions. Assumes that 
+the last file is a path unless the path ends in '\\', '\\.', '\\..'
+or $no_file is true.  On Win32 this means that $no_file true makes this return 
+( $volume, $path, undef ).
+
+Separators accepted are \ and /.
+
+Volumes can be drive letters or UNC sharenames (\\server\share).
+
+The results can be passed to L</catpath()> to get back a path equivalent to
+(usually identical to) the original path.
+
+=cut
+
+sub splitpath {
+    my ($self,$path, $nofile) = @_;
+    my ($volume,$directory,$file) = ('','','');
+    if ( $nofile ) {
+        $path =~ 
+            m@^( (?:[a-zA-Z]:|(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+)? ) 
+                 (.*)
+             @x;
+        $volume    = $1;
+        $directory = $2;
+    }
+    else {
+        $path =~ 
+            m@^ ( (?: [a-zA-Z]: |
+                      (?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+
+                  )?
+                )
+                ( (?:.*[\\\\/](?:\.\.?$)?)? )
+                (.*)
+             @x;
+        $volume    = $1;
+        $directory = $2;
+        $file      = $3;
+    }
+
+    return ($volume,$directory,$file);
+}
+
+
+=item splitdir
+
+The opposite of L</catdir()>.
+
+    @dirs = File::Spec->splitdir( $directories );
+
+$directories must be only the directory portion of the path on systems 
+that have the concept of a volume or that have path syntax that differentiates
+files from directories.
+
+Unlike just splitting the directories on the separator, leading empty and 
+trailing directory entries can be returned, because these are significant
+on some OSs. So,
+
+    File::Spec->splitdir( "/a/b/c" );
+
+Yields:
+
+    ( '', 'a', 'b', '', 'c', '' )
+
+=cut
+
+sub splitdir {
+    my ($self,$directories) = @_ ;
+    #
+    # split() likes to forget about trailing null fields, so here we
+    # check to be sure that there will not be any before handling the
+    # simple case.
+    #
+    if ( $directories !~ m|[\\/]$| ) {
+        return split( m|[\\/]|, $directories );
+    }
+    else {
+        #
+        # since there was a trailing separator, add a file name to the end, 
+        # then do the split, then replace it with ''.
+        #
+        my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
+        $directories[ $#directories ]= '' ;
+        return @directories ;
+    }
+}
+
+
+=item catpath
+
+Takes volume, directory and file portions and returns an entire path. Under
+Unix, $volume is ignored, and this is just like catfile(). On other OSs,
+the $volume become significant.
+
+=cut
+
+sub catpath {
+    my ($self,$volume,$directory,$file) = @_;
+
+    # If it's UNC, make sure the glue separator is there, reusing
+    # whatever separator is first in the $volume
+    $volume .= $1
+        if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+$@ &&
+             $directory =~ m@^[^\\/]@
+           ) ;
+
+    $volume .= $directory ;
+
+    # If the volume is not just A:, make sure the glue separator is 
+    # there, reusing whatever separator is first in the $volume if possible.
+    if ( $volume !~ m@^[a-zA-Z]:$@ &&
+         $volume !~ m@[\\/]$@      &&
+         $file   !~ m@^[\\/]@
+       ) {
+        $volume =~ m@([\\/])@ ;
+        my $sep = $1 ? $1 : '\\' ;
+        $volume .= $sep ;
+    }
+
+    $volume .= $file ;
+
+    return $volume ;
+}
+
+
+=item abs2rel
+
+Takes a destination path and an optional base path returns a relative path
+from the base path to the destination path:
+
+    $rel_path = File::Spec->abs2rel( $destination ) ;
+    $rel_path = File::Spec->abs2rel( $destination, $base ) ;
+
+If $base is not present or '', then L</cwd()> is used. If $base is relative, 
+then it is converted to absolute form using L</rel2abs()>. This means that it
+is taken to be relative to L<cwd()>.
+
+On systems with the concept of a volume, this assumes that both paths 
+are on the $destination volume, and ignores the $base volume. 
+
+On systems that have a grammar that indicates filenames, this ignores the 
+$base filename as well. Otherwise all path components are assumed to be
+directories.
+
+If $path is relative, it is converted to absolute form using L</rel2abs()>.
+This means that it is taken to be relative to L</cwd()>.
+
+Based on code written by Shigio Yamaguchi.
+
+No checks against the filesystem are made. 
+
+=cut
+
+sub abs2rel {
+    my($self,$path,$base) = @_;
+
+    # Clean up $path
+    if ( ! $self->file_name_is_absolute( $path ) ) {
+        $path = $self->rel2abs( $path ) ;
+    }
+    else {
+        $path = $self->canonpath( $path ) ;
+    }
+
+    # Figure out the effective $base and clean it up.
+    if ( ! $self->file_name_is_absolute( $base ) ) {
+        $base = $self->rel2abs( $base ) ;
+    }
+    elsif ( !defined( $base ) || $base eq '' ) {
+        $base = cwd() ;
+    }
+    else {
+        $base = $self->canonpath( $base ) ;
+    }
+
+    # Split up paths
+    my ( $path_volume, $path_directories, $path_file ) =
+        $self->splitpath( $path, 1 ) ;
+
+    my ( undef, $base_directories, undef ) =
+        $self->splitpath( $base, 1 ) ;
+
+    # Now, remove all leading components that are the same
+    my @pathchunks = $self->splitdir( $path_directories );
+    my @basechunks = $self->splitdir( $base_directories );
+
+    while ( @pathchunks && 
+            @basechunks && 
+            lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
+          ) {
+        shift @pathchunks ;
+        shift @basechunks ;
+    }
+
+    # No need to catdir, we know these are well formed.
+    $path_directories = CORE::join( '\\', @pathchunks );
+    $base_directories = CORE::join( '\\', @basechunks );
+
+    # $base 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_directories =~ s|[^/]+|..|g ;
+
+    # Glue the two together, using a separator if necessary, and preventing an
+    # empty result.
+    if ( $path ne '' && $base ne '' ) {
+        $path_directories = "$base_directories\\$path_directories" ;
+    } else {
+        $path_directories = "$base_directories$path_directories" ;
+    }
+
+    return $self->canonpath( 
+        $self->catpath( $path_volume, $path_directories, $path_file )
+    ) ;
+}
+
+=item rel2abs
+
+Converts a relative path to an absolute path. 
+
+    $abs_path = $File::Spec->rel2abs( $destination ) ;
+    $abs_path = $File::Spec->rel2abs( $destination, $base ) ;
+
+If $base is not present or '', then L<cwd()> is used. If $base is relative, 
+then it is converted to absolute form using L</rel2abs()>. This means that it
+is taken to be relative to L</cwd()>.
+
+Assumes that both paths are on the $base volume, and ignores the 
+$destination volume. 
+
+On systems that have a grammar that indicates filenames, this ignores the 
+$base filename as well. Otherwise all path components are assumed to be
+directories.
+
+If $path is absolute, it is cleaned up and returned using L</canonpath()>.
+
+Based on code written by Shigio Yamaguchi.
+
+No checks against the filesystem are made. 
+
+=cut
+
+sub rel2abs($;$;) {
+    my ($self,$path,$base ) = @_;
+
+    # Clean up and split up $path
+    if ( ! $self->file_name_is_absolute( $path ) ) {
+
+        # Figure out the effective $base and clean it up.
+        if ( ! $self->file_name_is_absolute( $base ) ) {
+            $base = $self->rel2abs( $base ) ;
+        }
+        elsif ( !defined( $base ) || $base eq '' ) {
+            $base = cwd() ;
+        }
+        else {
+            $base = $self->canonpath( $base ) ;
+        }
+
+        # Split up paths
+        my ( undef, $path_directories, $path_file ) =
+            $self->splitpath( $path, 1 ) ;
+
+        my ( $base_volume, $base_directories, undef ) =
+            $self->splitpath( $base, 1 ) ;
+
+        $path = $self->catpath( 
+            $base_volume, 
+            $self->catdir( $base_directories, $path_directories ), 
+            $path_file
+        ) ;
+    }
+
+    return $self->canonpath( $path ) ;
+}
 
 =back
 
-=cut 
+=head1 SEE ALSO
+
+L<File::Spec>
 
+=cut
+
+1;
index e71afa8..5238a1a 100644 (file)
@@ -2,9 +2,10 @@ package Pod::Html;
 
 use Pod::Functions;
 use Getopt::Long;      # package for handling command-line parameters
+use File::Spec::Unix;
 require Exporter;
 use vars qw($VERSION);
-$VERSION = 1.01;
+$VERSION = 1.02;
 @ISA = Exporter;
 @EXPORT = qw(pod2html htmlify);
 use Cwd;
@@ -44,6 +45,15 @@ Pod::Html takes the following arguments:
 
 Displays the usage message.
 
+=item htmldir
+
+    --htmldir=name
+
+Sets the directory in which the resulting HTML file is placed.  This
+is used to generate relative links to other files. Not passing this
+causes all links to be absolute, since this is the value that tells
+Pod::Html the root of the documentation tree.
+
 =item htmlroot
 
     --htmlroot=name
@@ -127,12 +137,24 @@ Do not recurse into subdirectories specified in podpath.
 
 Specify the title of the resulting HTML file.
 
+=item css
+
+    --css=stylesheet
+
+Specify the URL of a cascading style sheet.
+
 =item verbose
 
     --verbose
 
 Display progress messages.
 
+=item quiet
+
+    --quiet
+
+Don't display I<mostly harmless> warning messages.
+
 =back
 
 =head1 EXAMPLE
@@ -146,6 +168,10 @@ Display progress messages.
             "--infile=foo.pod",
             "--outfile=/perl/nmanual/foo.html");
 
+=head1 ENVIRONMENT
+
+Uses $Config{pod2html} to setup default options.
+
 =head1 AUTHOR
 
 Tom Christiansen, E<lt>tchrist@perl.comE<gt>.
@@ -164,20 +190,29 @@ This program is distributed under the Artistic License.
 
 =cut
 
-my $dircache = "pod2html-dircache";
-my $itemcache = "pod2html-itemcache";
+my $cache_ext = $^O eq 'VMS' ? ".tmp" : ".x~~";
+my $dircache = "pod2htmd$cache_ext";
+my $itemcache = "pod2htmi$cache_ext";
 
 my @begin_stack = ();          # begin/end stack
 
 my @libpods = ();              # files to search for links from C<> directives
 my $htmlroot = "/";            # http-server base directory from which all
                                #   relative paths in $podpath stem.
+my $htmldir = "";              # The directory to which the html pages
+                               # will (eventually) be written.
 my $htmlfile = "";             # write to stdout by default
+my $htmlfileurl = "" ;         # The url that other files would use to
+                               # refer to this file.  This is only used
+                               # to make relative urls that point to
+                               # other files.
 my $podfile = "";              # read from stdin by default
 my @podpath = ();              # list of directories containing library pods.
 my $podroot = ".";             # filesystem base directory from which all
                                #   relative paths in $podpath stem.
+my $css = '';                   # Cascading style sheet
 my $recurse = 1;               # recurse on subdirectories in $podpath.
+my $quiet = 0;                 # not quiet by default
 my $verbose = 0;               # not verbose by default
 my $doindex = 1;               # non-zero if we should generate an index
 my $listlevel = 0;             # current list depth
@@ -196,6 +231,7 @@ my %items_named = ();               # for the multiples of the same item in perlfunc
 my @items_seen = ();
 my $netscape = 0;              # whether or not to use netscape directives.
 my $title;                     # title to give the pod(s)
+my $header = 0;                        # produce block header/footer
 my $top = 1;                   # true if we are at the top of the doc.  used
                                #   to prevent the first <HR> directive.
 my $paragraph;                 # which paragraph we're processing (used
@@ -208,8 +244,8 @@ my %items = ();                     # associative array used to find the location
 my $Is83;                       # is dos with short filenames (8.3)
 
 sub init_globals {
-$dircache = "pod2html-dircache";
-$itemcache = "pod2html-itemcache";
+$dircache = "pod2htmd$cache_ext";
+$itemcache = "pod2htmi$cache_ext";
 
 @begin_stack = ();             # begin/end stack
 
@@ -221,7 +257,9 @@ $podfile = "";              # read from stdin by default
 @podpath = ();         # list of directories containing library pods.
 $podroot = ".";                # filesystem base directory from which all
                                #   relative paths in $podpath stem.
+$css = '';                   # Cascading style sheet
 $recurse = 1;          # recurse on subdirectories in $podpath.
+$quiet = 0;            # not quiet by default
 $verbose = 0;          # not verbose by default
 $doindex = 1;                  # non-zero if we should generate an index
 $listlevel = 0;                # current list depth
@@ -239,6 +277,7 @@ $ignore = 1;                        # whether or not to format text.  we don't
 @items_seen = ();
 %items_named = ();
 $netscape = 0;         # whether or not to use netscape directives.
+$header = 0;                   # produce block header/footer
 $title = '';                   # title to give the pod(s)
 $top = 1;                      # true if we are at the top of the doc.  used
                                #   to prevent the first <HR> directive.
@@ -283,6 +322,19 @@ sub pod2html {
     } 
     $htmlfile = "-" unless $htmlfile;  # stdout
     $htmlroot = "" if $htmlroot eq "/";        # so we don't get a //
+    $htmldir =~ s#/$## ;                # so we don't get a //
+    if (  $htmlroot eq ''
+       && defined( $htmldir ) 
+       && $htmldir ne ''
+       && substr( $htmlfile, 0, length( $htmldir ) ) eq $htmldir 
+       ) 
+    {
+       # Set the 'base' url for this file, so that we can use it
+       # as the location from which to calculate relative links 
+       # to other files. If this is '', then absolute links will
+       # be used throughout.
+        $htmlfileurl= "$htmldir/" . substr( $htmlfile, length( $htmldir ) + 1);
+    }
 
     # read the pod a paragraph at a time
     warn "Scanning for sections in input file(s)\n" if $verbose;
@@ -294,8 +346,7 @@ sub pod2html {
     my $index = scan_headings(\%sections, @poddata);
 
     unless($index) {
-       warn "No pod in $podfile\n" if $verbose;
-       return;
+       warn "No headings in $podfile\n" if $verbose;
     }
 
     # open the output file
@@ -327,20 +378,32 @@ sub pod2html {
     if ($title) {
        $title =~ s/\s*\(.*\)//;
     } else {
-       warn "$0: no title for $podfile";
+       warn "$0: no title for $podfile" unless $quiet;
        $podfile =~ /^(.*)(\.[^.\/]+)?$/;
        $title = ($podfile eq "-" ? 'No Title' : $1);
        warn "using $title" if $verbose;
     }
+    my $csslink = $css ? qq(\n<LINK REL="stylesheet" HREF="$css" TYPE="text/css">) : '';
+    $csslink =~ s,\\,/,g;
+    $csslink =~ s,(/.):,$1|,;
+
+    my $block = $header ? <<END_OF_BLOCK : '';
+<TABLE BORDER=0 CELLPADDING=0 CELLSPACING=0 WIDTH=100%>
+<TR><TD CLASS=block VALIGN=MIDDLE WIDTH=100% BGCOLOR="#cccccc">
+<FONT SIZE=+1><STRONG><P CLASS=block>&nbsp;$title</P></STRONG></FONT>
+</TD></TR>
+</TABLE>
+END_OF_BLOCK
+
     print HTML <<END_OF_HEAD;
 <HTML>
 <HEAD>
-<TITLE>$title</TITLE>
+<TITLE>$title</TITLE>$csslink
 <LINK REV="made" HREF="mailto:$Config{perladmin}">
 </HEAD>
 
 <BODY>
-
+$block
 END_OF_HEAD
 
     # load/reload/validate/cache %pages and %items
@@ -358,7 +421,7 @@ END_OF_HEAD
     print HTML $index;
     print HTML "-->\n" unless $doindex;
     print HTML "<!-- INDEX END -->\n\n";
-    print HTML "<HR>\n" if $doindex;
+    print HTML "<HR>\n" if $doindex and $index;
 
     # now convert this file
     warn "Converting input file\n" if $verbose;
@@ -402,13 +465,14 @@ END_OF_HEAD
            next if @begin_stack && $begin_stack[-1] ne 'html';
            my $text = $_;
            process_text(\$text, 1);
-           print HTML "<P>\n$text";
+           print HTML "<P>\n$text</P>\n";
        }
     }
 
     # finish off any pending directives
     finish_list();
     print HTML <<END_OF_TAIL;
+$block
 </BODY>
 
 </HTML>
@@ -460,15 +524,20 @@ Usage:  $0 --help --htmlroot=<name> --infile=<name> --outfile=<name>
   --recurse    - recurse on those subdirectories listed in podpath
                  (default behavior).
   --title      - title that will appear in resulting html file.
+  --header     - produce block header/footer
+  --css        - stylesheet URL
   --verbose    - self-explanatory
+  --quiet      - supress some benign warning messages
 
 END_OF_USAGE
 
 sub parse_command_line {
-    my ($opt_flush,$opt_help,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,$opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_norecurse,$opt_recurse,$opt_title,$opt_verbose);
+    my ($opt_flush,$opt_help,$opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,$opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_norecurse,$opt_recurse,$opt_title,$opt_verbose,$opt_css,$opt_header,$opt_quiet);
+    unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html};
     my $result = GetOptions(
                            'flush'      => \$opt_flush,
                            'help'       => \$opt_help,
+                           'htmldir=s'  => \$opt_htmldir,
                            'htmlroot=s' => \$opt_htmlroot,
                            'index!'     => \$opt_index,
                            'infile=s'   => \$opt_infile,
@@ -480,7 +549,10 @@ sub parse_command_line {
                            'norecurse'  => \$opt_norecurse,
                            'recurse!'   => \$opt_recurse,
                            'title=s'    => \$opt_title,
+                           'header'     => \$opt_header,
+                           'css=s'      => \$opt_css,
                            'verbose'    => \$opt_verbose,
+                           'quiet'      => \$opt_quiet,
                           );
     usage("-", "invalid parameters") if not $result;
 
@@ -489,6 +561,7 @@ sub parse_command_line {
 
     $podfile  = $opt_infile if defined $opt_infile;
     $htmlfile = $opt_outfile if defined $opt_outfile;
+    $htmldir  = $opt_htmldir if defined $opt_outfile;
 
     @podpath  = split(":", $opt_podpath) if defined $opt_podpath;
     @libpods  = split(":", $opt_libpods) if defined $opt_libpods;
@@ -503,7 +576,10 @@ sub parse_command_line {
     $doindex  = $opt_index if defined $opt_index;
     $recurse  = $opt_recurse if defined $opt_recurse;
     $title    = $opt_title if defined $opt_title;
+    $header   = defined $opt_header ? 1 : 0;
+    $css      = $opt_css if defined $opt_css;
     $verbose  = defined $opt_verbose ? 1 : 0;
+    $quiet    = defined $opt_quiet ? 1 : 0;
     $netscape = $opt_netscape if defined $opt_netscape;
 }
 
@@ -542,7 +618,7 @@ sub get_cache {
 sub cache_key {
     my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
     return join('!', $dircache, $itemcache, $recurse,
-               @$podpath, $podroot, stat($dircache), stat($itemcache));
+       @$podpath, $podroot, stat($dircache), stat($itemcache));
 }
 
 #
@@ -648,7 +724,9 @@ sub scan_podpath {
        next unless defined $pages{$libpod} && $pages{$libpod};
 
        # if there is a directory then use the .pod and .pm files within it.
-       if ($pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) {
+       # NOTE: Only finds the first so-named directory in the tree.
+#      if ($pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) {
+       if ($pages{$libpod} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
            #  find all the .pod and .pm files within the directory
            $dirname = $1;
            opendir(DIR, $dirname) ||
@@ -793,7 +871,7 @@ sub scan_headings {
 
            $index .= "\n" . ("\t" x $listdepth) . "<LI>" .
                      "<A HREF=\"#" . htmlify(0,$title) . "\">" .
-                     html_escape(process_text(\$title, 0)) . "</A>";
+                     html_escape(process_text(\$title, 0)) . "</A></LI>";
        }
     }
 
@@ -1098,8 +1176,32 @@ sub process_text {
                        "$1$2";
                    }
                  }xeg;
-       $rest =~ s/(<A HREF=)([^>:]*:)?([^>:]*)\.pod:([^>:]*:)?/$1$3.html/g;
+#      $rest =~ s/(<A HREF=)([^>:]*:)?([^>:]*)\.pod:([^>:]*:)?/$1$3.html/g;
+       $rest =~ s{
+                   (<A\ HREF="?) ([^>:]*:)? ([^>:]*) \.pod: ([^>:]*:)?
+                  }{
+                    my $url ;
+                    if ( $htmlfileurl ne '' ) {
+                       # Here, we take advantage of the knowledge 
+                       # that $htmlfileurl ne '' implies $htmlroot eq ''.
+                       # Since $htmlroot eq '', we need to prepend $htmldir
+                       # on the fron of the link to get the absolute path
+                       # of the link's target. We check for a leading '/'
+                       # to avoid corrupting links that are #, file:, etc.
+                       my $old_url = $3 ;
+                       $old_url = "$htmldir$old_url"
+                           if ( $old_url =~ m{^\/} ) ;
+                       $url = relativize_url( "$old_url.html", $htmlfileurl );
+# print( "  a: [$old_url.html,$htmlfileurl,$url]\n" ) ;
+                   }
+                   else {
+                       $url = "$3.html" ;
+                   }
+                   "$1$url" ;
+                 }xeg;
 
+  # Look for embedded URLs and make them in to links.  We don't
+  # relativize them since they are best left as the author intended.
   my $urls = '(' . join ('|', qw{
                 http
                 telnet
@@ -1121,6 +1223,7 @@ sub process_text {
         \b                          # start at word boundary
         (                           # begin $1  {
           $urls     :               # need resource and a colon
+         (?!:)                     # Ignore File::, among others.
           [$any] +?                 # followed by on or more
                                     #  of any valid character, but
                                     #  be conservative and take only
@@ -1241,7 +1344,7 @@ WARN
 
 sub html_escape {
     my $rest = $_[0];
-    $rest   =~ s/&/&amp;/g;
+    $rest   =~ s/&(?!\w+;|#)/&amp;/g;  # XXX not bulletproof
     $rest   =~ s/</&lt;/g;
     $rest   =~ s/>/&gt;/g;
     $rest   =~ s/"/&quot;/g;
@@ -1296,6 +1399,7 @@ sub process_puretext {
            $word = process_C($word, 1);
        } elsif ($word =~ m,^\w+://\w,) {
            # looks like a URL
+            # Don't relativize it: leave it as the author intended
            $word = qq(<A HREF="$word">$word</A>);
        } elsif ($word =~ /[\w.-]+\@[\w-]+\.\w/) {
            # looks like an e-mail address
@@ -1338,8 +1442,7 @@ sub process_puretext {
 #
 sub pre_escape {
     my($str) = @_;
-
-    $$str =~ s,&,&amp;,g;
+    $$str =~ s/&(?!\w+;|#)/&amp;/g;    # XXX not bulletproof
 }
 
 #
@@ -1347,6 +1450,7 @@ sub pre_escape {
 #
 sub dosify {
     my($str) = @_;
+    return lc($str) if $^O eq 'VMS';     # VMS just needs casing
     if ($Is83) {
         $str = lc $str;
         $str =~ s/(\.\w+)/substr ($1,0,4)/ge;
@@ -1391,6 +1495,9 @@ sub process_L {
            $section = $page;
            $page = "";
        }
+
+       # remove trailing punctuation, like ()
+       $section =~ s/\W*$// ;
     }
 
     $page83=dosify($page);
@@ -1401,10 +1508,33 @@ sub process_L {
     } elsif ( $page =~ /::/ ) {
        $linktext  = ($section ? "$section" : "$page");
        $page =~ s,::,/,g;
+       # Search page cache for an entry keyed under the html page name,
+       # then look to see what directory that page might be in.  NOTE:
+       # this will only find one page. A better solution might be to produce
+       # an intermediate page that is an index to all such pages.
+       my $page_name = $page ;
+       $page_name =~ s,^.*/,, ;
+       if ( defined( $pages{ $page_name } ) && 
+            $pages{ $page_name } =~ /([^:]*$page)\.(?:pod|pm):/ 
+          ) {
+           $page = $1 ;
+       }
+       else {
+           # NOTE: This branch assumes that all A::B pages are located in
+           # $htmlroot/A/B.html . This is often incorrect, since they are
+           # often in $htmlroot/lib/A/B.html or such like. Perhaps we could
+           # analyze the contents of %pages and figure out where any
+           # cousins of A::B are, then assume that.  So, if A::B isn't found,
+           # but A::C is found in lib/A/C.pm, then A::B is assumed to be in
+           # lib/A/B.pm. This is also limited, but it's an improvement.
+           # Maybe a hints file so that the links point to the correct places
+           # non-theless?
+           # Also, maybe put a warn "$0: cannot resolve..." here.
+       }
        $link = "$htmlroot/$page.html";
        $link .= "#" . htmlify(0,$section) if ($section);
     } elsif (!defined $pages{$page}) {
-       warn "$0: $podfile: cannot resolve L<$str> in paragraph $paragraph: no such page '$page'\n";
+       warn "$0: $podfile: cannot resolve L<$str> in paragraph $paragraph: no such page '$page'\n" unless $quiet;
        $link = "";
        $linktext = $page unless defined($linktext);
     } else {
@@ -1413,7 +1543,8 @@ sub process_L {
 
        # if there is a directory by the name of the page, then assume that an
        # appropriate section will exist in the subdirectory
-       if ($section ne "" && $pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) {
+#      if ($section ne "" && $pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) {
+       if ($section ne "" && $pages{$page} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
            $link = "$htmlroot/$1/$section.html";
 
        # since there is no directory by the name of the page, the section will
@@ -1437,7 +1568,24 @@ sub process_L {
 
     process_text(\$linktext, 0);
     if ($link) {
-       $s1 = "<A HREF=\"$link\">$linktext</A>";
+       # Here, we take advantage of the knowledge that $htmlfileurl ne ''
+       # implies $htmlroot eq ''. This means that the link in question
+       # needs a prefix of $htmldir if it begins with '/'. The test for
+       # the initial '/' is done to avoid '#'-only links, and to allow
+       # for other kinds of links, like file:, ftp:, etc.
+        my $url ;
+        if (  $htmlfileurl ne '' ) {
+            $link = "$htmldir$link"
+               if ( $link =~ m{^/} ) ;
+            
+            $url = relativize_url( $link, $htmlfileurl ) ;
+# print( "  b: [$link,$htmlfileurl,$url]\n" ) ;
+       }
+       else {
+            $url = $link ;
+       }
+
+       $s1 = "<A HREF=\"$url\">$linktext</A>";
     } else {
        $s1 = "<EM>$linktext</EM>";
     }
@@ -1445,6 +1593,39 @@ sub process_L {
 }
 
 #
+# relativize_url - convert an absolute URL to one relative to a base URL.
+# Assumes both end in a filename.
+#
+sub relativize_url {
+    my ($dest,$source) = @_ ;
+
+    my ($dest_volume,$dest_directory,$dest_file) = 
+        File::Spec::Unix->splitpath( $dest ) ;
+    $dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' ) ;
+
+    my ($source_volume,$source_directory,$source_file) = 
+        File::Spec::Unix->splitpath( $source ) ;
+    $source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' ) ;
+
+    my $rel_path = '' ;
+    if ( $dest ne '' ) {
+       $rel_path = File::Spec::Unix->abs2rel( $dest, $source ) ;
+    }
+
+    if ( $rel_path ne ''                && 
+         substr( $rel_path, -1 ) ne '/' &&
+         substr( $dest_file, 0, 1 ) ne '#' 
+        ) {
+        $rel_path .= "/$dest_file" ;
+    }
+    else {
+        $rel_path .= "$dest_file" ;
+    }
+
+    return $rel_path ;
+}
+
+#
 # process_BFI - process any of the B<>, F<>, or I<> pod-escapes and
 # convert them to corresponding HTML directives.
 #
@@ -1476,9 +1657,23 @@ sub process_C {
     # if there was a pod file that we found earlier with an appropriate
     # =item directive, then create a link to that page.
     if ($doref && defined $items{$s1}) {
-       $s1 = ($items{$s1} ?
-              "<A HREF=\"$htmlroot/$items{$s1}#item_" . htmlify(0,$s2) .  "\">$str</A>" :
-              "<A HREF=\"#item_" . htmlify(0,$s2) .  "\">$str</A>");
+        if ( $items{$s1} ) {
+            my $link = "$htmlroot/$items{$s1}#item_" . htmlify(0,$s2) ;
+           # Here, we take advantage of the knowledge that $htmlfileurl ne ''
+           # implies $htmlroot eq ''.
+            my $url ;
+            if (  $htmlfileurl ne '' ) {
+                $link = "$htmldir$link" ;
+                $url = relativize_url( $link, $htmlfileurl ) ;
+           }
+           else {
+                $url = $link ;
+           }
+           $s1 = "<A HREF=\"$url\">$str</A>" ;
+        }
+        else {
+           $s1 = "<A HREF=\"#item_" . htmlify(0,$s2) .  "\">$str</A>" ;
+        }
        $s1 =~ s,(perl\w+/(\S+)\.html)#item_\2\b,$1,; 
        confess "s1 has space: $s1" if $s1 =~ /HREF="[^"]*\s[^"]*"/;
     } else {
@@ -1537,6 +1732,18 @@ sub process_X {
 
 
 #
+# Adapted from Nick Ing-Simmons' PodToHtml package.
+sub relative_url {
+    my $source_file = shift ;
+    my $destination_file = shift;
+
+    my $source = URI::file->new_abs($source_file);
+    my $uo = URI::file->new($destination_file,$source)->abs;
+    return $uo->rel->as_string;
+}
+
+
+#
 # finish_list - finish off any pending HTML lists.  this should be called
 # after the entire pod file has been read and converted.
 #
index 94ea6be..41cd3cd 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
 #define nextchar            pPerl->nextchar
 #undef  ninstr
 #define ninstr              pPerl->Perl_ninstr
+#undef  no_bareword_allowed
+#define no_bareword_allowed       pPerl->Perl_no_bareword_allowed
 #undef  no_fh_allowed
 #define no_fh_allowed       pPerl->Perl_no_fh_allowed
 #undef  no_op
 #define telldir PerlDir_tell
 #define putenv PerlEnv_putenv
 #define getenv PerlEnv_getenv
+#define uname  PerlEnv_uname
 #define stdin PerlIO_stdin()
 #define stdout PerlIO_stdout()
 #define stderr PerlIO_stderr()
diff --git a/objpp.h b/objpp.h
index dd24e38..3ce0d46 100644 (file)
--- a/objpp.h
+++ b/objpp.h
 #define ninstr            CPerlObj::Perl_ninstr
 #undef  not_a_number
 #define not_a_number      CPerlObj::not_a_number
+#undef  no_bareword_allowed
+#define no_bareword_allowed     CPerlObj::Perl_no_bareword_allowed
 #undef  no_fh_allowed
 #define no_fh_allowed     CPerlObj::Perl_no_fh_allowed
 #undef  no_op
diff --git a/op.c b/op.c
index bf944a6..9ee9d62 100644 (file)
--- a/op.c
+++ b/op.c
@@ -43,6 +43,7 @@ static I32 list_assignment _((OP *o));
 static void bad_type _((I32 n, char *t, char *name, OP *kid));
 static OP *modkids _((OP *o, I32 type));
 static OP *no_fh_allowed _((OP *o));
+static void no_bareword_allowed _((OP *o));
 static OP *scalarboolean _((OP *o));
 static OP *too_few_arguments _((OP *o, char* name));
 static OP *too_many_arguments _((OP *o, char* name));
@@ -91,6 +92,15 @@ bad_type(I32 n, char *t, char *name, OP *kid)
                 (int)n, name, t, op_desc[kid->op_type]));
 }
 
+STATIC void
+no_bareword_allowed(OP *o)
+{
+    STRLEN n_a;
+    warn("Bareword \"%s\" not allowed while \"strict subs\" in use",
+         SvPV(cSVOPo->op_sv, n_a));
+    ++PL_error_count;
+}
+
 void
 assertref(OP *o)
 {
@@ -127,7 +137,7 @@ pad_allocmy(char *name)
            name[2] = toCTRL(name[1]);
            name[1] = '^';
        }
-       croak("Can't use global %s in \"my\"",name);
+       yyerror(form("Can't use global %s in \"my\"",name));
     }
     if (PL_dowarn && AvFILLp(PL_comppad_name) >= 0) {
        SV **svp = AvARRAY(PL_comppad_name);
@@ -149,7 +159,8 @@ pad_allocmy(char *name)
     sv_setpv(sv, name);
     if (PL_in_my_stash) {
        if (*name != '$')
-           croak("Can't declare class for non-scalar %s in \"my\"",name);
+           yyerror(form("Can't declare class for non-scalar %s in \"my\"",
+                        name));
        SvOBJECT_on(sv);
        (void)SvUPGRADE(sv, SVt_PVMG);
        SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
@@ -929,7 +940,9 @@ scalarvoid(OP *o)
 
     case OP_CONST:
        sv = cSVOPo->op_sv;
-       if (PL_dowarn) {
+       if (cSVOPo->op_private & OPpCONST_STRICT)
+           no_bareword_allowed(o);
+       else if (PL_dowarn) {
            useless = "a constant";
            if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
                useless = 0;
@@ -1722,13 +1735,23 @@ fold_constants(register OP *o)
     if (opargs[type] & OA_TARGET)
        o->op_targ = pad_alloc(type, SVs_PADTMP);
 
-    if ((opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
+    /* integerize op, unless it happens to be C<-foo>.
+     * XXX should pp_i_negate() do magic string negation instead? */
+    if ((opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
+       && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
+            && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
+    {
        o->op_ppaddr = ppaddr[type = ++(o->op_type)];
+    }
 
     if (!(opargs[type] & OA_FOLDCONST))
        goto nope;
 
     switch (type) {
+    case OP_NEGATE:
+       /* XXX might want a ck_negate() for this */
+       cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
+       break;
     case OP_SPRINTF:
     case OP_UCFIRST:
     case OP_LCFIRST:
@@ -1748,11 +1771,13 @@ fold_constants(register OP *o)
        goto nope;              /* Don't try to run w/ errors */
 
     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
-       if (curop->op_type != OP_CONST &&
-               curop->op_type != OP_LIST &&
-               curop->op_type != OP_SCALAR &&
-               curop->op_type != OP_NULL &&
-               curop->op_type != OP_PUSHMARK) {
+       if ((curop->op_type != OP_CONST ||
+            (curop->op_private & OPpCONST_BARE)) &&
+           curop->op_type != OP_LIST &&
+           curop->op_type != OP_SCALAR &&
+           curop->op_type != OP_NULL &&
+           curop->op_type != OP_PUSHMARK)
+       {
            goto nope;
        }
     }
@@ -4936,6 +4961,15 @@ ck_subr(OP *o)
            }
        }
     }
+    else if (cvop->op_type == OP_METHOD) {
+       if (o2->op_type == OP_CONST)
+           o2->op_private &= ~OPpCONST_STRICT;
+       else if (o2->op_type == OP_LIST) {
+           OP *o = ((UNOP*)o2)->op_first->op_sibling;
+           if (o && o->op_type == OP_CONST)
+               o->op_private &= ~OPpCONST_STRICT;
+       }
+    }
     o->op_private |= (PL_hints & HINT_STRICT_REFS);
     if (PERLDB_SUB && PL_curstash != PL_debstash)
        o->op_private |= OPpENTERSUB_DB;
@@ -4970,6 +5004,35 @@ ck_subr(OP *o)
                arg++;
                if (o2->op_type == OP_RV2GV)
                    goto wrapref;       /* autoconvert GLOB -> GLOBref */
+               else if (o2->op_type == OP_CONST)
+                   o2->op_private &= ~OPpCONST_STRICT;
+               else if (o2->op_type == OP_ENTERSUB) {
+                   /* accidental subroutine, revert to bareword */
+                   OP *gvop = ((UNOP*)o2)->op_first;
+                   if (gvop && gvop->op_type == OP_NULL) {
+                       gvop = ((UNOP*)gvop)->op_first;
+                       if (gvop) {
+                           for (; gvop->op_sibling; gvop = gvop->op_sibling)
+                               ;
+                           if (gvop &&
+                               (gvop->op_private & OPpENTERSUB_NOPAREN) &&
+                               (gvop = ((UNOP*)gvop)->op_first) &&
+                               gvop->op_type == OP_GV)
+                           {
+                               GV *gv = (GV*)((SVOP*)gvop)->op_sv;
+                               OP *sibling = o2->op_sibling;
+                               SV *n = newSVpvn("",0);
+                               op_free(o2);
+                               gv_fullname3(n, gv, "");
+                               if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
+                                   sv_chop(n, SvPVX(n)+6);
+                               o2 = newSVOP(OP_CONST, 0, n);
+                               prev->op_sibling = o2;
+                               o2->op_sibling = sibling;
+                           }
+                       }
+                   }
+               }
                scalar(o2);
                break;
            case '\\':
@@ -5048,9 +5111,12 @@ ck_trunc(OP *o)
 
        if (kid->op_type == OP_NULL)
            kid = (SVOP*)kid->op_sibling;
-       if (kid &&
-         kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE))
+       if (kid && kid->op_type == OP_CONST &&
+           (kid->op_private & OPpCONST_BARE))
+       {
            o->op_flags |= OPf_SPECIAL;
+           kid->op_private &= ~OPpCONST_STRICT;
+       }
     }
     return ck_fun(o);
 }
@@ -5081,8 +5147,11 @@ peep(register OP *o)
            o->op_seq = PL_op_seqmax++;
            break;
 
-       case OP_CONCAT:
        case OP_CONST:
+           if (cSVOPo->op_private & OPpCONST_STRICT)
+               no_bareword_allowed(o);
+           /* FALL THROUGH */
+       case OP_CONCAT:
        case OP_JOIN:
        case OP_UC:
        case OP_UCFIRST:
diff --git a/op.h b/op.h
index d0b56f3..b483b9f 100644 (file)
--- a/op.h
+++ b/op.h
@@ -118,12 +118,15 @@ typedef U32 PADOFFSET;
 #define OPpDEREF_SV            (32|64) /*   Want ref to SV. */
   /* OP_ENTERSUB only */
 #define OPpENTERSUB_DB         16      /* Debug subroutine. */
+  /* OP_RV2CV only */
 #define OPpENTERSUB_AMPER      8       /* Used & form to call. */
+#define OPpENTERSUB_NOPAREN    128     /* bare sub call (without parens) */
   /* OP_?ELEM only */
 #define OPpLVAL_DEFER          16      /* Defer creation of array/hash elem */
   /* for OP_RV2?V, lower bits carry hints */
 
 /* Private for OP_CONST */
+#define        OPpCONST_STRICT         8       /* bearword subject to strict 'subs' */
 #define OPpCONST_ENTERED       16      /* Has been entered as symbol. */
 #define OPpCONST_ARYBASE       32      /* Was a $[ translated to constant. */
 #define OPpCONST_BARE          64      /* Was a bare word (filehandle?). */
diff --git a/perl.h b/perl.h
index cab0bbc..0921b55 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -1703,15 +1703,20 @@ EXTCONST char no_myglob[]
 #ifdef DOINIT
 EXT char *sig_name[] = { SIG_NAME };
 EXT int   sig_num[]  = { SIG_NUM };
+#  ifndef PERL_OBJECT
 EXT SV * psig_ptr[sizeof(sig_num)/sizeof(*sig_num)];
 EXT SV  * psig_name[sizeof(sig_num)/sizeof(*sig_num)];
+#  endif
 #else
 EXT char *sig_name[];
 EXT int   sig_num[];
+#  ifndef PERL_OBJECT
 EXT SV  * psig_ptr[];
 EXT SV  * psig_name[];
+#  endif
 #endif
 
+
 /* fast case folding tables */
 
 #ifdef DOINIT
@@ -2039,6 +2044,10 @@ typedef int (CPerlObj::*runops_proc_t) _((void));
 #undef INIT
 #define INIT(x)
 
+const int perl_object_sig_num[]  = { SIG_NUM };
+const int PSIG_SIZE = (sizeof(perl_object_sig_num)/sizeof(*perl_object_sig_num));
+
+
 class CPerlObj {
 public:
        CPerlObj(IPerlMem*, IPerlEnv*, IPerlStdIO*, IPerlLIO*, IPerlDir*, IPerlSock*, IPerlProc*);
@@ -2187,6 +2196,13 @@ PERLVAR(filter_debug,    int)
 PERLVAR(super_bufptr,  char*)  /* PL_bufptr that was */
 PERLVAR(super_bufend,  char*)  /* PL_bufend that was */
 
+#undef psig_ptr
+#undef psig_name
+#define psig_ptr               PL_psig_ptr
+#define psig_name              PL_psig_name
+PERLVAR(psig_ptr[PSIG_SIZE], SV*);
+PERLVAR(psig_name[PSIG_SIZE], SV*);
+
 /*
  * The following is a buffer where new variables must
  * be defined to maintain binary compatibility with PERL_OBJECT
diff --git a/pod/Win32.pod b/pod/Win32.pod
new file mode 100644 (file)
index 0000000..2daaf78
--- /dev/null
@@ -0,0 +1,284 @@
+=head1 NAME
+
+Win32 - Interfaces to some Win32 API Functions
+
+=head1 DESCRIPTION
+
+Perl on Win32 contains several functions to access Win32 APIs. Some
+are included in Perl itself (on Win32) and some are only available
+after explicitly requesting the Win32 module with:
+
+       use Win32;
+
+The builtin functions are marked as [CORE] and the other ones
+as [EXT] in the following alphabetical listing. The C<Win32> module
+is not part of the Perl source distribution; it is distributed in
+the libwin32 bundle of Win32::* modules on CPAN. The module is
+already preinstalled in binary distributions like ActivePerl.
+
+=head2 Alphabetical Listing of Win32 Functions
+
+=over
+
+=item Win32::AbortSystemShutdown(MACHINE)
+
+[EXT] Aborts a system shutdown (started by the
+InitiateSystemShutdown function) on the specified MACHINE.
+
+=item Win32::BuildNumber()
+
+[CORE] Returns the ActivePerl build number. This function is
+only available in the ActivePerl binary distribution.
+
+=item Win32::CopyFile(FROM, TO, OVERWRITE)
+
+[CORE] The Win32::CopyFile() function copies an existing file to a new
+file. All file information like creation time and file attributes will
+be copied to the new file. However it will B<not> copy the security
+information. If the destination file already exists it will only be
+overwritten when the OVERWRITE parameter is true. But even this will
+not overwrite a read-only file; you have to unlink() it first
+yourself.
+
+=item Win32::DomainName()
+
+[CORE] Returns the name of the Microsoft Network domain that the
+owner of the current perl process is logged into.
+
+=item Win32::ExpandEnvironmentStrings(STRING)
+
+[EXT] Takes STRING and replaces all referenced environment variable
+names with their defined values. References to environment variables
+take the form C<%VariableName%>. Case is ignored when looking up the
+VariableName in the environment. If the variable is not found then the
+original C<%VariableName%> text is retained.  Has the same effect
+as the following:
+
+       $string =~ s/%([^%]*)%/$ENV{$1} || "%$1%"/eg
+
+=item Win32::FormatMessage(ERRORCODE)
+
+[CORE] Converts the supplied Win32 error number (e.g. returned by
+Win32::GetLastError()) to a descriptive string.  Analogous to the
+perror() standard-C library function.  Note that C<$^E> used
+in a string context has much the same effect.
+
+       C:\> perl -e "$^E = 26; print $^E;"
+       The specified disk or diskette cannot be accessed
+
+=item Win32::FsType()
+
+[CORE] Returns the name of the filesystem of the currently active
+drive (like 'FAT' or 'NTFS'). In list context it returns three values:
+(FSTYPE, FLAGS, MAXCOMPLEN). FSTYPE is the filesystem type as
+before. FLAGS is a combination of values of the following table:
+
+       0x00000001  supports case-sensitive filenames
+       0x00000002  preserves the case of filenames
+       0x00000004  supports Unicode in filenames
+       0x00000008  preserves and enforces ACLs
+       0x00000010  supports file-based compression
+       0x00000020  supports disk quotas
+       0x00000040  supports sparse files
+       0x00000080  supports reparse points
+       0x00000100  supports remote storage
+       0x00008000  is a compressed volume (e.g. DoubleSpace)
+       0x00010000  supports object identifiers
+       0x00020000  supports the Encrypted File System (EFS)
+
+MAXCOMPLEN is the maximum length of a filename component (the part
+between two backslashes) on this file system.
+
+=item Win32::FreeLibrary(HANDLE)
+
+[EXT] Unloads a previously loaded dynamic-link library. The HANDLE is
+no longer valid after this call. See L<LoadLibrary> for information on
+dynamically loading a library.
+
+=item Win32::GetArchName()
+
+[EXT] Use of this function is deprecated. It is equivalent with
+$ENV{PROCESSOR_ARCHITECTURE}. This might not work on Win9X.
+
+=item Win32::GetChipName()
+
+[EXT] Returns the processor type: 386, 486 or 586 for Intel processors,
+21064 for the Alpha chip.
+
+=item Win32::GetCwd()
+
+[CORE] Returns the current active drive and directory. This function
+does not return a UNC path, since the functionality required for such
+a feature is not available under Windows 95.
+
+=item Win32::GetFullPathName(FILENAME)
+
+[CORE] GetFullPathName combines the FILENAME with the current drive
+and directory name and returns a fully qualified (aka, absolute)
+path name. In list context it returns two elements: (PATH, FILE) where
+PATH is the complete pathname component (including trailing backslash)
+and FILE is just the filename part.  Note that no attempt is made to
+convert 8.3 components in the supplied FILENAME to longnames or
+vice-versa.  Compare with Win32::GetShortPathName and
+Win32::GetLongPathName.  
+
+This function has been added for Perl 5.006.
+
+=item Win32::GetLastError()
+
+[CORE] Returns the last error value generated by a call to a Win32 API
+function.  Note that C<$^E> used in a numeric context amounts to the
+same value.
+
+=item Win32::GetLongPathName(PATHNAME)
+
+[CORE] Returns a representaion of PATHNAME comprised of longname
+compnents (if any).  The result may not necessarily be longer
+than PATHNAME.  No attempt is made to convert PATHNAME to the
+absolute path.  Compare with Win32::GetShortPathName and
+Win32::GetFullPathName.
+
+This function has been added for Perl 5.006.
+
+=item Win32::GetNextAvailDrive()
+
+[CORE] Returns a string in the form of "<d>:" where <d> is the first
+available drive letter.
+
+=item Win32::GetOSVersion()
+
+[CORE] Returns the array (STRING, MAJOR, MINOR, BUILD, ID), where
+the elements are, respectively: An arbitrary descriptive string, the
+major version number of the operating system, the minor version
+number, the build number, and a digit indicating the actual operating
+system. For ID, the values are 0 for Win32s, 1 for Windows 9X and 2
+for Windows NT. In scalar context it returns just the ID.
+
+=item Win32::GetShortPathName(PATHNAME)
+
+[CORE] Returns a representation of PATHNAME comprised only of
+short (8.3) path components.  The result may not necessarily be
+shorter than PATHNAME.  Compare with Win32::GetFullPathName and
+Win32::GetLongPathName.
+
+=item Win32::GetProcAddress(INSTANCE, PROCNAME)
+
+[EXT] Returns the address of a function inside a loaded library. The
+information about what you can do with this address has been lost in
+the mist of time. Use the Win32::API module instead of this deprecated
+function.
+
+=item Win32::GetTickCount()
+
+[CORE] Returns the number of milliseconds elapsed since the last
+system boot. Resolution is limited to system timer ticks (about 10ms
+on WinNT and 55ms on Win9X).
+
+=item Win32::InitiateSystemShutdown(MACHINE, MESSAGE, TIMEOUT, FORCECLOSE, REBOOT)
+
+[EXT] Shutsdown the specified MACHINE, notifying users with the
+supplied MESSAGE, within the specified TIMEOUT interval. Forces
+closing of all documents without prompting the user if FORCECLOSE is
+true, and reboots the machine if REBOOT is true. This function works
+only on WinNT.
+
+=item Win32::IsWinNT()
+
+[CORE] Returns non zero if the Win32 subsystem is Windows NT.
+
+=item Win32::IsWin95()
+
+[CORE] Returns non zero if the Win32 subsystem is Windows 95.
+
+=item Win32::LoadLibrary(LIBNAME)
+
+[EXT] Loads a dynamic link library into memory and returns its module
+handle. This handle can be used with Win32::GetProcAddress and
+Win32::FreeLibrary. This function is deprecated. Use the Win32::API
+module instead.
+
+=item Win32::LoginName()
+
+[CORE] Returns the username of the owner of the current perl process.
+
+=item Win32::LookupAccountName(SYSTEM, ACCOUNT, DOMAIN, SID, SIDTYPE)
+
+[EXT] Looks up ACCOUNT on SYSTEM and returns the domain name the SID and
+the SID type.
+
+=item Win32::LookupAccountSID(SYSTEM, SID, ACCOUNT, DOMAIN, SIDTYPE)
+
+[EXT] Looks up SID on SYSTEM and returns the account name, domain name,
+and the SID type.
+
+=item Win32::MsgBox(MESSAGE [, FLAGS [, TITLE]])
+
+[EXT] Create a dialogbox containing MESSAGE. FLAGS specifies the
+required icon and buttons according to the following table:
+
+       0 = OK
+       1 = OK and Cancel
+       2 = Abort, Retry, and Ignore
+       3 = Yes, No and Cancel
+       4 = Yes and No
+       5 = Retry and Cancel
+
+       MB_ICONSTOP          "X" in a red circle
+       MB_ICONQUESTION      question mark in a bubble
+       MB_ICONEXCLAMATION   exclamation mark in a yellow triangle
+       MB_ICONINFORMATION   "i" in a bubble
+
+TITLE specifies an optional window title. The default is "Perl".
+
+The function returns the menu id of the selected push button:
+
+       0  Error
+
+       1  OK
+       2  Cancel
+       3  Abort
+       4  Retry
+       5  Ignore
+       6  Yes
+       7  No
+
+=item Win32::NodeName()
+
+[CORE] Returns the Microsoft Network node-name of the current machine.
+
+=item Win32::RegisterServer(LIBRARYNAME)
+
+[EXT] Loads the DLL LIBRARYNAME and calls the function DllRegisterServer.
+
+=item Win32::SetCwd(NEWDIRECTORY)
+
+[CORE] Sets the current active drive and directory. This function does not
+work with UNC paths, since the functionality required to required for
+such a feature is not available under Windows 95.
+
+=item Win32::SetLastError(ERROR)
+
+[CORE] Sets the value of the last error encountered to ERROR. This is
+that value that will be returned by the Win32::GetLastError()
+function. This functions has been added for Perl 5.006.
+
+=item Win32::Sleep(TIME)
+
+[CORE] Pauses for TIME milliseconds. The timeslices are made available
+to other processes and threads.
+
+=item Win32::Spawn(COMMAND, ARGS, PID)
+
+[CORE] Spawns a new process using the supplied COMMAND, passing in
+arguments in the string ARGS. The pid of the new process is stored in
+PID. This function is deprecated. Please use the Win32::Process module
+instead.
+
+=item Win32::UnregisterServer(LIBRARYNAME)
+
+[EXT] Loads the DLL LIBRARYNAME and calls the function
+DllUnregisterServer.
+
+=back
+
+=cut
diff --git a/pp.c b/pp.c
index 1f62886..37e3063 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -474,6 +474,8 @@ refto(SV *sv)
            vivify_defelem(sv);
        if (!(sv = LvTARG(sv)))
            sv = &PL_sv_undef;
+       else
+           (void)SvREFCNT_inc(sv);
     }
     else if (SvPADTMP(sv))
        sv = newSVsv(sv);
@@ -4365,6 +4367,7 @@ PP(pp_split)
        else {
            if (!AvREAL(ary)) {
                AvREAL_on(ary);
+               AvREIFY_off(ary);
                for (i = AvFILLp(ary); i >= 0; i--)
                    AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
            }
index 653a345..dddcb20 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2816,6 +2816,7 @@ PP(pp_leaveeval)
            MEXTEND(mark,0);
            *MARK = &PL_sv_undef;
        }
+       SP = MARK;
     }
     else {
        /* in case LEAVE wipes old return values */
index e4d398d..499d642 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2352,6 +2352,7 @@ PP(pp_entersub)
            if (AvREAL(av)) {
                av_clear(av);
                AvREAL_off(av);
+               AvREIFY_on(av);
            }
 #ifndef USE_THREADS
            cx->blk_sub.savearray = GvAV(PL_defgv);
diff --git a/proto.h b/proto.h
index 62fb9f6..b4a82f1 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -753,6 +753,7 @@ CV *get_db_sub _((SV **svp, CV *cv));
 I32 list_assignment _((OP *o));
 void bad_type _((I32 n, char *t, char *name, OP *kid));
 OP *modkids _((OP *o, I32 type));
+void no_bareword_allowed _((OP *o));
 OP *no_fh_allowed _((OP *o));
 OP *scalarboolean _((OP *o));
 OP *too_few_arguments _((OP *o, char* name));
index db6a9b5..0e0e82e 100755 (executable)
@@ -16,7 +16,7 @@ BEGIN {
 
 use strict;
 
-print "1..87\n";
+print "1..100\n";
 
 my $i = 1;
 
@@ -417,9 +417,42 @@ print "ok ", $i++, "\n";
 # test if the (*) prototype allows barewords, constants, scalar expressions,
 # globs and globrefs (just as CORE::open() does), all under stricture
 sub star (*&) { &{$_[1]} }
+sub star2 (**&) { &{$_[2]} }
+sub BAR { "quux" }
+sub Bar::BAZ { "quuz" }
 my $star = 'FOO';
 star FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
+star(FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++;
 star "FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
+star("FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++;
 star $star, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
+star($star, sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++;
 star *FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++;
+star(*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }); $i++;
 star \*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++;
+star(\*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }); $i++;
+star2 FOO, BAR, sub { print "ok $i\n"
+                       if $_[0] eq 'FOO' and $_[1] eq 'BAR' }; $i++;
+star2(Bar::BAZ, FOO, sub { print "ok $i\n"
+                       if $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO' }); $i++;
+star2 BAR(), FOO, sub { print "ok $i\n"
+                       if $_[0] eq 'quux' and $_[1] eq 'FOO' }; $i++;
+star2(FOO, BAR(), sub { print "ok $i\n"
+                       if $_[0] eq 'FOO' and $_[1] eq 'quux' }); $i++;
+star2 "FOO", "BAR", sub { print "ok $i\n"
+                       if $_[0] eq 'FOO' and $_[1] eq 'BAR' }; $i++;
+star2("FOO", "BAR", sub { print "ok $i\n"
+                       if $_[0] eq 'FOO' and $_[1] eq 'BAR' }); $i++;
+star2 $star, $star, sub { print "ok $i\n"
+                       if $_[0] eq 'FOO' and $_[1] eq 'FOO' }; $i++;
+star2($star, $star, sub { print "ok $i\n"
+                       if $_[0] eq 'FOO' and $_[1] eq 'FOO' }); $i++;
+star2 *FOO, *BAR, sub { print "ok $i\n"
+                       if $_[0] eq \*FOO and $_[0] eq \*BAR }; $i++;
+star2(*FOO, *BAR, sub { print "ok $i\n"
+                       if $_[0] eq \*FOO and $_[0] eq \*BAR }); $i++;
+star2 \*FOO, \*BAR, sub { no strict 'refs'; print "ok $i\n"
+                       if $_[0] eq \*{'FOO'} and $_[0] eq \*{'BAR'} }; $i++;
+star2(\*FOO, \*BAR, sub { no strict 'refs'; print "ok $i\n"
+                       if $_[0] eq \*{'FOO'} and $_[0] eq \*{'BAR'} }); $i++;
+
index f09d66c..1bbdebd 100755 (executable)
--- a/t/io/fs.t
+++ b/t/io/fs.t
@@ -142,8 +142,11 @@ else {
   if (-z "Iofs.tmp") {print "ok 24\n"} else {print "not ok 24\n"}
   open(FH, ">Iofs.tmp") or die "Can't create Iofs.tmp";
   { select FH; $| = 1; select STDOUT }
-  print FH "helloworld\n";
-  truncate FH, 5;
+  {
+    use strict;
+    print FH "helloworld\n";
+    truncate FH, 5;
+  }
   if ($^O eq 'dos') {
       close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
   }
index fb3757f..6437d0c 100755 (executable)
@@ -3,11 +3,12 @@
 BEGIN {
    chdir 't' if -d 't';
    unshift @INC, '../lib';
-   print "1..9\n";
+   print "1..13\n";
 }
 
+use vars '*FOO';
 use strict;
-use Fatal qw(open);
+use Fatal qw(open close);
 
 my $i = 1;
 eval { open FOO, '<lkjqweriuapofukndajsdlfjnvcvn' };
@@ -20,8 +21,9 @@ for ('$foo', "'$foo'", "*$foo", "\\*$foo") {
     print "not " if $@;
     print "ok $i\n"; ++$i;
 
-    print "not " unless scalar(<FOO>) =~ m|^#!./perl|;
+    print "not " if $@ or scalar(<FOO>) !~ m|^#!./perl|;
+    print "ok $i\n"; ++$i;
+    eval qq{ close FOO };
     print "not " if $@;
     print "ok $i\n"; ++$i;
-    close FOO;
 }
index dc163e9..c56498a 100755 (executable)
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..36\n";
+print "1..37\n";
 
 eval 'print "ok 1\n";';
 
@@ -171,3 +171,9 @@ sub terminal { eval 'print $r' }
 }
 $x++;
 
+# does scalar eval"" pop stack correctly?
+{
+    my $c = eval "(1,2)x10";
+    print $c eq '2222222222' ? "ok $x\n" : "# $c\nnot ok $x\n";
+    $x++;
+}
index 7f08e06..52ec2e9 100755 (executable)
@@ -120,8 +120,9 @@ ok 18, $$ > 0, $$;
     $script = "$wd/show-shebang";
     if ($Is_MSWin32) {
        chomp($wd = `cd`);
-       $perl = "$wd\\perl.exe";
-       $script = "$wd\\show-shebang.bat";
+       $wd =~ s|\\|/|g;
+       $perl = "$wd/perl.exe";
+       $script = "$wd/show-shebang.bat";
        $headmaybe = <<EOH ;
 \@rem ='
 \@echo off
@@ -154,9 +155,11 @@ EOF
     s/.exe//i if $Is_Dos;
     s{\bminiperl\b}{perl}; # so that test doesn't fail with miniperl
     s{is perl}{is $perl}; # for systems where $^X is only a basename
+    s{\\}{/}g;
     ok 23, ($Is_MSWin32 ? uc($_) eq uc($s2) : $_ eq $s2), ":$_:!=:$s2:";
     $_ = `$perl $script`;
     s/.exe//i if $Is_Dos;
+    s{\\}{/}g;
     ok 24, ($Is_MSWin32 ? uc($_) eq uc($s1) : $_ eq $s1), ":$_:!=:$s1: after `$perl $script`";
     ok 25, unlink($script), $!;
 }
index 1d70f9f..618cfcc 100755 (executable)
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..55\n";
+print "1..56\n";
 
 # Test glob operations.
 
@@ -271,14 +271,22 @@ print $$_,"\n";
     print "# good, didn't recurse\n";
 }
 
+# test if refgen behaves with autoviv magic
+
+{
+    my @a;
+    $a[1] = "ok 53\n";
+    print ${\$_} for @a;
+}
+
 # test global destruction
 
 package FINALE;
 
 {
-    $ref3 = bless ["ok 55\n"];         # package destruction
-    my $ref2 = bless ["ok 54\n"];      # lexical destruction
-    local $ref1 = bless ["ok 53\n"];   # dynamic destruction
+    $ref3 = bless ["ok 56\n"];         # package destruction
+    my $ref2 = bless ["ok 55\n"];      # lexical destruction
+    local $ref1 = bless ["ok 54\n"];   # dynamic destruction
     1;                                 # flush any temp values on stack
 }
 
index 61ec286..deeb381 100644 (file)
@@ -277,3 +277,25 @@ my $a = Fred ;
 EXPECT
 Bareword "Fred" not allowed while "strict subs" in use at - line 8.
 Execution of - aborted due to compilation errors.
+########
+
+# see if Foo->Bar(...) etc work under strictures
+use strict;
+package Foo; sub Bar { print "@_\n" }
+Foo->Bar('a',1);
+Bar Foo ('b',2);
+Foo->Bar(qw/c 3/);
+Bar Foo (qw/d 4/);
+Foo::->Bar('A',1);
+Bar Foo:: ('B',2);
+Foo::->Bar(qw/C 3/);
+Bar Foo:: (qw/D 4/);
+EXPECT
+Foo a 1
+Foo b 2
+Foo c 3
+Foo d 4
+Foo A 1
+Foo B 2
+Foo C 3
+Foo D 4
diff --git a/toke.c b/toke.c
index 52a42af..54ce091 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -1498,7 +1498,7 @@ yylex(void)
        */
        if (PL_in_my) {
            if (strchr(PL_tokenbuf,':'))
-               croak(no_myglob,PL_tokenbuf);
+               yyerror(form(no_myglob,PL_tokenbuf));
 
            yylval.opval = newOP(OP_PADANY, 0);
            yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
@@ -1942,8 +1942,24 @@ yylex(void)
                 * Look for options.
                 */
                d = instr(s,"perl -");
-               if (!d)
+               if (!d) {
                    d = instr(s,"perl");
+#if defined(DOSISH)
+                   /* avoid getting into infinite loops when shebang
+                    * line contains "Perl" rather than "perl" */
+                   if (!d) {
+                       for (d = ipathend-4; d >= ipath; --d) {
+                           if ((*d == 'p' || *d == 'P')
+                               && !ibcmp(d, "perl", 4))
+                           {
+                               break;
+                           }
+                       }
+                       if (d < ipath)
+                           d = Nullch;
+                   }
+#endif
+               }
 #ifdef ALTERNATE_SHEBANG
                /*
                 * If the ALTERNATE_SHEBANG on this system starts with a
@@ -2997,11 +3013,9 @@ yylex(void)
                    PL_oldoldbufptr < PL_bufptr &&
                    (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
                    /* NO SKIPSPACE BEFORE HERE! */
-                   (PL_expect == XREF 
-                    || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
-                    || (PL_last_lop_op == OP_ENTERSUB 
-                        && PL_last_proto 
-                        && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
+                   (PL_expect == XREF ||
+                    ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
+
                {
                    bool immediate_paren = *s == '(';
 
@@ -3017,8 +3031,10 @@ yylex(void)
                    /* (But it's an indir obj regardless for sort.) */
 
                    if ((PL_last_lop_op == OP_SORT ||
-                         (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
-                        (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
+                         (!immediate_paren && (!gv || !GvCVu(gv)))) &&
+                        (PL_last_lop_op != OP_MAPSTART &&
+                        PL_last_lop_op != OP_GREPSTART))
+                   {
                        PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
                        goto bareword;
                    }
@@ -3031,11 +3047,8 @@ yylex(void)
                if (*s == '(') {
                    CLINE;
                    if (gv && GvCVu(gv)) {
-                       CV *cv;
-                       if ((cv = GvCV(gv)) && SvPOK(cv))
-                           PL_last_proto = SvPV((SV*)cv, n_a);
                        for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
-                       if (*d == ')' && (sv = cv_const_sv(cv))) {
+                       if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
                            s = d + 1;
                            goto its_constant;
                        }
@@ -3044,7 +3057,6 @@ yylex(void)
                    PL_expect = XOPERATOR;
                    force_next(WORD);
                    yylval.ival = 0;
-                   PL_last_lop_op = OP_ENTERSUB;
                    TOKEN('&');
                }
 
@@ -3068,8 +3080,6 @@ yylex(void)
                    if (lastchar == '-')
                        warn("Ambiguous use of -%s resolved as -&%s()",
                                PL_tokenbuf, PL_tokenbuf);
-                   PL_last_lop = PL_oldbufptr;
-                   PL_last_lop_op = OP_ENTERSUB;
                    /* Check for a constant sub */
                    cv = GvCV(gv);
                    if ((sv = cv_const_sv(cv))) {
@@ -3083,52 +3093,40 @@ yylex(void)
                    /* Resolve to GV now. */
                    op_free(yylval.opval);
                    yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
+                   yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
+                   PL_last_lop = PL_oldbufptr;
                    PL_last_lop_op = OP_ENTERSUB;
                    /* Is there a prototype? */
                    if (SvPOK(cv)) {
                        STRLEN len;
-                       PL_last_proto = SvPV((SV*)cv, len);
+                       char *proto = SvPV((SV*)cv, len);
                        if (!len)
                            TERM(FUNC0SUB);
-                       if (strEQ(PL_last_proto, "$"))
+                       if (strEQ(proto, "$"))
                            OPERATOR(UNIOPSUB);
-                       if (*PL_last_proto == '&' && *s == '{') {
+                       if (*proto == '&' && *s == '{') {
                            sv_setpv(PL_subname,"__ANON__");
                            PREBLOCK(LSTOPSUB);
                        }
-                   } else
-                       PL_last_proto = NULL;
+                   }
                    PL_nextval[PL_nexttoke].opval = yylval.opval;
                    PL_expect = XTERM;
                    force_next(WORD);
                    TOKEN(NOAMP);
                }
 
-               if (PL_hints & HINT_STRICT_SUBS &&
-                   lastchar != '-' &&
-                   strnNE(s,"->",2) &&
-                   PL_last_lop_op != OP_TRUNCATE &&  /* S/F prototype in opcode.pl */
-                   PL_last_lop_op != OP_ACCEPT &&
-                   PL_last_lop_op != OP_PIPE_OP &&
-                   PL_last_lop_op != OP_SOCKPAIR &&
-                   !(PL_last_lop_op == OP_ENTERSUB 
-                        && PL_last_proto 
-                        && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*'))
-               {
-                   warn(
-                    "Bareword \"%s\" not allowed while \"strict subs\" in use",
-                       PL_tokenbuf);
-                   ++PL_error_count;
-               }
-
                /* Call it a bare word */
 
-           bareword:
-               if (PL_dowarn) {
-                   if (lastchar != '-') {
-                       for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
-                       if (!*d)
-                           warn(warn_reserved, PL_tokenbuf);
+               if (PL_hints & HINT_STRICT_SUBS)
+                   yylval.opval->op_private |= OPpCONST_STRICT;
+               else {
+               bareword:
+                   if (PL_dowarn) {
+                       if (lastchar != '-') {
+                           for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
+                           if (!*d)
+                               warn(warn_reserved, PL_tokenbuf);
+                       }
                    }
                }
 
index 2633510..8c1c696 100644 (file)
@@ -47,7 +47,7 @@ print OUT <<'!NO!SUBS!';
 # man replacement, written in perl. This perldoc is strictly for reading
 # the perl manuals, though it too is written in perl.
 
-if(@ARGV<1) {
+if (@ARGV<1) {
        my $me = $0;            # Editing $0 is unportable
        $me =~ s,.*/,,;
        die <<EOF;
@@ -82,7 +82,7 @@ perldoc [options] -q FAQRegex
 Options:
     -h   Display this help message
     -r   Recursive search (slow)
-    -i   Ignore case 
+    -i   Ignore case
     -t   Display pod using pod2text instead of pod2man and nroff
              (-t is the default on win32)
     -u  Display unformatted pod text
@@ -94,10 +94,10 @@ Options:
     -q   Search the text of questions (not answers) in perlfaq[1-9]
 
 PageName|ModuleName...
-         is the name of a piece of documentation that you want to look at. You 
+         is the name of a piece of documentation that you want to look at. You
          may either give a descriptive name of the page (as in the case of
-         `perlfunc') the name of a module, either like `Term::Info', 
-         `Term/Info', the partial name of a module, like `info', or 
+         `perlfunc') the name of a module, either like `Term::Info',
+         `Term/Info', the partial name of a module, like `info', or
          `makemaker', or the name of a program, like `perldoc'.
 
 BuiltinFunction
@@ -108,14 +108,14 @@ FAQRegex
          is a regex. Will search perlfaq[1-9] for and extract any
          questions that match.
 
-Any switches in the PERLDOC environment variable will be used before the 
+Any switches in the PERLDOC environment variable will be used before the
 command line arguments.  The optional pod index file contains a list of
 filenames, one per line.
 
 EOF
 }
 
-if( defined $ENV{"PERLDOC"} ) {
+if (defined $ENV{"PERLDOC"}) {
     require Text::ParseWords;
     unshift(@ARGV, Text::ParseWords::shellwords($ENV{"PERLDOC"}));
 }
@@ -134,14 +134,18 @@ print OUT <<'!NO!SUBS!';
 usage if $opt_h;
 
 my $podidx;
-if( $opt_X ) {
+if ($opt_X) {
     $podidx = "$Config{'archlib'}/pod.idx";
     $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
 }
 
-if( (my $opts = do{ local $^W; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) {
+if ((my $opts = do{ local $^W; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) {
     usage("only one of -t, -u, -m or -l")
-} elsif ($Is_MSWin32 || $Is_Dos) {
+}
+elsif ($Is_MSWin32
+       || $Is_Dos
+       || !(exists $ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i))
+{
     $opt_t = 1 unless $opts
 }
 
@@ -149,11 +153,13 @@ if ($opt_t) { require Pod::Text; import Pod::Text; }
 
 my @pages;
 if ($opt_f) {
-   @pages = ("perlfunc");
-} elsif ($opt_q) {
-   @pages = ("perlfaq1" .. "perlfaq9");
-} else {
-   @pages = @ARGV;
+    @pages = ("perlfunc");
+}
+elsif ($opt_q) {
+    @pages = ("perlfaq1" .. "perlfaq9");
+}
+else {
+    @pages = @ARGV;
 }
 
 # Does this look like a module or extension directory?
@@ -164,15 +170,13 @@ if (-f "Makefile.PL") {
        require ExtUtils::testlib;
 }
 
-
-
 sub containspod {
     my($file, $readit) = @_;
     return 1 if !$readit && $file =~ /\.pod$/i;
     local($_);
     open(TEST,"<$file");
-    while(<TEST>) {
-       if(/^=head/) {
+    while (<TEST>) {
+       if (/^=head/) {
            close(TEST);
            return 1;
        }
@@ -186,7 +190,7 @@ sub minus_f_nocase {
      my $path = join('/',$dir,$file);
      return $path if -f $path and -r _;
      if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') {
-        # on a case-forgiving file system or if case is important 
+        # on a case-forgiving file system or if case is important
        # that is it all we can do
        warn "Ignored $path: unreadable\n" if -f _;
        return '';
@@ -198,7 +202,7 @@ sub minus_f_nocase {
      foreach $p (split(/\//, $file)){
        my $try = "@p/$p";
        stat $try;
-       if (-d _){
+       if (-d _) {
            push @p, $p;
            if ( $p eq $global_target) {
                my $tmp_path = join ('/', @p);
@@ -209,11 +213,14 @@ sub minus_f_nocase {
                push (@global_found, $tmp_path) unless $path_f;
                print STDERR "Found as @p but directory\n" if $opt_v;
            }
-       } elsif (-f _ && -r _) {
+       }
+       elsif (-f _ && -r _) {
            return $try;
-       } elsif (-f _) {
+       }
+       elsif (-f _) {
            warn "Ignored $try: unreadable\n";
-       } else {
+       }
+       else {
            my $found=0;
            my $lcp = lc $p;
            opendir DIR, "@p";
@@ -232,13 +239,14 @@ sub minus_f_nocase {
      }
      return "";
 }
+
 
 sub check_file {
     my($dir,$file) = @_;
     if ($opt_m) {
        return minus_f_nocase($dir,$file);
-    } else {
+    }
+    else {
        my $path = minus_f_nocase($dir,$file);
         return $path if length $path and containspod($path);
     }
@@ -264,7 +272,7 @@ sub searchfor {
                or ( $ret = check_file $dir,$s)
                or ( $Is_VMS and
                     $ret = check_file $dir,"$s.com")
-               or ( $^O eq 'os2' and 
+               or ( $^O eq 'os2' and
                     $ret = check_file $dir,"$s.cmd")
                or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and
                     $ret = check_file $dir,"$s.bat")
@@ -273,7 +281,7 @@ sub searchfor {
        ) {
            return $ret;
        }
-       
+
        if ($recurse) {
            opendir(D,$dir);
            my @newdirs = map "$dir/$_", grep {
@@ -291,73 +299,151 @@ sub searchfor {
     return ();
 }
 
+sub filter_nroff {
+  my @data = split /\n{2,}/, shift;
+  shift @data while @data and $data[0] !~ /\S/; # Go to header
+  shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header
+  pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like
+                               # 28/Jan/99 perl 5.005, patch 53 1
+  join "\n\n", @data;
+}
+
+sub printout {
+    my ($file, $tmp, $filter) = @_;
+    my $err;
+
+    if ($opt_t) {
+       open(TMP,">>$tmp")
+               or warn("Can't open $tmp: $!"), return;
+       Pod::Text::pod2text($file,*TMP);
+       close TMP;
+    }
+    elsif (not $opt_u) {
+       my $cmd = "pod2man --lax $file | nroff -man";
+       $cmd .= " | col -x" if $^O =~ /hpux/;
+       my $rslt = `$cmd`;
+       $rslt = filter_nroff($rslt) if $filter;
+       unless (($err = $?)) {
+           open(TMP,">>$tmp") or warn("Can't open $tmp: $!"), return;
+           print TMP $rslt;
+           close TMP;
+       }
+    }
+    if ($opt_u or $err or -z $tmp) {
+       open(OUT,">>$tmp") or warn("Can't open $tmp: $!"), return;
+       open(IN,"<$file") or warn("Can't open $file: $!"), return;
+       my $cut = 1;
+       while (<IN>) {
+           $cut = $1 eq 'cut' if /^=(\w+)/;
+           next if $cut;
+           print OUT;
+       }
+       close IN;
+       close OUT;
+    }
+}
+
+sub page {
+    my ($tmp, $no_tty, @pagers) = @_;
+    if ($no_tty) {
+       open(TMP,"<$tmp") or warn("Can't open $tmp: $!"), return;
+       print while <TMP>;
+       close TMP;
+    }
+    else {
+       foreach my $pager (@pagers) {
+           system("$pager $tmp") or last;
+       }
+    }
+}
+
+sub cleanup {
+    my @files = @_;
+    for (@files) {
+       1 while unlink($_); #Possibly pointless VMSism
+    }
+}
+
+sub safe_exit {
+    my ($val, @files) = @_;
+    cleanup(@files);
+    exit $val;
+}
+
+sub safe_die {
+    my ($msg, @files) = @_;
+    cleanup(@files);
+    die $msg;
+}
+
 my @found;
 foreach (@pages) {
-        if ($podidx && open(PODIDX, $podidx)) {
-           my $searchfor = $_;
-           local($_);
-           $searchfor =~ s,::,/,g;
-           print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
-           while (<PODIDX>) {
-               chomp;
-               push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?$,i;
-           }
-           close(PODIDX);
-           next;
-        }
-       print STDERR "Searching for $_\n" if $opt_v;
-       # We must look both in @INC for library modules and in PATH
-       # for executables, like h2xs or perldoc itself.
-       my @searchdirs = @INC;
-       if ($opt_F) {
-         next unless -r;
-         push @found, $_ if $opt_m or containspod($_);
-         next;
+    if ($podidx && open(PODIDX, $podidx)) {
+       my $searchfor = $_;
+       local($_);
+       $searchfor =~ s,::,/,g;
+       print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
+       while (<PODIDX>) {
+           chomp;
+           push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?$,i;
        }
-       unless ($opt_m) { 
-           if ($Is_VMS) {
-               my($i,$trn);
-               for ($i = 0; $trn = $ENV{'DCL$PATH'.$i}; $i++) {
-                   push(@searchdirs,$trn);
-               }
-               push(@searchdirs,'perl_root:[lib.pod]')  # installed pods
-           } else {
-               push(@searchdirs, grep(-d, split($Config{path_sep}, 
-                                                $ENV{'PATH'})));
+       close(PODIDX);
+       next;
+    }
+    print STDERR "Searching for $_\n" if $opt_v;
+    # We must look both in @INC for library modules and in PATH
+    # for executables, like h2xs or perldoc itself.
+    my @searchdirs = @INC;
+    if ($opt_F) {
+       next unless -r;
+       push @found, $_ if $opt_m or containspod($_);
+       next;
+    }
+    unless ($opt_m) {
+       if ($Is_VMS) {
+           my($i,$trn);
+           for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
+               push(@searchdirs,$trn);
            }
+           push(@searchdirs,'perl_root:[lib.pod]')  # installed pods
+       }
+       else {
+           push(@searchdirs, grep(-d, split($Config{path_sep},
+                                            $ENV{'PATH'})));
        }
-       my @files = searchfor(0,$_,@searchdirs);
-       if( @files ) {
-               print STDERR "Found as @files\n" if $opt_v;
-       } else {
-               # no match, try recursive search
-               
-               @searchdirs = grep(!/^\.$/,@INC);
-               
-               @files= searchfor(1,$_,@searchdirs) if $opt_r;
-               if( @files ) {
-                       print STDERR "Loosely found as @files\n" if $opt_v;
-               } else {
-                       print STDERR "No documentation found for \"$_\".\n";
-                       if (@global_found) {
-                           print STDERR "However, try\n";
-                           for my $dir (@global_found) {
-                               opendir(DIR, $dir) or die "$!";
-                               while (my $file = readdir(DIR)) {
-                                   next if ($file =~ /^\./);
-                                   $file =~ s/\.(pm|pod)$//;
-                                   print STDERR "\tperldoc $_\::$file\n";
-                               }
-                               closedir DIR;
-                           }
-                       }
+    }
+    my @files = searchfor(0,$_,@searchdirs);
+    if (@files) {
+       print STDERR "Found as @files\n" if $opt_v;
+    }
+    else {
+       # no match, try recursive search
+       @searchdirs = grep(!/^\.$/,@INC);
+       @files= searchfor(1,$_,@searchdirs) if $opt_r;
+       if (@files) {
+           print STDERR "Loosely found as @files\n" if $opt_v;
+       }
+       else {
+           print STDERR "No documentation found for \"$_\".\n";
+           if (@global_found) {
+               print STDERR "However, try\n";
+               for my $dir (@global_found) {
+                   opendir(DIR, $dir) or die "$!";
+                   while (my $file = readdir(DIR)) {
+                       next if ($file =~ /^\./);
+                       $file =~ s/\.(pm|pod)$//;
+                       print STDERR "\tperldoc $_\::$file\n";
+                   }
+                   closedir DIR;
                }
+           }
        }
-       push(@found,@files);
+    }
+    push(@found,@files);
 }
 
-if(!@found) {
-       exit ($Is_VMS ? 98962 : 1);
+if (!@found) {
+    exit ($Is_VMS ? 98962 : 1);
 }
 
 if ($opt_l) {
@@ -368,175 +454,143 @@ if ($opt_l) {
 my $lines = $ENV{LINES} || 24;
 
 my $no_tty;
-if( ! -t STDOUT ) { $no_tty = 1 }
+if (! -t STDOUT) { $no_tty = 1 }
+
+# until here we could simply exit or die
+# now we create temporary files that we have to clean up
+# namely $tmp, $buffer
 
 my $tmp;
+my $buffer;
 if ($Is_MSWin32) {
-       $tmp = "$ENV{TEMP}\\perldoc1.$$";
-       push @pagers, qw( more< less notepad );
-       unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
-} elsif ($Is_VMS) {
-       $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
-       push @pagers, qw( most more less type/page );
-} elsif ($Is_Dos) {
-       $tmp = "$ENV{TEMP}/perldoc1.$$";
-       $tmp =~ tr!\\/!//!s;
-       push @pagers, qw( less.exe more.com< );
-       unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
-} else {
-       if ($^O eq 'os2') {
-         require POSIX;
-         $tmp = POSIX::tmpnam();
-         unshift @pagers, 'less', 'cmd /c more <';
-       } else {
-         $tmp = "/tmp/perldoc1.$$";      
-       }
-       push @pagers, qw( more less pg view cat );
-       unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
+    $tmp = "$ENV{TEMP}\\perldoc1.$$";
+    $buffer = "$ENV{TEMP}\\perldoc1.b$$";
+    push @pagers, qw( more< less notepad );
+    unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
+    for (@found) { s,/,\\,g }
+}
+elsif ($Is_VMS) {
+    $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
+    $buffer = 'Sys$Scratch:perldoc.tmp1_b'.$$;
+    push @pagers, qw( most more less type/page );
+}
+elsif ($Is_Dos) {
+    $tmp = "$ENV{TEMP}/perldoc1.$$";
+    $buffer = "$ENV{TEMP}/perldoc1.b$$";
+    $tmp =~ tr!\\/!//!s;
+    $buffer =~ tr!\\/!//!s;
+    push @pagers, qw( less.exe more.com< );
+    unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
+}
+else {
+    if ($^O eq 'os2') {
+      require POSIX;
+      $tmp = POSIX::tmpnam();
+      $buffer = POSIX::tmpnam();
+      unshift @pagers, 'less', 'cmd /c more <';
+    }
+    else {
+      $tmp = "/tmp/perldoc1.$$";
+      $buffer = "/tmp/perldoc1.b$$";
+    }
+    push @pagers, qw( more less pg view cat );
+    unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
 }
 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
 
+# all exit calls from here on have to be safe_exit calls (see above)
+# and all die calls safe_die calls to guarantee removal of files and
+# dir as needed
+
 if ($opt_m) {
-       foreach my $pager (@pagers) {
-               system("$pager @found") or exit;
-       }
-       if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' }
-       exit 1;
-} 
+    foreach my $pager (@pagers) {
+       system("$pager @found") or safe_exit(0, $tmp, $buffer);
+    }
+    if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' }
+    # I don't get the line above. Please patch yourself as needed.
+    safe_exit(1, $tmp, $buffer);
+}
 
+my @pod;
 if ($opt_f) {
-   my $perlfunc = shift @found;
-   open(PFUNC, $perlfunc) or die "Can't open $perlfunc: $!";
-
-   # Functions like -r, -e, etc. are listed under `-X'.
-   my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) ? 'I<-X' : $opt_f ;
-
-   # Skip introduction
-   while (<PFUNC>) {
-       last if /^=head2 Alphabetical Listing of Perl Functions/;
-   }
-
-   # Look for our function
-   my $found = 0;
-   my @pod;
-   while (<PFUNC>) {
-       if (/^=item\s+\Q$search_string\E\b/o)  {
-          $found = 1;
-       } elsif (/^=item/) {
-          last if $found > 1;
-       }
-       next unless $found;
-       push @pod, $_;
-       ++$found if /^\w/;      # found descriptive text
-   }
-   if (@pod) {
-       if ($opt_t) {
-          open(FORMATTER, "| pod2text") || die "Can't start filter";
-          print FORMATTER "=over 8\n\n";
-          print FORMATTER @pod;
-          print FORMATTER "=back\n";
-          close(FORMATTER);
-       } elsif (@pod < $lines-2) {
-          print @pod;
-       } else {
-          foreach my $pager (@pagers) {
-               open (PAGER, "| $pager") or next;
-               print PAGER @pod ;
-               close(PAGER) or next;
-               last;
-          }
-       }
-   } else {
-       die "No documentation for perl function `$opt_f' found\n";
-   }
-   exit;
-}
+    my $perlfunc = shift @found;
+    open(PFUNC, $perlfunc)
+       or safe_die("Can't open $perlfunc: $!", $tmp, $buffer);
 
-if ($opt_q) {
-   local @ARGV = @found;       # I'm lazy, sue me.
-   my $found = 0;
-   my %found_in;
-   my @pod;
-
-   while (<>) {
-      if (/^=head2\s+.*(?:$opt_q)/oi) {
-        $found = 1;
-        push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
-      } elsif (/^=head2/) {
-        $found = 0;
-      }
-      next unless $found;
-      push @pod, $_;
-   }
-   
-   if (@pod) {
-      if ($opt_t) {
-        open(FORMATTER, "| pod2text") || die "Can't start filter";
-        print FORMATTER "=over 8\n\n";
-        print FORMATTER @pod;
-        print FORMATTER "=back\n";
-        close(FORMATTER);
-      } elsif (@pod < $lines-2) {
-        print @pod;
-      } else {
-        foreach my $pager (@pagers) {
-           open (PAGER, "| $pager") or next;
-           print PAGER @pod ;
-           close(PAGER) or next;
-           last;
-        }
-      }
-   } else {
-      die "No documentation for perl FAQ keyword `$opt_q' found\n";
-   }
-   exit;
-}
+    # Functions like -r, -e, etc. are listed under `-X'.
+    my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
+                       ? 'I<-X' : $opt_f ;
 
-foreach (@found) {
+    # Skip introduction
+    while (<PFUNC>) {
+       last if /^=head2 Alphabetical Listing of Perl Functions/;
+    }
 
-       my $err;
-       if($opt_t) {
-               open(TMP,">>$tmp");
-               Pod::Text::pod2text($_,*TMP);
-               close(TMP);
-       } elsif(not $opt_u) {
-               my $cmd = "pod2man --lax $_ | nroff -man";
-               $cmd .= " | col -x" if $^O =~ /hpux/;
-               my $rslt = `$cmd`;
-               unless(($err = $?)) {
-                       open(TMP,">>$tmp");
-                       print TMP $rslt;
-                       close TMP;
-               }
+    # Look for our function
+    my $found = 0;
+    my $inlist = 0;
+    while (<PFUNC>) {
+       if (/^=item\s+\Q$search_string\E\b/o)  {
+           $found = 1;
        }
-                                                       
-       if( $opt_u or $err or -z $tmp) {
-               open(OUT,">>$tmp");
-               open(IN,"<$_");
-               my $cut = 1;
-               while (<IN>) {
-                       $cut = $1 eq 'cut' if /^=(\w+)/;
-                       next if $cut;
-                       print OUT;
-               }
-               close(IN);
-               close(OUT);
+       elsif (/^=item/) {
+           last if $found > 1 and not $inlist;
+       }
+       next unless $found;
+       if (/^=over/) {
+           ++$inlist;
+       }
+       elsif (/^=back/) {
+           --$inlist;
        }
+       push @pod, $_;
+       ++$found if /^\w/;      # found descriptive text
+    }
+    if (!@pod) {
+       die "No documentation for perl function `$opt_f' found\n";
+    }
 }
 
-if( $no_tty ) {
-       open(TMP,"<$tmp");
-       print while <TMP>;
-       close(TMP);
-} else {
-       foreach my $pager (@pagers) {
-               system("$pager $tmp") or last;
+if ($opt_q) {
+    local @ARGV = @found;      # I'm lazy, sue me.
+    my $found = 0;
+    my %found_in;
+
+    while (<>) {
+       if (/^=head2\s+.*(?:$opt_q)/oi) {
+           $found = 1;
+           push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
        }
+       elsif (/^=head2/) {
+           $found = 0;
+       }
+       next unless $found;
+       push @pod, $_;
+    }
+    if (!@pod) {
+       safe_die("No documentation for perl FAQ keyword `$opt_q' found\n",
+                $tmp, $buffer);
+    }
 }
 
-1 while unlink($tmp); #Possibly pointless VMSism
+my $filter;
+
+if (@pod) {
+    open(TMP,">$buffer") or safe_die("Can't open '$buffer': $!", $tmp, $buffer);
+    print TMP "=over 8\n\n";
+    print TMP @pod;
+    print TMP "=back\n";
+    close TMP;
+    @found = $buffer;
+    $filter = 1;
+}
+
+foreach (@found) {
+    printout($_, $tmp, $filter);
+}
+page($tmp, $no_tty, @pagers);
 
-exit 0;
+safe_exit(0, $tmp, $buffer);
 
 __END__
 
@@ -620,7 +674,7 @@ contain fully qualified filenames, one per line.
 
 The item you want to look up.  Nested modules (such as C<File::Basename>)
 are specified either as C<File::Basename> or C<File/Basename>.  You may also
-give a descriptive name of a page, such as C<perlfunc>. You make also give a
+give a descriptive name of a page, such as C<perlfunc>. You may also give a
 partial or wrong-case name, such as "basename" for "File::Basename", but
 this will be slower, if there is more then one page with the same partial
 name, you will only get the first one.
@@ -629,7 +683,7 @@ name, you will only get the first one.
 
 =head1 ENVIRONMENT
 
-Any switches in the C<PERLDOC> environment variable will be used before the 
+Any switches in the C<PERLDOC> environment variable will be used before the
 command line arguments.  C<perldoc> also searches directories
 specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
 defined) and C<PATH> environment variables.
@@ -639,11 +693,18 @@ preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or
 C<PAGER> before trying to find a pager on its own.  (C<MANPAGER> is not
 used if C<perldoc> was told to display plain text or unformatted pod.)
 
+One useful value for C<PERLDOC_PAGER> is C<less -+C -E>.
+
+=head1 VERSION
+
+This is perldoc v2.0.
+
 =head1 AUTHOR
 
 Kenneth Albanowski <kjahds@kjahds.com>
 
-Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>
+Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>,
+and others.
 
 =cut
 
@@ -661,7 +722,7 @@ Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>
 #       Kenneth Albanowski <kjahds@kjahds.com>
 #   -added Charles Bailey's further VMS patches, and -u switch
 #   -added -t switch, with pod2text support
-# 
+#
 # Version 1.10: Thu Nov  9 07:23:47 EST 1995
 #              Kenneth Albanowski <kjahds@kjahds.com>
 #      -added VMS support
index c2ff67d..4a2c07b 100644 (file)
@@ -524,6 +524,7 @@ readvars %globvar, '..\perlvars.h','G';
 open(HDRFILE, ">$hdrfile") or die "$0: Can't open $hdrfile: $!\n";
 print HDRFILE <<ENDCODE;
 EXTERN_C void SetCPerlObj(void* pP);
+EXTERN_C void boot_CAPI_handler(CV *cv, void (*subaddr)(CV *c), void *pP);
 EXTERN_C CV* Perl_newXS(char* name, void (*subaddr)(CV* cv), char* filename);
 
 ENDCODE
@@ -593,6 +594,14 @@ U32 *      _Perl_opargs(void)
     return pPerl->Perl_get_opargs();
 }
 
+void boot_CAPI_handler(CV *cv, void (*subaddr)(CV *c), void *pP)
+{
+#ifndef NO_XSLOCKS
+    XSLock localLock((CPerlObj*)pP);
+#endif
+    subaddr(cv);
+}
+
 void xs_handler(CV* cv, CPerlObj* p)
 {
 #ifndef NO_XSLOCKS
@@ -616,7 +625,7 @@ void xs_handler(CV* cv, CPerlObj* p)
     }
 }
 
-EXTERN_C CV* Perl_newXS(char* name, void (*subaddr)(CV* cv), char* filename)
+CV* Perl_newXS(char* name, void (*subaddr)(CV* cv), char* filename)
 {
     CV* cv = pPerl->Perl_newXS(name, xs_handler, filename);
     pPerl->Perl_sv_magic((SV*)cv, pPerl->Perl_sv_2mortal(pPerl->Perl_newSViv((IV)subaddr)), '~', "CAPI", 4);
@@ -982,11 +991,21 @@ int          _win32_ioctl(int i, unsigned int u, char *data)
     return pPerl->PL_piLIO->IOCtl(i, u, data, ErrorNo());
 }
 
+int          _win32_unlink(const char *f)
+{
+    return pPerl->PL_piLIO->Unlink(f, ErrorNo());
+}
+
 int          _win32_utime(const char *f, struct utimbuf *t)
 {
     return pPerl->PL_piLIO->Utime((char*)f, t, ErrorNo());
 }
 
+int          _win32_uname(struct utsname *name)
+{
+    return pPerl->PL_piENV->Uname(name, ErrorNo());
+}
+
 char*   _win32_getenv(const char *name)
 {
     return pPerl->PL_piENV->Getenv(name, ErrorNo());
index fb91efb..faad89c 100644 (file)
@@ -32,6 +32,17 @@ INST_TOP     = $(INST_DRV)\perl
 INST_VER       = \5.00503
 
 #
+# Comment this out if you DON'T want your perl installation to have
+# architecture specific components.  This means that architecture-
+# specific files will be installed along with the architecture-neutral
+# files.  Leaving it enabled is safer and more flexible, in case you
+# want to build multiple flavors of perl and install them together in
+# the same location.  Commenting it out gives you a simpler
+# installation that is easier to understand for beginners.
+#
+INST_ARCH      = \$(ARCHNAME)
+
+#
 # uncomment to enable threads-capabilities
 #
 #USE_THREADS   = define
@@ -182,6 +193,19 @@ ARCHNAME   = MSWin32-$(PROCESSOR_ARCHITECTURE)
 ARCHDIR                = ..\lib\$(ARCHNAME)
 COREDIR                = ..\lib\CORE
 AUTODIR                = ..\lib\auto
+LIBDIR         = ..\lib
+EXTDIR         = ..\ext
+PODDIR         = ..\pod
+EXTUTILSDIR    = $(LIBDIR)\extutils
+
+#
+INST_SCRIPT    = $(INST_TOP)$(INST_VER)\bin
+INST_BIN       = $(INST_SCRIPT)$(INST_ARCH)
+INST_LIB       = $(INST_TOP)$(INST_VER)\lib
+INST_ARCHLIB   = $(INST_LIB)$(INST_ARCH)
+INST_COREDIR   = $(INST_ARCHLIB)\CORE
+INST_POD       = $(INST_LIB)\pod
+INST_HTML      = $(INST_POD)\html
 
 #
 # Programs to compile, build .lib files and link
@@ -253,7 +277,9 @@ LIBFILES    = $(LIBBASEFILES) $(LIBC)
 
 CFLAGS         = -nologo -Gf -W3 $(INCLUDES) $(DEFINES) $(LOCDEFS) \
                $(PCHFLAGS) $(OPTIMIZE)
-LINK_FLAGS     = -nologo -nodefaultlib $(LINK_DBG) -machine:$(PROCESSOR_ARCHITECTURE)
+LINK_FLAGS     = -nologo -nodefaultlib $(LINK_DBG) \
+               -libpath:"$(INST_COREDIR)" \
+               -machine:$(PROCESSOR_ARCHITECTURE)
 OBJOUT_FLAG    = -Fo
 EXEOUT_FLAG    = -Fe
 
@@ -281,17 +307,6 @@ $(o).dll:
            -out:$@ $(LINK_FLAGS) $(LIBFILES) $< $(LIBPERL)  
 
 #
-INST_BIN       = $(INST_TOP)$(INST_VER)\bin\$(ARCHNAME)
-INST_SCRIPT    = $(INST_TOP)$(INST_VER)\bin
-INST_LIB       = $(INST_TOP)$(INST_VER)\lib
-INST_POD       = $(INST_LIB)\pod
-INST_HTML      = $(INST_POD)\html
-LIBDIR         = ..\lib
-EXTDIR         = ..\ext
-PODDIR         = ..\pod
-EXTUTILSDIR    = $(LIBDIR)\extutils
-
-#
 # various targets
 !IF "$(OBJECT)" == "-DPERL_OBJECT"
 PERLIMPLIB     = ..\perlcore.lib
@@ -571,6 +586,7 @@ CFG_VARS    =                                       \
                "INST_DRV=$(INST_DRV)"                  \
                "INST_TOP=$(INST_TOP)"                  \
                "INST_VER=$(INST_VER)"                  \
+               "INST_ARCH=$(INST_ARCH)"                \
                "archname=$(ARCHNAME)"                  \
                "cc=$(CC)"                              \
                "ccflags=$(OPTIMIZE:"=\") $(DEFINES) $(OBJECT)" \
index eef2440..dbde709 100644 (file)
@@ -23,15 +23,15 @@ ansi2knr=''
 aphostname=''
 apiversion='5.005'
 ar='tlib /P128'
-archlib='~INST_TOP~~INST_VER~\lib\~archname~'
-archlibexp='~INST_TOP~~INST_VER~\lib\~archname~'
+archlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~'
+archlibexp='~INST_TOP~~INST_VER~\lib~INST_ARCH~'
 archname='MSWin32'
 archobjs=''
 awk='awk'
 baserev='5.0'
 bash=''
-bin='~INST_TOP~~INST_VER~\bin\~archname~'
-binexp='~INST_TOP~~INST_VER~\bin\~archname~'
+bin='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
+binexp='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
 bison=''
 byacc='byacc'
 byteorder='1234'
@@ -271,7 +271,7 @@ d_times='define'
 d_truncate='undef'
 d_tzname='define'
 d_umask='define'
-d_uname='undef'
+d_uname='define'
 d_union_semun='define'
 d_vfork='undef'
 d_void_closedir='undef'
@@ -377,15 +377,15 @@ i_varhdr='varargs.h'
 i_vfork='undef'
 incpath=''
 inews=''
-installarchlib='~INST_TOP~~INST_VER~\lib\~archname~'
-installbin='~INST_TOP~~INST_VER~\bin\~archname~'
+installarchlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~'
+installbin='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
 installman1dir='~INST_TOP~~INST_VER~\man\man1'
 installman3dir='~INST_TOP~~INST_VER~\man\man3'
 installhtmldir='~INST_TOP~~INST_VER~\html'
 installhtmlhelpdir='~INST_TOP~~INST_VER~\htmlhelp'
 installprivlib='~INST_TOP~~INST_VER~\lib'
 installscript='~INST_TOP~~INST_VER~\bin'
-installsitearch='~INST_TOP~\site~INST_VER~\lib\~archname~'
+installsitearch='~INST_TOP~\site~INST_VER~\lib~INST_ARCH~'
 installsitelib='~INST_TOP~\site~INST_VER~\lib'
 intsize='4'
 known_extensions='DB_File Fcntl GDBM_File NDBM_File ODBM_File Opcode POSIX SDBM_File Socket IO attrs Thread'
@@ -463,7 +463,7 @@ patchlevel='~PATCHLEVEL~'
 path_sep=';'
 perl='perl'
 perladmin=''
-perlpath='~INST_TOP~~INST_VER~\bin\~archname~\perl.exe'
+perlpath='~INST_TOP~~INST_VER~\bin~INST_ARCH~\perl.exe'
 pg=''
 phostname='hostname'
 pidtype='int'
@@ -499,8 +499,8 @@ sig_name_init='"ZERO", "NUM01", "INT", "QUIT", "ILL", "NUM05", "NUM06", "NUM07",
 sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 18 0'
 sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 18, 0'
 signal_t='void'
-sitearch='~INST_TOP~\site~INST_VER~\lib\~archname~'
-sitearchexp='~INST_TOP~\site~INST_VER~\lib\~archname~'
+sitearch='~INST_TOP~\site~INST_VER~\lib~INST_ARCH~'
+sitearchexp='~INST_TOP~\site~INST_VER~\lib~INST_ARCH~'
 sitelib='~INST_TOP~\site~INST_VER~\lib'
 sitelibexp='~INST_TOP~\site~INST_VER~\lib'
 sizetype='size_t'
index b43c511..0ab3acb 100644 (file)
@@ -23,15 +23,15 @@ ansi2knr=''
 aphostname=''
 apiversion='5.005'
 ar='ar'
-archlib='~INST_TOP~~INST_VER~\lib\~archname~'
-archlibexp='~INST_TOP~~INST_VER~\lib\~archname~'
+archlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~'
+archlibexp='~INST_TOP~~INST_VER~\lib~INST_ARCH~'
 archname='MSWin32'
 archobjs=''
 awk='awk'
 baserev='5.0'
 bash=''
-bin='~INST_TOP~~INST_VER~\bin\~archname~'
-binexp='~INST_TOP~~INST_VER~\bin\~archname~'
+bin='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
+binexp='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
 bison=''
 byacc='byacc'
 byteorder='1234'
@@ -271,7 +271,7 @@ d_times='define'
 d_truncate='undef'
 d_tzname='undef'
 d_umask='define'
-d_uname='undef'
+d_uname='define'
 d_union_semun='define'
 d_vfork='undef'
 d_void_closedir='undef'
@@ -377,15 +377,15 @@ i_varhdr='varargs.h'
 i_vfork='undef'
 incpath=''
 inews=''
-installarchlib='~INST_TOP~~INST_VER~\lib\~archname~'
-installbin='~INST_TOP~~INST_VER~\bin\~archname~'
+installarchlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~'
+installbin='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
 installman1dir='~INST_TOP~~INST_VER~\man\man1'
 installman3dir='~INST_TOP~~INST_VER~\man\man3'
 installhtmldir='~INST_TOP~~INST_VER~\html'
 installhtmlhelpdir='~INST_TOP~~INST_VER~\htmlhelp'
 installprivlib='~INST_TOP~~INST_VER~\lib'
 installscript='~INST_TOP~~INST_VER~\bin'
-installsitearch='~INST_TOP~\site~INST_VER~\lib\~archname~'
+installsitearch='~INST_TOP~\site~INST_VER~\lib~INST_ARCH~'
 installsitelib='~INST_TOP~\site~INST_VER~\lib'
 intsize='4'
 known_extensions='DB_File Fcntl GDBM_File NDBM_File ODBM_File Opcode POSIX SDBM_File Socket IO attrs Thread'
@@ -463,7 +463,7 @@ patchlevel='~PATCHLEVEL~'
 path_sep=';'
 perl='perl'
 perladmin=''
-perlpath='~INST_TOP~~INST_VER~\bin\~archname~\perl.exe'
+perlpath='~INST_TOP~~INST_VER~\bin~INST_ARCH~\perl.exe'
 pg=''
 phostname='hostname'
 pidtype='int'
@@ -499,8 +499,8 @@ sig_name_init='"ZERO", "NUM01", "INT", "QUIT", "ILL", "NUM05", "NUM06", "NUM07",
 sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 20 0'
 sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 20, 0'
 signal_t='void'
-sitearch='~INST_TOP~\site~INST_VER~\lib\~archname~'
-sitearchexp='~INST_TOP~\site~INST_VER~\lib\~archname~'
+sitearch='~INST_TOP~\site~INST_VER~\lib~INST_ARCH~'
+sitearchexp='~INST_TOP~\site~INST_VER~\lib~INST_ARCH~'
 sitelib='~INST_TOP~\site~INST_VER~\lib'
 sitelibexp='~INST_TOP~\site~INST_VER~\lib'
 sizetype='size_t'
index df6e0e0..ad66285 100644 (file)
@@ -23,15 +23,15 @@ ansi2knr=''
 aphostname=''
 apiversion='5.005'
 ar='lib'
-archlib='~INST_TOP~~INST_VER~\lib\~archname~'
-archlibexp='~INST_TOP~~INST_VER~\lib\~archname~'
+archlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~'
+archlibexp='~INST_TOP~~INST_VER~\lib~INST_ARCH~'
 archname='MSWin32'
 archobjs=''
 awk='awk'
 baserev='5.0'
 bash=''
-bin='~INST_TOP~~INST_VER~\bin\~archname~'
-binexp='~INST_TOP~~INST_VER~\bin\~archname~'
+bin='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
+binexp='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
 bison=''
 byacc='byacc'
 byteorder='1234'
@@ -271,7 +271,7 @@ d_times='define'
 d_truncate='undef'
 d_tzname='define'
 d_umask='define'
-d_uname='undef'
+d_uname='define'
 d_union_semun='define'
 d_vfork='undef'
 d_void_closedir='undef'
@@ -377,15 +377,15 @@ i_varhdr='varargs.h'
 i_vfork='undef'
 incpath=''
 inews=''
-installarchlib='~INST_TOP~~INST_VER~\lib\~archname~'
-installbin='~INST_TOP~~INST_VER~\bin\~archname~'
+installarchlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~'
+installbin='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
 installman1dir='~INST_TOP~~INST_VER~\man\man1'
 installman3dir='~INST_TOP~~INST_VER~\man\man3'
 installhtmldir='~INST_TOP~~INST_VER~\html'
 installhtmlhelpdir='~INST_TOP~~INST_VER~\htmlhelp'
 installprivlib='~INST_TOP~~INST_VER~\lib'
 installscript='~INST_TOP~~INST_VER~\bin'
-installsitearch='~INST_TOP~\site~INST_VER~\lib\~archname~'
+installsitearch='~INST_TOP~\site~INST_VER~\lib~INST_ARCH~'
 installsitelib='~INST_TOP~\site~INST_VER~\lib'
 intsize='4'
 known_extensions='DB_File Fcntl GDBM_File NDBM_File ODBM_File Opcode POSIX SDBM_File Socket IO attrs Thread'
@@ -463,7 +463,7 @@ patchlevel='~PATCHLEVEL~'
 path_sep=';'
 perl='perl'
 perladmin=''
-perlpath='~INST_TOP~~INST_VER~\bin\~archname~\perl.exe'
+perlpath='~INST_TOP~~INST_VER~\bin~INST_ARCH~\perl.exe'
 pg=''
 phostname='hostname'
 pidtype='int'
@@ -499,8 +499,8 @@ sig_name_init='"ZERO", "NUM01", "INT", "QUIT", "ILL", "NUM05", "NUM06", "NUM07",
 sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 20 0'
 sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 20, 0'
 signal_t='void'
-sitearch='~INST_TOP~\site~INST_VER~\lib\~archname~'
-sitearchexp='~INST_TOP~\site~INST_VER~\lib\~archname~'
+sitearch='~INST_TOP~\site~INST_VER~\lib~INST_ARCH~'
+sitearchexp='~INST_TOP~\site~INST_VER~\lib~INST_ARCH~'
 sitelib='~INST_TOP~\site~INST_VER~\lib'
 sitelibexp='~INST_TOP~\site~INST_VER~\lib'
 sizetype='size_t'
index 1d895dd..0575b1b 100644 (file)
  *     uname() routine to derive the host name.  See also HAS_GETHOSTNAME
  *     and PHOSTNAME.
  */
-/*#define HAS_UNAME            /**/
+#define HAS_UNAME              /**/
 
 /* HAS_GETLOGIN:
  *     This symbol, if defined, indicates that the getlogin routine is
index 0cb45e4..4b0ddcc 100644 (file)
  *     uname() routine to derive the host name.  See also HAS_GETHOSTNAME
  *     and PHOSTNAME.
  */
-/*#define HAS_UNAME            /**/
+#define HAS_UNAME              /**/
 
 /* HAS_GETLOGIN:
  *     This symbol, if defined, indicates that the getlogin routine is
index d239d24..04b393b 100644 (file)
  *     uname() routine to derive the host name.  See also HAS_GETHOSTNAME
  *     and PHOSTNAME.
  */
-/*#define HAS_UNAME            /**/
+#define HAS_UNAME              /**/
 
 /* HAS_GETLOGIN:
  *     This symbol, if defined, indicates that the getlogin routine is
index a637ca1..59661e5 100644 (file)
@@ -134,6 +134,7 @@ Perl_my_ntohl
 Perl_my_swap
 Perl_my_chsize
 Perl_newXSUB
+Perl_no_bareword_allowed
 Perl_no_fh_allowed
 Perl_no_op
 Perl_nointrp
@@ -540,7 +541,9 @@ win32_alarm
 win32_open_osfhandle
 win32_get_osfhandle
 win32_ioctl
+win32_unlink
 win32_utime
+win32_uname
 win32_wait
 win32_waitpid
 win32_kill
@@ -551,6 +554,7 @@ win32_telldir
 win32_seekdir
 win32_rewinddir
 win32_closedir
+win32_longpath
 Perl_win32_init
 Perl_init_os_extras
 Perl_getTHR
index 244b2c9..6058df8 100644 (file)
@@ -36,6 +36,17 @@ INST_TOP     *= $(INST_DRV)\perl
 INST_VER       *= \5.00503
 
 #
+# Comment this out if you DON'T want your perl installation to have
+# architecture specific components.  This means that architecture-
+# specific files will be installed along with the architecture-neutral
+# files.  Leaving it enabled is safer and more flexible, in case you
+# want to build multiple flavors of perl and install them together in
+# the same location.  Commenting it out gives you a simpler
+# installation that is easier to understand for beginners.
+#
+INST_ARCH      *= \$(ARCHNAME)
+
+#
 # uncomment to enable threads-capabilities
 #
 #USE_THREADS   *= define
@@ -191,6 +202,19 @@ ARCHNAME   = MSWin32-$(PROCESSOR_ARCHITECTURE)
 ARCHDIR                = ..\lib\$(ARCHNAME)
 COREDIR                = ..\lib\CORE
 AUTODIR                = ..\lib\auto
+LIBDIR         = ..\lib
+EXTDIR         = ..\ext
+PODDIR         = ..\pod
+EXTUTILSDIR    = $(LIBDIR)\extutils
+
+#
+INST_SCRIPT    = $(INST_TOP)$(INST_VER)\bin
+INST_BIN       = $(INST_SCRIPT)$(INST_ARCH)
+INST_LIB       = $(INST_TOP)$(INST_VER)\lib
+INST_ARCHLIB   = $(INST_LIB)$(INST_ARCH)
+INST_COREDIR   = $(INST_ARCHLIB)\CORE
+INST_POD       = $(INST_LIB)\pod
+INST_HTML      = $(INST_POD)\html
 
 #
 # Programs to compile, build .lib files and link
@@ -229,7 +253,7 @@ LINK_DBG    =
 
 CFLAGS         = -w -g0 -tWM -tWD $(INCLUDES) $(DEFINES) $(LOCDEFS) \
                $(PCHFLAGS) $(OPTIMIZE)
-LINK_FLAGS     = $(LINK_DBG) -L"$(CCLIBDIR)"
+LINK_FLAGS     = $(LINK_DBG) -L"$(INST_COREDIR)" -L"$(CCLIBDIR)"
 OBJOUT_FLAG    = -o
 EXEOUT_FLAG    = -e
 LIBOUT_FLAG    = 
@@ -267,7 +291,7 @@ LINK_DBG    =
 .ENDIF
 
 CFLAGS         = $(INCLUDES) $(DEFINES) $(LOCDEFS) $(OPTIMIZE)
-LINK_FLAGS     = $(LINK_DBG) -L"$(CCLIBDIR)"
+LINK_FLAGS     = $(LINK_DBG) -L"$(INST_COREDIR)" -L"$(CCLIBDIR)"
 OBJOUT_FLAG    = -o
 EXEOUT_FLAG    = -o
 LIBOUT_FLAG    = 
@@ -336,7 +360,9 @@ LIBFILES    = $(LIBBASEFILES) $(LIBC)
 
 CFLAGS         = -nologo -Gf -W3 $(INCLUDES) $(DEFINES) $(LOCDEFS) \
                $(PCHFLAGS) $(OPTIMIZE)
-LINK_FLAGS     = -nologo -nodefaultlib $(LINK_DBG) -machine:$(PROCESSOR_ARCHITECTURE)
+LINK_FLAGS     = -nologo -nodefaultlib $(LINK_DBG) \
+               -libpath:"$(INST_COREDIR)" \
+               -machine:$(PROCESSOR_ARCHITECTURE)
 OBJOUT_FLAG    = -Fo
 EXEOUT_FLAG    = -Fe
 LIBOUT_FLAG    = /out:
@@ -383,17 +409,6 @@ $(o).dll:
 .ENDIF
 
 #
-INST_BIN       = $(INST_TOP)$(INST_VER)\bin\$(ARCHNAME)
-INST_SCRIPT    = $(INST_TOP)$(INST_VER)\bin
-INST_LIB       = $(INST_TOP)$(INST_VER)\lib
-INST_POD       = $(INST_LIB)\pod
-INST_HTML      = $(INST_POD)\html
-LIBDIR         = ..\lib
-EXTDIR         = ..\ext
-PODDIR         = ..\pod
-EXTUTILSDIR    = $(LIBDIR)\extutils
-
-#
 # various targets
 MINIPERL       = ..\miniperl.exe
 MINIDIR                = .\mini
@@ -686,6 +701,7 @@ CFG_VARS    =                                       \
                "INST_DRV=$(INST_DRV)"                  \
                "INST_TOP=$(INST_TOP)"                  \
                "INST_VER=$(INST_VER)"                  \
+               "INST_ARCH=$(INST_ARCH)"                \
                "archname=$(ARCHNAME)"                  \
                "cc=$(CC)"                              \
                "ccflags=$(OPTIMIZE:s/"/\"/) $(DEFINES) $(OBJECT)"      \
index a0f7783..d32ab68 100644 (file)
@@ -98,6 +98,10 @@ public:
     {
        return g_win32_get_sitelib(pl);
     };
+    virtual int Uname(struct utsname *name, int &err)
+    {
+       return win32_uname(name);
+    };
 };
 
 class CPerlSock : public IPerlSock
@@ -422,8 +426,7 @@ public:
     };
     virtual int Unlink(const char *filename, int &err)
     {
-       chmod(filename, S_IREAD | S_IWRITE);
-       CALLFUNCRET(unlink(filename))
+       CALLFUNCRET(win32_unlink(filename))
     };
     virtual int Utime(char *filename, struct utimbuf *times, int &err)
     {
@@ -573,12 +576,14 @@ public:
                          |FORMAT_MESSAGE_IGNORE_INSERTS
                          |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
                           dwErr, 0, (char *)&sMsg, 1, NULL);
+       /* strip trailing whitespace and period */
        if (0 < dwLen) {
-           while (0 < dwLen  &&  isspace(sMsg[--dwLen]))
-               ;
+           do {
+               --dwLen;        /* dwLen doesn't include trailing null */
+           } while (0 < dwLen && isSPACE(sMsg[dwLen]));
            if ('.' != sMsg[dwLen])
                dwLen++;
-           sMsg[dwLen]= '\0';
+           sMsg[dwLen] = '\0';
        }
        if (0 == dwLen) {
            sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
@@ -859,6 +864,8 @@ public:
                               &perlDir, &perlSock, &perlProc);
            if(pPerl != NULL)
            {
+               perl_init_i18nl10n(1);
+
                try
                {
                    pPerl->perl_construct();
index 8cf521d..336f2a8 100644 (file)
@@ -28,9 +28,6 @@ xs_init(CPERLarg)
 
 CPerlObj *pPerl;
 
-#undef PERL_SYS_INIT
-#define PERL_SYS_INIT(a, c)
-
 int
 main(int argc, char **argv, char **env)
 {
@@ -41,11 +38,15 @@ main(int argc, char **argv, char **env)
      * want to free() argv after main() returns.  As luck would have it,
      * Borland's CRT does the right thing to argv[0] already. */
     char szModuleName[MAX_PATH];
+    char *ptr;
 
     GetModuleFileName(NULL, szModuleName, sizeof(szModuleName));
+    (void)win32_longpath(szModuleName);
     argv[0] = szModuleName;
 #endif
 
+    PERL_SYS_INIT(&argc,&argv);
+
     if (!host.PerlCreate())
        exit(exitstatus);
 
@@ -87,7 +88,10 @@ main(int argc, char **argv, char **env)
      * want to free() argv after main() returns.  As luck would have it,
      * Borland's CRT does the right thing to argv[0] already. */
     char szModuleName[MAX_PATH];
+    char *ptr;
+
     GetModuleFileName(NULL, szModuleName, sizeof(szModuleName));
+    (void)win32_longpath(szModuleName);
     argv[0] = szModuleName;
 #endif
     return RunPerl(argc, argv, env, (void*)0);
index a76467a..f045113 100644 (file)
 #endif
 #include <windows.h>
 
-#ifndef __MINGW32__
-#include <lmcons.h>
-#include <lmerr.h>
-/* ugliness to work around a buggy struct definition in lmwksta.h */
-#undef LPTSTR
-#define LPTSTR LPWSTR
-#include <lmwksta.h>
-#undef LPTSTR
-#define LPTSTR LPSTR
-#include <lmapibuf.h>
-#endif /* __MINGW32__ */
-
 /* #include "config.h" */
 
 #define PERLIO_NOT_STDIO 0 
@@ -96,10 +84,13 @@ static long         tokenize(char *str, char **dest, char ***destv);
 static BOOL            has_shell_metachars(char *ptr);
 static long            filetime_to_clock(PFILETIME ft);
 static BOOL            filetime_from_time(PFILETIME ft, time_t t);
-static char *          get_emd_part(char *leading, char *trailing, ...);
-static void            remove_dead_process(HANDLE deceased);
+static char *          get_emd_part(SV **leading, char *trailing, ...);
+static void            remove_dead_process(long deceased);
+static long            find_pid(int pid);
+static char *          qualified_path(const char *cmd);
 
 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
+char   w32_module_name[MAX_PATH+1];
 static DWORD   w32_platform = (DWORD)-1;
 
 #ifdef USE_THREADS
@@ -135,48 +126,50 @@ IsWinNT(void) {
     return (os_id() == VER_PLATFORM_WIN32_NT);
 }
 
-char*
-GetRegStrFromKey(HKEY hkey, const char *lpszValueName, char** ptr, DWORD* lpDataLen)
-{   /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
+/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
+static char*
+get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
+{
+    /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
     HKEY handle;
     DWORD type;
     const char *subkey = "Software\\Perl";
+    char *str = Nullch;
     long retval;
 
     retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
-    if (retval == ERROR_SUCCESS){
-       retval = RegQueryValueEx(handle, lpszValueName, 0, &type, NULL, lpDataLen);
+    if (retval == ERROR_SUCCESS) {
+       DWORD datalen;
+       retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
        if (retval == ERROR_SUCCESS && type == REG_SZ) {
-           if (*ptr) {
-               Renew(*ptr, *lpDataLen, char);
-           }
-           else {
-               New(1312, *ptr, *lpDataLen, char);
-           }
-           retval = RegQueryValueEx(handle, lpszValueName, 0, NULL, (PBYTE)*ptr, lpDataLen);
-           if (retval != ERROR_SUCCESS) {
-               Safefree(*ptr);
-               *ptr = Nullch;
+           if (!*svp)
+               *svp = sv_2mortal(newSVpvn("",0));
+           SvGROW(*svp, datalen);
+           retval = RegQueryValueEx(handle, valuename, 0, NULL,
+                                    (PBYTE)SvPVX(*svp), &datalen);
+           if (retval == ERROR_SUCCESS) {
+               str = SvPVX(*svp);
+               SvCUR_set(*svp,datalen-1);
            }
        }
        RegCloseKey(handle);
     }
-    return *ptr;
+    return str;
 }
 
-char*
-GetRegStr(const char *lpszValueName, char** ptr, DWORD* lpDataLen)
+/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
+static char*
+get_regstr(const char *valuename, SV **svp)
 {
-    *ptr = GetRegStrFromKey(HKEY_CURRENT_USER, lpszValueName, ptr, lpDataLen);
-    if (*ptr == Nullch)
-    {
-       *ptr = GetRegStrFromKey(HKEY_LOCAL_MACHINE, lpszValueName, ptr, lpDataLen);
-    }
-    return *ptr;
+    char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
+    if (!str)
+       str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
+    return str;
 }
 
+/* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
 static char *
-get_emd_part(char *prev_path, char *trailing_path, ...)
+get_emd_part(SV **prev_pathp, char *trailing_path, ...)
 {
     char base[10];
     va_list ap;
@@ -191,19 +184,42 @@ get_emd_part(char *prev_path, char *trailing_path, ...)
 
     sprintf(base, "%5.3f", (double) 5 + ((double) PATCHLEVEL / (double) 1000));
 
-    GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
-                               ? GetModuleHandle(NULL) : w32_perldll_handle),
-                     mod_name, sizeof(mod_name));
-    ptr = strrchr(mod_name, '\\');
+    if (!*w32_module_name) {
+       GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
+                                   ? GetModuleHandle(NULL)
+                                   : w32_perldll_handle),
+                         w32_module_name, sizeof(w32_module_name));
+
+       /* try to get full path to binary (which may be mangled when perl is
+        * run from a 16-bit app) */
+       /*PerlIO_printf(PerlIO_stderr(), "Before %s\n", w32_module_name);*/
+       (void)win32_longpath(w32_module_name);
+       /*PerlIO_printf(PerlIO_stderr(), "After  %s\n", w32_module_name);*/
+
+       /* normalize to forward slashes */
+       ptr = w32_module_name;
+       while (*ptr) {
+           if (*ptr == '\\')
+               *ptr = '/';
+           ++ptr;
+       }
+    }
+    strcpy(mod_name, w32_module_name);
+    ptr = strrchr(mod_name, '/');
     while (ptr && strip) {
         /* look for directories to skip back */
        optr = ptr;
        *ptr = '\0';
-       ptr = strrchr(mod_name, '\\');
+       ptr = strrchr(mod_name, '/');
+       /* avoid stripping component if there is no slash,
+        * or it doesn't match ... */
        if (!ptr || stricmp(ptr+1, strip) != 0) {
-           if(!(*strip == '5' && *(ptr+1) == '5' && strncmp(strip, base, 5) == 0
-                   && strncmp(ptr+1, base, 5) == 0)) {
-               *optr = '\\';
+           /* ... but not if component matches 5.00X* */
+           if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
+                         && strncmp(strip, base, 5) == 0
+                         && strncmp(ptr+1, base, 5) == 0))
+           {
+               *optr = '/';
                ptr = optr;
            }
        }
@@ -212,29 +228,22 @@ get_emd_part(char *prev_path, char *trailing_path, ...)
     if (!ptr) {
        ptr = mod_name;
        *ptr++ = '.';
-       *ptr = '\\';
+       *ptr = '/';
     }
     va_end(ap);
     strcpy(++ptr, trailing_path);
 
     /* only add directory if it exists */
-    if(GetFileAttributes(mod_name) != (DWORD) -1) {
+    if (GetFileAttributes(mod_name) != (DWORD) -1) {
        /* directory exists */
-       newsize = strlen(mod_name) + 1;
-       if (prev_path) {
-           oldsize = strlen(prev_path) + 1;
-           newsize += oldsize;                 /* includes plus 1 for ';' */
-           Renew(prev_path, newsize, char);
-           prev_path[oldsize-1] = ';';
-           strcpy(&prev_path[oldsize], mod_name);
-       }
-       else {
-           New(1311, prev_path, newsize, char);
-           strcpy(prev_path, mod_name);
-       }
+       if (!*prev_pathp)
+           *prev_pathp = sv_2mortal(newSVpvn("",0));
+       sv_catpvn(*prev_pathp, ";", 1);
+       sv_catpv(*prev_pathp, mod_name);
+       return SvPVX(*prev_pathp);
     }
 
-    return prev_path;
+    return Nullch;
 }
 
 char *
@@ -242,17 +251,15 @@ win32_get_privlib(char *pl)
 {
     char *stdlib = "lib";
     char buffer[MAX_PATH+1];
-    char *path = Nullch;
-    DWORD datalen;
+    SV *sv = Nullsv;
 
     /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || "";  */
     sprintf(buffer, "%s-%s", stdlib, pl);
-    path = GetRegStr(buffer, &path, &datalen);
-    if (!path)
-       path = GetRegStr(stdlib, &path, &datalen);
+    if (!get_regstr(buffer, &sv))
+       (void)get_regstr(stdlib, &sv);
 
     /* $stdlib .= ";$EMD/../../lib" */
-    return get_emd_part(path, stdlib, ARCHNAME, "bin", Nullch);
+    return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
 }
 
 char *
@@ -262,41 +269,43 @@ win32_get_sitelib(char *pl)
     char regstr[40];
     char pathstr[MAX_PATH+1];
     DWORD datalen;
-    char *path1 = Nullch;
-    char *path2 = Nullch;
     int len, newsize;
+    SV *sv1 = Nullsv;
+    SV *sv2 = Nullsv;
 
     /* $HKCU{"sitelib-$]"} || $HKLM{"sitelib-$]"} . ---; */
     sprintf(regstr, "%s-%s", sitelib, pl);
-    path1 = GetRegStr(regstr, &path1, &datalen);
+    (void)get_regstr(regstr, &sv1);
 
     /* $sitelib .=
      * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/site/$]/lib";  */
-    sprintf(pathstr, "site\\%s\\lib", pl);
-    path1 = get_emd_part(path1, pathstr, ARCHNAME, "bin", pl, Nullch);
+    sprintf(pathstr, "site/%s/lib", pl);
+    (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
+    if (!sv1 && strlen(pl) == 7) {
+       /* pl may have been SUBVERSION-specific; try again without
+        * SUBVERSION */
+       sprintf(pathstr, "site/%.5s/lib", pl);
+       (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
+    }
 
     /* $HKCU{'sitelib'} || $HKLM{'sitelib'} . ---; */
-    path2 = GetRegStr(sitelib, &path2, &datalen);
+    (void)get_regstr(sitelib, &sv2);
 
     /* $sitelib .=
      * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/site/lib";  */
-    path2 = get_emd_part(path2, "site\\lib", ARCHNAME, "bin", pl, Nullch);
-
-    if (!path1)
-       return path2;
+    (void)get_emd_part(&sv2, "site/lib", ARCHNAME, "bin", pl, Nullch);
 
-    if (!path2)
-       return path1;
-
-    len = strlen(path1);
-    newsize = len + strlen(path2) + 2; /* plus one for ';' */
+    if (!sv1 && !sv2)
+       return Nullch;
+    if (!sv1)
+       return SvPVX(sv2);
+    if (!sv2)
+       return SvPVX(sv1);
 
-    Renew(path1, newsize, char);
-    path1[len++] = ';';
-    strcpy(&path1[len], path2);
+    sv_catpvn(sv1, ";", 1);
+    sv_catsv(sv1, sv2);
 
-    Safefree(path2);
-    return path1;
+    return SvPVX(sv1);
 }
 
 
@@ -543,11 +552,11 @@ do_spawn2(char *cmd, int exectype)
        strcpy(cmd2, cmd);
        a = argv;
        for (s = cmd2; *s;) {
-           while (*s && isspace(*s))
+           while (*s && isSPACE(*s))
                s++;
            if (*s)
                *(a++) = s;
-           while (*s && !isspace(*s))
+           while (*s && !isSPACE(*s))
                s++;
            if (*s)
                *s++ = '\0';
@@ -662,8 +671,15 @@ win32_opendir(char *filename)
 
     /* Create the search pattern */
     strcpy(scanname, filename);
-    if (scanname[len-1] != '/' && scanname[len-1] != '\\')
+
+    /* bare drive name means look in cwd for drive */
+    if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
+       scanname[len++] = '.';
+       scanname[len++] = '/';
+    }
+    else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
        scanname[len++] = '/';
+    }
     scanname[len++] = '*';
     scanname[len] = '\0';
 
@@ -843,42 +859,40 @@ chown(const char *path, uid_t owner, gid_t group)
     return 0;
 }
 
-static void
-remove_dead_process(HANDLE deceased)
+static long
+find_pid(int pid)
 {
-#ifndef USE_RTL_WAIT
-    int child;
+    long child;
     for (child = 0 ; child < w32_num_children ; ++child) {
-       if (w32_child_pids[child] == deceased) {
-           Copy(&w32_child_pids[child+1], &w32_child_pids[child],
-                (w32_num_children-child-1), HANDLE);
-           w32_num_children--;
-           break;
-       }
+       if (w32_child_pids[child] == pid)
+           return child;
+    }
+    return -1;
+}
+
+static void
+remove_dead_process(long child)
+{
+    if (child >= 0) {
+       CloseHandle(w32_child_handles[child]);
+       Copy(&w32_child_handles[child+1], &w32_child_handles[child],
+            (w32_num_children-child-1), HANDLE);
+       Copy(&w32_child_pids[child+1], &w32_child_pids[child],
+            (w32_num_children-child-1), DWORD);
+       w32_num_children--;
     }
-#endif
 }
 
 DllExport int
 win32_kill(int pid, int sig)
 {
-#ifdef USE_RTL_WAIT
-    HANDLE hProcess= OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
-#else
-    HANDLE hProcess = (HANDLE) pid;
-#endif
-
-    if (hProcess == NULL) {
-       croak("kill process failed!\n");
-    }
-    else {
-       if (!TerminateProcess(hProcess, sig))
-           croak("kill process failed!\n");
+    HANDLE hProcess;
+    hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
+    if (hProcess && TerminateProcess(hProcess, sig))
        CloseHandle(hProcess);
-
-       /* WaitForMultipleObjects() on a pid that was killed returns error
-        * so if we know the pid is gone we remove it from process list */
-       remove_dead_process(hProcess);
+    else {
+       errno = EINVAL;
+       return -1;
     }
     return 0;
 }
@@ -898,30 +912,40 @@ DllExport int
 win32_stat(const char *path, struct stat *buffer)
 {
     char       t[MAX_PATH+1]; 
-    const char *p = path;
     int                l = strlen(path);
     int                res;
 
     if (l > 1) {
        switch(path[l - 1]) {
+       /* FindFirstFile() and stat() are buggy with a trailing
+        * backslash, so change it to a forward slash :-( */
        case '\\':
-       case '/':
-           if (path[l - 2] != ':') {
-               strncpy(t, path, l - 1);
-               t[l - 1] = 0;
-               p = t;
-           };
+           strncpy(t, path, l);
+           t[l - 1] = '/';
+           t[l] = '\0';
+           path = t;
+           break;
+       /* FindFirstFile() is buggy with "x:", so add a dot :-( */
+       case ':':
+           if (l == 2 && isALPHA(path[0])) {
+               t[0] = path[0]; t[1] = ':'; t[2] = '.'; t[3] = '\0';
+               l = 3;
+               path = t;
+           }
+           break;
        }
     }
-    res = stat(p,buffer);
+    res = stat(path,buffer);
     if (res < 0) {
        /* CRT is buggy on sharenames, so make sure it really isn't.
         * XXX using GetFileAttributesEx() will enable us to set
         * buffer->st_*time (but note that's not available on the
         * Windows of 1995) */
-       DWORD r = GetFileAttributes(p);
+       DWORD r = GetFileAttributes(path);
        if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
-           buffer->st_mode |= S_IFDIR | S_IREAD;
+           /* buffer may still contain old garbage since stat() failed */
+           Zero(buffer, 1, struct stat);
+           buffer->st_mode = S_IFDIR | S_IREAD;
            errno = 0;
            if (!(r & FILE_ATTRIBUTE_READONLY))
                buffer->st_mode |= S_IWRITE | S_IEXEC;
@@ -929,8 +953,8 @@ win32_stat(const char *path, struct stat *buffer)
        }
     }
     else {
-       if (l == 3 && path[l-2] == ':'
-           && (path[l-1] == '\\' || path[l-1] == '/'))
+       if (l == 3 && isALPHA(path[0]) && path[1] == ':'
+           && (path[2] == '\\' || path[2] == '/'))
        {
            /* The drive can be inaccessible, some _stat()s are buggy */
            if (!GetVolumeInformation(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
@@ -960,46 +984,111 @@ win32_stat(const char *path, struct stat *buffer)
     return res;
 }
 
+/* Find the longname of a given path.  path is destructively modified.
+ * It should have space for at least MAX_PATH characters. */
+DllExport char *
+win32_longpath(char *path)
+{
+    WIN32_FIND_DATA fdata;
+    HANDLE fhand;
+    char tmpbuf[MAX_PATH+1];
+    char *tmpstart = tmpbuf;
+    char *start = path;
+    char sep;
+    if (!path)
+       return Nullch;
+
+    /* drive prefix */
+    if (isALPHA(path[0]) && path[1] == ':' &&
+       (path[2] == '/' || path[2] == '\\'))
+    {
+       start = path + 2;
+       *tmpstart++ = path[0];
+       *tmpstart++ = ':';
+    }
+    /* UNC prefix */
+    else if ((path[0] == '/' || path[0] == '\\') &&
+            (path[1] == '/' || path[1] == '\\'))
+    {
+       start = path + 2;
+       *tmpstart++ = path[0];
+       *tmpstart++ = path[1];
+       /* copy machine name */
+       while (*start && *start != '/' && *start != '\\')
+           *tmpstart++ = *start++;
+       if (*start) {
+           *tmpstart++ = *start;
+           start++;
+           /* copy share name */
+           while (*start && *start != '/' && *start != '\\')
+               *tmpstart++ = *start++;
+       }
+    }
+    sep = *start++;
+    if (sep == '/' || sep == '\\')
+       *tmpstart++ = sep;
+    *tmpstart = '\0';
+    while (sep) {
+       /* walk up to slash */
+       while (*start && *start != '/' && *start != '\\')
+           ++start;
+
+       /* discard doubled slashes */
+       while (*start && (start[1] == '/' || start[1] == '\\'))
+           ++start;
+       sep = *start;
+
+       /* stop and find full name of component */
+       *start = '\0';
+       fhand = FindFirstFile(path,&fdata);
+       if (fhand != INVALID_HANDLE_VALUE) {
+           strcpy(tmpstart, fdata.cFileName);
+           tmpstart += strlen(fdata.cFileName);
+           if (sep)
+               *tmpstart++ = sep;
+           *tmpstart = '\0';
+           *start++ = sep;
+           FindClose(fhand);
+       }
+       else {
+           /* failed a step, just return without side effects */
+           /*PerlIO_printf(PerlIO_stderr(), "Failed to find %s\n", path);*/
+           *start = sep;
+           return Nullch;
+       }
+    }
+    strcpy(path,tmpbuf);
+    return path;
+}
+
 #ifndef USE_WIN32_RTL_ENV
 
 DllExport char *
 win32_getenv(const char *name)
 {
-    static char *curitem = Nullch;     /* XXX threadead */
-    static DWORD curlen = 0;           /* XXX threadead */
     DWORD needlen;
-    if (!curitem) {
-       curlen = 512;
-       New(1305,curitem,curlen,char);
-    }
+    SV *curitem = Nullsv;
 
-    needlen = GetEnvironmentVariable(name,curitem,curlen);
+    needlen = GetEnvironmentVariable(name,NULL,0);
     if (needlen != 0) {
-       while (needlen > curlen) {
-           Renew(curitem,needlen,char);
-           curlen = needlen;
-           needlen = GetEnvironmentVariable(name,curitem,curlen);
-       }
+       curitem = sv_2mortal(newSVpvn("", 0));
+       do {
+           SvGROW(curitem, needlen+1);
+           needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
+                                             needlen);
+       } while (needlen >= SvLEN(curitem));
+       SvCUR_set(curitem, needlen);
     }
     else {
        /* allow any environment variables that begin with 'PERL'
           to be stored in the registry */
-       if (curitem)
-           *curitem = '\0';
-
-       if (strncmp(name, "PERL", 4) == 0) {
-           if (curitem) {
-               Safefree(curitem);
-               curitem = Nullch;
-               curlen = 0;
-           }
-           curitem = GetRegStr(name, &curitem, &curlen);
-       }
+       if (strncmp(name, "PERL", 4) == 0)
+           (void)get_regstr(name, &curitem);
     }
-    if (curitem && *curitem == '\0')
-       return Nullch;
+    if (curitem && SvCUR(curitem))
+       return SvPVX(curitem);
 
-    return curitem;
+    return Nullch;
 }
 
 DllExport int
@@ -1072,14 +1161,13 @@ win32_times(struct tms *timebuf)
     return 0;
 }
 
-/* fix utime() so it works on directories in NT
- * thanks to Jan Dubois <jan.dubois@ibm.net>
- */
+/* fix utime() so it works on directories in NT */
 static BOOL
 filetime_from_time(PFILETIME pFileTime, time_t Time)
 {
-    struct tm *pTM = gmtime(&Time);
+    struct tm *pTM = localtime(&Time);
     SYSTEMTIME SystemTime;
+    FILETIME LocalTime;
 
     if (pTM == NULL)
        return FALSE;
@@ -1092,7 +1180,25 @@ filetime_from_time(PFILETIME pFileTime, time_t Time)
     SystemTime.wSecond = pTM->tm_sec;
     SystemTime.wMilliseconds = 0;
 
-    return SystemTimeToFileTime(&SystemTime, pFileTime);
+    return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
+           LocalFileTimeToFileTime(&LocalTime, pFileTime);
+}
+
+DllExport int
+win32_unlink(const char *filename)
+{
+    int ret;
+    DWORD attrs = GetFileAttributes(filename);
+    if (attrs & FILE_ATTRIBUTE_READONLY) {
+       (void)SetFileAttributes(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
+       ret = unlink(filename);
+       if (ret == -1)
+           (void)SetFileAttributes(filename, attrs);
+    }
+    else
+       ret = unlink(filename);
+
+    return ret;
 }
 
 DllExport int
@@ -1135,29 +1241,131 @@ win32_utime(const char *filename, struct utimbuf *times)
 }
 
 DllExport int
+win32_uname(struct utsname *name)
+{
+    struct hostent *hep;
+    STRLEN nodemax = sizeof(name->nodename)-1;
+    OSVERSIONINFO osver;
+
+    memset(&osver, 0, sizeof(OSVERSIONINFO));
+    osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
+    if (GetVersionEx(&osver)) {
+       /* sysname */
+       switch (osver.dwPlatformId) {
+       case VER_PLATFORM_WIN32_WINDOWS:
+           strcpy(name->sysname, "Windows");
+           break;
+       case VER_PLATFORM_WIN32_NT:
+           strcpy(name->sysname, "Windows NT");
+           break;
+       case VER_PLATFORM_WIN32s:
+           strcpy(name->sysname, "Win32s");
+           break;
+       default:
+           strcpy(name->sysname, "Win32 Unknown");
+           break;
+       }
+
+       /* release */
+       sprintf(name->release, "%d.%d",
+               osver.dwMajorVersion, osver.dwMinorVersion);
+
+       /* version */
+       sprintf(name->version, "Build %d",
+               osver.dwPlatformId == VER_PLATFORM_WIN32_NT
+               ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
+       if (osver.szCSDVersion[0]) {
+           char *buf = name->version + strlen(name->version);
+           sprintf(buf, " (%s)", osver.szCSDVersion);
+       }
+    }
+    else {
+       *name->sysname = '\0';
+       *name->version = '\0';
+       *name->release = '\0';
+    }
+
+    /* nodename */
+    hep = win32_gethostbyname("localhost");
+    if (hep) {
+       STRLEN len = strlen(hep->h_name);
+       if (len <= nodemax) {
+           strcpy(name->nodename, hep->h_name);
+       }
+       else {
+           strncpy(name->nodename, hep->h_name, nodemax);
+           name->nodename[nodemax] = '\0';
+       }
+    }
+    else {
+       DWORD sz = nodemax;
+       if (!GetComputerName(name->nodename, &sz))
+           *name->nodename = '\0';
+    }
+
+    /* machine (architecture) */
+    {
+       SYSTEM_INFO info;
+       char *arch;
+       GetSystemInfo(&info);
+#ifdef __BORLANDC__
+       switch (info.u.s.wProcessorArchitecture) {
+#else
+       switch (info.wProcessorArchitecture) {
+#endif
+       case PROCESSOR_ARCHITECTURE_INTEL:
+           arch = "x86"; break;
+       case PROCESSOR_ARCHITECTURE_MIPS:
+           arch = "mips"; break;
+       case PROCESSOR_ARCHITECTURE_ALPHA:
+           arch = "alpha"; break;
+       case PROCESSOR_ARCHITECTURE_PPC:
+           arch = "ppc"; break;
+       default:
+           arch = "unknown"; break;
+       }
+       strcpy(name->machine, arch);
+    }
+    return 0;
+}
+
+DllExport int
 win32_waitpid(int pid, int *status, int flags)
 {
-    int rc;
+    int retval = -1;
     if (pid == -1) 
-      return win32_wait(status);
+       return win32_wait(status);
     else {
-      rc = cwait(status, pid, WAIT_CHILD);
-    /* cwait() returns "correctly" on Borland */
+       long child = find_pid(pid);
+       if (child >= 0) {
+           HANDLE hProcess = w32_child_handles[child];
+           DWORD waitcode = WaitForSingleObject(hProcess, INFINITE);
+           if (waitcode != WAIT_FAILED) {
+               if (GetExitCodeProcess(hProcess, &waitcode)) {
+                   *status = (int)((waitcode & 0xff) << 8);
+                   retval = (int)w32_child_pids[child];
+                   remove_dead_process(child);
+                   return retval;
+               }
+           }
+           else
+               errno = ECHILD;
+       }
+       else {
+           retval = cwait(status, pid, WAIT_CHILD);
+           /* cwait() returns "correctly" on Borland */
 #ifndef __BORLANDC__
-    if (status)
-       *status *= 256;
+           if (status)
+               *status *= 256;
 #endif
-      remove_dead_process((HANDLE)pid);
+       }
     }
-    return rc >= 0 ? pid : rc;                
+    return retval >= 0 ? pid : retval;                
 }
 
 DllExport int
 win32_wait(int *status)
 {
-#ifdef USE_RTL_WAIT
-    return wait(status);
-#else
     /* XXX this wait emulation only knows about processes
      * spawned via win32_spawnvp(P_NOWAIT, ...).
      */
@@ -1171,7 +1379,7 @@ win32_wait(int *status)
 
     /* if a child exists, wait for it to die */
     waitcode = WaitForMultipleObjects(w32_num_children,
-                                     w32_child_pids,
+                                     w32_child_handles,
                                      FALSE,
                                      INFINITE);
     if (waitcode != WAIT_FAILED) {
@@ -1180,13 +1388,10 @@ win32_wait(int *status)
            i = waitcode - WAIT_ABANDONED_0;
        else
            i = waitcode - WAIT_OBJECT_0;
-       if (GetExitCodeProcess(w32_child_pids[i], &exitcode) ) {
-           CloseHandle(w32_child_pids[i]);
+       if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
            *status = (int)((exitcode & 0xff) << 8);
            retval = (int)w32_child_pids[i];
-           Copy(&w32_child_pids[i+1], &w32_child_pids[i],
-                (w32_num_children-i-1), HANDLE);
-           w32_num_children--;
+           remove_dead_process(i);
            return retval;
        }
     }
@@ -1194,8 +1399,6 @@ win32_wait(int *status)
 FAILED:
     errno = GetLastError();
     return -1;
-
-#endif
 }
 
 static UINT timerid = 0;
@@ -1488,12 +1691,14 @@ win32_str_os_error(void *sv, DWORD dwErr)
                          |FORMAT_MESSAGE_IGNORE_INSERTS
                          |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
                           dwErr, 0, (char *)&sMsg, 1, NULL);
+    /* strip trailing whitespace and period */
     if (0 < dwLen) {
-       while (0 < dwLen  &&  isspace(sMsg[--dwLen]))
-           ;
+       do {
+           --dwLen;    /* dwLen doesn't include trailing null */
+       } while (0 < dwLen && isSPACE(sMsg[dwLen]));
        if ('.' != sMsg[dwLen])
            dwLen++;
-       sMsg[dwLen]= '\0';
+       sMsg[dwLen] = '\0';
     }
     if (0 == dwLen) {
        sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
@@ -1551,6 +1756,9 @@ win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
 DllExport FILE *
 win32_fopen(const char *filename, const char *mode)
 {
+    if (!*filename)
+       return NULL;
+
     if (stricmp(filename, "/dev/null")==0)
        return fopen("NUL", mode);
     return fopen(filename, mode);
@@ -1793,16 +2001,10 @@ win32_pclose(FILE *pf)
     win32_fclose(pf);
     SvIVX(sv) = 0;
 
-    remove_dead_process((HANDLE)childpid);
+    if (win32_waitpid(childpid, &status, 0) == -1)
+        return -1;
 
-    /* wait for the child */
-    if (cwait(&status, childpid, WAIT_CHILD) == -1)
-        return (-1);
-    /* cwait() returns "correctly" on Borland */
-#ifndef __BORLANDC__
-    status *= 256;
-#endif
-    return (status);
+    return status;
 
 #endif /* USE_RTL_POPEN */
 }
@@ -1995,26 +2197,209 @@ win32_chdir(const char *dir)
     return chdir(dir);
 }
 
+static char *
+create_command_line(const char* command, const char * const *args)
+{
+    int index;
+    char *cmd, *ptr, *arg;
+    STRLEN len = strlen(command) + 1;
+
+    for (index = 0; (ptr = (char*)args[index]) != NULL; ++index)
+       len += strlen(ptr) + 1;
+
+    New(1310, cmd, len, char);
+    ptr = cmd;
+    strcpy(ptr, command);
+
+    for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
+       ptr += strlen(ptr);
+        *ptr++ = ' ';
+       strcpy(ptr, arg);
+    }
+
+    return cmd;
+}
+
+static char *
+qualified_path(const char *cmd)
+{
+    char *pathstr;
+    char *fullcmd, *curfullcmd;
+    STRLEN cmdlen = 0;
+    int has_slash = 0;
+
+    if (!cmd)
+       return Nullch;
+    fullcmd = (char*)cmd;
+    while (*fullcmd) {
+       if (*fullcmd == '/' || *fullcmd == '\\')
+           has_slash++;
+       fullcmd++;
+       cmdlen++;
+    }
+
+    /* look in PATH */
+    pathstr = win32_getenv("PATH");
+    New(0, fullcmd, MAX_PATH+1, char);
+    curfullcmd = fullcmd;
+
+    while (1) {
+       DWORD res;
+
+       /* start by appending the name to the current prefix */
+       strcpy(curfullcmd, cmd);
+       curfullcmd += cmdlen;
+
+       /* if it doesn't end with '.', or has no extension, try adding
+        * a trailing .exe first */
+       if (cmd[cmdlen-1] != '.'
+           && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
+       {
+           strcpy(curfullcmd, ".exe");
+           res = GetFileAttributes(fullcmd);
+           if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
+               return fullcmd;
+           *curfullcmd = '\0';
+       }
+
+       /* that failed, try the bare name */
+       res = GetFileAttributes(fullcmd);
+       if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
+           return fullcmd;
+
+       /* quit if no other path exists, or if cmd already has path */
+       if (!pathstr || !*pathstr || has_slash)
+           break;
+
+       /* skip leading semis */
+       while (*pathstr == ';')
+           pathstr++;
+
+       /* build a new prefix from scratch */
+       curfullcmd = fullcmd;
+       while (*pathstr && *pathstr != ';') {
+           if (*pathstr == '"') {      /* foo;"baz;etc";bar */
+               pathstr++;              /* skip initial '"' */
+               while (*pathstr && *pathstr != '"') {
+                   if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
+                       *curfullcmd++ = *pathstr;
+                   pathstr++;
+               }
+               if (*pathstr)
+                   pathstr++;          /* skip trailing '"' */
+           }
+           else {
+               if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
+                   *curfullcmd++ = *pathstr;
+               pathstr++;
+           }
+       }
+       if (*pathstr)
+           pathstr++;                  /* skip trailing semi */
+       if (curfullcmd > fullcmd        /* append a dir separator */
+           && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
+       {
+           *curfullcmd++ = '\\';
+       }
+    }
+GIVE_UP:
+    Safefree(fullcmd);
+    return Nullch;
+}
+
 DllExport int
 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
 {
-    int status;
+#ifdef USE_RTL_SPAWNVP
+    return spawnvp(mode, cmdname, (char * const *)argv);
+#else
+    DWORD ret;
+    STARTUPINFO StartupInfo;
+    PROCESS_INFORMATION ProcessInformation;
+    DWORD create = 0;
+
+    char *cmd = create_command_line(cmdname, strcmp(cmdname, argv[0]) == 0
+                                            ? &argv[1] : argv);
+    char *fullcmd = Nullch;
+
+    switch(mode) {
+    case P_NOWAIT:     /* asynch + remember result */
+       if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
+           errno = EAGAIN;
+           ret = -1;
+           goto RETVAL;
+       }
+       /* FALL THROUGH */
+    case P_WAIT:       /* synchronous execution */
+       break;
+    default:           /* invalid mode */
+       errno = EINVAL;
+       ret = -1;
+       goto RETVAL;
+    }
+    memset(&StartupInfo,0,sizeof(StartupInfo));
+    StartupInfo.cb = sizeof(StartupInfo);
+    StartupInfo.hStdInput  = GetStdHandle(STD_INPUT_HANDLE);
+    StartupInfo.hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE);
+    StartupInfo.hStdError  = GetStdHandle(STD_ERROR_HANDLE);
+    if (StartupInfo.hStdInput != INVALID_HANDLE_VALUE &&
+       StartupInfo.hStdOutput != INVALID_HANDLE_VALUE &&
+       StartupInfo.hStdError != INVALID_HANDLE_VALUE)
+    {
+       StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
+    }
+    else {
+       create |= CREATE_NEW_CONSOLE;
+    }
 
-#ifndef USE_RTL_WAIT
-    if (mode == P_NOWAIT && w32_num_children >= MAXIMUM_WAIT_OBJECTS)
-       return -1;
-#endif
+RETRY:
+    if (!CreateProcess(cmdname,                /* search PATH to find executable */
+                      cmd,             /* executable, and its arguments */
+                      NULL,            /* process attributes */
+                      NULL,            /* thread attributes */
+                      TRUE,            /* inherit handles */
+                      create,          /* creation flags */
+                      NULL,            /* inherit environment */
+                      NULL,            /* inherit cwd */
+                      &StartupInfo,
+                      &ProcessInformation))
+    {
+       /* initial NULL argument to CreateProcess() does a PATH
+        * search, but it always first looks in the directory
+        * where the current process was started, which behavior
+        * is undesirable for backward compatibility.  So we
+        * jump through our own hoops by picking out the path
+        * we really want it to use. */
+       if (!fullcmd) {
+           fullcmd = qualified_path(cmdname);
+           if (fullcmd) {
+               cmdname = fullcmd;
+               goto RETRY;
+           }
+       }
+       errno = ENOENT;
+       ret = -1;
+       goto RETVAL;
+    }
 
-    status = spawnvp(mode, cmdname, (char * const *) argv);
-#ifndef USE_RTL_WAIT
-    /* XXX For the P_NOWAIT case, Borland RTL returns pinfo.dwProcessId
-     * while VC RTL returns pinfo.hProcess. For purposes of the custom
-     * implementation of win32_wait(), we assume the latter.
-     */
-    if (mode == P_NOWAIT && status >= 0)
-       w32_child_pids[w32_num_children++] = (HANDLE)status;
+    if (mode == P_NOWAIT) {
+       /* asynchronous spawn -- store handle, return PID */
+       w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
+       ret = w32_child_pids[w32_num_children] = ProcessInformation.dwProcessId;
+       ++w32_num_children;
+    }
+    else  {
+       WaitForSingleObject(ProcessInformation.hProcess, INFINITE);
+       GetExitCodeProcess(ProcessInformation.hProcess, &ret);
+       CloseHandle(ProcessInformation.hProcess);
+    }
+
+    CloseHandle(ProcessInformation.hThread);
+RETVAL:
+    Safefree(cmd);
+    Safefree(fullcmd);
+    return (int)ret;
 #endif
-    return status;
 }
 
 DllExport int
@@ -2262,6 +2647,7 @@ XS(w32_GetNextAvailDrive)
     dXSARGS;
     char ix = 'C';
     char root[] = "_:\\";
+
     EXTEND(SP,1);
     while (ix <= 'Z') {
        root[0] = ix++;
@@ -2282,6 +2668,16 @@ XS(w32_GetLastError)
 }
 
 static
+XS(w32_SetLastError)
+{
+    dXSARGS;
+    if (items != 1)
+       croak("usage: Win32::SetLastError($error)");
+    SetLastError(SvIV(ST(0)));
+    XSRETURN_EMPTY;
+}
+
+static
 XS(w32_LoginName)
 {
     dXSARGS;
@@ -2311,48 +2707,67 @@ XS(w32_NodeName)
     XSRETURN_UNDEF;
 }
 
-
 static
 XS(w32_DomainName)
 {
     dXSARGS;
-#ifndef HAS_NETWKSTAGETINFO
-    /* mingw32 (and Win95) don't have NetWksta*(), so do it the old way */
-    char name[256];
-    DWORD size = sizeof(name);
+    HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
+    DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
+    DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
+                                         void *bufptr);
+
+    if (hNetApi32) {
+       pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
+           GetProcAddress(hNetApi32, "NetApiBufferFree");
+       pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
+           GetProcAddress(hNetApi32, "NetWkstaGetInfo");
+    }
     EXTEND(SP,1);
-    if (GetUserName(name,&size)) {
-       char sid[1024];
-       DWORD sidlen = sizeof(sid);
+    if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
+       /* this way is more reliable, in case user has a local account. */
        char dname[256];
        DWORD dnamelen = sizeof(dname);
-       SID_NAME_USE snu;
-       if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
-                             dname, &dnamelen, &snu)) {
-           XSRETURN_PV(dname);         /* all that for this */
+       struct {
+           DWORD   wki100_platform_id;
+           LPWSTR  wki100_computername;
+           LPWSTR  wki100_langroup;
+           DWORD   wki100_ver_major;
+           DWORD   wki100_ver_minor;
+       } *pwi;
+       /* NERR_Success *is* 0*/
+       if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
+           if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
+               WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_langroup,
+                                   -1, (LPSTR)dname, dnamelen, NULL, NULL);
+           }
+           else {
+               WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_computername,
+                                   -1, (LPSTR)dname, dnamelen, NULL, NULL);
+           }
+           pfnNetApiBufferFree(pwi);
+           FreeLibrary(hNetApi32);
+           XSRETURN_PV(dname);
        }
+       FreeLibrary(hNetApi32);
     }
-#else
-    /* this way is more reliable, in case user has a local account.
-     * XXX need dynamic binding of netapi32.dll symbols or this will fail on
-     * Win95. Probably makes more sense to move it into libwin32. */
-    char dname[256];
-    DWORD dnamelen = sizeof(dname);
-    PWKSTA_INFO_100 pwi;
-    EXTEND(SP,1);
-    if (NERR_Success == NetWkstaGetInfo(NULL, 100, (LPBYTE*)&pwi)) {
-       if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
-           WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_langroup,
-                               -1, (LPSTR)dname, dnamelen, NULL, NULL);
-       }
-       else {
-           WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_computername,
-                               -1, (LPSTR)dname, dnamelen, NULL, NULL);
+    else {
+       /* Win95 doesn't have NetWksta*(), so do it the old way */
+       char name[256];
+       DWORD size = sizeof(name);
+       if (hNetApi32)
+           FreeLibrary(hNetApi32);
+       if (GetUserName(name,&size)) {
+           char sid[1024];
+           DWORD sidlen = sizeof(sid);
+           char dname[256];
+           DWORD dnamelen = sizeof(dname);
+           SID_NAME_USE snu;
+           if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
+                                 dname, &dnamelen, &snu)) {
+               XSRETURN_PV(dname);             /* all that for this */
+           }
        }
-       NetApiBufferFree(pwi);
-       XSRETURN_PV(dname);
     }
-#endif
     XSRETURN_UNDEF;
 }
 
@@ -2365,16 +2780,17 @@ XS(w32_FsType)
     EXTEND(SP,1);
     if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
                         &flags, fsname, sizeof(fsname))) {
-       if (GIMME == G_ARRAY) {
+       if (GIMME_V == G_ARRAY) {
            XPUSHs(sv_2mortal(newSVpv(fsname,0)));
            XPUSHs(sv_2mortal(newSViv(flags)));
            XPUSHs(sv_2mortal(newSViv(filecomplen)));
            PUTBACK;
            return;
        }
+       EXTEND(SP,1);
        XSRETURN_PV(fsname);
     }
-    XSRETURN_UNDEF;
+    XSRETURN_EMPTY;
 }
 
 static
@@ -2393,7 +2809,7 @@ XS(w32_GetOSVersion)
        PUTBACK;
        return;
     }
-    XSRETURN_UNDEF;
+    XSRETURN_EMPTY;
 }
 
 static
@@ -2474,8 +2890,11 @@ static
 XS(w32_GetTickCount)
 {
     dXSARGS;
+    DWORD msec = GetTickCount();
     EXTEND(SP,1);
-    XSRETURN_IV(GetTickCount());
+    if ((IV)msec > 0)
+       XSRETURN_IV(msec);
+    XSRETURN_NV(msec);
 }
 
 static
@@ -2499,10 +2918,67 @@ XS(w32_GetShortPathName)
     if (len) {
        SvCUR_set(shortpath,len);
        ST(0) = shortpath;
+       XSRETURN(1);
     }
-    else
-       ST(0) = &PL_sv_undef;
-    XSRETURN(1);
+    XSRETURN_UNDEF;
+}
+
+static
+XS(w32_GetFullPathName)
+{
+    dXSARGS;
+    SV *filename;
+    SV *fullpath;
+    char *filepart;
+    DWORD len;
+
+    if (items != 1)
+       croak("usage: Win32::GetFullPathName($filename)");
+
+    filename = ST(0);
+    fullpath = sv_mortalcopy(filename);
+    SvUPGRADE(fullpath, SVt_PV);
+    do {
+       len = GetFullPathName(SvPVX(filename),
+                             SvLEN(fullpath),
+                             SvPVX(fullpath),
+                             &filepart);
+    } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
+    if (len) {
+       if (GIMME_V == G_ARRAY) {
+           EXTEND(SP,1);
+           XST_mPV(1,filepart);
+           len = filepart - SvPVX(fullpath);
+           items = 2;
+       }
+       SvCUR_set(fullpath,len);
+       ST(0) = fullpath;
+       XSRETURN(items);
+    }
+    XSRETURN_EMPTY;
+}
+
+static
+XS(w32_GetLongPathName)
+{
+    dXSARGS;
+    SV *path;
+    char tmpbuf[MAX_PATH+1];
+    char *pathstr;
+    STRLEN len;
+
+    if (items != 1)
+       croak("usage: Win32::GetLongPathName($pathname)");
+
+    path = ST(0);
+    pathstr = SvPV(path,len);
+    strcpy(tmpbuf, pathstr);
+    pathstr = win32_longpath(tmpbuf);
+    if (pathstr) {
+       ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
+       XSRETURN(1);
+    }
+    XSRETURN_UNDEF;
 }
 
 static
@@ -2515,6 +2991,18 @@ XS(w32_Sleep)
     XSRETURN_YES;
 }
 
+static
+XS(w32_CopyFile)
+{
+    dXSARGS;
+    STRLEN n_a;
+    if (items != 3)
+       croak("usage: Win32::CopyFile($from, $to, $overwrite)");
+    if (CopyFile(SvPV(ST(0),n_a), SvPV(ST(1),n_a), !SvTRUE(ST(2))))
+       XSRETURN_YES;
+    XSRETURN_NO;
+}
+
 void
 Perl_init_os_extras()
 {
@@ -2524,15 +3012,15 @@ Perl_init_os_extras()
     w32_perlshell_tokens = Nullch;
     w32_perlshell_items = -1;
     w32_fdpid = newAV();               /* XXX needs to be in Perl_win32_init()? */
-#ifndef USE_RTL_WAIT
+    New(1313, w32_children, 1, child_tab);
     w32_num_children = 0;
-#endif
 
     /* these names are Activeware compatible */
     newXS("Win32::GetCwd", w32_GetCwd, file);
     newXS("Win32::SetCwd", w32_SetCwd, file);
     newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
     newXS("Win32::GetLastError", w32_GetLastError, file);
+    newXS("Win32::SetLastError", w32_SetLastError, file);
     newXS("Win32::LoginName", w32_LoginName, file);
     newXS("Win32::NodeName", w32_NodeName, file);
     newXS("Win32::DomainName", w32_DomainName, file);
@@ -2544,6 +3032,9 @@ Perl_init_os_extras()
     newXS("Win32::Spawn", w32_Spawn, file);
     newXS("Win32::GetTickCount", w32_GetTickCount, file);
     newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
+    newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
+    newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
+    newXS("Win32::CopyFile", w32_CopyFile, file);
     newXS("Win32::Sleep", w32_Sleep, file);
 
     /* XXX Bloat Alert! The following Activeware preloads really
index 961347d..1e86895 100644 (file)
@@ -22,7 +22,9 @@
 #endif
 
 #ifdef __GNUC__
-typedef long long __int64;
+#  ifndef __int64              /* some versions seem to #define it already */
+#    define __int64 long long
+#  endif
 #  define Win32_Winsock
 /* GCC does not do __declspec() - render it a nop 
  * and turn on options to avoid importing data 
@@ -81,6 +83,18 @@ struct tms {
        long    tms_cstime;
 };
 
+#ifndef SYS_NMLN
+#define SYS_NMLN       257
+#endif
+
+struct utsname {
+    char sysname[SYS_NMLN];
+    char nodename[SYS_NMLN];
+    char release[SYS_NMLN];
+    char version[SYS_NMLN];
+    char machine[SYS_NMLN];
+};
+
 #ifndef START_EXTERN_C
 #undef EXTERN_C
 #ifdef __cplusplus
@@ -150,8 +164,6 @@ struct tms {
 #pragma warn -csu      /* "comparing signed and unsigned values" */
 #pragma warn -pro      /* "call to function with no prototype" */
 
-#define USE_RTL_WAIT   /* Borland has a working wait() */
-
 /* Borland is picky about a bare member function name used as its ptr */
 #ifdef PERL_OBJECT
 #define FUNC_NAME_TO_PTR(name) &(name)
@@ -163,6 +175,7 @@ struct tms {
 
 typedef long           uid_t;
 typedef long           gid_t;
+typedef unsigned short mode_t;
 #pragma  warning(disable: 4018 4035 4101 4102 4244 4245 4761)
 
 #ifndef PERL_OBJECT
@@ -318,26 +331,29 @@ EXT void win32_strip_return(struct sv *sv);
 #endif
 
 #define HAVE_INTERP_INTERN
+typedef struct {
+    long       num;
+    DWORD      pids[MAXIMUM_WAIT_OBJECTS];
+} child_tab;
+
 struct interp_intern {
-    char *     w32_perlshell_tokens;
-    char **    w32_perlshell_vec;
-    long       w32_perlshell_items;
-    struct av *        w32_fdpid;
-#ifndef USE_RTL_WAIT
-    long       w32_num_children;
-    HANDLE     w32_child_pids[MAXIMUM_WAIT_OBJECTS];
-#endif
+    char *     perlshell_tokens;
+    char **    perlshell_vec;
+    long       perlshell_items;
+    struct av *        fdpid;
+    child_tab *        children;
+    HANDLE     child_handles[MAXIMUM_WAIT_OBJECTS];
 };
 
-#define w32_perlshell_tokens   (PL_sys_intern.w32_perlshell_tokens)
-#define w32_perlshell_vec      (PL_sys_intern.w32_perlshell_vec)
-#define w32_perlshell_items    (PL_sys_intern.w32_perlshell_items)
-#define w32_fdpid              (PL_sys_intern.w32_fdpid)
 
-#ifndef USE_RTL_WAIT
-#  define w32_num_children     (PL_sys_intern.w32_num_children)
-#  define w32_child_pids       (PL_sys_intern.w32_child_pids)
-#endif
+#define w32_perlshell_tokens   (PL_sys_intern.perlshell_tokens)
+#define w32_perlshell_vec      (PL_sys_intern.perlshell_vec)
+#define w32_perlshell_items    (PL_sys_intern.perlshell_items)
+#define w32_fdpid              (PL_sys_intern.fdpid)
+#define w32_children           (PL_sys_intern.children)
+#define w32_num_children       (w32_children->num)
+#define w32_child_pids         (w32_children->pids)
+#define w32_child_handles      (PL_sys_intern.child_handles)
 
 /* 
  * Now Win32 specific per-thread data stuff 
index c7a7444..e8228a5 100644 (file)
@@ -122,8 +122,11 @@ DllExport  unsigned        win32_sleep(unsigned int);
 DllExport  int         win32_times(struct tms *timebuf);
 DllExport  unsigned    win32_alarm(unsigned int sec);
 DllExport  int         win32_stat(const char *path, struct stat *buf);
+DllExport  char*       win32_longpath(char *path);
 DllExport  int         win32_ioctl(int i, unsigned int u, char *data);
+DllExport  int         win32_unlink(const char *f);
 DllExport  int         win32_utime(const char *f, struct utimbuf *t);
+DllExport  int         win32_uname(struct utsname *n);
 DllExport  int         win32_wait(int *status);
 DllExport  int         win32_waitpid(int pid, int *status, int flags);
 DllExport  int         win32_kill(int pid, int sig);
@@ -152,7 +155,9 @@ END_EXTERN_C
 #undef times
 #undef alarm
 #undef ioctl
+#undef unlink
 #undef utime
+#undef uname
 #undef wait
 
 #ifdef __BORLANDC__
@@ -205,6 +210,7 @@ END_EXTERN_C
 #define abort()                        win32_abort()
 #define fstat(fd,bufptr)       win32_fstat(fd,bufptr)
 #define stat(pth,bufptr)       win32_stat(pth,bufptr)
+#define longpath(pth)          win32_longpath(pth)
 #define rename(old,new)                win32_rename(old,new)
 #define setmode(fd,mode)       win32_setmode(fd,mode)
 #define lseek(fd,offset,orig)  win32_lseek(fd,offset,orig)
@@ -260,7 +266,9 @@ END_EXTERN_C
 #define times                  win32_times
 #define alarm                  win32_alarm
 #define ioctl                  win32_ioctl
+#define unlink                 win32_unlink
 #define utime                  win32_utime
+#define uname                  win32_uname
 #define wait                   win32_wait
 #define waitpid                        win32_waitpid
 #define kill                   win32_kill
index 2713605..e40bd15 100644 (file)
@@ -112,6 +112,12 @@ start_sockets(void)
 }
 
 void
+end_sockets(void)
+{
+    EndSockets();
+}
+
+void
 set_socktype(void)
 {
 #ifdef USE_SOCKETS_AS_HANDLES