From: Nick Ing-Simmons Date: Sun, 24 Oct 1999 15:09:51 +0000 (+0000) Subject: Follow that camel ... another sync. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6e7c9e4dbac15378c097f03304f6025aebc78a15;p=p5sagit%2Fp5-mst-13.2.git Follow that camel ... another sync. p4raw-id: //depot/utfperl@4443 --- diff --git a/Changes b/Changes index 9d142bc..828cc12 100644 --- a/Changes +++ b/Changes @@ -79,6 +79,291 @@ Version 5.005_62 Development release working toward 5.006 ---------------- ____________________________________________________________________________ +[ 4435] By: gsar on 1999/10/24 11:39:42 + Log: VMS tweak (suggested by Craig A. Berry ) + Branch: perl + ! ext/B/defsubs_h.PL +____________________________________________________________________________ +[ 4434] By: gsar on 1999/10/24 11:36:08 + Log: relax range checking if they ask for it (from John L. Allen + ) + Branch: perl + ! lib/Time/Local.pm +____________________________________________________________________________ +[ 4433] By: gsar on 1999/10/24 11:25:51 + Log: README nits pointed out by Chris Nandor + Branch: perl + ! README lib/File/Path.pm +____________________________________________________________________________ +[ 4432] By: gsar on 1999/10/24 11:11:02 + Log: From: Ilya Zakharevich + Date: Sun, 24 Oct 1999 03:24:28 -0400 (EDT) + Message-Id: <199910240724.DAA12230@monk.mps.ohio-state.edu> + Subject: Re: [PATCH 5.005_62] OS/2 improvements + Branch: perl + + os2/OS2/REXX/DLL/Changes os2/OS2/REXX/DLL/DLL.pm + + os2/OS2/REXX/DLL/DLL.xs os2/OS2/REXX/DLL/MANIFEST + + os2/OS2/REXX/DLL/Makefile.PL os2/OS2/REXX/t/rx_emxrv.t + ! MANIFEST hints/os2.sh mg.c miniperlmain.c os2/Changes + ! os2/OS2/REXX/Changes os2/OS2/REXX/Makefile.PL + ! os2/OS2/REXX/REXX.pm os2/OS2/REXX/REXX.xs + ! os2/OS2/REXX/t/rx_dllld.t os2/OS2/REXX/t/rx_objcall.t + ! os2/OS2/REXX/t/rx_tievar.t os2/OS2/REXX/t/rx_tieydb.t + ! os2/OS2/REXX/t/rx_vrexx.t os2/dl_os2.c os2/os2.c os2/os2ish.h + ! perl.c perl.h t/io/fs.t t/op/magic.t +____________________________________________________________________________ +[ 4431] By: gsar on 1999/10/24 10:50:14 + Log: install all README.foo with pod content as podfoo.pod + Branch: perl + ! Makefile.SH installman +____________________________________________________________________________ +[ 4430] By: gsar on 1999/10/24 09:28:24 + Log: @INC needs ../lib + Branch: perl + ! t/op/int.t +____________________________________________________________________________ +[ 4429] By: jhi on 1999/10/23 21:47:49 + Log: More printf-fixes (see also #4426). + Branch: cfgperl + ! deb.c dump.c ext/Data/Dumper/Dumper.xs + ! ext/Devel/DProf/DProf.xs malloc.c mg.c op.c perl.c pp.c + ! pp_ctl.c regcomp.c regexec.c run.c scope.c sv.c util.c +____________________________________________________________________________ +[ 4428] By: gsar on 1999/10/23 20:28:56 + Log: fix accidental C modulo semantics on integer-valued operations + (e.g. caused C to return 3 rather than -7) + Branch: perl + ! op.c t/op/int.t +____________________________________________________________________________ +[ 4427] By: jhi on 1999/10/23 16:10:10 + Log: Integrate with Sarathy. + Branch: cfgperl + !> sv.c win32/win32.c +____________________________________________________________________________ +[ 4426] By: jhi on 1999/10/23 16:04:02 + Log: Fix the printfing nits pointed out by using gcc -Wall and + Configure -Duse64bits -Dccflags=-DDEBUGGING in Solaris, + plus few other warnings in Dumper.xs. + Branch: cfgperl + ! ext/Data/Dumper/Dumper.xs ext/Devel/DProf/DProf.xs + ! ext/Devel/Peek/Peek.xs regcomp.c regexec.c sv.c util.c +____________________________________________________________________________ +[ 4425] By: jhi on 1999/10/23 15:16:41 + Log: Configure regen to pick up the new installation directories + from Policy_sh.SH. The explanations of "public add-ons" and + "vendor-supplied" could do with more work. + Branch: cfgperl + ! Configure config_h.SH +____________________________________________________________________________ +[ 4424] By: nick on 1999/10/23 00:46:22 + Log: Resolve mainline before possible hacking operertunity this weekend + Branch: utfperl + +> pod/perlfilter.pod + !> (integrate 32 files) +____________________________________________________________________________ +[ 4423] By: jhi on 1999/10/22 22:53:17 + Log: Update Policy_sh.SH to handle the newer installation directives. + From: Andy Dougherty + To: Perl Porters + Subject: [PATCH 5.005_62] Policy_sh.SH update + Date: Fri, 22 Oct 1999 16:47:34 -0400 (EDT) + Message-ID: + Branch: cfgperl + ! Policy_sh.SH +____________________________________________________________________________ +[ 4422] By: jhi on 1999/10/22 22:44:44 + Log: so back to 'so', from Stephanie Beals + Branch: cfgperl + ! hints/aix.sh +____________________________________________________________________________ +[ 4421] By: gsar on 1999/10/22 21:16:44 + Log: sv_vcatpvfn() bug: fell through to assuming intsize of 'q' for + C<"%ld", long_val> + Branch: perl + ! sv.c +____________________________________________________________________________ +[ 4420] By: gsar on 1999/10/22 16:36:46 + Log: win32_utime() on directories should use localtime() rather + than gmtime() (from Jan Dubois) + Branch: perl + ! win32/win32.c +____________________________________________________________________________ +[ 4419] By: jhi on 1999/10/21 10:31:41 + Log: Integrate with Sarathy. + Branch: cfgperl + !> Makefile.SH lib/CPAN/FirstTime.pm op.c opcode.h opcode.pl + !> t/lib/glob-basic.t t/op/sort.t +____________________________________________________________________________ +[ 4418] By: gsar on 1999/10/20 23:49:47 + Log: add test for change#4417 + Branch: perl + ! t/op/sort.t +____________________________________________________________________________ +[ 4417] By: gsar on 1999/10/20 23:45:03 + Log: avoid coredump on C + Branch: perl + ! op.c +____________________________________________________________________________ +[ 4416] By: gsar on 1999/10/20 01:00:50 + Log: fix prototype mismatch (from Hans Mulder ) + Branch: perl + ! lib/CPAN/FirstTime.pm +____________________________________________________________________________ +[ 4415] By: gsar on 1999/10/20 00:52:34 + Log: disable optimizing troublesome ops in change#3612 + (from Ilya Zakharevich) + Branch: perl + ! Makefile.SH opcode.h opcode.pl +____________________________________________________________________________ +[ 4414] By: gsar on 1999/10/20 00:37:46 + Log: skip unreadable directory test when running as root + Branch: perl + ! t/lib/glob-basic.t +____________________________________________________________________________ +[ 4413] By: jhi on 1999/10/19 09:26:52 + Log: Avoid GNU ar if HP cc is being used. + Branch: cfgperl + ! hints/hpux.sh +____________________________________________________________________________ +[ 4412] By: jhi on 1999/10/19 07:24:29 + Log: Integrate with Sarathy. + Branch: cfgperl + !> perlvars.h +____________________________________________________________________________ +[ 4411] By: jhi on 1999/10/19 07:22:34 + Log: Long double support: sqrtl et al are not available everywhere, + e.g. not in Solaris, even when long doubles are. + Branch: cfgperl + ! Configure Porting/Glossary Porting/config.sh Porting/config_H + ! config_h.SH perl.h +____________________________________________________________________________ +[ 4410] By: jhi on 1999/10/19 07:21:42 + Log: Add sqrtl probe, add echo dependencies. + Branch: metaconfig + ! U/threads/d_pthreadj.U + Branch: metaconfig/U/perl + + d_sqrtl.U + ! i_inttypes.U io64.U +____________________________________________________________________________ +[ 4409] By: gsar on 1999/10/19 02:18:54 + Log: perl_mutex n/a if !USE_THREADS + Branch: perl + ! perlvars.h +____________________________________________________________________________ +[ 4408] By: jhi on 1999/10/18 20:13:02 + Log: Forgotten s/warning/warnings/. + Branch: cfgperl + ! Makefile.SH +____________________________________________________________________________ +[ 4407] By: jhi on 1999/10/18 20:02:12 + Log: Integrate with Sarathy. + Branch: cfgperl + +> pod/perlfilter.pod + !> (integrate 30 files) +____________________________________________________________________________ +[ 4406] By: gsar on 1999/10/18 16:32:10 + Log: added intro to source filters from Paul Marquess + Branch: perl + + pod/perlfilter.pod + ! MANIFEST pod/perldelta.pod +____________________________________________________________________________ +[ 4405] By: gsar on 1999/10/18 05:53:06 + Log: missing manpages + Branch: perl + ! installman +____________________________________________________________________________ +[ 4404] By: gsar on 1999/10/18 05:09:22 + Log: pod updates from Tom Christiansen + Branch: perl + ! lib/Pod/Man.pm pod/perldelta.pod pod/perlmodlib.pod +____________________________________________________________________________ +[ 4403] By: gsar on 1999/10/17 23:43:59 + Log: PL_malloc_mutex needs to be global, not per-interpreter + (malloc.c has static data) + Branch: perl + ! embedvar.h intrpvar.h objXSUB.h perl.c perlvars.h +____________________________________________________________________________ +[ 4402] By: gsar on 1999/10/17 22:30:30 + Log: support PERL_IMPLICIT_SYS with MULTIPLICITY/USE_THREADS on + windows + Branch: perl + ! XSUB.h ext/POSIX/POSIX.xs intrpvar.h makedef.pl malloc.c + ! perl.c perl.h perlio.c win32/perllib.c win32/win32.c + ! win32/win32.h +____________________________________________________________________________ +[ 4401] By: gsar on 1999/10/17 20:33:42 + Log: serious bug introduced by G_VOID changes in 5.003_96: scalar + eval"" did not pop stack correctly; C<$a = eval "(1,2)x1"> + is one symptom of the problem + Branch: perl + ! pp_ctl.c t/op/eval.t +____________________________________________________________________________ +[ 4400] By: gsar on 1999/10/17 18:36:46 + Log: remove FileHandle from list of PodParser dependencies (the + difference is 20 files vs 6 files loaded!) + Branch: perl + ! lib/Pod/Parser.pm lib/Pod/Select.pm pod/perldelta.pod + ! t/pod/testcmp.pl +____________________________________________________________________________ +[ 4399] By: nick on 1999/10/17 14:51:35 + Log: Pre-trip resolve + Branch: utfperl + !> installperl lib/Text/Tabs.pm perl.c pp_hot.c +____________________________________________________________________________ +[ 4398] By: gsar on 1999/10/17 09:19:24 + Log: make installperl ignore RCS files (from Michael G Schwern + ) + Branch: perl + ! installperl lib/Text/Tabs.pm +____________________________________________________________________________ +[ 4397] By: gsar on 1999/10/16 18:30:14 + Log: another bug in change#3386 (CATCH_SET wasn't reverted correctly) + Branch: perl + ! perl.c +____________________________________________________________________________ +[ 4396] By: jhi on 1999/10/16 17:44:39 + Log: Missing comma. + Branch: cfgperl + ! lib/diagnostics.pm +____________________________________________________________________________ +[ 4395] By: gsar on 1999/10/16 17:18:36 + Log: assumption about @_ always being non-REAL doesn't hold when + debugger is running; DB::sub() can call arbitrary stuff + that modifies @_ at will + Branch: perl + ! pp_hot.c +____________________________________________________________________________ +[ 4394] By: nick on 1999/10/16 09:35:20 + Log: Resolve utfperl branch against mainline as of _62 + Branch: utfperl + +> eg/cgi/dna_small_gif.uu eg/cgi/wilogo_gif.uu + +> ext/DB_File/hints/sco.pl ext/DynaLoader/hints/aix.pl + +> ext/File/Glob/Changes ext/File/Glob/Glob.pm + +> ext/File/Glob/Glob.xs ext/File/Glob/Makefile.PL + +> ext/File/Glob/TODO ext/File/Glob/bsd_glob.c + +> ext/File/Glob/bsd_glob.h ext/NDBM_File/hints/sco.pl + +> pod/perlhack.pod t/lib/glob-basic.t t/lib/glob-global.t + +> t/lib/glob-taint.t win32/genmk95.pl + - eg/cgi/dna.small.gif.uu eg/cgi/wilogo.gif.uu + !> (integrate 144 files) +____________________________________________________________________________ +[ 4393] By: gsar on 1999/10/16 04:07:02 + Log: OS/2 support bits (from Ilya Zakharevich) + Branch: perl + ! hints/os2.sh makedef.pl os2/Makefile.SHs t/lib/glob-basic.t +____________________________________________________________________________ +[ 4392] By: jhi on 1999/10/15 10:28:09 + Log: Integrate with Sarathy. + Branch: cfgperl + !> Changes MANIFEST Makefile.SH Porting/makerel lib/Pod/Man.pm + !> lib/Pod/Parser.pm op.c pod/perldelta.pod pod/perlopentut.pod + !> win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 4391] By: gsar on 1999/10/15 10:12:42 + Log: here be 5.005_62 + Branch: perl + ! Changes MANIFEST Porting/makerel +____________________________________________________________________________ [ 4390] By: gsar on 1999/10/15 09:45:51 Log: lvalue subs patch (change#4081) breaks C<\(Foo->Bar())>; avoid tickling it in Pod::Man for now; other nits in diff --git a/MANIFEST b/MANIFEST index 2ad8ec2..de3c0f7 100644 --- a/MANIFEST +++ b/MANIFEST @@ -954,11 +954,17 @@ os2/OS2/Process/Process.pm system() constants in a module os2/OS2/Process/Process.xs system() constants in a module os2/OS2/REXX/Changes DLL access module os2/OS2/REXX/MANIFEST DLL access module +os2/OS2/REXX/DLL/Changes DLL access module +os2/OS2/REXX/DLL/DLL.pm DLL access module +os2/OS2/REXX/DLL/DLL.xs DLL access module +os2/OS2/REXX/DLL/MANIFEST DLL access module +os2/OS2/REXX/DLL/Makefile.PL DLL access module os2/OS2/REXX/Makefile.PL DLL access module os2/OS2/REXX/REXX.pm DLL access module os2/OS2/REXX/REXX.xs DLL access module os2/OS2/REXX/t/rx_cmprt.t DLL access module os2/OS2/REXX/t/rx_dllld.t DLL access module +os2/OS2/REXX/t/rx_emxrv.t DLL access module os2/OS2/REXX/t/rx_objcall.t DLL access module os2/OS2/REXX/t/rx_sql.test DLL access module os2/OS2/REXX/t/rx_tiesql.test DLL access module diff --git a/Makefile.SH b/Makefile.SH index 7c542a6..b60715e 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -481,8 +481,16 @@ lib/re.pm: ext/re/re.pm $(plextract): miniperl lib/Config.pm lib/re.pm $(LDLIBPTH) ./miniperl -Ilib $@.PL - -install: all install.perl install.man + +extra.pods: perl + -@rm -f extra.pods + -@for x in `grep -l '^=[a-z]' README.*` ; do \ + nx=`echo $$x | sed -e "s/README\.//"`; \ + $(LNS) ../$$x "pod/perl"$$nx".pod" ; \ + echo "pod/perl"$$nx".pod" >> extra.pods ; \ + done + +install: all install.perl install.man extra.pods install.perl: all installperl if [ -n "$(COMPILE)" ]; \ @@ -606,7 +614,8 @@ distclean: clobber # Do not 'make _mopup' directly. _mopup: rm -f *$(OBJ_EXT) *$(LIB_EXT) all perlmain.c - rm -f perl.exp ext.libs + -@test -f extra.pods && rm -f `cat extra.pods` + -rm -f perl.exp ext.libs extra.pods -rm -f perl.export perl.dll perl.libexp perl.map perl.def -rm -f perl.loadmap miniperl.loadmap perl.prelmap miniperl.prelmap rm -f perl suidperl miniperl $(LIBPERL) diff --git a/README b/README index 63ae2e3..7b294f2 100644 --- a/README +++ b/README @@ -50,9 +50,9 @@ -------------------------------------------------------------------------- Perl is a language that combines some of the features of C, sed, awk -and shell. See the manual page for more hype. There are also two Nutshell -Handbooks published by O'Reilly & Assoc. See pod/perlbook.pod -for more information. +and shell. See the manual page for more hype. There are also many Perl +books available, covering a wide variety of topics, from various publishers. +See pod/perlbook.pod for more information. Please read all the directions below before you proceed any further, and then follow them carefully. @@ -62,29 +62,10 @@ in MANIFEST. Installation -1) Detailed instructions are in the file INSTALL which you should read. -In brief, the following should work on most systems: - - rm -f config.sh Policy.sh - sh Configure -de - make - make test - make install - -For most systems, it should be safe to accept all the Configure defaults. -It is recommended that you accept the defaults the first time you build -or if you have any problems building. - -The above commands will install Perl to /usr/local or /opt, depending -on the platform. If that's not okay with you, use - - rm -f config.sh Policy.sh - sh Configure - make - make test - make install - -Full configuration instructions can be found in the INSTALL file. +1) Detailed instructions are in the file "INSTALL", which you should +read if you are either installing on a system resembling Unix +or porting perl to another platform. For non-Unix platforms, see the +corresponding README. 2) Read the manual entries before running perl. @@ -94,18 +75,16 @@ If you have a problem, there's someone else out there who either has had or will have the same problem. It's usually helpful if you send the output of the "myconfig" script in the main perl directory. -If you've succeeded in compiling perl, the perlbug script in the utils/ +If you've succeeded in compiling perl, the perlbug script in the "utils" subdirectory can be used to help mail in a bug report. If possible, send in patches such that the patch program will apply them. Context diffs are the best, then normal diffs. Don't send ed scripts-- I've probably changed my copy since the version you have. -Watch for perl patches in comp.lang.perl.announce. Patches will generally -be in a form usable by the patch program. If you are just now bringing -up perl and aren't sure how many patches there are, write to me and I'll -send any you don't have. Your current patch level is shown in -patchlevel.h. +The latest versions of perl are always available on the various CPAN +(Comprehensive Perl Archive Network) sites around the world. +See . Just a personal note: I want you to know that I create nice things like this diff --git a/ext/B/defsubs_h.PL b/ext/B/defsubs_h.PL index dc4275b..80ef936 100644 --- a/ext/B/defsubs_h.PL +++ b/ext/B/defsubs_h.PL @@ -2,7 +2,7 @@ # this file as a template for defsubs.h # Extracting defsubs.h (with variable substitutions) #!perl -my ($out) = __FILE__ =~ /(^.*)\.PL/; +my ($out) = __FILE__ =~ /(^.*)\.PL/i; $out =~ s/_h$/.h/; open(OUT,">$out") || die "Cannot open $file:$!"; print "Extracting $out...\n"; diff --git a/hints/os2.sh b/hints/os2.sh index 0167a0a..1d9df36 100644 --- a/hints/os2.sh +++ b/hints/os2.sh @@ -95,6 +95,8 @@ libpth="$libpth $libemx/mt $libemx" set `emxrev -f emxlibcm` emxcrtrev=$5 +# indented to not put it into config.sh + _defemxcrtrev=-D_EMX_CRT_REV_=$emxcrtrev so='dll' @@ -124,8 +126,8 @@ fi aout_ldflags="$aout_ldflags" aout_d_fork='define' -aout_ccflags='-DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I.' -aout_cppflags='-DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I.' +aout_ccflags="-DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I. $_defemxcrtrev" +aout_cppflags="-DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I. $_defemxcrtrev" aout_use_clib='c' aout_usedl='undef' aout_archobjs="os2.o dl_os2.o" @@ -165,9 +167,9 @@ else # Recursive regmatch may eat 2.5M of stack alone. ldflags='-Zexe -Zomf -Zmt -Zcrtdll -Zstack 32000' if [ $emxcrtrev -ge 50 ]; then - ccflags='-Zomf -Zmt -DDOSISH -DOS2=2 -DEMBED -I.' + ccflags="-Zomf -Zmt -DDOSISH -DOS2=2 -DEMBED -I. $_defemxcrtrev" else - ccflags='-Zomf -Zmt -DDOSISH -DOS2=2 -DEMBED -I. -DEMX_BAD_SBRK' + ccflags="-Zomf -Zmt -DDOSISH -DOS2=2 -DEMBED -I. -DEMX_BAD_SBRK $_defemxcrtrev" fi use_clib='c_import' usedl='define' diff --git a/installman b/installman index 55dee4f..a70fdd3 100755 --- a/installman +++ b/installman @@ -127,7 +127,8 @@ sub runpod2man { # of the pod. This might be useful for pod2man someday. if ($script) { @modpods = ($script); - } else { + } + else { @modpods = (); find(\&lsmodpods, '.'); } @@ -143,16 +144,20 @@ sub runpod2man { $manpage =~ s#\.p(m|od)$##; if ($^O eq 'os2' || $^O eq 'amigaos' || $^O eq 'uwin' || $^O =~ /cygwin/) { $manpage =~ s#/#.#g; - } else { + } + else { $manpage =~ s#/#::#g; } $tmp = "${mandir}/${manpage}.tmp"; $manpage = "${mandir}/${manpage}.${manext}"; if (&cmd("$pod2man $mod > $tmp") == 0 && !$notify && -s $tmp) { - rename($tmp, $manpage) && next; + if (rename($tmp, $manpage)) { + $packlist->{$manpage} = { type => 'file' }; + next; + } } unless ($notify) { - unlink($tmp); + unlink($tmp); } } chdir "$builddir" || die "Unable to cd back to $builddir directory!\n$!\n"; @@ -197,11 +202,11 @@ sub unlink { my $cnt = 0; foreach $name (@names) { -next unless -e $name; -chmod 0777, $name if $^O eq 'os2'; -print STDERR " unlink $name\n"; -( CORE::unlink($name) and ++$cnt - or warn "Couldn't unlink $name: $!\n" ) unless $notify; + next unless -e $name; + chmod 0777, $name if $^O eq 'os2'; + print STDERR " unlink $name\n"; + ( CORE::unlink($name) and ++$cnt + or warn "Couldn't unlink $name: $!\n" ) unless $notify; } return $cnt; } @@ -218,14 +223,12 @@ sub link { ? die "AFS" # okay inside eval {} : warn "Couldn't link $from to $to: $!\n" unless $notify; - $packlist->{$to} = { type => 'file' }; }; if ($@) { File::Copy::copy($from, $to) ? $success++ : warn "Couldn't copy $from to $to: $!\n" unless $notify; - $packlist->{$to} = { type => 'file' }; } $success; } @@ -233,16 +236,15 @@ sub link { sub rename { local($from,$to) = @_; if (-f $to and not unlink($to)) { -my($i); -for ($i = 1; $i < 50; $i++) { - last if CORE::rename($to, "$to.$i"); -} -warn("Cannot rename to `$to.$i': $!"), return 0 - if $i >= 50; # Give up! + my($i); + for ($i = 1; $i < 50; $i++) { + last if CORE::rename($to, "$to.$i"); + } + warn("Cannot rename to `$to.$i': $!"), return 0 + if $i >= 50; # Give up! } link($from,$to) || return 0; unlink($from); - $packlist->{$to} = { type => 'file' }; } sub chmod { diff --git a/lib/File/Path.pm b/lib/File/Path.pm index 7290372..a82fd80 100644 --- a/lib/File/Path.pm +++ b/lib/File/Path.pm @@ -2,15 +2,14 @@ package File::Path; =head1 NAME -File::Path - create or remove a series of directories +File::Path - create or remove directory trees =head1 SYNOPSIS -C + use File::Path; -C - -C + mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711); + rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1); =head1 DESCRIPTION diff --git a/lib/Time/Local.pm b/lib/Time/Local.pm index f2f1672..7a10d98 100644 --- a/lib/Time/Local.pm +++ b/lib/Time/Local.pm @@ -3,8 +3,19 @@ require 5.000; require Exporter; use Carp; -@ISA = qw(Exporter); -@EXPORT = qw(timegm timelocal); +@ISA = qw( Exporter ); +@EXPORT = qw( timegm timelocal ); +@EXPORT_OK = qw( $no_range_check ); + +sub import { + my $package = shift; + my @args; + for (@_) { + $no_range_check = 1, next if $_ eq 'no_range_check'; + push @args, $_; + } + Time::Local->export_to_level(1, $package, @args); +} # Set up constants $SEC = 1; @@ -51,7 +62,6 @@ sub timelocal { my $tzsec = ($gt[1] - $lt[1]) * $MIN + ($gt[2] - $lt[2]) * $HR; - my($lday,$gday) = ($lt[7],$gt[7]); if($lt[5] > $gt[5]) { $tzsec -= $DAY; } @@ -73,11 +83,13 @@ sub timelocal { sub cheat { $year = $_[5]; $month = $_[4]; - croak "Month '$month' out of range 0..11" if $month > 11 || $month < 0; - croak "Day '$_[3]' out of range 1..31" if $_[3] > 31 || $_[3] < 1; - croak "Hour '$_[2]' out of range 0..23" if $_[2] > 23 || $_[2] < 0; - croak "Minute '$_[1]' out of range 0..59" if $_[1] > 59 || $_[1] < 0; - croak "Second '$_[0]' out of range 0..59" if $_[0] > 59 || $_[0] < 0; + unless ($no_range_check) { + croak "Month '$month' out of range 0..11" if $month > 11 || $month < 0; + croak "Day '$_[3]' out of range 1..31" if $_[3] > 31 || $_[3] < 1; + croak "Hour '$_[2]' out of range 0..23" if $_[2] > 23 || $_[2] < 0; + croak "Minute '$_[1]' out of range 0..59" if $_[1] > 59 || $_[1] < 0; + croak "Second '$_[0]' out of range 0..59" if $_[0] > 59 || $_[0] < 0; + } $guess = $^T; @g = gmtime($guess); $lastguess = ""; @@ -137,6 +149,27 @@ the values provided. While the day of the month is expected to be in the range 1..31, the month should be in the range 0..11. This is consistent with the values returned from localtime() and gmtime(). +Also worth noting is the ability to disable the range checking that +would normally occur on the input $sec, $min, $hours, $mday, and $mon +values. You can do this by setting $Time::Local::no_range_check = 1, +or by invoking the module with C. +This enables you to abuse the terminology somewhat and gain the +flexibilty to do things like: + + use Time::Local qw( no_range_check ); + + # The 365th day of 1999 + print scalar localtime timelocal 0,0,0,365,0,99; + + # The twenty thousandth day since 1970 + print scalar localtime timelocal 0,0,0,20000,0,70; + + # And even the 10,000,000th second since 1999! + print scalar localtime timelocal 10000000,0,0,1,0,99; + +Your mileage may vary when trying this trick with minutes and hours, +and it doesn't work at all for months. + Strictly speaking, the year should also be specified in a form consistent with localtime(), i.e. the offset from 1900. In order to make the interpretation of the year easier for humans, diff --git a/lib/attributes.pm b/lib/attributes.pm index e49204f..09f3551 100644 --- a/lib/attributes.pm +++ b/lib/attributes.pm @@ -1,9 +1,10 @@ package attributes; -$VERSION = 0.01; +$VERSION = 0.02; -#@EXPORT_OK = qw(get reftype); -#@EXPORT = (); +@EXPORT_OK = qw(get reftype); +@EXPORT = (); +%EXPORT_TAGS = (ALL => [@EXPORT, @EXPORT_OK]); use strict; @@ -29,8 +30,10 @@ sub carp { BEGIN { bootstrap } sub import { - @_ > 2 && ref $_[2] or - croak 'Usage: use '.__PACKAGE__.' $home_stash, $ref, @attrlist'; + @_ > 2 && ref $_[2] or do { + require Exporter; + goto &Exporter::import; + }; my (undef,$home_stash,$svref,@attrs) = @_; my $svtype = uc reftype($svref); @@ -82,12 +85,7 @@ sub get ($) { ; } -#sub export { -# require Exporter; -# goto &Exporter::import; -#} -# -#sub require_version { goto &UNIVERSAL::VERSION } +sub require_version { goto &UNIVERSAL::VERSION } 1; __END__ @@ -106,13 +104,16 @@ attributes - get/set subroutine or variable attributes use attributes (); # optional, to get subroutine declarations my @attrlist = attributes::get(\&foo); + use attributes 'get'; # import the attributes::get subroutine + my @attrlist = get \&foo; + =head1 DESCRIPTION Subroutine declarations and definitions may optionally have attribute lists associated with them. (Variable C declarations also may, but see the warning below.) Perl handles these declarations by passing some information about the call site and the thing being declared along with the attribute -list to this module. In particular, first example above is equivalent to +list to this module. In particular, the first example above is equivalent to the following: use attributes __PACKAGE__, \&foo, 'method'; @@ -187,7 +188,7 @@ empty. If passed invalid arguments, it uses die() (via L) to raise a fatal exception. If it can find an appropriate package name for a class method lookup, it will include the results from a C_ATTRIBUTES> call in its return list, as described in -L"Package-specific Attribute Handling"> below. +L<"Package-specific Attribute Handling"> below. Otherwise, only L will be returned. =item reftype @@ -196,13 +197,11 @@ This routine expects a single parameter--a reference to a subroutine or variable. It returns the built-in type of the referenced variable, ignoring any package into which it might have been blessed. This can be useful for determining the I value which forms part of -the method names described in L"Package-specific Attribute Handling"> below. +the method names described in L<"Package-specific Attribute Handling"> below. =back -Note that these routines are I exported. This is primarily because -the C mechanism which would normally import them is already in use -by Perl itself to implement the C syntax. +Note that these routines are I exported by default. =head2 Package-specific Attribute Handling @@ -289,6 +288,20 @@ Some examples of syntactically invalid attribute lists (with annotation): Y2::north # "Y2::north" not a simple identifier foo + bar # "+" neither a comma nor whitespace +=head1 EXPORTS + +=head2 Default exports + +None. + +=head2 Available exports + +The routines C and C are exportable. + +=head2 Export tags defined + +The C<:ALL> tag will get all of the above exports. + =head1 EXAMPLES Here are some samples of syntactically valid declarations, with annotation diff --git a/mg.c b/mg.c index b08cee3..09be2f7 100644 --- a/mg.c +++ b/mg.c @@ -638,7 +638,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) int saveerrno = errno; sv_setnv(sv, (NV)errno); #ifdef OS2 - if (errno == errno_isOS2) sv_setpv(sv, os2error(Perl_rc)); + if (errno == errno_isOS2 || errno == errno_isOS2_set) + sv_setpv(sv, os2error(Perl_rc)); else #endif sv_setpv(sv, errno ? Strerror(errno) : ""); diff --git a/miniperlmain.c b/miniperlmain.c index f7b24f4..fb5cf1a 100644 --- a/miniperlmain.c +++ b/miniperlmain.c @@ -38,7 +38,7 @@ main(int argc, char **argv, char **env) #undef PERLVARIC #endif - PERL_SYS_INIT(&argc,&argv); + PERL_SYS_INIT3(&argc,&argv,&env); if (!PL_do_undump) { my_perl = perl_alloc(); diff --git a/op.c b/op.c index f38b26c..7fae9f7 100644 --- a/op.c +++ b/op.c @@ -2112,8 +2112,12 @@ Perl_fold_constants(pTHX_ register OP *o) return o; if (!(PL_hints & HINT_INTEGER)) { - if (type == OP_DIVIDE || !(o->op_flags & OPf_KIDS)) + if (type == OP_MODULO + || type == OP_DIVIDE + || !(o->op_flags & OPf_KIDS)) + { return o; + } for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) { if (curop->op_type == OP_CONST) { diff --git a/os2/Changes b/os2/Changes index 910ec46..e56b708 100644 --- a/os2/Changes +++ b/os2/Changes @@ -296,3 +296,29 @@ after 5.005_54: If the only shell-metachars of a command are ' 2>&1' at the end of a command, it is executed without calling the external shell. + +after 5.005_57: + Make UDP sockets return correct caller address (OS2 API bug); + Enable TCPIPV4 defines (works with Warp 3 IAK too?!); + Force Unix-domain sockets to start with "/socket", convert + '/' to '\' in the calls; + Make C to treat $cmd as in C; + Autopatch Configure; + Find name and location of g[nu]patch.exe; + Autocopy perl????.dll to t/ when testing; + +after 5.005_62: + Extract a lightweight DLL access module OS2::DLL from OS2::REXX + which would not load REXX runtime system; + Allow compile with os2.h which loads os2tk.h instead of os2emx.h; + Put the version of EMX CRTL into -D define; + Use _setsyserror() to store last error of OS/2 API for $^E; + New macro PERL_SYS_INIT3(argvp, argcp, envp); + Make Dynaloader return info on the failing module after failed dl_open(); + OS2::REXX test were done for interactive testing (were writing + "ok" to stderr); + system() and friends return -1 on failure (was 0xFF00); + Put the full name of executable into $^X + (alas, uppercased - but with /); + t/io/fs.t was failing on HPFS386; + Remove extra ';' from defines for MQ operations. diff --git a/os2/OS2/REXX/Changes b/os2/OS2/REXX/Changes index 46b38ef..7c19710 100644 --- a/os2/OS2/REXX/Changes +++ b/os2/OS2/REXX/Changes @@ -2,3 +2,6 @@ After fixpak17 a lot of other places have mismatched lengths returned in the REXXPool interface. Also drop does not work on stems any more. +0.22: + A subsystem module OS2::DLL extracted which does not link + with REXX runtime library. diff --git a/os2/OS2/REXX/DLL/Changes b/os2/OS2/REXX/DLL/Changes new file mode 100644 index 0000000..874f7fa --- /dev/null +++ b/os2/OS2/REXX/DLL/Changes @@ -0,0 +1,2 @@ +0.01: + Split out of OS2::REXX diff --git a/os2/OS2/REXX/DLL/DLL.pm b/os2/OS2/REXX/DLL/DLL.pm new file mode 100644 index 0000000..7e54371 --- /dev/null +++ b/os2/OS2/REXX/DLL/DLL.pm @@ -0,0 +1,136 @@ +package OS2::DLL; + +use Carp; +use DynaLoader; + +@ISA = qw(DynaLoader); + +sub AUTOLOAD { + $AUTOLOAD =~ /^OS2::DLL::.+::(.+)$/ + or confess("Undefined subroutine &$AUTOLOAD called"); + return undef if $1 eq "DESTROY"; + $_[0]->find($1) + or confess("Can't find entry '$1' to DLL '$_[0]->{File}': $^E"); + goto &$AUTOLOAD; +} + +@libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'}); +%dlls = (); + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. + +# Cannot autoload, the autoloader is used for the REXX functions. + +sub load +{ + confess 'Usage: load OS2::DLL []' unless $#_ >= 1; + my ($class, $file, @where) = (@_, @libs); + return $dlls{$file} if $dlls{$file}; + my $handle; + foreach (@where) { + $handle = DynaLoader::dl_load_file("$_/$file.dll"); + last if $handle; + } + $handle = DynaLoader::dl_load_file($file) unless $handle; + return undef unless $handle; + my $packs = $INC{'OS2/REXX.pm'} ? 'OS2::DLL OS2::REXX' : 'OS2::DLL'; + eval < $handle, File => $file, Queue => 'SESSION' }, + "OS2::DLL::$file"; +} + +sub find +{ + my $self = shift; + my $file = $self->{File}; + my $handle = $self->{Handle}; + my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : ""; + my $queue = $self->{Queue}; + foreach (@_) { + my $name = "OS2::DLL::${file}::$_"; + next if defined(&$name); + my $addr = DynaLoader::dl_find_symbol($handle, uc $prefix.$_) + || DynaLoader::dl_find_symbol($handle, $prefix.$_) + or return 0; + eval < module if you need the variable pool. + +=head1 SYNOPSIS + + use OS2::DLL; + $emx_dll = OS2::DLL->load('emx'); + $emx_version = $emx_dll->emx_revision(); + +=head1 DESCRIPTION + +=head2 Load REXX DLL + + $dll = load OS2::DLL NAME [, WHERE]; + +NAME is DLL name, without path and extension. + +Directories are searched WHERE first (list of dirs), then environment +paths PERL5REXX, PERLREXX, PATH or, as last resort, OS/2-ish search +is performed in default DLL path (without adding paths and extensions). + +The DLL is not unloaded when the variable dies. + +Returns DLL object reference, or undef on failure. + +=head2 Check for functions (optional): + + BOOL = $dll->find(NAME [, NAME [, ...]]); + +Returns true if all functions are available. + +=head2 Call external REXX function: + + $dll->function(arguments); + +Returns the return string if the return code is 0, else undef. +Dies with error message if the function is not available. + +=head1 ENVIRONMENT + +If C is set, emits debugging output. Looks for DLLs +in C, C, C. + +=head1 AUTHOR + +Extracted by Ilya Zakharevich ilya@math.ohio-state.edu from L +written by Andreas Kaiser ak@ananke.s.bawue.de. + +=cut diff --git a/os2/OS2/REXX/DLL/DLL.xs b/os2/OS2/REXX/DLL/DLL.xs new file mode 100644 index 0000000..c8e7c58 --- /dev/null +++ b/os2/OS2/REXX/DLL/DLL.xs @@ -0,0 +1,72 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define INCL_BASE +#define INCL_REXXSAA +#include + +static RXSTRING * strs; +static int nstrs; +static char * trace; + +static void +needstrs(int n) +{ + if (n > nstrs) { + if (strs) + free(strs); + nstrs = 2 * n; + strs = malloc(nstrs * sizeof(RXSTRING)); + } +} + +MODULE = OS2::DLL PACKAGE = OS2::DLL + +BOOT: + needstrs(8); + trace = getenv("PERL_REXX_DEBUG"); + +SV * +_call(name, address, queue="SESSION", ...) + char * name + void * address + char * queue + CODE: + { + ULONG rc; + int argc, i; + RXSTRING result; + UCHAR resbuf[256]; + RexxFunctionHandler *fcn = address; + argc = items-3; + needstrs(argc); + if (trace) + fprintf(stderr, "REXXCALL::_call name: '%s' args:", name); + for (i = 0; i < argc; ++i) { + STRLEN len; + char *ptr = SvPV(ST(3+i), len); + MAKERXSTRING(strs[i], ptr, len); + if (trace) + fprintf(stderr, " '%.*s'", len, ptr); + } + if (!*queue) + queue = "SESSION"; + if (trace) + fprintf(stderr, "\n"); + MAKERXSTRING(result, resbuf, sizeof resbuf); + rc = fcn(name, argc, strs, queue, &result); + if (trace) + fprintf(stderr, " rc=%X, result='%.*s'\n", rc, + result.strlength, result.strptr); + ST(0) = sv_newmortal(); + if (rc == 0) { + if (result.strptr) + sv_setpvn(ST(0), result.strptr, result.strlength); + else + sv_setpvn(ST(0), "", 0); + } + if (result.strptr && result.strptr != resbuf) + DosFreeMem(result.strptr); + } + diff --git a/os2/OS2/REXX/DLL/MANIFEST b/os2/OS2/REXX/DLL/MANIFEST new file mode 100644 index 0000000..d7ad9b6 --- /dev/null +++ b/os2/OS2/REXX/DLL/MANIFEST @@ -0,0 +1,5 @@ +Changes +MANIFEST +Makefile.PL +DLL.pm +DLL.xs diff --git a/os2/OS2/REXX/DLL/Makefile.PL b/os2/OS2/REXX/DLL/Makefile.PL new file mode 100644 index 0000000..fe2403d --- /dev/null +++ b/os2/OS2/REXX/DLL/Makefile.PL @@ -0,0 +1,9 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'OS2::DLL', + VERSION => '0.01', + MAN3PODS => ' ', # Pods will be built by installman. + XSPROTOARG => '-noprototypes', + PERL_MALLOC_OK => 1, +); diff --git a/os2/OS2/REXX/Makefile.PL b/os2/OS2/REXX/Makefile.PL index 5eda5a3..6648b2c 100644 --- a/os2/OS2/REXX/Makefile.PL +++ b/os2/OS2/REXX/Makefile.PL @@ -2,7 +2,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'OS2::REXX', - VERSION => '0.21', + VERSION => '0.22', MAN3PODS => ' ', # Pods will be built by installman. XSPROTOARG => '-noprototypes', PERL_MALLOC_OK => 1, diff --git a/os2/OS2/REXX/REXX.pm b/os2/OS2/REXX/REXX.pm index 4580ede..5c6dfd2 100644 --- a/os2/OS2/REXX/REXX.pm +++ b/os2/OS2/REXX/REXX.pm @@ -3,6 +3,8 @@ package OS2::REXX; use Carp; require Exporter; require DynaLoader; +require OS2::DLL; + @ISA = qw(Exporter DynaLoader); # Items to export into callers namespace by default # (move infrequently used names to @EXPORT_OK below) @@ -10,66 +12,18 @@ require DynaLoader; # Other items we are prepared to export if requested @EXPORT_OK = qw(drop); -sub AUTOLOAD { - $AUTOLOAD =~ /^OS2::REXX::.+::(.+)$/ - or confess("Undefined subroutine &$AUTOLOAD called"); - return undef if $1 eq "DESTROY"; - $_[0]->find($1) - or confess("Can't find entry '$1' to DLL '$_[0]->{File}'"); - goto &$AUTOLOAD; -} +# We cannot just put OS2::DLL in @ISA, since some scripts would use +# function interface, not method interface... -@libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'}); -%dlls = (); +*_call = \&OS2::DLL::_call; +*load = \&OS2::DLL::load; +*find = \&OS2::DLL::find; bootstrap OS2::REXX; # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. -# Cannot autoload, the autoloader is used for the REXX functions. - -sub load -{ - confess 'Usage: load OS2::REXX []' unless $#_ >= 1; - my ($class, $file, @where) = (@_, @libs); - return $dlls{$file} if $dlls{$file}; - my $handle; - foreach (@where) { - $handle = DynaLoader::dl_load_file("$_/$file.dll"); - last if $handle; - } - $handle = DynaLoader::dl_load_file($file) unless $handle; - return undef unless $handle; - eval "package OS2::REXX::$file; \@ISA = ('OS2::REXX');" - . "sub AUTOLOAD {" - . " \$OS2::REXX::AUTOLOAD = \$AUTOLOAD;" - . " goto &OS2::REXX::AUTOLOAD;" - . "} 1;" or die "eval package $@"; - return $dlls{$file} = bless {Handle => $handle, File => $file, Queue => 'SESSION' }, "OS2::REXX::$file"; -} - -sub find -{ - my $self = shift; - my $file = $self->{File}; - my $handle = $self->{Handle}; - my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : ""; - my $queue = $self->{Queue}; - foreach (@_) { - my $name = "OS2::REXX::${file}::$_"; - next if defined(&$name); - my $addr = DynaLoader::dl_find_symbol($handle, uc $prefix.$_) - || DynaLoader::dl_find_symbol($handle, $prefix.$_) - or return 0; - eval "package OS2::REXX::$file; sub $_". - "{ shift; OS2::REXX::_call('$_', $addr, '$queue', \@_); }". - "1;" - or die "eval sub"; - } - return 1; -} - sub prefix { my $self = shift; @@ -386,4 +340,8 @@ See C for examples. Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich ilya@math.ohio-state.edu. +=head1 SEE ALSO + +L. + =cut diff --git a/os2/OS2/REXX/REXX.xs b/os2/OS2/REXX/REXX.xs index 9f23714..8a8e5f2 100644 --- a/os2/OS2/REXX/REXX.xs +++ b/os2/OS2/REXX/REXX.xs @@ -236,49 +236,6 @@ constant(name,arg) char * name int arg -SV * -_call(name, address, queue="SESSION", ...) - char * name - void * address - char * queue - CODE: - { - ULONG rc; - int argc, i; - RXSTRING result; - UCHAR resbuf[256]; - RexxFunctionHandler *fcn = address; - argc = items-3; - needstrs(argc); - if (trace) - fprintf(stderr, "REXXCALL::_call name: '%s' args:", name); - for (i = 0; i < argc; ++i) { - STRLEN len; - char *ptr = SvPV(ST(3+i), len); - MAKERXSTRING(strs[i], ptr, len); - if (trace) - fprintf(stderr, " '%.*s'", len, ptr); - } - if (!*queue) - queue = "SESSION"; - if (trace) - fprintf(stderr, "\n"); - MAKERXSTRING(result, resbuf, sizeof resbuf); - rc = fcn(name, argc, strs, queue, &result); - if (trace) - fprintf(stderr, " rc=%X, result='%.*s'\n", rc, - result.strlength, result.strptr); - ST(0) = sv_newmortal(); - if (rc == 0) { - if (result.strptr) - sv_setpvn(ST(0), result.strptr, result.strlength); - else - sv_setpvn(ST(0), "", 0); - } - if (result.strptr && result.strptr != resbuf) - DosFreeMem(result.strptr); - } - int _set(name,value,...) char * name diff --git a/os2/OS2/REXX/t/rx_dllld.t b/os2/OS2/REXX/t/rx_dllld.t index 9d81bf3..15362d7 100644 --- a/os2/OS2/REXX/t/rx_dllld.t +++ b/os2/OS2/REXX/t/rx_dllld.t @@ -16,7 +16,7 @@ foreach $dir (split(';', $path)) { $found = "$dir/YDBAUTIL.DLL"; last; } -$found or die "1..0\n#Cannot find YDBAUTIL.DLL\n"; +$found or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit; print "1..5\n"; diff --git a/os2/OS2/REXX/t/rx_emxrv.t b/os2/OS2/REXX/t/rx_emxrv.t new file mode 100644 index 0000000..d51e1b0 --- /dev/null +++ b/os2/OS2/REXX/t/rx_emxrv.t @@ -0,0 +1,24 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +print "1..5\n"; + +require OS2::DLL; +print "ok 1\n"; +$emx_dll = OS2::DLL->load('emx'); +print "ok 2\n"; +$emx_version = $emx_dll->emx_revision(); +print "ok 3\n"; +$emx_version >= 40 or print "not "; # We cannot work with old EMXs +print "ok 4\n"; + +$reason = ''; +$emx_version >= 99 and $reason = ' # skipped: version of EMX 100 or more'; # Be safe +print "ok 5$reason\n"; diff --git a/os2/OS2/REXX/t/rx_objcall.t b/os2/OS2/REXX/t/rx_objcall.t index cb3c52a..8bdf905 100644 --- a/os2/OS2/REXX/t/rx_objcall.t +++ b/os2/OS2/REXX/t/rx_objcall.t @@ -13,7 +13,8 @@ use OS2::REXX; # # DLL # -$ydba = load OS2::REXX "ydbautil" or die "1..0\n# load\n"; +$ydba = load OS2::REXX "ydbautil" + or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit; print "1..5\n", "ok 1\n"; # diff --git a/os2/OS2/REXX/t/rx_tievar.t b/os2/OS2/REXX/t/rx_tievar.t index 77f90c2..5f43f4e 100644 --- a/os2/OS2/REXX/t/rx_tievar.t +++ b/os2/OS2/REXX/t/rx_tievar.t @@ -13,7 +13,8 @@ use OS2::REXX; # # DLL # -load OS2::REXX "ydbautil" or die "1..0\n# load\n"; +load OS2::REXX "ydbautil" + or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit; print "1..19\n"; diff --git a/os2/OS2/REXX/t/rx_tieydb.t b/os2/OS2/REXX/t/rx_tieydb.t index 30a2daf..1653a20 100644 --- a/os2/OS2/REXX/t/rx_tieydb.t +++ b/os2/OS2/REXX/t/rx_tieydb.t @@ -9,7 +9,9 @@ BEGIN { } use OS2::REXX; -$rx = load OS2::REXX "ydbautil" or die "1..0\n# load\n"; # from RXU17.ZIP +$rx = load OS2::REXX "ydbautil" # from RXU17.ZIP + or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit; + print "1..7\n", "ok 1\n"; $rx->prefix("Rx"); # implicit function prefix diff --git a/os2/OS2/REXX/t/rx_vrexx.t b/os2/OS2/REXX/t/rx_vrexx.t index 04ca663..b0621f4 100644 --- a/os2/OS2/REXX/t/rx_vrexx.t +++ b/os2/OS2/REXX/t/rx_vrexx.t @@ -18,7 +18,7 @@ foreach $dir (split(';', $path)) { print "# found at `$found'\n"; last; } -$found or die "1..0\n#Cannot find $name.DLL\n"; +$found or print "1..0 # skipped: cannot find $name.DLL\n" and exit; print "1..10\n"; diff --git a/os2/dl_os2.c b/os2/dl_os2.c index 19f36f6..4a9688c 100644 --- a/os2/dl_os2.c +++ b/os2/dl_os2.c @@ -4,15 +4,16 @@ #include static ULONG retcode; +static char fail[300]; void * dlopen(char *path, int mode) { HMODULE handle; char tmp[260], *beg, *dot; - char fail[300]; ULONG rc; + fail[0] = 0; if ((rc = DosLoadModule(fail, sizeof fail, path, &handle)) == 0) return (void *)handle; @@ -42,6 +43,7 @@ dlsym(void *handle, char *symbol) ULONG rc, type; PFN addr; + fail[0] = 0; rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr); if (rc == 0) { rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type); @@ -56,15 +58,31 @@ dlsym(void *handle, char *symbol) char * dlerror(void) { - static char buf[300]; + static char buf[700]; ULONG len; if (retcode == 0) return NULL; - if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode, "OSO001.MSG", &len)) - sprintf(buf, "OS/2 system error code %d", retcode); - else + if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode, + "OSO001.MSG", &len)) { + if (fail[0]) + sprintf(buf, +"OS/2 system error code %d, possible problematic module: '%s'", + retcode, fail); + else + sprintf(buf, "OS/2 system error code %d", retcode); + } else { buf[len] = '\0'; + if (len && buf[len - 1] == '\n') + buf[--len] = 0; + if (len && buf[len - 1] == '\r') + buf[--len] = 0; + if (len && buf[len - 1] == '.') + buf[--len] = 0; + if (fail[0] && len < 300) + sprintf(buf + len, ", possible problematic module: '%s'", + fail); + } retcode = 0; return buf; } diff --git a/os2/os2.c b/os2/os2.c index 7c23200..8a17ae7 100644 --- a/os2/os2.c +++ b/os2/os2.c @@ -3,6 +3,10 @@ #define INCL_DOSFILEMGR #define INCL_DOSMEMMGR #define INCL_DOSERRORS +/* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */ +#define INCL_DOSPROCESS +#define SPU_DISABLESUPPRESSION 0 +#define SPU_ENABLESUPPRESSION 1 #include #include @@ -802,7 +806,7 @@ U32 addflag; PL_Argv[0], Strerror(errno)); if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT) && ((trueflag & 0xFF) == P_WAIT)) - rc = 255 << 8; /* Emulate the fork(). */ + rc = -1; finish: if (new_stderr != -1) { /* How can we use error codes? */ @@ -907,7 +911,8 @@ do_spawn3(char *cmd, int execf, int flag) Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s", (execf == EXECF_SPAWN ? "spawn" : "exec"), shell, Strerror(errno)); - if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ + if (rc < 0) + rc = -1; } if (news) Safefree(news); @@ -1356,18 +1361,37 @@ os2error(int rc) return NULL; if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len)) sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc); - else + else { buf[len] = '\0'; - if (len > 0 && buf[len - 1] == '\n') - buf[len - 1] = '\0'; - if (len > 1 && buf[len - 2] == '\r') - buf[len - 2] = '\0'; - if (len > 2 && buf[len - 3] == '.') - buf[len - 3] = '\0'; + if (len && buf[len - 1] == '\n') + buf[--len] = 0; + if (len && buf[len - 1] == '\r') + buf[--len] = 0; + if (len && buf[len - 1] == '.') + buf[--len] = 0; + } return buf; } char * +os2_execname(void) +{ + char buf[300], *p; + + if (_execname(buf, sizeof buf) != 0) + return PL_origargv[0]; + p = buf; + while (*p) { + if (*p == '\\') + *p = '/'; + p++; + } + p = savepv(buf); + SAVEFREEPV(p); + return p; +} + +char * perllib_mangle(char *s, unsigned int l) { static char *newp, *oldp; @@ -2067,7 +2091,7 @@ Perl_OS2_init(char **env) settmppath(); OS2_Perl_data.xs_init = &Xs_OS2_init; _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY); - if (environ == NULL) { + if (environ == NULL && env) { environ = env; } if ( (shell = getenv("PERL_SH_DRIVE")) ) { diff --git a/os2/os2ish.h b/os2/os2ish.h index 6993dfc..23b1096 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -183,16 +183,26 @@ void Perl_OS2_init(char **); /* XXX This code hideously puts env inside: */ -#ifdef __EMX__ +#ifdef PERL_CORE +# define PERL_SYS_INIT3(argcp, argvp, envp) STMT_START { \ + _response(argcp, argvp); \ + _wildcard(argcp, argvp); \ + Perl_OS2_init(*envp); } STMT_END # define PERL_SYS_INIT(argcp, argvp) STMT_START { \ _response(argcp, argvp); \ _wildcard(argcp, argvp); \ - Perl_OS2_init(env); } STMT_END -#else /* Compiling embedded Perl with non-EMX compiler */ + Perl_OS2_init(NULL); } STMT_END +#else /* Compiling embedded Perl or Perl extension */ +# define PERL_SYS_INIT3(argcp, argvp, envp) STMT_START { \ + Perl_OS2_init(*envp); } STMT_END # define PERL_SYS_INIT(argcp, argvp) STMT_START { \ - Perl_OS2_init(env); } STMT_END + Perl_OS2_init(NULL); } STMT_END +#endif + +#ifndef __EMX__ # define PERL_CALLCONV _System #endif + #define PERL_SYS_TERM() MALLOC_TERM /* #define PERL_SYS_TERM() STMT_START { \ @@ -318,6 +328,7 @@ extern OS2_Perl_data_t OS2_Perl_data; #define Perl_rc (OS2_Perl_data.rc) #define Perl_severity (OS2_Perl_data.severity) #define errno_isOS2 12345678 +#define errno_isOS2_set 12345679 #define OS2_Perl_flags (OS2_Perl_data.flags) #define Perl_HAB_set_f 1 #define Perl_HAB_set (OS2_Perl_flags & Perl_HAB_set_f) @@ -339,6 +350,7 @@ void Perl_Deregister_MQ(int serve); int Perl_Serve_Messages(int force); /* Cannot prototype with I32 at this point. */ int Perl_Process_Messages(int force, long *cntp); +char *os2_execname(void); struct _QMSG; struct PMWIN_entries_t { @@ -356,23 +368,29 @@ struct PMWIN_entries_t { extern struct PMWIN_entries_t PMWIN_entries; void init_PMWIN_entries(void); -#define perl_hmq_GET(serve) Perl_Register_MQ(serve); -#define perl_hmq_UNSET(serve) Perl_Deregister_MQ(serve); +#define perl_hmq_GET(serve) Perl_Register_MQ(serve) +#define perl_hmq_UNSET(serve) Perl_Deregister_MQ(serve) #define OS2_XS_init() (*OS2_Perl_data.xs_init)() + +#if _EMX_CRT_REV_ >= 60 +# define os2_setsyserrno(rc) (Perl_rc = rc, errno = errno_isOS2_set, \ + _setsyserrno(rc)) +#else +# define os2_setsyserrno(rc) (Perl_rc = rc, errno = errno_isOS2) +#endif + /* The expressions below return true on error. */ /* INCL_DOSERRORS needed. rc should be declared outside. */ #define CheckOSError(expr) (!(rc = (expr)) ? 0 : (FillOSError(rc), 1)) /* INCL_WINERRORS needed. */ #define SaveWinError(expr) ((expr) ? : (FillWinError, 0)) #define CheckWinError(expr) ((expr) ? 0: (FillWinError, 1)) -#define FillOSError(rc) (Perl_rc = rc, \ - errno = errno_isOS2, \ +#define FillOSError(rc) (os2_setsyserrno(rc), \ Perl_severity = SEVERITY_ERROR) -#define FillWinError (Perl_rc = WinGetLastError(Perl_hab), \ - errno = errno_isOS2, \ - Perl_severity = ERRORIDSEV(Perl_rc), \ - Perl_rc = ERRORIDERROR(Perl_rc)) +#define FillWinError (Perl_severity = ERRORIDSEV(Perl_rc), \ + Perl_rc = ERRORIDERROR(Perl_rc)), \ + os2_setsyserrno(Perl_rc) #define STATIC_FILE_LENGTH 127 @@ -392,7 +410,7 @@ char *os2error(int rc); #define QSS_FILE 8 /* Buggy until fixpack18 */ #define QSS_SHARED 16 -#ifdef _OS2EMX_H +#ifdef _OS2_H APIRET APIENTRY Dos32QuerySysState(ULONG func,ULONG arg1,ULONG pid, ULONG _res_,PVOID buf,ULONG bufsz); @@ -550,5 +568,5 @@ typedef struct { PQTOPLEVEL get_sysinfo(ULONG pid, ULONG flags); -#endif /* _OS2EMX_H */ +#endif /* _OS2_H */ diff --git a/perl.c b/perl.c index 23ece0f..71b3b94 100644 --- a/perl.c +++ b/perl.c @@ -201,6 +201,7 @@ perl_construct(pTHXx) init_i18nl10n(1); SET_NUMERIC_STANDARD(); + #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION + ((double) PERL_VERSION / (double) 1000) @@ -942,6 +943,21 @@ print \" \\@INC:\\n @INC\\n\";"); validate_suid(validarg, scriptname,fdscript); +#if defined(SIGCHLD) || defined(SIGCLD) + { +#ifndef SIGCHLD +# define SIGCHLD SIGCLD +#endif + Sighandler_t sigstate = rsignal_state(SIGCHLD); + if (sigstate == SIG_IGN) { + if (ckWARN(WARN_SIGNAL)) + Perl_warner(aTHX_ WARN_SIGNAL, + "Can't ignore signal CHLD, forcing to default"); + (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); + } + } +#endif + if (PL_doextract) find_beginning(); @@ -2726,7 +2742,11 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register magicname("0", "0", 1); } if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)) +#ifdef OS2 + sv_setpv(GvSV(tmpgv), os2_execname()); +#else sv_setpv(GvSV(tmpgv),PL_origargv[0]); +#endif if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) { GvMULTI_on(PL_argvgv); (void)gv_AVadd(PL_argvgv); diff --git a/perl.h b/perl.h index 6d026ba..23a2f13 100644 --- a/perl.h +++ b/perl.h @@ -1560,6 +1560,10 @@ typedef union any ANY; # endif #endif +#ifndef PERL_SYS_INIT3 +# define PERL_SYS_INIT3(argvp,argcp,envp) PERL_SYS_INIT(argvp,argcp) +#endif + #ifndef MAXPATHLEN # ifdef PATH_MAX # ifdef _POSIX_PATH_MAX diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 0c7a0c7..6344ee4 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -1404,16 +1404,6 @@ See L. but this did not follow some numeric unpack specification. See L. -=item Repeat count in pack overflows - -(F) You can't specify a repeat count so large that it overflows -your signed integers. See L. - -=item Repeat count in unpack overflows - -(F) You can't specify a repeat count so large that it overflows -your signed integers. See L. - =item /%s/: Unrecognized escape \\%c passed through (W) You used a backslash-character combination which is not recognized @@ -1504,6 +1494,15 @@ so it was truncated to the string shown. (P) For some reason you can't check the filesystem of the script for nosuid. +=item Can't ignore signal CHLD, forcing to default + +(W) Perl has detected that it is being run with the SIGCHLD signal +(sometimes known as SIGCLD) disabled. Since disabling this signal +will interfere with proper determination of exit status of child +processes, Perl has reset the signal to its default value. +This situation typically indicates that the parent program under +which Perl may be running (e.g. cron) is being very careless. + =item Can't modify non-lvalue subroutine call (F) Subroutines meant to be used in lvalue context should be declared as @@ -1746,6 +1745,16 @@ could be a potential Year 2000 problem. See Server error. +=item Repeat count in pack overflows + +(F) You can't specify a repeat count so large that it overflows +your signed integers. See L. + +=item Repeat count in unpack overflows + +(F) You can't specify a repeat count so large that it overflows +your signed integers. See L. + =item realloc() of freed memory ignored (S) An internal routine called realloc() on something that had already diff --git a/pod/perldiag.pod b/pod/perldiag.pod index a6a723c..18abdea 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -826,6 +826,15 @@ L. (F) The "goto subroutine" call can't be used to jump out of an eval "string". (You can use it to jump out of an eval {BLOCK}, but you probably don't want to.) +=item Can't ignore signal CHLD, forcing to default + +(W) Perl has detected that it is being run with the SIGCHLD signal +(sometimes known as SIGCLD) disabled. Since disabling this signal +will interfere with proper determination of exit status of child +processes, Perl has reset the signal to its default value. +This situation typically indicates that the parent program under +which Perl may be running (e.g. cron) is being very careless. + =item Can't localize through a reference (F) You said something like C, which Perl can't currently diff --git a/pod/perlop.pod b/pod/perlop.pod index 6e65ba3..c430dbc 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -1074,9 +1074,9 @@ this expression: qw(foo bar baz) -is exactly equivalent to the list: +is semantically equivalent to the list: - ('foo', 'bar', 'baz') + 'foo', 'bar', 'baz' Some frequently seen examples: diff --git a/t/io/fs.t b/t/io/fs.t index 087021b..3192970 100755 --- a/t/io/fs.t +++ b/t/io/fs.t @@ -147,12 +147,18 @@ else { print FH "helloworld\n"; truncate FH, 5; } - if ($^O eq 'dos') { + if ($^O eq 'dos' + # Not needed on HPFS, but needed on HPFS386 ?! + or $^O eq 'os2') + { close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; } if (-s "Iofs.tmp" == 5) {print "ok 25\n"} else {print "not ok 25\n"} truncate FH, 0; - if ($^O eq 'dos') { + if ($^O eq 'dos' + # Not needed on HPFS, but needed on HPFS386 ?! + or $^O eq 'os2') + { close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; } if (-z "Iofs.tmp") {print "ok 26\n"} else {print "not ok 26\n"} diff --git a/t/op/int.t b/t/op/int.t index eb060ac..6ac0866 100755 --- a/t/op/int.t +++ b/t/op/int.t @@ -1,8 +1,11 @@ #!./perl -# $RCSfile: int.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:00 $ +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} -print "1..4\n"; +print "1..6\n"; # compile time evaluation @@ -15,3 +18,13 @@ if (int(-1.234) == -1) {print "ok 2\n";} else {print "not ok 2\n";} $x = 1.234; if (int($x) == 1) {print "ok 3\n";} else {print "not ok 3\n";} if (int(-$x) == -1) {print "ok 4\n";} else {print "not ok 4\n";} + +$x = length("abc") % -10; +print $x == -7 ? "ok 5\n" : "# expected -7, got $x\nnot ok 5\n"; + +{ + use integer; + $x = length("abc") % -10; + $y = (3/-10)*-10; + print $x+$y == 3 && abs($x) < 10 ? "ok 6\n" : "not ok 6\n"; +} diff --git a/t/op/lex_assign.t b/t/op/lex_assign.t index b5c471a..0f65869 100755 --- a/t/op/lex_assign.t +++ b/t/op/lex_assign.t @@ -4,6 +4,7 @@ BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; } +$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; umask 0; $xref = \ ""; diff --git a/t/op/magic.t b/t/op/magic.t index 31765e2..fe55521 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -22,6 +22,7 @@ sub ok { $Is_MSWin32 = $^O eq 'MSWin32'; $Is_VMS = $^O eq 'VMS'; $Is_Dos = $^O eq 'dos'; +$Is_os2 = $^O eq 'os2'; $Is_Cygwin = $^O =~ /cygwin/; $PERL = ($Is_MSWin32 ? '.\perl' : './perl'); @@ -117,6 +118,9 @@ ok 18, $$ > 0, $$; chomp($wd = `pwd`); $wd =~ s#/t$##; } + elsif($Is_os2) { + $wd = Cwd::sys_cwd(); + } else { $wd = '.'; } @@ -142,6 +146,9 @@ __END__ :endofperl EOT } + elsif ($Is_os2) { + $script = "./show-shebang"; + } if ($^O eq 'os390' or $^O eq 'posix-bc' or $^O eq 'vmesa') { # no shebang $headmaybe = < 3; # known scalar leak +BEGIN{ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } # known scalar leak use warnings 'unsafe' ; my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; @a =~ /abc/ ;