----------------
____________________________________________________________________________
+[ 4435] By: gsar on 1999/10/24 11:39:42
+ Log: VMS tweak (suggested by Craig A. Berry <craig.berry@metamor.com>)
+ 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
+ <allen@grumman.com>)
+ Branch: perl
+ ! lib/Time/Local.pm
+____________________________________________________________________________
+[ 4433] By: gsar on 1999/10/24 11:25:51
+ Log: README nits pointed out by Chris Nandor <pudge@pobox.com>
+ Branch: perl
+ ! README lib/File/Path.pm
+____________________________________________________________________________
+[ 4432] By: gsar on 1999/10/24 11:11:02
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ 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<length("abc") % -10> 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 <doughera@lafayette.edu>
+ To: Perl Porters <perl5-porters@perl.org>
+ Subject: [PATCH 5.005_62] Policy_sh.SH update
+ Date: Fri, 22 Oct 1999 16:47:34 -0400 (EDT)
+ Message-ID: <Pine.SOL.4.10.9910221645470.15232-100000@maxwell.phys.lafayette.edu>
+ Branch: cfgperl
+ ! Policy_sh.SH
+____________________________________________________________________________
+[ 4422] By: jhi on 1999/10/22 22:44:44
+ Log: so back to 'so', from Stephanie Beals <bealzy@us.ibm.com>
+ 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<sort { my $c; return $a cmp $b } ...>
+ Branch: perl
+ ! op.c
+____________________________________________________________________________
+[ 4416] By: gsar on 1999/10/20 01:00:50
+ Log: fix prototype mismatch (from Hans Mulder <hansm@xs4all.nl>)
+ 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
+ <schwern@pobox.com>)
+ 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
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
$(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)" ]; \
# 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)
--------------------------------------------------------------------------
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.
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.
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 <URL:http://www.perl.com/CPAN/src/>.
Just a personal note: I want you to know that I create nice things like this
# 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";
set `emxrev -f emxlibcm`
emxcrtrev=$5
+# indented to not put it into config.sh
+ _defemxcrtrev=-D_EMX_CRT_REV_=$emxcrtrev
so='dll'
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"
# 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'
# of the pod. This might be useful for pod2man someday.
if ($script) {
@modpods = ($script);
- } else {
+ }
+ else {
@modpods = ();
find(\&lsmodpods, '.');
}
$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";
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;
}
? 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;
}
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 {
=head1 NAME
-File::Path - create or remove a series of directories
+File::Path - create or remove directory trees
=head1 SYNOPSIS
-C<use File::Path>
+ use File::Path;
-C<mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);>
-
-C<rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);>
+ mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
+ rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);
=head1 DESCRIPTION
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;
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;
}
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 = "";
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<use Time::Local 'no_range_check'>.
+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,
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;
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);
;
}
-#sub export {
-# require Exporter;
-# goto &Exporter::import;
-#}
-#
-#sub require_version { goto &UNIVERSAL::VERSION }
+sub require_version { goto &UNIVERSAL::VERSION }
1;
__END__
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<my> 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';
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<FETCH_I<type>_ATTRIBUTES> call in its return list, as described in
-L"Package-specific Attribute Handling"> below.
+L<"Package-specific Attribute Handling"> below.
Otherwise, only L<built-in attributes|"Built-in Attributes"> will be returned.
=item reftype
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<type> 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<not> exported. This is primarily because
-the C<use> mechanism which would normally import them is already in use
-by Perl itself to implement the C<sub : attributes> syntax.
+Note that these routines are I<not> exported by default.
=head2 Package-specific Attribute Handling
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<get> and C<reftype> 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
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) : "");
#undef PERLVARIC
#endif
- PERL_SYS_INIT(&argc,&argv);
+ PERL_SYS_INIT3(&argc,&argv,&env);
if (!PL_do_undump) {
my_perl = perl_alloc();
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) {
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<system 1, $cmd> to treat $cmd as in C<system $cmd>;
+ 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.
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.
--- /dev/null
+0.01:
+ Split out of OS2::REXX
--- /dev/null
+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 <file> [<dirs>]' 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 <<EOE or die "eval package $@";
+package OS2::DLL::$file; \@ISA = qw($packs);
+sub AUTOLOAD {
+ \$OS2::DLL::AUTOLOAD = \$AUTOLOAD;
+ goto &OS2::DLL::AUTOLOAD;
+}
+1;
+EOE
+ return $dlls{$file} =
+ bless {Handle => $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 <<EOE or die "eval sub";
+package OS2::DLL::$file;
+sub $_ {
+ shift;
+ OS2::DLL::_call('$_', $addr, '$queue', \@_);
+}
+1;
+EOE
+ }
+ return 1;
+}
+
+bootstrap OS2::DLL;
+
+1;
+__END__
+
+=head1 NAME
+
+OS2::DLL - access to DLLs with REXX calling convention.
+
+=head2 NOTE
+
+When you use this module, the REXX variable pool is not available.
+
+See documentation of L<OS2::REXX> 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<PERL_REXX_DEBUG> is set, emits debugging output. Looks for DLLs
+in C<PERL5REXX>, C<PERLREXX>, C<PATH>.
+
+=head1 AUTHOR
+
+Extracted by Ilya Zakharevich ilya@math.ohio-state.edu from L<OS2::REXX>
+written by Andreas Kaiser ak@ananke.s.bawue.de.
+
+=cut
--- /dev/null
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#define INCL_BASE
+#define INCL_REXXSAA
+#include <os2emx.h>
+
+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);
+ }
+
--- /dev/null
+Changes
+MANIFEST
+Makefile.PL
+DLL.pm
+DLL.xs
--- /dev/null
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'OS2::DLL',
+ VERSION => '0.01',
+ MAN3PODS => ' ', # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes',
+ PERL_MALLOC_OK => 1,
+);
WriteMakefile(
NAME => 'OS2::REXX',
- VERSION => '0.21',
+ VERSION => '0.22',
MAN3PODS => ' ', # Pods will be built by installman.
XSPROTOARG => '-noprototypes',
PERL_MALLOC_OK => 1,
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)
# 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 <file> [<dirs>]' 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;
Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich
ilya@math.ohio-state.edu.
+=head1 SEE ALSO
+
+L<OS2::DLL>.
+
=cut
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
$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";
--- /dev/null
+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";
#
# 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";
#
#
# 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";
}
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
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";
#include <os2.h>
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;
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);
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;
}
#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 <os2.h>
#include <sys/uflags.h>
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? */
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);
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;
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")) ) {
/* 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 { \
#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)
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 {
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
#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);
PQTOPLEVEL get_sysinfo(ULONG pid, ULONG flags);
-#endif /* _OS2EMX_H */
+#endif /* _OS2_H */
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)
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();
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);
# 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
but this did not follow some numeric unpack specification.
See L<perlfunc/pack>.
-=item Repeat count in pack overflows
-
-(F) You can't specify a repeat count so large that it overflows
-your signed integers. See L<perlfunc/pack>.
-
-=item Repeat count in unpack overflows
-
-(F) You can't specify a repeat count so large that it overflows
-your signed integers. See L<perlfunc/unpack>.
-
=item /%s/: Unrecognized escape \\%c passed through
(W) You used a backslash-character combination which is not recognized
(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
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<perlfunc/pack>.
+
+=item Repeat count in unpack overflows
+
+(F) You can't specify a repeat count so large that it overflows
+your signed integers. See L<perlfunc/unpack>.
+
=item realloc() of freed memory ignored
(S) An internal routine called realloc() on something that had already
(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<local $$ref>, which Perl can't currently
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:
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"}
#!./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
$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";
+}
chdir 't' if -d 't';
unshift @INC, '../lib';
}
+$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
umask 0;
$xref = \ "";
$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');
chomp($wd = `pwd`);
$wd =~ s#/t$##;
}
+ elsif($Is_os2) {
+ $wd = Cwd::sys_cwd();
+ }
else {
$wd = '.';
}
:endofperl
EOT
}
+ elsif ($Is_os2) {
+ $script = "./show-shebang";
+ }
if ($^O eq 'os390' or $^O eq 'posix-bc' or $^O eq 'vmesa') { # no shebang
$headmaybe = <<EOH ;
eval 'exec ./perl -S \$0 \${1+"\$\@"}'
ok 21, close(SCRIPT), $!;
ok 22, chmod(0755, $script), $!;
$_ = `$script`;
- s/\.exe//i if $Is_Dos or $Is_Cygwin;
+ s/\.exe//i if $Is_Dos or $Is_Cygwin or $Is_os2;
s{\bminiperl\b}{perl}; # so that test doesn't fail with miniperl
s{is perl}{is $perl}; # for systems where $^X is only a basename
s{\\}{/}g;
- ok 23, ($Is_MSWin32 ? uc($_) eq uc($s1) : $_ eq $s1), ":$_:!=:$s1:";
+ ok 23, (($Is_MSWin32 || $Is_os2) ? uc($_) eq uc($s1) : $_ eq $s1), " :$_:!=:$s1:";
$_ = `$perl $script`;
- s/\.exe//i if $Is_Dos;
+ s/\.exe//i if $Is_Dos or $Is_os2;
s{\\}{/}g;
- ok 24, ($Is_MSWin32 ? uc($_) eq uc($s1) : $_ eq $s1), ":$_:!=:$s1: after `$perl $script`";
+ ok 24, (($Is_MSWin32 || $Is_os2) ? uc($_) eq uc($s1) : $_ eq $s1), " :$_:!=:$s1: after `$perl $script`";
ok 25, unlink($script), $!;
}
ok 35, (scalar(keys(%ENV)) == 0);
}
else {
- ok "32 # skipped",1;
- ok "33 # skipped",1;
- ok "34 # skipped",1;
- ok "35 # skipped",1;
+ ok "32 # skipped: no caseless %ENV support",1;
+ ok "33 # skipped: no caseless %ENV support",1;
+ ok "34 # skipped: no caseless %ENV support",1;
+ ok "35 # skipped: no caseless %ENV support",1;
}
Useless use of a constant in void context at - line 4.
########
# op.c
-$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 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/ ;
projects / p5sagit/p5-mst-13.2.git / commitdiff