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
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
/* destroy arg array */ \
av_clear(cxsub.argarray); \
AvREAL_off(cxsub.argarray); \
+ AvREIFY_on(cxsub.argarray); \
} \
if (cxsub.cv) { \
if (!(CvDEPTH(cxsub.cv) = cxsub.olddepth)) \
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)
#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
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('\\');
*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';
newXSUB
nextargv
ninstr
+no_bareword_allowed
no_fh_allowed
no_op
oopsAV
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))
#define PerlEnv_putenv(str) putenv((str))
#define PerlEnv_getenv(str) getenv((str))
+#define PerlEnv_uname(name) uname((name))
#endif /* PERL_OBJECT */
# 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;
}
# 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 );
}
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') {
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
# 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/
/) {
$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);
}
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
##endif
#XSCAPI(boot_$Module_cname)
#[[
-# SetCPerlObj(pPerl);
-# boot__CAPI_entry(cv);
+# boot_CAPI_handler(cv, boot__CAPI_entry, pPerl);
#]]
##endif /* PERL_CAPI */
EOF
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;
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);
*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) &&
*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;
fail_open2:
if ($closefrom) {
- $status = $!;
+ my $status = $!;
$! = 0;
close FROM;
$! = $status unless $!;
*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__
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
&& !$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);
# 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 = \©
}
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
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__
=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
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
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;
--- /dev/null
+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
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
=head1 SYNOPSIS
-C<require File::Spec::Mac;>
+ require File::Spec::Mac; # Done internally by File::Spec if needed
=head1 DESCRIPTION
=cut
sub canonpath {
- my($self,$path) = @_;
- $path;
+ my ($self,$path) = @_;
+ return $path;
}
=item catdir
=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
=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
=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");
}
}
# 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
=cut
1;
-__END__
-
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;
=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
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
=head1 SYNOPSIS
-C<require File::Spec::Unix;>
+ require File::Spec::Unix; # Done automatically by File::Spec
=head1 DESCRIPTION
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
=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
=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
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
=cut
sub no_upwards {
- my($self) = shift;
+ my $self = shift;
return grep(!/^\.{1,2}$/, @_);
}
=cut
sub file_name_is_absolute {
- my($self,$file) = @_;
- $file =~ m:^/: ;
+ my ($self,$file) = @_;
+ return scalar($file =~ m:^/:);
}
=item path
=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
=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
=cut
1;
-__END__
-
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
=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
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
=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
=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
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
=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)
=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;
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
=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
=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
=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;
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;
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
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
"--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>.
=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
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
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
@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
@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.
}
$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;
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
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> $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
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;
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>
--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,
'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;
$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;
$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;
}
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));
}
#
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) ||
$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>";
}
}
"$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
\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
sub html_escape {
my $rest = $_[0];
- $rest =~ s/&/&/g;
+ $rest =~ s/&(?!\w+;|#)/&/g; # XXX not bulletproof
$rest =~ s/</</g;
$rest =~ s/>/>/g;
$rest =~ s/"/"/g;
$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
#
sub pre_escape {
my($str) = @_;
-
- $$str =~ s,&,&,g;
+ $$str =~ s/&(?!\w+;|#)/&/g; # XXX not bulletproof
}
#
#
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;
$section = $page;
$page = "";
}
+
+ # remove trailing punctuation, like ()
+ $section =~ s/\W*$// ;
}
$page83=dosify($page);
} 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 {
# 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
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>";
}
}
#
+# 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.
#
# 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 {
#
+# 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.
#
#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()
#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
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));
(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)
{
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);
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);
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;
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:
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;
}
}
}
}
}
+ 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;
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 '\\':
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);
}
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:
#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?). */
#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
#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*);
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
--- /dev/null
+=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
vivify_defelem(sv);
if (!(sv = LvTARG(sv)))
sv = &PL_sv_undef;
+ else
+ (void)SvREFCNT_inc(sv);
}
else if (SvPADTMP(sv))
sv = newSVsv(sv);
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 */
}
MEXTEND(mark,0);
*MARK = &PL_sv_undef;
}
+ SP = MARK;
}
else {
/* in case LEAVE wipes old return values */
if (AvREAL(av)) {
av_clear(av);
AvREAL_off(av);
+ AvREIFY_on(av);
}
#ifndef USE_THREADS
cx->blk_sub.savearray = GvAV(PL_defgv);
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));
use strict;
-print "1..87\n";
+print "1..100\n";
my $i = 1;
# 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++;
+
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";
}
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' };
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;
}
#!./perl
-print "1..36\n";
+print "1..37\n";
eval 'print "ok 1\n";';
}
$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++;
+}
$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
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), $!;
}
#!./perl
-print "1..55\n";
+print "1..56\n";
# Test glob operations.
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
}
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
*/
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);
* 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
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 == '(';
/* (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;
}
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;
}
PL_expect = XOPERATOR;
force_next(WORD);
yylval.ival = 0;
- PL_last_lop_op = OP_ENTERSUB;
TOKEN('&');
}
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))) {
/* 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);
+ }
}
}
# 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;
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
-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
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"}));
}
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
}
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?
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;
}
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 '';
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);
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";
}
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);
}
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")
) {
return $ret;
}
-
+
if ($recurse) {
opendir(D,$dir);
my @newdirs = map "$dir/$_", grep {
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) {
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__
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.
=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.
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
# 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
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
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
}
}
-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);
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());
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
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
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
-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
"INST_DRV=$(INST_DRV)" \
"INST_TOP=$(INST_TOP)" \
"INST_VER=$(INST_VER)" \
+ "INST_ARCH=$(INST_ARCH)" \
"archname=$(ARCHNAME)" \
"cc=$(CC)" \
"ccflags=$(OPTIMIZE:"=\") $(DEFINES) $(OBJECT)" \
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'
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'
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'
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'
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'
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'
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'
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'
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'
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'
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'
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'
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'
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'
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'
* 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
* 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
* 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
Perl_my_swap
Perl_my_chsize
Perl_newXSUB
+Perl_no_bareword_allowed
Perl_no_fh_allowed
Perl_no_op
Perl_nointrp
win32_open_osfhandle
win32_get_osfhandle
win32_ioctl
+win32_unlink
win32_utime
+win32_uname
win32_wait
win32_waitpid
win32_kill
win32_seekdir
win32_rewinddir
win32_closedir
+win32_longpath
Perl_win32_init
Perl_init_os_extras
Perl_getTHR
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
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
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 =
.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 =
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:
.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
"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)" \
{
return g_win32_get_sitelib(pl);
};
+ virtual int Uname(struct utsname *name, int &err)
+ {
+ return win32_uname(name);
+ };
};
class CPerlSock : public IPerlSock
};
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)
{
|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)*/);
&perlDir, &perlSock, &perlProc);
if(pPerl != NULL)
{
+ perl_init_i18nl10n(1);
+
try
{
pPerl->perl_construct();
CPerlObj *pPerl;
-#undef PERL_SYS_INIT
-#define PERL_SYS_INIT(a, c)
-
int
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);
* 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);
#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
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
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;
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;
}
}
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 *
{
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 *
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);
}
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';
/* 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';
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;
}
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;
}
}
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)) {
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
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;
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
}
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, ...).
*/
/* 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) {
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;
}
}
FAILED:
errno = GetLastError();
return -1;
-
-#endif
}
static UINT timerid = 0;
|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)*/);
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);
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 */
}
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
dXSARGS;
char ix = 'C';
char root[] = "_:\\";
+
EXTEND(SP,1);
while (ix <= 'Z') {
root[0] = ix++;
}
static
+XS(w32_SetLastError)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("usage: Win32::SetLastError($error)");
+ SetLastError(SvIV(ST(0)));
+ XSRETURN_EMPTY;
+}
+
+static
XS(w32_LoginName)
{
dXSARGS;
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;
}
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
PUTBACK;
return;
}
- XSRETURN_UNDEF;
+ XSRETURN_EMPTY;
}
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
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
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()
{
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);
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
#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
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
#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)
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
#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
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);
#undef times
#undef alarm
#undef ioctl
+#undef unlink
#undef utime
+#undef uname
#undef wait
#ifdef __BORLANDC__
#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)
#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
}
void
+end_sockets(void)
+{
+ EndSockets();
+}
+
+void
set_socktype(void)
{
#ifdef USE_SOCKETS_AS_HANDLES
projects / perl.git / commitdiff
