diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/AutoSplit.pm | 2 | ||||
| -rw-r--r-- | lib/CGI/Push.pm | 6 | ||||
| -rw-r--r-- | lib/ExtUtils/Install.pm | 2 | ||||
| -rw-r--r-- | lib/ExtUtils/Liblist.pm | 138 | ||||
| -rw-r--r-- | lib/ExtUtils/MM_Unix.pm | 5 | ||||
| -rw-r--r-- | lib/ExtUtils/MM_Win32.pm | 327 | ||||
| -rw-r--r-- | lib/ExtUtils/MakeMaker.pm | 14 | ||||
| -rw-r--r-- | lib/ExtUtils/Mksymlists.pm | 5 | ||||
| -rw-r--r-- | lib/File/DosGlob.pm | 201 | ||||
| -rw-r--r-- | lib/Pod/Html.pm | 105 | ||||
| -rw-r--r-- | lib/Sys/Syslog.pm | 2 | ||||
| -rw-r--r-- | lib/chat2.pl | 368 | ||||
| -rw-r--r-- | lib/ftp.pl | 9 |
13 files changed, 1117 insertions, 67 deletions
diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index 1bdcb78e5b..8019df7187 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -126,7 +126,7 @@ sub autosplit{ sub autosplit_lib_modules{ my(@modules) = @_; # list of Module names - while($_ = shift @modules){ + while(defined($_ = shift @modules)){ s#::#/#g; # incase specified as ABC::XYZ s|\\|/|g; # bug in ksh OS/2 s#^lib/##; # incase specified as lib/*.pm diff --git a/lib/CGI/Push.pm b/lib/CGI/Push.pm index 11421a7f23..4390d0383e 100644 --- a/lib/CGI/Push.pm +++ b/lib/CGI/Push.pm @@ -148,14 +148,14 @@ prefer: $q->do_push(-next_page=>\&draw_a_page); -or- - + use CGI::Push qw(:standard); do_push(-next_page=>\&draw_a_page); Parameters are as follows: =over 4 - + =item -next_page do_push(-next_page=>\&my_draw_routine); @@ -234,6 +234,6 @@ This section intentionally left blank. =head1 SEE ALSO L<CGI::Carp>, L<CGI> - + =cut diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm index 71f553bcbf..bdf154375f 100644 --- a/lib/ExtUtils/Install.pm +++ b/lib/ExtUtils/Install.pm @@ -37,6 +37,8 @@ sub install { my(%hash) = %$hash; my(%pack, %write, $dir, $warn_permissions); + # -w doesn't work reliably on FAT dirs + $warn_permissions++ if $^O eq 'MSWin32'; local(*DIR, *P); for (qw/read write/) { $pack{$_}=$hash{$_}; diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index 2a43022638..9d15fe9edf 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -9,8 +9,9 @@ use Cwd 'cwd'; use File::Basename; sub ext { - if ($^O eq 'VMS') { return &_vms_ext; } - else { return &_unix_os2_ext; } + if ($^O eq 'VMS') { return &_vms_ext; } + elsif($^O eq 'MSWin32') { return &_win32_ext; } + else { return &_unix_os2_ext; } } sub _unix_os2_ext { @@ -181,6 +182,81 @@ sub _unix_os2_ext { ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path)); } +sub _win32_ext { + my($self, $potential_libs, $Verbose) = @_; + + # If user did not supply a list, we punt. + # (caller should probably use the list in $Config{libs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; + my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + + if ($libs and $potential_libs !~ /:nodefault/i) { + # If Config.pm defines a set of default libs, we always + # tack them on to the user-supplied list, unless the user + # specified :nodefault + + $potential_libs .= " " if $potential_libs; + $potential_libs .= $libs; + } + print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose; + + # compute $extralibs from $potential_libs + + my(@searchpath); # from "-L/path" entries in $potential_libs + my(@libpath) = split " ", $libpth; + my(@extralibs); + my($fullname, $thislib, $thispth); + my($pwd) = cwd(); # from Cwd.pm + my($lib) = ''; + my($found) = 0; + + foreach $thislib (split ' ', $potential_libs){ + + # Handle possible linker path arguments. + if ($thislib =~ s/^-L// and not -d $thislib) { + print STDOUT "-L$thislib ignored, directory does not exist\n" + if $Verbose; + next; + } + elsif (-d $thislib) { + unless ($self->file_name_is_absolute($thislib)) { + print STDOUT "Warning: -L$thislib changed to -L$pwd/$thislib\n"; + $thislib = $self->catdir($pwd,$thislib); + } + push(@searchpath, $thislib); + next; + } + + # Handle possible library arguments. + $thislib =~ s/^-l//; + $thislib .= $libext if $thislib !~ /\Q$libext\E$/i; + + my($found_lib)=0; + foreach $thispth (@searchpath, @libpath){ + unless (-f ($fullname="$thispth\\$thislib")) { + print STDOUT "$thislib not found in $thispth\n" if $Verbose; + next; + } + print STDOUT "'$thislib' found at $fullname\n" if $Verbose; + $found++; + $found_lib++; + push(@extralibs, $fullname); + last; + } + print STDOUT "Note (probably harmless): " + ."No library found for '$thislib'\n" + unless $found_lib>0; + } + return ('','','','') unless $found; + $lib = join(' ',@extralibs); + print "Result: $lib\n" if $verbose; + wantarray ? ($lib, '', $lib, '') : $lib; +} + sub _vms_ext { my($self, $potential_libs,$verbose) = @_; @@ -327,7 +403,7 @@ ExtUtils::Liblist - determine libraries to use and how to use them C<require ExtUtils::Liblist;> -C<ExtUtils::Liblist::ext($potential_libs, $Verbose);> +C<ExtUtils::Liblist::ext($self, $potential_libs, $Verbose);> =head1 DESCRIPTION @@ -338,7 +414,9 @@ C<-L/another/path> this will affect the searches for all subsequent libraries. It returns an array of four scalar values: EXTRALIBS, BSLOADLIBS, -LDLOADLIBS, and LD_RUN_PATH. +LDLOADLIBS, and LD_RUN_PATH. Some of these don't mean anything +on VMS and Win32. See the details about those platform specifics +below. Dependent libraries can be linked in one of three ways: @@ -434,6 +512,58 @@ extensions originally designed for a Unix or VMS environment. If you encounter problems, or discover cases where the search could be improved, please let us know. +=head2 Win32 implementation + +The version of ext() which is executed under Win32 differs from the +Unix-OS/2 version in several respects: + +=over 2 + +=item * + +Input library and path specifications are accepted with or without the +C<-l> and C<-L> prefices used by Unix linkers. C<-lfoo> specifies the +library C<foo.lib> and C<-Ls:ome\dir> specifies a directory to look for +the libraries that follow. If neither prefix is present, a token is +considered a directory to search if it is in fact a directory, and a +library to search for otherwise. The C<$Config{lib_ext}> suffix will +be appended to any entries that are not directories and don't already +have the suffix. Authors who wish their extensions to be portable to +Unix or OS/2 should use the Unix prefixes, since the Unix-OS/2 version +of ext() requires them. + +=item * + +Entries cannot be plain object files, as many Win32 compilers will +not handle object files in the place of libraries. + +=item * + +If C<$potential_libs> is empty, the return value will be empty. +Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) +will be appended to the list of C<$potential_libs>. The libraries +will be searched for in the directories specified in C<$potential_libs> +as well as in C<$Config{libpth}>. For each library that is found, a +space-separated list of fully qualified library pathnames is generated. +You may specify an entry that matches C</:nodefault/i> in +C<$potential_libs> to disable the appending of default libraries +found in C<$Config{libs}> (this should be only needed very rarely). + +=item * + +The libraries specified may be a mixture of static libraries and +import libraries (to link with DLLs). Since both kinds are used +pretty transparently on the win32 platform, we do not attempt to +distinguish between them. + +=item * + +LDLOADLIBS and EXTRALIBS are always identical under Win32, and BSLOADLIBS +and LD_RUN_PATH are always empty (this may change in future). + +=back + + =head1 SEE ALSO L<ExtUtils::MakeMaker> diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index b051617c38..f24c5d0eb2 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -265,7 +265,7 @@ sub c_o { push @m, ' .C$(OBJ_EXT): $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.C -' if $^O ne 'os2'; # Case-specific +' if $^O ne 'os2' and $^O ne 'MSWin32'; # Case-specific push @m, ' .cpp$(OBJ_EXT): $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.cpp @@ -1113,6 +1113,7 @@ sub force { my($self) = shift; '# Phony target to force checking subdirectories. FORCE: + '.$self->{NOECHO}.'$(NOOP) '; } @@ -1913,7 +1914,7 @@ realclean :: last unless defined $from; my $todir = dirname($to); push @m, " -$to: $from $self->{MAKEFILE} $todir/.exists +$to: $from $self->{MAKEFILE} ".$self->catfile($todir,'.exists')." $self->{NOECHO}$self->{RM_F} $to $self->{CP} $from $to "; diff --git a/lib/ExtUtils/MM_Win32.pm b/lib/ExtUtils/MM_Win32.pm index e3161b5412..3545f2c5a4 100644 --- a/lib/ExtUtils/MM_Win32.pm +++ b/lib/ExtUtils/MM_Win32.pm @@ -18,7 +18,7 @@ the semantics. =cut -#use Config; +use Config; #use Cwd; use File::Basename; require Exporter; @@ -29,6 +29,10 @@ Exporter::import('ExtUtils::MakeMaker', $ENV{EMXSHELL} = 'sh'; # to run `commands` unshift @MM::ISA, 'ExtUtils::MM_Win32'; +$BORLAND = 1 if $Config{'cc'} =~ /^bcc/i; +$DMAKE = 1 if $Config{'make'} =~ /^dmake/i; +$NMAKE = 1 if $Config{'make'} =~ /^nmake/i; + sub dlsyms { my($self,%attribs) = @_; @@ -147,11 +151,167 @@ sub init_others $self->{'MV'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mv'; $self->{'NOOP'} = 'rem'; $self->{'TEST_F'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e test_f'; - $self->{'LD'} = 'link'; + $self->{'LD'} = $Config{'ld'} || 'link'; + $self->{'AR'} = $Config{'ar'} || 'lib'; + $self->{'LDLOADLIBS'} + ||= ( $BORLAND + ? 'import32.lib cw32mti.lib ' + : 'msvcrt.lib oldnames.lib kernel32.lib comdlg32.lib winspool.lib gdi32.lib ' + .'advapi32.lib user32.lib shell32.lib netapi32.lib ole32.lib ' + .'oleaut32.lib uuid.lib wsock32.lib mpr.lib winmm.lib version.lib ' + ) . ' odbc32.lib odbccp32.lib'; $self->{'DEV_NULL'} = '> NUL'; # $self->{'NOECHO'} = ''; # till we have it working } + +=item constants (o) + +Initializes lots of constants and .SUFFIXES and .PHONY + +=cut + +sub constants { + my($self) = @_; + my(@m,$tmp); + + for $tmp (qw/ + + AR_STATIC_ARGS NAME DISTNAME NAME_SYM VERSION + VERSION_SYM XS_VERSION INST_BIN INST_EXE INST_LIB + INST_ARCHLIB INST_SCRIPT PREFIX INSTALLDIRS + INSTALLPRIVLIB INSTALLARCHLIB INSTALLSITELIB + INSTALLSITEARCH INSTALLBIN INSTALLSCRIPT PERL_LIB + PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB + FIRST_MAKEFILE MAKE_APERL_FILE PERLMAINCC PERL_SRC + PERL_INC PERL FULLPERL + + / ) { + next unless defined $self->{$tmp}; + push @m, "$tmp = $self->{$tmp}\n"; + } + + push @m, qq{ +VERSION_MACRO = VERSION +DEFINE_VERSION = -D\$(VERSION_MACRO)=\\\"\$(VERSION)\\\" +XS_VERSION_MACRO = XS_VERSION +XS_DEFINE_VERSION = -D\$(XS_VERSION_MACRO)=\\\"\$(XS_VERSION)\\\" +}; + + push @m, qq{ +MAKEMAKER = $INC{'ExtUtils\MakeMaker.pm'} +MM_VERSION = $ExtUtils::MakeMaker::VERSION +}; + + push @m, q{ +# FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle). +# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle) +# ROOTEXT = Directory part of FULLEXT with leading slash (eg /DBD) !!! Deprecated from MM 5.32 !!! +# PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar) +# DLBASE = Basename part of dynamic library. May be just equal BASEEXT. +}; + + for $tmp (qw/ + FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT + LDFROM LINKTYPE + / ) { + next unless defined $self->{$tmp}; + push @m, "$tmp = $self->{$tmp}\n"; + } + + push @m, " +# Handy lists of source code files: +XS_FILES= ".join(" \\\n\t", sort keys %{$self->{XS}})." +C_FILES = ".join(" \\\n\t", @{$self->{C}})." +O_FILES = ".join(" \\\n\t", @{$self->{O_FILES}})." +H_FILES = ".join(" \\\n\t", @{$self->{H}})." +MAN1PODS = ".join(" \\\n\t", sort keys %{$self->{MAN1PODS}})." +MAN3PODS = ".join(" \\\n\t", sort keys %{$self->{MAN3PODS}})." +"; + + for $tmp (qw/ + INST_MAN1DIR INSTALLMAN1DIR MAN1EXT INST_MAN3DIR INSTALLMAN3DIR MAN3EXT + /) { + next unless defined $self->{$tmp}; + push @m, "$tmp = $self->{$tmp}\n"; + } + + push @m, qq{ +.USESHELL : +} if $DMAKE; + + push @m, q{ +.NO_CONFIG_REC: Makefile +} if $ENV{CLEARCASE_ROOT}; + + # why not q{} ? -- emacs + push @m, qq{ +# work around a famous dec-osf make(1) feature(?): +makemakerdflt: all + +.SUFFIXES: .xs .c .C .cpp .cxx .cc \$(OBJ_EXT) + +# Nick wanted to get rid of .PRECIOUS. I don't remember why. I seem to recall, that +# some make implementations will delete the Makefile when we rebuild it. Because +# we call false(1) when we rebuild it. So make(1) is not completely wrong when it +# does so. Our milage may vary. +# .PRECIOUS: Makefile # seems to be not necessary anymore + +.PHONY: all config static dynamic test linkext manifest + +# Where is the Config information that we are using/depend on +CONFIGDEP = \$(PERL_ARCHLIB)\\Config.pm \$(PERL_INC)\\config.h +}; + + my @parentdir = split(/::/, $self->{PARENT_NAME}); + push @m, q{ +# Where to put things: +INST_LIBDIR = }. $self->catdir('$(INST_LIB)',@parentdir) .q{ +INST_ARCHLIBDIR = }. $self->catdir('$(INST_ARCHLIB)',@parentdir) .q{ + +INST_AUTODIR = }. $self->catdir('$(INST_LIB)','auto','$(FULLEXT)') .q{ +INST_ARCHAUTODIR = }. $self->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)') .q{ +}; + + if ($self->has_link_code()) { + push @m, ' +INST_STATIC = $(INST_ARCHAUTODIR)\$(BASEEXT)$(LIB_EXT) +INST_DYNAMIC = $(INST_ARCHAUTODIR)\$(DLBASE).$(DLEXT) +INST_BOOT = $(INST_ARCHAUTODIR)\$(BASEEXT).bs +'; + } else { + push @m, ' +INST_STATIC = +INST_DYNAMIC = +INST_BOOT = +'; + } + + $tmp = $self->export_list; + push @m, " +EXPORT_LIST = $tmp +"; + $tmp = $self->perl_archive; + push @m, " +PERL_ARCHIVE = $tmp +"; + +# push @m, q{ +#INST_PM = }.join(" \\\n\t", sort values %{$self->{PM}}).q{ +# +#PM_TO_BLIB = }.join(" \\\n\t", %{$self->{PM}}).q{ +#}; + + push @m, q{ +TO_INST_PM = }.join(" \\\n\t", sort keys %{$self->{PM}}).q{ + +PM_TO_BLIB = }.join(" \\\n\t", %{$self->{PM}}).q{ +}; + + join('',@m); +} + + sub path { local $^W = 1; my($self) = @_; @@ -176,7 +336,7 @@ sub static_lib { my(@m); push(@m, <<'END'); -$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)/.exists +$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)\.exists $(RM_RF) $@ END # If this extension has it's own library (eg SDBM_File) @@ -184,21 +344,52 @@ END push(@m, "\t$self->{CP} \$(MYEXTLIB) \$\@\n") if $self->{MYEXTLIB}; push @m, -q{ lib -nologo -out:$@ $(OBJECT) - }.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld +q{ $(AR) }.($BORLAND ? '$@ $(OBJECT:^"+")' : '-out:$@ $(OBJECT)').q{ + }.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)\extralibs.ld $(CHMOD) 755 $@ }; # Old mechanism - still available: - push @m, "\t$self->{NOECHO}".q{echo "$(EXTRALIBS)" >> $(PERL_SRC)/ext.libs}."\n\n" + push @m, "\t$self->{NOECHO}".q{echo "$(EXTRALIBS)" >> $(PERL_SRC)\ext.libs}."\n\n" if $self->{PERL_SRC}; push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); join('', "\n",@m); } +=item dynamic_bs (o) + +Defines targets for bootstrap files. + +=cut +sub dynamic_bs { + my($self, %attribs) = @_; + return ' +BOOTSTRAP = +' unless $self->has_link_code(); + + return ' +BOOTSTRAP = '."$self->{BASEEXT}.bs".' + +# As Mkbootstrap might not write a file (if none is required) +# we use touch to prevent make continually trying to remake it. +# The DynaLoader only reads a non-empty file. +$(BOOTSTRAP): '."$self->{MAKEFILE} $self->{BOOTDEP}".' $(INST_ARCHAUTODIR)\.exists + '.$self->{NOECHO}.'echo "Running Mkbootstrap for $(NAME) ($(BSLOADLIBS))" + '.$self->{NOECHO}.'$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" \ + -MExtUtils::Mkbootstrap \ + -e "Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');" + '.$self->{NOECHO}.'$(TOUCH) $(BOOTSTRAP) + $(CHMOD) 644 $@ + +$(INST_BOOT): $(BOOTSTRAP) $(INST_ARCHAUTODIR)\.exists + '."$self->{NOECHO}$self->{RM_RF}".' $(INST_BOOT) + -'.$self->{CP}.' $(BOOTSTRAP) $(INST_BOOT) + $(CHMOD) 644 $@ +'; +} =item dynamic_lib (o) @@ -212,7 +403,7 @@ sub dynamic_lib { return '' unless $self->has_link_code; - my($otherldflags) = $attribs{OTHERLDFLAGS} || ""; + my($otherldflags) = $attribs{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': ''); my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || ""; my($ldfrom) = '$(LDFROM)'; my(@m); @@ -222,11 +413,13 @@ sub dynamic_lib { OTHERLDFLAGS = '.$otherldflags.' INST_DYNAMIC_DEP = '.$inst_dynamic_dep.' -$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) +$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)\.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) '); - push(@m,' $(LD) -out:$@ $(LDDLFLAGS) '.$ldfrom. - ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)'); + push(@m, $BORLAND ? +q{ $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) }.$ldfrom.q{,$@,,$(PERL_ARCHIVE:s,/,\,) $(LDLOADLIBS:s,/,\,) $(MYEXTLIB:s,/,\,),$(EXPORT_LIST:s,/,\,),$(RESFILES)} : +q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)} + ); push @m, ' $(CHMOD) 755 $@ '; @@ -257,7 +450,7 @@ sub canonpath { my($self,$path) = @_; $path =~ s/^([a-z]:)/\u$1/; $path =~ s|/|\\|g; - $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|\\$|| @@ -294,11 +487,14 @@ sub pm_to_blib { pm_to_blib: $(TO_INST_PM) }.$self->{NOECHO}.q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \ "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \ - -e "pm_to_blib(qw{ <<pmfiles.dat },'}.$autodir.q{')" - }.q{ + -e "pm_to_blib(qw[ }. + ($NMAKE ? '<<pmfiles.dat' + : '$(mktmp,pmfiles.dat $(PM_TO_BLIB:s,\\,\\\\,)\n)'). + q{ ],'}.$autodir.q{')" + }. ($NMAKE ? q{ $(PM_TO_BLIB) << - }.$self->{NOECHO}.q{$(TOUCH) $@ + } : '') . $self->{NOECHO}.q{$(TOUCH) $@ }; } @@ -313,6 +509,7 @@ sub test_via_harness { "\t$perl".q! -Mblib -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e "use Test::Harness qw(&runtests $$verbose); $$verbose=$(TEST_VERBOSE); runtests @ARGV;" !."$tests\n"; } + =item tool_autosplit (override) Use Win32 quoting on command line. @@ -345,7 +542,7 @@ sub tools_other { my $bin_sh = $Config{sh} || 'cmd /c'; push @m, qq{ SHELL = $bin_sh -}; +} unless $DMAKE; # dmake determines its own shell for (qw/ CHMOD CP LD MV NOOP RM_F RM_RF TEST_F TOUCH UMASK_NULL DEV_NULL/ ) { push @m, "$_ = $self->{$_}\n"; @@ -378,12 +575,12 @@ UNINST=0 VERBINST=1 MOD_INSTALL = $(PERL) -I$(INST_LIB) -I$(PERL_LIB) -MExtUtils::Install \ --e "install({@ARGV},'$(VERBINST)',0,'$(UNINST)');" +-e "install({ @ARGV },'$(VERBINST)',0,'$(UNINST)');" DOC_INSTALL = $(PERL) -e "$$\=\"\n\n\";" \ -e "print '=head2 ', scalar(localtime), ': C<', shift, '>', ' L<', shift, '>';" \ -e "print '=over 4';" \ --e "while (defined($$key = shift) and defined($$val = shift)){print '=item *';print 'C<', \"$$key: $$val\", '>';}" \ +-e "while (defined($$key = shift) and defined($$val = shift)) { print '=item *';print 'C<', \"$$key: $$val\", '>'; }" \ -e "print '=back';" UNINSTALL = $(PERL) -MExtUtils::Install \ @@ -395,6 +592,100 @@ UNINSTALL = $(PERL) -MExtUtils::Install \ return join "", @m; } +=item xs_o (o) + +Defines suffix rules to go from XS to object files directly. This is +only intended for broken make implementations. + +=cut + +sub xs_o { # many makes are too dumb to use xs_c then c_o + my($self) = shift; + return '' +} + +=item top_targets (o) + +Defines the targets all, subdirs, config, and O_FILES + +=cut + +sub top_targets { +# --- Target Sections --- + + my($self) = shift; + my(@m); + push @m, ' +#all :: config $(INST_PM) subdirs linkext manifypods +'; + + push @m, ' +all :: pure_all manifypods + '.$self->{NOECHO}.'$(NOOP) +' + unless $self->{SKIPHASH}{'all'}; + + push @m, ' +pure_all :: config pm_to_blib subdirs linkext + '.$self->{NOECHO}.'$(NOOP) + +subdirs :: $(MYEXTLIB) + '.$self->{NOECHO}.'$(NOOP) + +config :: '.$self->{MAKEFILE}.' $(INST_LIBDIR)\.exists + '.$self->{NOECHO}.'$(NOOP) + +config :: $(INST_ARCHAUTODIR)\.exists + '.$self->{NOECHO}.'$(NOOP) + +config :: $(INST_AUTODIR)\.exists + '.$self->{NOECHO}.'$(NOOP) +'; + + push @m, qq{ +config :: Version_check + $self->{NOECHO}\$(NOOP) + +} unless $self->{PARENT} or ($self->{PERL_SRC} && $self->{INSTALLDIRS} eq "perl") or $self->{NO_VC}; + + push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]); + + if (%{$self->{MAN1PODS}}) { + push @m, qq[ +config :: \$(INST_MAN1DIR)\\.exists + $self->{NOECHO}\$(NOOP) + +]; + push @m, $self->dir_target(qw[$(INST_MAN1DIR)]); + } + if (%{$self->{MAN3PODS}}) { + push @m, qq[ +config :: \$(INST_MAN3DIR)\\.exists + $self->{NOECHO}\$(NOOP) + +]; + push @m, $self->dir_target(qw[$(INST_MAN3DIR)]); + } + + push @m, ' +$(O_FILES): $(H_FILES) +' if @{$self->{O_FILES} || []} && @{$self->{H} || []}; + + push @m, q{ +help: + perldoc ExtUtils::MakeMaker +}; + + push @m, q{ +Version_check: + }.$self->{NOECHO}.q{$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \ + -MExtUtils::MakeMaker=Version_check \ + -e "Version_check('$(MM_VERSION)')" +}; + + join('',@m); +} + =item manifypods (o) We don't want manpage process. XXX add pod2html support later. @@ -479,7 +770,7 @@ subdirectories. sub pasthru { my($self) = shift; - return "PASTHRU = /nologo" + return "PASTHRU = " . ($NMAKE ? "-nologo" : ""); } diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index b03ccee7be..6d1746c31f 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -454,11 +454,17 @@ sub ExtUtils::MakeMaker::new { if (! $self->{PERL_SRC} ) { my($pthinks) = $self->canonpath($INC{'Config.pm'}); + my($cthinks) = $self->catfile($Config{'archlibexp'},'Config.pm'); $pthinks = VMS::Filespec::vmsify($pthinks) if $Is_VMS; - if ($pthinks ne $self->catfile($Config{archlibexp},'Config.pm')){ - print "Have $pthinks expected ",$self->catfile($Config{archlibexp},'Config.pm'),"\n"; - $pthinks =~ s!/Config\.pm$!!; - $pthinks =~ s!.*/!!; + if ($pthinks ne $cthinks && + !($Is_Win32 and lc($pthinks) eq lc($cthinks))) { + print "Have $pthinks expected $cthinks\n"; + if ($Is_Win32) { + $pthinks =~ s![/\\]Config\.pm$!!i; $pthinks =~ s!.*[/\\]!!; + } + else { + $pthinks =~ s!/Config\.pm$!!; $pthinks =~ s!.*/!!; + } print STDOUT <<END; Your perl and your Config.pm seem to have different ideas about the architecture they are running on. diff --git a/lib/ExtUtils/Mksymlists.pm b/lib/ExtUtils/Mksymlists.pm index fd609152c3..73dc81d069 100644 --- a/lib/ExtUtils/Mksymlists.pm +++ b/lib/ExtUtils/Mksymlists.pm @@ -97,6 +97,7 @@ while (($name, $exp)= each %{$data->{IMPORTS}}) { sub _write_win32 { my($data) = @_; + require Config; if (not $data->{DLBASE}) { ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://; $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_'; @@ -109,6 +110,10 @@ sub _write_win32 { print DEF "CODE LOADONCALL\n"; print DEF "DATA LOADONCALL NONSHARED MULTIPLE\n"; print DEF "EXPORTS\n "; + if ($Config::Config{'cc'} =~ /^bcc/i) { + for (@{$data->{DL_VARS}}) { $_ = "$_ = _$_" } + for (@{$data->{FUNCLIST}}) { $_ = "$_ = _$_" } + } print DEF join("\n ",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}}; print DEF join("\n ",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}}; if (%{$data->{IMPORTS}}) { diff --git a/lib/File/DosGlob.pm b/lib/File/DosGlob.pm new file mode 100644 index 0000000000..e0887d122c --- /dev/null +++ b/lib/File/DosGlob.pm @@ -0,0 +1,201 @@ +#!perl -w + +# +# Documentation at the __END__ +# + +package File::DosGlob; + +unless (caller) { + $| = 1; + while (@ARGV) { + # + # We have to do this one by one for compatibility reasons. + # If an arg doesn't match anything, we are supposed to return + # the original arg. I know, it stinks, eh? + # + my $arg = shift; + my @m = doglob(1,$arg); + print (@m ? join("\0", sort @m) : $arg); + print "\0" if @ARGV; + } +} + +sub doglob { + my $cond = shift; + my @retval = (); + #print "doglob: ", join('|', @_), "\n"; + OUTER: + for my $arg (@_) { + local $_ = $arg; + my @matched = (); + my @globdirs = (); + my $head = '.'; + my $sepchr = '/'; + next OUTER unless defined $_ and $_ ne ''; + # if arg is within quotes strip em and do no globbing + if (/^"(.*)"$/) { + $_ = $1; + if ($cond eq 'd') { push(@retval, $_) if -d $_ } + else { push(@retval, $_) if -e $_ } + next OUTER; + } + if (m|^(.*)([\\/])([^\\/]*)$|) { + my $tail; + ($head, $sepchr, $tail) = ($1,$2,$3); + #print "div: |$head|$sepchr|$tail|\n"; + push (@retval, $_), next OUTER if $tail eq ''; + if ($head =~ /[*?]/) { + @globdirs = doglob('d', $head); + push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)), + next OUTER if @globdirs; + } + $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:$/; + $_ = $tail; + } + # + # If file component has no wildcards, we can avoid opendir + unless (/[*?]/) { + $head = '' if $head eq '.'; + $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; + $head .= $_; + if ($cond eq 'd') { push(@retval,$head) if -d $head } + else { push(@retval,$head) if -e $head } + next OUTER; + } + opendir(D, $head) or next OUTER; + my @leaves = readdir D; + closedir D; + $head = '' if $head eq '.'; + $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; + + # escape regex metachars but not glob chars + s:([].+^\-\${}[|]):\\$1:g; + # and convert DOS-style wildcards to regex + s/\*/.*/g; + s/\?/.?/g; + + #print "regex: '$_', head: '$head'\n"; + my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '$|io }'; + warn($@), next OUTER if $@; + INNER: + for my $e (@leaves) { + next INNER if $e eq '.' or $e eq '..'; + next INNER if $cond eq 'd' and ! -d "$head$e"; + push(@matched, "$head$e"), next INNER if &$matchsub($e); + # + # [DOS compatibility special case] + # Failed, add a trailing dot and try again, but only + # if name does not have a dot in it *and* pattern + # has a dot *and* name is shorter than 9 chars. + # + if (index($e,'.') == -1 and length($e) < 9 + and index($_,'\\.') != -1) { + push(@matched, "$head$e"), next INNER if &$matchsub("$e."); + } + } + push @retval, @matched if @matched; + } + return @retval; +} + +# +# this can be used to override CORE::glob +# by saying C<use File::DosGlob 'glob';>. +# +sub glob { doglob(1,@_) } + +sub import { + my $pkg = shift; + my $callpkg = caller(0); + my $sym = shift; + *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob'; +} + +1; + +__END__ + +=head1 NAME + +File::DosGlob - DOS like globbing and then some + +perlglob.bat - a more capable perlglob.exe replacement + +=head1 SYNOPSIS + + require 5.004; + use File::DosGlob 'glob'; # override CORE::glob + @perlfiles = glob "..\\pe?l/*.p?"; + print <..\\pe?l/*.p?>; + + # from the command line + > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>" + + > perlglob ../pe*/*p? + +=head1 DESCRIPTION + +A module that implements DOS-like globbing with a few enhancements. +This file is also a portable replacement for perlglob.exe. It +is largely compatible with perlglob.exe (the M$ setargv.obj +version) in all but one respect--it understands wildcards in +directory components. + +For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in +that it will find something like '..\lib\File/DosGlob.pm' alright). +Note that all path components are case-insensitive, and that +backslashes and forward slashes are both accepted, and preserved. +You may have to double the backslashes if you are putting them in +literally, due to double-quotish parsing of the pattern by perl. + +When invoked as a program, it will print null-separated filenames +to standard output. + +While one may replace perlglob.exe with this, usage by overriding +CORE::glob via importation should be much more efficient, because +it avoids launching a separate process, and is therefore strongly +recommended. + +Extending it to csh patterns is left as an exercise to the reader. + +=head1 EXPORTS (by request only) + +glob() + +=head1 BUGS + +Should probably be built into the core, and needs to stop +pandering to DOS habits. Needs a dose of optimizium too. + +=head1 AUTHOR + +Gurusamy Sarathy <gsar@umich.edu> + +=head1 HISTORY + +=over 4 + +=item * + +A few dir-vs-file optimizations result in glob importation being +10 times faster than using perlglob.exe, and using perlglob.bat is +only twice as slow as perlglob.exe (GSAR 28-MAY-97) + +=item * + +Several cleanups prompted by lack of compatible perlglob.exe +under Borland (GSAR 27-MAY-97) + +=item * + +Initial version (GSAR 20-FEB-97) + +=back + +=head1 SEE ALSO + +perl + +=cut + diff --git a/lib/Pod/Html.pm b/lib/Pod/Html.pm index 6efaf1ffa2..82453344d8 100644 --- a/lib/Pod/Html.pm +++ b/lib/Pod/Html.pm @@ -236,10 +236,13 @@ $top = 1; # true if we are at the top of the doc. used # to prevent the first <HR> directive. $paragraph = ''; # which paragraph we're processing (used # for error messages) -%pages = (); # associative array used to find the location - # of pages referenced by L<> links. %sections = (); # sections within this page -%items = (); # associative array used to find the location + +# These are not reinitialised here but are kept as a cache. +# See get_cache and related cache management code. +#%pages = (); # associative array used to find the location + # of pages referenced by L<> links. +#%items = (); # associative array used to find the location # of =item directives referenced by C<> links } @@ -252,7 +255,6 @@ sub pod2html { init_globals(); # cache of %pages and %items from last time we ran pod2html - my $podpath = ''; #undef $opt_help if defined $opt_help; @@ -281,6 +283,11 @@ sub pod2html { # scan the pod for =head[1-6] directives and build an index my $index = scan_headings(\%sections, @poddata); + unless($index) { + warn "No pod in $podfile\n" if $verbose; + return; + } + # open the output file open(HTML, ">$htmlfile") || die "$0: cannot open $htmlfile file for output: $!\n"; @@ -297,14 +304,19 @@ sub pod2html { } } + if (!$title and $podfile =~ /\.pod$/) { + # probably a split pod so take first =head[12] as title + for (my $i = 0; $i < @poddata; $i++) { + last if ($title) = $poddata[$i] =~ /^=head[12]\s*(.*)/; + } + warn "adopted '$title' as title for $podfile\n" + if $verbose and $title; + } unless ($title) { + warn "$0: no title for $podfile"; $podfile =~ /^(.*)(\.[^.\/]+)?$/; $title = ($podfile eq "-" ? 'No Title' : $1); - warn "found $title" if $verbose; - } - if ($title =~ /\.pm/) { - warn "$0: no title for $podfile"; - $title = $podfile; + warn "using $title" if $verbose; } print HTML <<END_OF_HEAD; <HTML> @@ -316,20 +328,8 @@ sub pod2html { END_OF_HEAD - # load a cache of %pages and %items if possible. $tests will be - # non-zero if successful. - my $tests = 0; - if (-f $dircache && -f $itemcache) { - warn "scanning for item cache\n" if $verbose; - $tests = find_cache($dircache, $itemcache, $podpath, $podroot); - } - - # if we didn't succeed in loading the cache then we must (re)build - # %pages and %items. - if (!$tests) { - warn "scanning directories in pod-path\n" if $verbose; - scan_podpath($podroot, $recurse); - } + # load/reload/validate/cache %pages and %items + get_cache($dircache, $itemcache, \@podpath, $podroot, $recurse); # scan the pod for =item directives scan_items("", \%items, @poddata); @@ -492,12 +492,51 @@ sub parse_command_line { $netscape = $opt_netscape if defined $opt_netscape; } + +my $saved_cache_key; + +sub get_cache { + my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_; + my @cache_key_args = @_; + + # A first-level cache: + # Don't bother reading the cache files if they still apply + # and haven't changed since we last read them. + + my $this_cache_key = cache_key(@cache_key_args); + + return if $saved_cache_key and $this_cache_key eq $saved_cache_key; + + # load the cache of %pages and %items if possible. $tests will be + # non-zero if successful. + my $tests = 0; + if (-f $dircache && -f $itemcache) { + warn "scanning for item cache\n" if $verbose; + $tests = load_cache($dircache, $itemcache, $podpath, $podroot); + } + + # if we didn't succeed in loading the cache then we must (re)build + # %pages and %items. + if (!$tests) { + warn "scanning directories in pod-path\n" if $verbose; + scan_podpath($podroot, $recurse, 0); + } + $saved_cache_key = cache_key(@cache_key_args); +} + +sub cache_key { + my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_; + return join('!', $dircache, $itemcache, $recurse, + @$podpath, $podroot, stat($dircache), stat($itemcache)); +} + # -# find_cache - tries to find if the caches stored in $dircache and $itemcache +# load_cache - tries to find if the caches stored in $dircache and $itemcache # are valid caches of %pages and %items. if they are valid then it loads # them and returns a non-zero value. # -sub find_cache { + +sub load_cache { my($dircache, $itemcache, $podpath, $podroot) = @_; my($tests); local $_; @@ -511,7 +550,7 @@ sub find_cache { # is it the same podpath? $_ = <CACHE>; chomp($_); - $tests++ if (join(":", @podpath) eq $_); + $tests++ if (join(":", @$podpath) eq $_); # is it the same podroot? $_ = <CACHE>; @@ -521,8 +560,6 @@ sub find_cache { # load the cache if its good if ($tests != 2) { close(CACHE); - - %items = (); return 0; } @@ -542,7 +579,7 @@ sub find_cache { # is it the same podpath? $_ = <CACHE>; chomp($_); - $tests++ if (join(":", @podpath) eq $_); + $tests++ if (join(":", @$podpath) eq $_); # is it the same podroot? $_ = <CACHE>; @@ -552,9 +589,6 @@ sub find_cache { # load the cache if its good if ($tests != 2) { close(CACHE); - - %pages = (); - %items = (); return 0; } @@ -575,10 +609,15 @@ sub find_cache { # @libpods for =item directives. # sub scan_podpath { - my($podroot, $recurse) = @_; + my($podroot, $recurse, $append) = @_; my($pwd, $dir); my($libpod, $dirname, $pod, @files, @poddata); + unless($append) { + %items = (); + %pages = (); + } + # scan each directory listed in @podpath $pwd = getcwd(); chdir($podroot) diff --git a/lib/Sys/Syslog.pm b/lib/Sys/Syslog.pm index 471be11fcd..9efcfbf3c4 100644 --- a/lib/Sys/Syslog.pm +++ b/lib/Sys/Syslog.pm @@ -201,7 +201,7 @@ sub connect { unless ($host) { require Sys::Hostname; my($host_uniq) = Sys::Hostname::hostname(); - ($host) = $host_uniq =~ /([\w\-]+)/; + ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _) } my $udp = getprotobyname('udp'); my $syslog = getservbyname('syslog','udp'); diff --git a/lib/chat2.pl b/lib/chat2.pl new file mode 100644 index 0000000000..0d9a7d3d50 --- /dev/null +++ b/lib/chat2.pl @@ -0,0 +1,368 @@ +# chat.pl: chat with a server +# Based on: V2.01.alpha.7 91/06/16 +# Randal L. Schwartz (was <merlyn@stonehenge.com>) +# multihome additions by A.Macpherson@bnr.co.uk +# allow for /dev/pts based systems by Joe Doupnik <JRD@CC.USU.EDU> + +package chat; + +require 'sys/socket.ph'; + +if( defined( &main'PF_INET ) ){ + $pf_inet = &main'PF_INET; + $sock_stream = &main'SOCK_STREAM; + local($name, $aliases, $proto) = getprotobyname( 'tcp' ); + $tcp_proto = $proto; +} +else { + # XXX hardwired $PF_INET, $SOCK_STREAM, 'tcp' + # but who the heck would change these anyway? (:-) + $pf_inet = 2; + $sock_stream = 1; + $tcp_proto = 6; +} + + +$sockaddr = 'S n a4 x8'; +chop($thishost = `hostname`); + +# *S = symbol for current I/O, gets assigned *chatsymbol.... +$next = "chatsymbol000000"; # next one +$nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++ + + +## $handle = &chat'open_port("server.address",$port_number); +## opens a named or numbered TCP server + +sub open_port { ## public + local($server, $port) = @_; + + local($serveraddr,$serverproc); + + # We may be multi-homed, start with 0, fixup once connexion is made + $thisaddr = "\0\0\0\0" ; + $thisproc = pack($sockaddr, 2, 0, $thisaddr); + + *S = ++$next; + if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) { + $serveraddr = pack('C4', $1, $2, $3, $4); + } else { + local(@x) = gethostbyname($server); + return undef unless @x; + $serveraddr = $x[4]; + } + $serverproc = pack($sockaddr, 2, $port, $serveraddr); + unless (socket(S, $pf_inet, $sock_stream, $tcp_proto)) { + ($!) = ($!, close(S)); # close S while saving $! + return undef; + } + unless (bind(S, $thisproc)) { + ($!) = ($!, close(S)); # close S while saving $! + return undef; + } + unless (connect(S, $serverproc)) { + ($!) = ($!, close(S)); # close S while saving $! + return undef; + } +# We opened with the local address set to ANY, at this stage we know +# which interface we are using. This is critical if our machine is +# multi-homed, with IP forwarding off, so fix-up. + local($fam,$lport); + ($fam,$lport,$thisaddr) = unpack($sockaddr, getsockname(S)); + $thisproc = pack($sockaddr, 2, 0, $thisaddr); +# end of post-connect fixup + select((select(S), $| = 1)[0]); + $next; # return symbol for switcharound +} + +## ($host, $port, $handle) = &chat'open_listen([$port_number]); +## opens a TCP port on the current machine, ready to be listened to +## if $port_number is absent or zero, pick a default port number +## process must be uid 0 to listen to a low port number + +sub open_listen { ## public + + *S = ++$next; + local($thisport) = shift || 0; + local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr); + local(*NS) = "__" . time; + unless (socket(NS, $pf_inet, $sock_stream, $tcp_proto)) { + ($!) = ($!, close(NS)); + return undef; + } + unless (bind(NS, $thisproc_local)) { + ($!) = ($!, close(NS)); + return undef; + } + unless (listen(NS, 1)) { + ($!) = ($!, close(NS)); + return undef; + } + select((select(NS), $| = 1)[0]); + local($family, $port, @myaddr) = + unpack("S n C C C C x8", getsockname(NS)); + $S{"needs_accept"} = *NS; # so expect will open it + (@myaddr, $port, $next); # returning this +} + +## $handle = &chat'open_proc("command","arg1","arg2",...); +## opens a /bin/sh on a pseudo-tty + +sub open_proc { ## public + local(@cmd) = @_; + + *S = ++$next; + local(*TTY) = "__TTY" . time; + local($pty,$tty) = &_getpty(S,TTY); + die "Cannot find a new pty" unless defined $pty; + $pid = fork; + die "Cannot fork: $!" unless defined $pid; + unless ($pid) { + close STDIN; close STDOUT; close STDERR; + setpgrp(0,$$); + if (open(DEVTTY, "/dev/tty")) { + ioctl(DEVTTY,0x20007471,0); # XXX s/b &TIOCNOTTY + close DEVTTY; + } + open(STDIN,"<&TTY"); + open(STDOUT,">&TTY"); + open(STDERR,">&STDOUT"); + die "Oops" unless fileno(STDERR) == 2; # sanity + close(S); + exec @cmd; + die "Cannot exec @cmd: $!"; + } + close(TTY); + $next; # return symbol for switcharound +} + +# $S is the read-ahead buffer + +## $return = &chat'expect([$handle,] $timeout_time, +## $pat1, $body1, $pat2, $body2, ... ) +## $handle is from previous &chat'open_*(). +## $timeout_time is the time (either relative to the current time, or +## absolute, ala time(2)) at which a timeout event occurs. +## $pat1, $pat2, and so on are regexs which are matched against the input +## stream. If a match is found, the entire matched string is consumed, +## and the corresponding body eval string is evaled. +## +## Each pat is a regular-expression (probably enclosed in single-quotes +## in the invocation). ^ and $ will work, respecting the current value of $*. +## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded. +## If pat is 'EOF', the body is executed if the process exits before +## the other patterns are seen. +## +## Pats are scanned in the order given, so later pats can contain +## general defaults that won't be examined unless the earlier pats +## have failed. +## +## The result of eval'ing body is returned as the result of +## the invocation. Recursive invocations are not thought +## through, and may work only accidentally. :-) +## +## undef is returned if either a timeout or an eof occurs and no +## corresponding body has been defined. +## I/O errors of any sort are treated as eof. + +$nextsubname = "expectloop000000"; # used for subroutines + +sub expect { ## public + if ($_[0] =~ /$nextpat/) { + *S = shift; + } + local($endtime) = shift; + + local($timeout,$eof) = (1,1); + local($caller) = caller; + local($rmask, $nfound, $timeleft, $thisbuf); + local($cases, $pattern, $action, $subname); + $endtime += time if $endtime < 600_000_000; + + if (defined $S{"needs_accept"}) { # is it a listen socket? + local(*NS) = $S{"needs_accept"}; + delete $S{"needs_accept"}; + $S{"needs_close"} = *NS; + unless(accept(S,NS)) { + ($!) = ($!, close(S), close(NS)); + return undef; + } + select((select(S), $| = 1)[0]); + } + + # now see whether we need to create a new sub: + + unless ($subname = $expect_subname{$caller,@_}) { + # nope. make a new one: + $expect_subname{$caller,@_} = $subname = $nextsubname++; + + $cases .= <<"EDQ"; # header is funny to make everything elsif's +sub $subname { + LOOP: { + if (0) { ; } +EDQ + while (@_) { + ($pattern,$action) = splice(@_,0,2); + if ($pattern =~ /^eof$/i) { + $cases .= <<"EDQ"; + elsif (\$eof) { + package $caller; + $action; + } +EDQ + $eof = 0; + } elsif ($pattern =~ /^timeout$/i) { + $cases .= <<"EDQ"; + elsif (\$timeout) { + package $caller; + $action; + } +EDQ + $timeout = 0; + } else { + $pattern =~ s#/#\\/#g; + $cases .= <<"EDQ"; + elsif (\$S =~ /$pattern/) { + \$S = \$'; + package $caller; + $action; + } +EDQ + } + } + $cases .= <<"EDQ" if $eof; + elsif (\$eof) { + undef; + } +EDQ + $cases .= <<"EDQ" if $timeout; + elsif (\$timeout) { + undef; + } +EDQ + $cases .= <<'ESQ'; + else { + $rmask = ""; + vec($rmask,fileno(S),1) = 1; + ($nfound, $rmask) = + select($rmask, undef, undef, $endtime - time); + if ($nfound) { + $nread = sysread(S, $thisbuf, 1024); + if ($nread > 0) { + $S .= $thisbuf; + } else { + $eof++, redo LOOP; # any error is also eof + } + } else { + $timeout++, redo LOOP; # timeout + } + redo LOOP; + } + } +} +ESQ + eval $cases; die "$cases:\n$@" if $@; + } + $eof = $timeout = 0; + do $subname(); +} + +## &chat'print([$handle,] @data) +## $handle is from previous &chat'open(). +## like print $handle @data + +sub print { ## public + if ($_[0] =~ /$nextpat/) { + *S = shift; + } + print S @_; + if( $chat'debug ){ + print STDERR "printed:"; + print STDERR @_; + } +} + +## &chat'close([$handle,]) +## $handle is from previous &chat'open(). +## like close $handle + +sub close { ## public + if ($_[0] =~ /$nextpat/) { + *S = shift; + } + close(S); + if (defined $S{"needs_close"}) { # is it a listen socket? + local(*NS) = $S{"needs_close"}; + delete $S{"needs_close"}; + close(NS); + } +} + +## @ready_handles = &chat'select($timeout, @handles) +## select()'s the handles with a timeout value of $timeout seconds. +## Returns an array of handles that are ready for I/O. +## Both user handles and chat handles are supported (but beware of +## stdio's buffering for user handles). + +sub select { ## public + local($timeout) = shift; + local(@handles) = @_; + local(%handlename) = (); + local(%ready) = (); + local($caller) = caller; + local($rmask) = ""; + for (@handles) { + if (/$nextpat/o) { # one of ours... see if ready + local(*SYM) = $_; + if (length($SYM)) { + $timeout = 0; # we have a winner + $ready{$_}++; + } + $handlename{fileno($_)} = $_; + } else { + $handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_; + } + } + for (sort keys %handlename) { + vec($rmask, $_, 1) = 1; + } + select($rmask, undef, undef, $timeout); + for (sort keys %handlename) { + $ready{$handlename{$_}}++ if vec($rmask,$_,1); + } + sort keys %ready; +} + +# ($pty,$tty) = $chat'_getpty(PTY,TTY): +# internal procedure to get the next available pty. +# opens pty on handle PTY, and matching tty on handle TTY. +# returns undef if can't find a pty. +# Modify "/dev/pty" to "/dev/pts" for Dell Unix v2.2 (aka SVR4.04). Joe Doupnik. + +sub _getpty { ## private + local($_PTY,$_TTY) = @_; + $_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e; + $_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e; + local($pty, $tty, $kind); + if( -e "/dev/pts000" ){ ## mods by Joe Doupnik Dec 1992 + $kind = "pts"; ## SVR4 Streams + } else { + $kind = "pty"; ## BSD Clist stuff + } + for $bank (112..127) { + next unless -e sprintf("/dev/$kind%c0", $bank); + for $unit (48..57) { + $pty = sprintf("/dev/$kind%c%c", $bank, $unit); + open($_PTY,"+>$pty") || next; + select((select($_PTY), $| = 1)[0]); + ($tty = $pty) =~ s/pty/tty/; + open($_TTY,"+>$tty") || next; + select((select($_TTY), $| = 1)[0]); + system "stty nl>$tty"; + return ($pty,$tty); + } + } + undef; +} + +1; diff --git a/lib/ftp.pl b/lib/ftp.pl index 9528360da2..e671348105 100644 --- a/lib/ftp.pl +++ b/lib/ftp.pl @@ -88,7 +88,14 @@ # Initial revision # -require 'chat2.pl'; +eval { require 'chat2.pl' }; +die qq{$@ +The obsolete and problematic chat2.pl library has been removed from the +Perl distribution at the request of it's author. You can either get a +copy yourself or, preferably, fetch the new and much better Net::FTP +package from a CPAN ftp site. +} if $@ && $@ =~ /locate chat2.pl/; +die $@ if $@; eval "require 'socket.ph'" || eval "require 'sys/socket.ph'" || die "socket.ph missing: $!\n"; |