diff options
48 files changed, 1437 insertions, 674 deletions
@@ -31,6 +31,301 @@ or any other branch. Version v5.7.2 Development release working toward v5.8 -------------- ____________________________________________________________________________ +[ 12535] By: jhi on 2001/10/20 15:18:57 + Log: Upgrade to podlators 1.11, from Russ Allbery. + Branch: perl + ! lib/Pod/Man.pm lib/Pod/Text.pm lib/Pod/Text/Color.pm + ! lib/Pod/Text/Overstrike.pm lib/Pod/Text/Termcap.pm + ! pod/pod2man.PL pod/pod2text.PL +____________________________________________________________________________ +[ 12534] By: jhi on 2001/10/20 15:14:25 + Log: Integrate perlio change #12532: + introduce and use PerlIO_intmod2str(). + Branch: perl + !> doio.c lib/Net/Domain.pm perlio.c perlio.h +____________________________________________________________________________ +[ 12533] By: jhi on 2001/10/20 14:42:33 + Log: Update to Getopt::Long 2.26_02, from Johan Vromans. + Branch: perl + ! lib/Getopt/Long.pm lib/Getopt/Long/CHANGES lib/newgetopt.pl +____________________________________________________________________________ +[ 12532] By: nick on 2001/10/20 14:25:37 + Log: Extract doio.c's open(2) mode to string conversion as PerlIO_intmod2str() + Use for non-PERLIO fdupopen(). + Branch: perlio + ! doio.c lib/Net/Domain.pm perlio.c perlio.h +____________________________________________________________________________ +[ 12531] By: jhi on 2001/10/20 14:05:47 + Log: Integrate perlio: PerlIO win32 fixes. + Branch: perl + !> embed.h embed.pl embedvar.h ext/threads/threads.xs global.sym + !> perl.h perlapi.c perlapi.h perlio.c perlsdio.h pod/perlapi.pod + !> proto.h sv.h win32/win32io.c +____________________________________________________________________________ +[ 12530] By: nick on 2001/10/20 12:53:30 + Log: Fixed in two places - p4 resolve + Branch: perlio + ! perlsdio.h +____________________________________________________________________________ +[ 12529] By: nick on 2001/10/20 12:51:05 + Log: Fix for ithreads/stdio build + Branch: perlio + ! perlio.c perlsdio.h +____________________________________________________________________________ +[ 12528] By: ams on 2001/10/20 12:13:25 + Log: Subject: [PATCH installman] Using Pod::Man instead of pod2man + From: Michael G Schwern <schwern@pobox.com> + Date: Sat, 20 Oct 2001 01:41:21 -0400 + Message-Id: <20011020014121.I3681@blackrider> + Branch: perl + ! installman +____________________________________________________________________________ +[ 12527] By: ams on 2001/10/20 12:09:41 + Log: Subject: [PATCH lib/Pod/Checker.pm] Minor typo + From: Michael G Schwern <schwern@pobox.com> + Date: Sat, 20 Oct 2001 02:04:21 -0400 + Message-Id: <20011020020421.A11732@blackrider> + Branch: perl + ! lib/Pod/Checker.pm +____________________________________________________________________________ +[ 12526] By: ams on 2001/10/20 11:59:41 + Log: Subject: [PATCH lib/Net/Config.pm] Fix Some Pod Typos + From: "chromatic" <chromatic@rmci.net> + Date: Fri, 19 Oct 2001 22:46:39 -0600 + Message-Id: <20011020045254.73112.qmail@onion.perl.org> + Branch: perl + ! lib/Net/Config.pm +____________________________________________________________________________ +[ 12525] By: nick on 2001/10/20 11:16:18 + Log: Avoid calling (now non-existant) Perl_sv_setsv(), by calling + Perl_sv_setsv_flags directly. + Branch: perlio + ! ext/threads/threads.xs +____________________________________________________________________________ +[ 12524] By: nick on 2001/10/20 10:28:17 + Log: Add a new flag character 'm' to embed.pl set to represent + "functions" which are really macros. Use it foe the troublesome + sv_setsv() etc. macros in sv.h - changing latter to define + sv_setsv rather than sv_setsv_macro etc. + Branch: perlio + ! embed.h embed.pl embedvar.h global.sym perlapi.c perlapi.h + ! pod/perlapi.pod proto.h sv.h +____________________________________________________________________________ +[ 12523] By: nick on 2001/10/20 09:17:17 + Log: Add comments explaining why win32.h/embed.h are included where they are + in perl.h + Branch: perlio + ! perl.h +____________________________________________________________________________ +[ 12522] By: nick on 2001/10/20 08:27:44 + Log: Code PerlIOWin32_dup - does not fix Win32 problems as :win32 is not + being used yet. + Branch: perlio + ! win32/win32io.c +____________________________________________________________________________ +[ 12521] By: jhi on 2001/10/20 02:36:21 + Log: Wording tweaks. + Branch: perl + ! t/TEST +____________________________________________________________________________ +[ 12520] By: jhi on 2001/10/20 01:02:26 + Log: Subject: IO module with nonblocking socket connect patch + From: Raul Dias <raul@dias.com.br> + Date: Fri, 19 Oct 2001 22:45:32 -0300 + Message-Id: <200110200145.f9K1jWW08398@stratus.swi.com.br> + Branch: perl + ! ext/IO/lib/IO/Socket.pm ext/IO/lib/IO/Socket/INET.pm +____________________________________________________________________________ +[ 12519] By: jhi on 2001/10/20 00:51:07 + Log: Test vertical whitespace combined with /x in \p{}. + Branch: perl + ! t/op/pat.t +____________________________________________________________________________ +[ 12518] By: jhi on 2001/10/20 00:13:47 + Log: Subject: [PATCH] PERL_MM_USE_DEFAULT + From: Gisle Aas <gisle@ActiveState.com> + Date: 19 Oct 2001 16:46:02 -0700 + Message-ID: <lrofn3i479.fsf_-_@caliper.ActiveState.com> + Branch: perl + ! lib/ExtUtils/MakeMaker.pm +____________________________________________________________________________ +[ 12517] By: jhi on 2001/10/19 23:59:34 + Log: No more this symbol. + Branch: perl + ! makedef.pl +____________________________________________________________________________ +[ 12516] By: jhi on 2001/10/19 23:57:48 + Log: Integrate change #12511; fix gross win32 build issues. + Branch: perl + !> makedef.pl sv.c +____________________________________________________________________________ +[ 12515] By: jhi on 2001/10/19 23:16:06 + Log: Unpack in scalar context should return the first value + returned in list context, as pointed out by Ton Hospel + in 2001-05-21 (this is how it works already in blead, + just adding the test). + Branch: perl + ! t/op/pack.t +____________________________________________________________________________ +[ 12514] By: jhi on 2001/10/19 21:10:43 + Log: Subject: [PATCH perl@12494] perldoc.PL tweak for VMS + From: "Craig A. Berry" <craigberry@mac.com> + Date: Fri, 19 Oct 2001 16:59:30 -0500 + Message-Id: <5.1.0.14.2.20011019162623.021e3868@exchi01> + Branch: perl + ! utils/perldoc.PL +____________________________________________________________________________ +[ 12513] By: jhi on 2001/10/19 21:09:27 + Log: Subject: [PATCH Perl@12494] vmsish fix, ieee rand() cleanup + From: lane@DUPHY4.Physics.Drexel.Edu (Charles Lane) + Date: Fri, 19 Oct 2001 17:45:23 EDT + Message-Id: <011019174427.d749b@DUPHY4.Physics.Drexel.Edu> + Branch: perl + ! configure.com dump.c ext/B/t/stash.t op.c op.h opcode.h + ! opcode.pl perl.c perl.h perlvars.h pp.sym pp_ctl.c pp_proto.h + ! pp_sys.c vms/ext/vmsish.pm vms/ext/vmsish.t vms/vms.c + ! vms/vmsish.h +____________________________________________________________________________ +[ 12512] By: jhi on 2001/10/19 20:28:48 + Log: Subject: [PATCH Perl@12494] two fake test failures on VMS fixed + From: lane@DUPHY4.Physics.Drexel.Edu (Charles Lane) + Date: Fri, 19 Oct 2001 17:26:35 EDT + Message-Id: <011019172623.11292c@DUPHY4.Physics.Drexel.Edu> + Branch: perl + ! lib/Term/Complete.t lib/Test/Simple/t/output.t +____________________________________________________________________________ +[ 12511] By: nick on 2001/10/19 19:55:36 + Log: Fix gross win32 build issues + Branch: perlio + ! makedef.pl sv.c +____________________________________________________________________________ +[ 12510] By: jhi on 2001/10/19 19:52:17 + Log: Subject: Re: find2perl and File::Find on cdrom filesystems (with Tel's patch applied to perl-current) + From: David Dyck <dcd@tc.fluke.com> + Date: Fri, 19 Oct 2001 13:36:09 -0700 (PDT) + Message-ID: <Pine.LNX.4.33.0110191309310.28510-100000@dd.tc.fluke.com> + Branch: perl + ! lib/File/Find.pm +____________________________________________________________________________ +[ 12509] By: jhi on 2001/10/19 19:01:46 + Log: Subject: Re: PerlIO and Encode + From: SADAHIRO Tomoyuki <BQW10602@nifty.com> + Date: Tue, 16 Oct 2001 01:50:16 +0900 + Message-Id: <20011016014150.0C8E.BQW10602@nifty.com> + Branch: perl + ! ext/Encode/Encode.pm ext/Encode/Encode/Tcl.pm + ! ext/Encode/Encode/Tcl.t +____________________________________________________________________________ +[ 12508] By: ams on 2001/10/19 17:59:16 + Log: C<foo I<bar>> hunks from <20011019014551.A35625@not.autrijus.org>. + (See #12499) + Branch: perl + ! pod/perlintro.pod +____________________________________________________________________________ +[ 12507] By: nick on 2001/10/19 16:30:43 + Log: Integrate mainline + Branch: perlio + +> lib/Test/Builder.pm lib/Test/Simple/t/Builder.t + +> lib/Test/Simple/t/filehandles.t lib/Test/Simple/t/import.t + +> lib/Test/Simple/t/is_deeply.t lib/Test/Simple/t/no_ending.t + +> lib/Test/Simple/t/no_header.t lib/Test/Simple/t/output.t + +> lib/Test/Simple/t/plan.t lib/Test/Simple/t/plan_no_plan.t + +> lib/Test/Simple/t/plan_skip_all.t lib/Test/Simple/t/use_ok.t + +> lib/unicore/To/SpecLower.pl lib/unicore/To/SpecTitle.pl + +> lib/unicore/To/SpecUpper.pl pod/perlintro.pod + +> pod/perlmodstyle.pod win32/Makefile.win64 win32/config.win64 + +> win32/config_H.win64 + - lib/Test/Utils.pm lib/unicore/mktables.PL + - t/lib/Test/Simple/Catch/More.pm + !> (integrate 84 files) +____________________________________________________________________________ +[ 12506] By: jhi on 2001/10/19 14:20:15 + Log: Retract the #10451 which seems to be the cause + of the major leakage from while(){eval"sub{}"} + Branch: perl + ! op.c t/run/kill_perl.t +____________________________________________________________________________ +[ 12505] By: jhi on 2001/10/19 13:39:59 + Log: Regen toc. + Branch: perl + ! pod/perltoc.pod +____________________________________________________________________________ +[ 12504] By: jhi on 2001/10/19 13:35:59 + Log: Tiny tweaks. + Branch: perl + ! pod/perl.pod +____________________________________________________________________________ +[ 12503] By: ams on 2001/10/19 13:34:24 + Log: Subject: Re: perlintro.pod + From: Abe Timmerman <abe@ztreet.demon.nl> + Date: Fri, 19 Oct 2001 14:12:40 +0200 + Message-Id: <ls40ttsmrr3rpjlm3dqhh8v60onsiopmuc@4ax.com> + Branch: perl + ! pod/perlintro.pod +____________________________________________________________________________ +[ 12502] By: ams on 2001/10/19 13:24:12 + Log: Slight reorganisation of references. + Branch: perl + ! pod/perl.pod +____________________________________________________________________________ +[ 12501] By: jhi on 2001/10/19 13:19:14 + Log: Subject: [DOC PATCH lib/ExtUtils/MakeMaker.pm] Discouraging use of PREREQ_FATAL in day-to-day Makefile.PL's + From: Kay Röpke <kroepke@dolphin-services.de> + Date: Fri, 19 Oct 2001 14:04:01 +0200 + Message-Id: <E15uYNb-00040L-00@mrvdom01.schlund.de> + Branch: perl + ! lib/ExtUtils/MakeMaker.pm +____________________________________________________________________________ +[ 12500] By: jhi on 2001/10/19 03:25:44 + Log: Unicode categories continue: + implement Category=, Script=, Block= + (these are based on an upcoming update of TR#18) + Fix a bug where we got two In categories named "old italic", + and another where shortcut for the Is categories wasn't taken. + Branch: perl + ! lib/unicore/Blocks.pl lib/unicore/In.pl lib/unicore/In/137.pl + ! lib/unicore/mktables lib/utf8_heavy.pl pod/perltodo.pod + ! pod/perlunicode.pod t/op/pat.t +____________________________________________________________________________ +[ 12499] By: ams on 2001/10/19 01:42:29 + Log: Subject: a small patch to perlintro.pod. + From: Autrijus Tang <autrijus@autrijus.org> + Date: Fri, 19 Oct 2001 01:45:51 +0800 + Message-Id: <20011019014551.A35625@not.autrijus.org> + (Applied by hand with nits.) + Branch: perl + ! pod/perlintro.pod +____________________________________________________________________________ +[ 12498] By: jhi on 2001/10/19 00:14:50 + Log: Subject: [PATCH] OpenBSD hints for ithreads + From: Andy Dougherty <doughera@lafayette.edu> + Date: Thu, 18 Oct 2001 12:33:59 -0400 (EDT) + Message-ID: <Pine.SOL.4.10.10110181232060.15040-100000@maxwell.phys.lafayette.edu> + Branch: perl + ! hints/openbsd.sh +____________________________________________________________________________ +[ 12497] By: jhi on 2001/10/18 16:14:13 + Log: Retract #12446; the problem solved by #12474. + Branch: perl + ! hints/aix.sh +____________________________________________________________________________ +[ 12496] By: gsar on 2001/10/18 15:38:22 + Log: Carp::shortmess_heavy() doesn't notice trailing newline in + message and suppress line number info (from Steve Hay + <Steve.Hay@uk.radan.com>) + Branch: maint-5.6/perl + ! lib/Carp/Heavy.pm +____________________________________________________________________________ +[ 12495] By: jhi on 2001/10/18 14:06:52 + Log: More documented In categories. + Branch: perl + ! pod/perlunicode.pod +____________________________________________________________________________ +[ 12494] By: jhi on 2001/10/18 13:04:48 + Log: Update Changes. + Branch: perl + ! Changes patchlevel.h +____________________________________________________________________________ [ 12493] By: jhi on 2001/10/18 12:58:31 Log: Add the lib/unicore/To/Spec*.pl to the MANIFEST. Branch: perl diff --git a/configure.com b/configure.com index 82fa3ed4a0..2c4f1be9d2 100644 --- a/configure.com +++ b/configure.com @@ -4514,7 +4514,6 @@ $! $! Check rand48 and its ilk $! $ echo4 "Looking for a random number function..." -$ d_use_rand = "undef" $ OS $ WS "#if defined(__DECC) || defined(__DECCXX)" $ WS "#include <stdlib.h>" @@ -4555,10 +4554,9 @@ $ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link $ THEN $ echo4 "OK, found random()." $ ELSE -$ drand01="(((float)rand())*PL_my_inv_rand_max)" +$ drand01="(((float)rand())*MY_INV_RAND_MAX)" $ randseedtype = "unsigned" $ seedfunc = "srand" -$ d_use_rand = "define" $ echo4 "Yick, looks like I have to use rand()." $ ENDIF $ ENDIF @@ -5732,7 +5730,6 @@ $ THEN $! Alas this does not help to build Fcntl $! WC "#define PERL_IGNORE_FPUSIG SIGFPE" $ ENDIF -$ if d_use_rand .EQS. "define" then WC "#define Drand01_is_rand" $ CLOSE CONFIG $! $ echo4 "Doing variable substitutions on .SH files..." @@ -616,7 +616,13 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) } else if (o->op_type == OP_EXIT) { if (o->op_private & OPpEXIT_VMSISH) - sv_catpv(tmpsv, ",EXIST_VMSISH"); + sv_catpv(tmpsv, ",EXIT_VMSISH"); + if (o->op_private & OPpHUSH_VMSISH) + sv_catpv(tmpsv, ",HUSH_VMSISH"); + } + else if (o->op_type == OP_DIE) { + if (o->op_private & OPpHUSH_VMSISH) + sv_catpv(tmpsv, ",HUSH_VMSISH"); } if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO) sv_catpv(tmpsv, ",INTRO"); diff --git a/ext/B/t/stash.t b/ext/B/t/stash.t index b83493fe34..88e4ca2492 100755 --- a/ext/B/t/stash.t +++ b/ext/B/t/stash.t @@ -42,6 +42,7 @@ $a =~ s/-uCwd,// if $^O eq 'cygwin'; if ($Is_VMS) { $a =~ s/-uFile,-uFile::Copy,//; $a =~ s/-uVMS,-uVMS::Filespec,//; + $a =~ s/-uvmsish,//; $a =~ s/-uSocket,//; # Socket is optional/compiler version dependent } diff --git a/ext/Encode/Encode.pm b/ext/Encode/Encode.pm index 2035e20c15..6ddcb32132 100644 --- a/ext/Encode/Encode.pm +++ b/ext/Encode/Encode.pm @@ -225,7 +225,7 @@ sub decode my $enc = find_encoding($name); croak("Unknown encoding '$name'") unless defined $enc; my $string = $enc->decode($octets,$check); - return undef if ($check && length($octets)); + $_[1] = $octets if $check; return $string; } diff --git a/ext/Encode/Encode/Tcl.pm b/ext/Encode/Encode/Tcl.pm index eb13c5f4fc..460a521bb9 100644 --- a/ext/Encode/Encode/Tcl.pm +++ b/ext/Encode/Encode/Tcl.pm @@ -40,6 +40,23 @@ sub import INC_search(); } +sub no_map_in_encode ($$) + # codepoint, enc-name; +{ + carp sprintf "\"\\N{U+%x}\" does not map to %s", @_; +# /* FIXME: Skip over the character, copy in replacement and continue +# * but that is messy so for now just fail. +# */ + return; +} + +sub no_map_in_decode ($$) + # enc-name, string beginning the malform char; +{ +# /* UTF-8 is supposed to be "Universal" so should not happen */ + croak sprintf "%s '%s' does not map to UTF-8", @_; +} + sub encode { my $obj = shift; @@ -78,11 +95,11 @@ sub loadEncoding $type = substr($line,0,1); last unless $type eq '#'; } - my $class = ref($obj).('::'.( - ($type eq 'X') ? 'Extended' : - ($type eq 'H') ? 'HanZi' : - ($type eq 'E') ? 'Escape' : 'Table' - )); + my $subclass = + ($type eq 'X') ? 'Extended' : + ($type eq 'H') ? 'HanZi' : + ($type eq 'E') ? 'Escape' : 'Table'; + my $class = ref($obj) . '::' . $subclass; # carp "Loading $file"; bless $obj,$class; return $obj if $obj->read($fh,$obj->name,$type); @@ -109,7 +126,8 @@ sub INC_find package Encode::Tcl::Table; use base 'Encode::Encoding'; -use Data::Dumper; +use Carp; +#use Data::Dumper; sub read { @@ -150,8 +168,12 @@ sub read } $touni[$page] = \@page; } - $rep = $type ne 'M' ? $obj->can("rep_$type") : - sub { ($_[0] > 255) || $leading[$_[0]] ? 'n' : 'C'}; + $rep = $type ne 'M' + ? $obj->can("rep_$type") + : sub + { + ($_[0] > 255) || $leading[$_[0]] ? 'n' : 'C'; + }; $obj->{'Rep'} = $rep; $obj->{'ToUni'} = \@touni; $obj->{'FmUni'} = \%fmuni; @@ -175,13 +197,15 @@ sub representation sub decode { - my ($obj,$str,$chk) = @_; + my($obj,$str,$chk) = @_; + my $name = $obj->{'Name'}; my $rep = $obj->{'Rep'}; my $touni = $obj->{'ToUni'}; my $uni; while (length($str)) { - my $ch = ord(substr($str,0,1,'')); + my $cc = substr($str,0,1,''); + my $ch = ord($cc); my $x; if (&$rep($ch) eq 'C') { @@ -189,13 +213,18 @@ sub decode } else { - $x = $touni->[$ch][ord(substr($str,0,1,''))]; + if(! length $str) + { + $str = pack('C',$ch); # split leading byte + last; + } + my $c2 = substr($str,0,1,''); + $cc .= $c2; + $x = $touni->[$ch][ord($c2)]; } unless (defined $x) { - last if $chk; - # What do we do here ? - $x = ''; + Encode::Tcl::no_map_in_decode($name, $cc.$str); } $uni .= $x; } @@ -209,16 +238,20 @@ sub encode my ($obj,$uni,$chk) = @_; my $fmuni = $obj->{'FmUni'}; my $def = $obj->{'Def'}; + my $name = $obj->{'Name'}; my $rep = $obj->{'Rep'}; my $str; while (length($uni)) { my $ch = substr($uni,0,1,''); - my $x = $fmuni->{chr(ord($ch))}; - unless (defined $x) + my $x = $fmuni->{$ch}; + unless(defined $x) { - last if ($chk); - $x = $def; + unless($chk) + { + Encode::Tcl::no_map_in_encode(ord($ch), $name) + } + return undef; } $str .= pack(&$rep($x),$x); } @@ -231,29 +264,41 @@ use base 'Encode::Encoding'; use Carp; +use constant SI => "\cO"; +use constant SO => "\cN"; +use constant SS2 => "\eN"; +use constant SS3 => "\eO"; + sub read { my ($obj,$fh,$name) = @_; my(%tbl, @seq, $enc, @esc, %grp); while (<$fh>) { - my ($key,$val) = /^(\S+)\s+(.*)$/; + next unless /^(\S+)\s+(.*)$/; + my ($key,$val) = ($1,$2); $val =~ s/^\{(.*?)\}/$1/g; $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge; - if($enc = Encode->getEncoding($key)){ + if($enc = Encode->getEncoding($key)) + { $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc; push @seq, $val; $grp{$val} = - $val =~ m|[(]| ? 0 : # G0 : SI eq "\cO" - $val =~ m|[)-]| ? 1 : # G1 : SO eq "\cN" - $val =~ m|[*.]| ? 2 : # G2 : SS2 eq "\eN" - $val =~ m|[+/]| ? 3 : # G3 : SS3 eq "\eO" - 0; # G0 - }else{ + $val =~ m|[(]| ? 0 : # G0 : SI eq "\cO" + $val =~ m|[)-]| ? 1 : # G1 : SO eq "\cN" + $val =~ m|[*.]| ? 2 : # G2 : SS2 eq "\eN" + $val =~ m|[+/]| ? 3 : # G3 : SS3 eq "\eO" + 0; # G0 + } + else + { $obj->{$key} = $val; - } - if($val =~ /^\e(.*)/){ push(@esc, quotemeta $1) } + } + if($val =~ /^\e(.*)/) + { + push(@esc, quotemeta $1); + } } $obj->{'Grp'} = \%grp; # graphic chars $obj->{'Seq'} = \@seq; # escape sequences @@ -265,6 +310,7 @@ sub read sub decode { my ($obj,$str,$chk) = @_; + my $name = $obj->{'Name'}; my $tbl = $obj->{'Tbl'}; my $seq = $obj->{'Seq'}; my $grp = $obj->{'Grp'}; @@ -277,45 +323,57 @@ sub decode my $s = 0; # state of SO-SI. 0 (G0) or 1 (G1); my $ss = 0; # state of SS2,SS3. 0 (G0), 2 (G2) or 3 (G3); my $uni; - while (length($str)){ - my $uch = substr($str,0,1,''); - if($uch eq "\e"){ - if($str =~ s/^($esc)//) - { - my $e = "\e$1"; - $sta[ $grp->{$e} ] = $e if $tbl->{$e}; - } + while (length($str)) + { + my $cc = substr($str,0,1,''); + if($cc eq "\e") + { + if($str =~ s/^($esc)//) + { + my $e = "\e$1"; + $sta[ $grp->{$e} ] = $e if $tbl->{$e}; + } # appearance of "\eN\eO" or "\eO\eN" isn't supposed. - elsif($str =~ s/^N//) - { - $ss = 2; - } - elsif($str =~ s/^O//) - { - $ss = 3; - } - else - { - $str =~ s/^([\x20-\x2F]*[\x30-\x7E])//; - carp "unknown escape sequence: ESC $1"; - } - next; - } - if($uch eq "\x0e"){ - $s = 1; next; - } - if($uch eq "\x0f"){ - $s = 0; next; - } + # but in that case, the former will be ignored. + elsif($str =~ s/^N//) + { + $ss = 2; + } + elsif($str =~ s/^O//) + { + $ss = 3; + } + else + { + # strictly, ([\x20-\x2F]*[\x30-\x7E]). '?' for chopped. + $str =~ s/^([\x20-\x2F]*[\x30-\x7E]?)//; + if($chk && ! length $str) + { + $str = "\e$1"; # split sequence + last; + } + croak "unknown escape sequence: ESC $1"; + } + next; + } + if($cc eq SO) + { + $s = 1; next; + } + if($cc eq SI) + { + $s = 0; next; + } $cur = $ss ? $sta[$ss] : $sta[$s]; - if(ref($tbl->{$cur}) eq 'Encode::XS'){ - $uni .= $tbl->{$cur}->decode($uch); + if(ref($tbl->{$cur}) ne 'Encode::Tcl::Table') + { + $uni .= $tbl->{$cur}->decode($cc); $ss = 0; next; - } - my $ch = ord($uch); + } + my $ch = ord($cc); my $rep = $tbl->{$cur}->{'Rep'}; my $touni = $tbl->{$cur}->{'ToUni'}; my $x; @@ -325,24 +383,36 @@ sub decode } else { - $x = $touni->[$ch][ord(substr($str,0,1,''))]; + if(! length $str) + { + $str = $cc; # split leading byte + last; + } + my $c2 = substr($str,0,1,''); + $cc .= $c2; + $x = $touni->[$ch][ord($c2)]; } unless (defined $x) { - last if $chk; - # What do we do here ? - $x = ''; + Encode::Tcl::no_map_in_decode($name, $cc.$str); } $uni .= $x; $ss = 0; } - $_[1] = $str if $chk; - return $uni; + if($chk) + { + my $back = join('', grep defined($_) && $_ ne $std, @sta); + $back .= SO if $s; + $back .= $ss == 2 ? SS2 : SS3 if $ss; + $_[1] = $back.$str; + } + return $uni; } sub encode { my ($obj,$uni,$chk) = @_; + my $name = $obj->{'Name'}; my $tbl = $obj->{'Tbl'}; my $seq = $obj->{'Seq'}; my $grp = $obj->{'Grp'}; @@ -357,39 +427,45 @@ sub encode if($ini && defined $grp->{$ini}) { - $sta[ $grp->{$ini} ] = $ini; + $sta[ $grp->{$ini} ] = $ini; } - while (length($uni)){ - my $ch = substr($uni,0,1,''); - my $x; - foreach my $e_seq (@$seq){ - $x = ref($tbl->{$e_seq}) eq 'Encode::XS' - ? $tbl->{$e_seq}->encode($ch,1) - : $tbl->{$e_seq}->{FmUni}->{$ch}; - $cur = $e_seq, last if defined $x; - } - if(ref($tbl->{$cur}) ne 'Encode::XS') - { - my $def = $tbl->{$cur}->{'Def'}; - my $rep = $tbl->{$cur}->{'Rep'}; - unless (defined $x){ - last if ($chk); - $x = $def; + while (length($uni)) + { + my $ch = substr($uni,0,1,''); + my $x; + foreach my $e_seq (@$seq) + { + $x = ref($tbl->{$e_seq}) eq 'Encode::Tcl::Table' + ? $tbl->{$e_seq}->{FmUni}->{$ch} + : $tbl->{$e_seq}->encode($ch,1); + $cur = $e_seq, last if defined $x; } - $x = pack(&$rep($x),$x); + unless (defined $x) + { + unless($chk) + { + Encode::Tcl::no_map_in_encode(ord($ch), $name) + } + return undef; } - $cG = $grp->{$cur}; - $str .= $sta[$cG] = $cur unless $cG < 2 && $cur eq $sta[$cG]; - - $str .= $cG == 0 && $pG == 1 ? "\cO" : - $cG == 1 && $pG == 0 ? "\cN" : - $cG == 2 ? "\eN" : - $cG == 3 ? "\eO" : ""; - $str .= $x; - $pG = $cG if $cG < 2; - } - $str .= "\cO" if $pG == 1; # back to G0 + if(ref($tbl->{$cur}) eq 'Encode::Tcl::Table') + { + my $def = $tbl->{$cur}->{'Def'}; + my $rep = $tbl->{$cur}->{'Rep'}; + $x = pack(&$rep($x),$x); + } + $cG = $grp->{$cur}; + $str .= $sta[$cG] = $cur unless $cG < 2 && $cur eq $sta[$cG]; + + $str .= $cG == 0 && $pG == 1 ? SI : + $cG == 1 && $pG == 0 ? SO : + $cG == 2 ? SS2 : + $cG == 3 ? SS3 : ""; + $str .= $x; + $pG = $cG if $cG < 2; + } + $str .= SI if $pG == 1; # back to G0 $str .= $std unless $std eq $sta[0]; # GO to ASCII $str .= $fin; # necessary? $_[1] = $uni if $chk; @@ -408,18 +484,21 @@ sub read my(%tbl, $enc, %ssc, @key); while (<$fh>) { - my ($key,$val) = /^(\S+)\s+(.*)$/; + next unless /^(\S+)\s+(.*)$/; + my ($key,$val) = ($1,$2); $val =~ s/\{(.*?)\}/$1/; $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge; - if($enc = Encode->getEncoding($key)){ + if($enc = Encode->getEncoding($key)) + { push @key, $val; - $tbl{$val} = ref($enc) eq 'Encode::Tcl' - ? $enc->loadEncoding : $enc; + $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc; $ssc{$val} = substr($val,1) if $val =~ /^>/; - }else{ + } + else + { $obj->{$key} = $val; - } + } } $obj->{'SSC'} = \%ssc; # single shift char $obj->{'Tbl'} = \%tbl; # encoding tables @@ -430,25 +509,28 @@ sub read sub decode { my ($obj,$str,$chk) = @_; - my $tbl = $obj->{'Tbl'}; - my $ssc = $obj->{'SSC'}; + my $name = $obj->{'Name'}; + my $tbl = $obj->{'Tbl'}; + my $ssc = $obj->{'SSC'}; my $cur = ''; # current state my $uni; - while (length($str)){ - my $uch = substr($str,0,1,''); - my $ch = ord($uch); + while (length($str)) + { + my $cc = substr($str,0,1,''); + my $ch = ord($cc); if(!$cur && $ch > 0x7F) { $cur = '>'; - $cur .= $uch, next if $ssc->{$cur.$uch}; + $cur .= $cc, next if $ssc->{$cur.$cc}; } $ch ^= 0x80 if $cur; - if(ref($tbl->{$cur}) eq 'Encode::XS'){ - $uni .= $tbl->{$cur}->decode(chr($ch)); + if(ref($tbl->{$cur}) ne 'Encode::Tcl::Table') + { + $uni .= $tbl->{$cur}->decode($cc); $cur = ''; next; - } + } my $rep = $tbl->{$cur}->{'Rep'}; my $touni = $tbl->{$cur}->{'ToUni'}; my $x; @@ -458,59 +540,74 @@ sub decode } else { - $x = $touni->[$ch][0x80 ^ ord(substr($str,0,1,''))]; + if(! length $str) + { + $str = $cc; # split leading byte + last; + } + my $c2 = substr($str,0,1,''); + $cc .= $c2; + $x = $touni->[$ch][0x80 ^ ord($c2)]; } unless (defined $x) { - last if $chk; - # What do we do here ? - $x = ''; + Encode::Tcl::no_map_in_decode($name, $cc.$str); } $uni .= $x; $cur = ''; } - $_[1] = $str if $chk; + if($chk) + { + $cur =~ s/>//; + $_[1] = $cur ne '' ? $cur.$str : $str; + } return $uni; } sub encode { my ($obj,$uni,$chk) = @_; + my $name = $obj->{'Name'}; my $tbl = $obj->{'Tbl'}; my $ssc = $obj->{'SSC'}; my $key = $obj->{'Key'}; my $str; my $cur; - while (length($uni)){ - my $ch = substr($uni,0,1,''); - my $x; - foreach my $k (@$key){ - $x = ref($tbl->{$k}) eq 'Encode::XS' - ? $k =~ /^>/ - ? $tbl->{$k}->encode(chr(0x80 ^ ord $ch),1) - : $tbl->{$k}->encode($ch,1) - : $tbl->{$k}->{FmUni}->{$ch}; - $cur = $k, last if defined $x; - } - if(ref($tbl->{$cur}) ne 'Encode::XS') - { - my $def = $tbl->{$cur}->{'Def'}; - my $rep = $tbl->{$cur}->{'Rep'}; - unless (defined $x){ - last if ($chk); - $x = $def; - } - my $r = &$rep($x); - $x = pack($r, + while (length($uni)) + { + my $ch = substr($uni,0,1,''); + my $x; + foreach my $k (@$key) + { + $x = ref($tbl->{$k}) ne 'Encode::Tcl::Table' + ? $k =~ /^>/ + ? $tbl->{$k}->encode(chr(0x80 ^ ord $ch),1) + : $tbl->{$k}->encode($ch,1) + : $tbl->{$k}->{FmUni}->{$ch}; + $cur = $k, last if defined $x; + } + unless (defined $x) + { + unless($chk) + { + Encode::Tcl::no_map_in_encode(ord($ch), $name) + } + return undef; + } + if(ref($tbl->{$cur}) eq 'Encode::Tcl::Table') + { + my $def = $tbl->{$cur}->{'Def'}; + my $rep = $tbl->{$cur}->{'Rep'}; + my $r = &$rep($x); + $x = pack($r, $cur =~ /^>/ ? $r eq 'C' ? 0x80 ^ $x : 0x8080 ^ $x : $x); - } - - $str .= $ssc->{$cur} if defined $ssc->{$cur}; - $str .= $x; - } + } + $str .= $ssc->{$cur} if defined $ssc->{$cur}; + $str .= $x; + } $_[1] = $uni if $chk; return $str; } @@ -526,15 +623,19 @@ sub read my(%tbl, @seq, $enc); while (<$fh>) { - my ($key,$val) = /^(\S+)\s+(.*)$/; + next unless /^(\S+)\s+(.*)$/; + my ($key,$val) = ($1,$2); $val =~ s/^\{(.*?)\}/$1/g; $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge; - if($enc = Encode->getEncoding($key)){ + if($enc = Encode->getEncoding($key)) + { $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc; push @seq, $val; - }else{ + } + else + { $obj->{$key} = $val; - } + } } $obj->{'Seq'} = \@seq; # escape sequences $obj->{'Tbl'} = \%tbl; # encoding tables @@ -544,39 +645,47 @@ sub read sub decode { my ($obj,$str,$chk) = @_; + my $name = $obj->{'Name'}; my $tbl = $obj->{'Tbl'}; my $seq = $obj->{'Seq'}; my $std = $seq->[0]; my $cur = $std; my $uni; while (length($str)){ - my $uch = substr($str,0,1,''); - if($uch eq "~"){ - if($str =~ s/^\cJ//) - { - next; - } - elsif($str =~ s/^\~//) - { - 1; - } - elsif($str =~ s/^([{}])//) - { - $cur = "~$1"; - next; - } - else - { - $str =~ s/^([^~])//; - carp "unknown HanZi escape sequence: ~$1"; - next; - } - } - if(ref($tbl->{$cur}) eq 'Encode::XS'){ - $uni .= $tbl->{$cur}->decode($uch); + my $cc = substr($str,0,1,''); + if($cc eq "~") + { + if($str =~ s/^\cJ//) + { + next; + } + elsif($str =~ s/^\~//) + { + 1; # no-op + } + elsif($str =~ s/^([{}])//) + { + $cur = "~$1"; + next; + } + elsif(! length $str) + { + $str = '~'; + last; + } + else + { + $str =~ s/^([^~])//; + croak "unknown HanZi escape sequence: ~$1"; + next; + } + } + if(ref($tbl->{$cur}) ne 'Encode::Tcl::Table') + { + $uni .= $tbl->{$cur}->decode($cc); next; - } - my $ch = ord($uch); + } + my $ch = ord($cc); my $rep = $tbl->{$cur}->{'Rep'}; my $touni = $tbl->{$cur}->{'ToUni'}; my $x; @@ -586,23 +695,32 @@ sub decode } else { - $x = $touni->[$ch][ord(substr($str,0,1,''))]; + if(! length $str) + { + $str = $cc; # split leading byte + last; + } + my $c2 = substr($str,0,1,''); + $cc .= $c2; + $x = $touni->[$ch][ord($c2)]; } unless (defined $x) { - last if $chk; - # What do we do here ? - $x = ''; + Encode::Tcl::no_map_in_decode($name, $cc.$str); } $uni .= $x; } - $_[1] = $str if $chk; + if($chk) + { + $_[1] = $cur eq $std ? $str : $cur.$str; + } return $uni; } sub encode { my ($obj,$uni,$chk) = @_; + my $name = $obj->{'Name'}; my $tbl = $obj->{'Tbl'}; my $seq = $obj->{'Seq'}; my $std = $seq->[0]; @@ -610,28 +728,34 @@ sub encode my $pre = $std; my $cur = $pre; - while (length($uni)){ - my $ch = chr(ord(substr($uni,0,1,''))); - my $x; - foreach my $e_seq (@$seq){ - $x = ref($tbl->{$e_seq}) eq 'Encode::XS' - ? $tbl->{$e_seq}->encode($ch,1) - : $tbl->{$e_seq}->{FmUni}->{$ch}; - $cur = $e_seq and last if defined $x; - } - if(ref($tbl->{$cur}) ne 'Encode::XS') - { - my $def = $tbl->{$cur}->{'Def'}; - my $rep = $tbl->{$cur}->{'Rep'}; - unless (defined $x){ - last if ($chk); - $x = $def; + while (length($uni)) + { + my $ch = substr($uni,0,1,''); + my $x; + foreach my $e_seq (@$seq) + { + $x = ref($tbl->{$e_seq}) eq 'Encode::Tcl::Table' + ? $tbl->{$e_seq}->{FmUni}->{$ch} + : $tbl->{$e_seq}->encode($ch,1); + $cur = $e_seq and last if defined $x; } - $x = pack(&$rep($x),$x); - } - $str .= $cur eq $pre ? $x : ($pre = $cur).$x; - $str .= '~' if $x eq '~'; # to '~~' - } + unless (defined $x) + { + unless($chk) + { + Encode::Tcl::no_map_in_encode(ord($ch), $name) + } + return undef; + } + if(ref($tbl->{$cur}) eq 'Encode::Tcl::Table') + { + my $def = $tbl->{$cur}->{'Def'}; + my $rep = $tbl->{$cur}->{'Rep'}; + $x = pack(&$rep($x),$x); + } + $str .= $cur eq $pre ? $x : ($pre = $cur).$x; + $str .= '~' if $x eq '~'; # to '~~' + } $str .= $std unless $cur eq $std; $_[1] = $uni if $chk; return $str; diff --git a/ext/Encode/Encode/Tcl.t b/ext/Encode/Encode/Tcl.t index 7e01ca6c13..950f658f90 100644 --- a/ext/Encode/Encode/Tcl.t +++ b/ext/Encode/Encode/Tcl.t @@ -1,6 +1,6 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; +# @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bEncode\b/) { print "1..0 # Skip: Encode was not built\n"; @@ -88,8 +88,41 @@ my @hz_txt = ( my $hz_exp = '007e0069006e002000470042002e5df162404e0d6b32' . 'ff0c52ff65bd65bc4eba3002004200790065002e007e'; +use constant BUFSIZ => 64; # for test +use constant hiragana => "\x{3042}\x{3044}\x{3046}\x{3048}\x{304A}"; +use constant han_kana => "\x{FF71}\x{FF72}\x{FF73}\x{FF74}\x{FF75}"; +use constant macron => "\x{0100}\x{0112}\x{012a}\x{014c}\x{016a}"; +use constant TAIL => 'bbb'; +use constant YES => 1; + +my @ary_buff = ( # [ encoding, decoded, encoded ] +# type-M + ["euc-cn", hiragana, "\xA4\xA2\xA4\xA4\xA4\xA6\xA4\xA8\xA4\xAA" ], + ["euc-jp", hiragana, "\xA4\xA2\xA4\xA4\xA4\xA6\xA4\xA8\xA4\xAA" ], + ["euc-jp", han_kana, "\x8E\xB1\x8E\xB2\x8E\xB3\x8E\xB4\x8E\xB5" ], + ["euc-kr", hiragana, "\xAA\xA2\xAA\xA4\xAA\xA6\xAA\xA8\xAA\xAA" ], + ["shiftjis", hiragana, "\x82\xA0\x82\xA2\x82\xA4\x82\xA6\x82\xA8" ], + ["shiftjis", han_kana, "\xB1\xB2\xB3\xB4\xB5" ], +# type-E + ["2022-cn", hiragana, "\e\$)A\cN". '$"$$$&$($*' . "\cO" ], + ["2022-jp", hiragana, "\e\$B".'$"$$$&$($*'."\e(B" ], + ["2022-kr", hiragana, "\e\$)C\cN". '*"*$*&*(**' . "\cO" ], + [ $jis, han_kana, "\e\(I".'12345'."\e(B" ], + ["2022-jp1", macron, "\e\$(D\x2A\x27\x2A\x37\x2A\x45\x2A\x57\x2A\x69\e(B"], + ["2022-jp2", "\x{C0}" . macron . "\x{C1}", + "\e\$(D\e.A\eN\x40\x2A\x27\x2A\x37\x2A\x45\x2A\x57\x2A\x69\e(B\eN\x41"], +# type-X + ["euc-jp-0212", hiragana, "\xA4\xA2\xA4\xA4\xA4\xA6\xA4\xA8\xA4\xAA" ], + ["euc-jp-0212", han_kana, "\x8E\xB1\x8E\xB2\x8E\xB3\x8E\xB4\x8E\xB5" ], + ["euc-jp-0212", macron, + "\x8F\xAA\xA7\x8F\xAA\xB7\x8F\xAA\xC5\x8F\xAA\xD7\x8F\xAA\xE9" ], +# type-H + [ $hz, hiragana, "~{". '$"$$$&$($*' . "~}" ], + [ $hz, hiragana, "~{". '$"$$' ."~\cJ". '$&$($*' . "~}" ], +); + plan test => $n*@encodings + $n*@encodings*@greek - + $n*@encodings*@ideodigit + $num_esc + $n + @hz_txt; + + $n*@encodings*@ideodigit + $num_esc + $n + @hz_txt + @ary_buff; foreach my $enc (@encodings) { @@ -189,3 +222,33 @@ foreach my $enc (@encodings) } } } + +for my $ary (@ary_buff) { + my $NG = 0; + my $enc = $ary->[0]; + for my $n ( int(BUFSIZ/2) .. 2*BUFSIZ+4 ){ + my $dst = "a"x$n. $ary->[1] . TAIL; + my $src = "a"x$n. $ary->[2] . TAIL; + my $utf = buff_decode($enc, $src); + $NG++ unless $dst eq $utf; + } + ok($NG, 0, "$enc mangled translating to Unicode"); +} + +sub buff_decode { + my($enc, $str) = @_; + my $utf8 = ''; + my $inconv = ''; + while(length $str){ + my $buff = $inconv.substr($str,0,BUFSIZ - length $inconv,''); + my $decoded = decode($enc, $buff, YES); + if(length $decoded){ + $utf8 .= $decoded; + $inconv = $buff; + } else { + last; # malformed? + } + } + return $utf8; +} + diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm index b62e7b39dd..d670fe5996 100644 --- a/ext/IO/lib/IO/Socket.pm +++ b/ext/IO/lib/IO/Socket.pm @@ -109,8 +109,8 @@ sub connect { my $timeout = ${*$sock}{'io_socket_timeout'}; my $err; my $blocking; - $blocking = $sock->blocking(0) if $timeout; + $blocking = $sock->blocking(0) if $timeout; if (!connect($sock, $addr)) { if (defined $timeout && $!{EINPROGRESS}) { require IO::Select; @@ -121,14 +121,14 @@ sub connect { $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); $@ = "connect: timeout"; } - elsif(!connect($sock,$addr) && not $!{EISCONN}) { + elsif (!connect($sock,$addr) && not $!{EISCONN}) { # Some systems refuse to re-connect() to # an already open socket and set errno to EISCONN. $err = $!; $@ = "connect: $!"; } } - else { + elsif ($blocking || !$!{EINPROGRESS}) { $err = $!; $@ = "connect: $!"; } diff --git a/ext/IO/lib/IO/Socket/INET.pm b/ext/IO/lib/IO/Socket/INET.pm index 051de539cf..62012d7816 100644 --- a/ext/IO/lib/IO/Socket/INET.pm +++ b/ext/IO/lib/IO/Socket/INET.pm @@ -129,6 +129,8 @@ sub configure { or return _error($sock, $!, $@); } + $sock->blocking($arg->{Blocking}) if defined $arg->{Blocking}; + $proto ||= (getprotobyname('tcp'))[2]; my $pname = (getprotobynumber($proto))[0]; @@ -309,7 +311,7 @@ C<IO::Socket::INET> provides. ReusePort Set SO_REUSEPORT before binding Timeout Timeout value for various operations MultiHomed Try all adresses for multi-homed hosts - + Blocking Determine if connection will be blocking mode If C<Listen> is defined then a listen socket is created, else if the socket type, which is derived from the protocol, is SOCK_STREAM then @@ -335,6 +337,9 @@ parameter will be deduced from C<Proto> if not specified. If the constructor is only passed a single argument, it is assumed to be a C<PeerAddr> specification. +If C<Blocking> is set to 0, the connection will be in nonblocking mode. +If not specified it defaults to 1 (blocking mode). + Examples: $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org', diff --git a/installman b/installman index 6e00774845..0c146bde8c 100755 --- a/installman +++ b/installman @@ -7,6 +7,7 @@ use File::Find; use File::Copy; use File::Path qw(mkpath); use ExtUtils::Packlist; +use Pod::Man; use subs qw(unlink chmod rename link); use vars qw($packlist @modpods); require Cwd; @@ -34,7 +35,6 @@ my $usage = man1ext = $Config{'man1ext'}; man3dir = $Config{'installman3dir'}; man3ext = $Config{'man3ext'}; - batchlimit is maximum number of pod files per invocation of pod2man --notify (or -n) just lists commands that would be executed. --verbose (or -V) report all progress. --silent (or -S) be silent. Only report errors.\n"; @@ -54,7 +54,6 @@ $opts{man3dir} = $Config{'installman3dir'} unless defined($opts{man3dir}); $opts{man3ext} = $Config{'man3ext'} unless defined($opts{man3ext}); -$opts{batchlimit} ||= 40; $opts{silent} ||= $opts{S}; $opts{notify} ||= $opts{n}; $opts{verbose} ||= $opts{V} || $opts{notify}; @@ -73,10 +72,10 @@ $packlist = ExtUtils::Packlist->new("$Config{installarchlib}/.packlist"); # Install the main pod pages. -runpod2man('pod', $opts{man1dir}, $opts{man1ext}); +pod2man('pod', $opts{man1dir}, $opts{man1ext}); # Install the pods for library modules. -runpod2man('lib', $opts{man3dir}, $opts{man3ext}); +pod2man('lib', $opts{man3dir}, $opts{man3ext}); # Install the pods embedded in the installed scripts open UTILS, "utils.lst" or die "Can't open 'utils.lst': $!"; @@ -85,13 +84,13 @@ while (<UTILS>) { chomp; $_ = $1 if /#.*pod\s*=\s*(\S+)/; my ($where, $what) = m|^(.*?)/(\S+)|; - runpod2man($where, $opts{man1dir}, $opts{man1ext}, $what); + pod2man($where, $opts{man1dir}, $opts{man1ext}, $what); if (($where, $what) = m|#.*link\s*=\s*(\S+)/(\S+)|) { - runpod2man($where, $opts{man1dir}, $opts{man1ext}, $what); + pod2man($where, $opts{man1dir}, $opts{man1ext}, $what); } } -sub runpod2man { +sub pod2man { # @script is scripts names if we are installing manpages embedded # in scripts, () otherwise my($poddir, $mandir, $manext, @script) = @_; @@ -115,23 +114,10 @@ sub runpod2man { print "chdir $poddir\n" if $opts{verbose}; chdir $poddir || die "Unable to cd to $poddir directory!\n$!\n"; - # We insist on using the current version of pod2man in case there - # are enhancements or changes from previous installed versions. - # The error message doesn't include the '..' because the user - # won't be aware that we've chdir to $poddir. - -r "$downdir/pod/pod2man" || die "Executable pod/pod2man not found.\n"; - - # We want to be sure to use the current perl. We can't rely on - # the installed perl because it might not be actually installed - # yet. (The user may have set the $install* Configure variables - # to point to some temporary home, from which the executable gets - # installed by occult means.) - my $pod2man = "$downdir/perl -I $downdir/lib $downdir/pod/pod2man --section=$manext --official"; - mkpath($mandir, $opts{verbose}, 0777) unless $opts{notify}; # In File::Path # Make a list of all the .pm and .pod files in the directory. We will - # always run pod2man from the lib directory and feed it the full pathname - # of the pod. This might be useful for pod2man someday. + # always run from the lib directory and use the full pathname + # of the pod. if (@script) { @modpods = @script; } @@ -160,22 +146,23 @@ sub runpod2man { $manpage = "${mandir}/${manpage}.${manext}"; push @to_process, [$mod, $tmp, $manpage]; } - # Don't do all pods in same command to avoid busting command line limits - while (my @this_batch = splice @to_process, 0, $opts{batchlimit}) { - my $cmd = join " ", $pod2man, map "$$_[0] $$_[1]", @this_batch; - if (&cmd($cmd) == 0 && !$opts{notify}) { - foreach (@this_batch) { - my (undef, $tmp, $manpage) = @$_; - if (-s $tmp) { - if (rename($tmp, $manpage)) { - $packlist->{$manpage} = { type => 'file' }; - next; - } - } - unless ($opts{notify}) { - unlink($tmp); - } - } + + my $parser = Pod::Man->new( section => $manext, + official=> 1, + center => 'Perl Programmers Reference Guide' + ); + foreach my $page (@to_process) { + my($pod, $tmp, $manpage) = @$page; + + print " $manpage\n"; + if (!$opts{notify} && $parser->parse_from_file($pod, $tmp)) { + if (-s $tmp) { + if (rename($tmp, $manpage)) { + $packlist->{$manpage} = { type => 'file' }; + next; + } + } + unlink($tmp); } } chdir "$builddir" || die "Unable to cd back to $builddir directory!\n$!\n"; @@ -200,21 +187,6 @@ exit 0; ############################################################################### # Utility subroutines from installperl -sub cmd { - my ($cmd) = @_; - print " $cmd\n" if $opts{verbose}; - unless ($opts{notify}) { - if ($Config{d_fork}) { - fork ? wait : exec $cmd; # Allow user to ^C out of command. - } - else { - system $cmd; - } - warn "Command failed!!\n" if $?; - } - return $? != 0; -} - sub unlink { my(@names) = @_; my $cnt = 0; @@ -233,7 +205,7 @@ sub link { my($from,$to) = @_; my($success) = 0; - print $opts{verbose} ? " ln $from $to\n" : " $to\n" unless $opts{silent}; + print " ln $from $to\n" if $opts{verbose}; eval { CORE::link($from, $to) ? $success++ diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index ef8bfab2dc..b34fe28c18 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -139,7 +139,7 @@ sub prompt ($;$) { my $ans; local $|=1; print "$mess $dispdef"; - if ($ISA_TTY) { + if ($ISA_TTY && !$ENV{PERL_MM_USE_DEFAULT}) { chomp($ans = <STDIN>); } else { print "$def\n"; @@ -2147,6 +2147,11 @@ Command line options used by C<MakeMaker-E<gt>new()>, and thus by C<WriteMakefile()>. The string is split on whitespace, and the result is processed before any actual command line arguments are processed. +=item PERL_MM_USE_DEFAULT + +If set to a true value then MakeMaker's prompt function will +always return the default without waiting for user input. + =back =head1 SEE ALSO diff --git a/lib/File/Find.pm b/lib/File/Find.pm index ae76323e4c..7bcd2706e8 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -2,7 +2,7 @@ package File::Find; use 5.006; use strict; use warnings; -our $VERSION = '1.02'; +our $VERSION = '1.03'; require Exporter; require Cwd; @@ -180,9 +180,6 @@ Notice the C<_> in the above C<int(-M _)>: the C<_> is a magical filehandle that caches the information from the preceding stat(), lstat(), or filetest. -Set the variable C<$File::Find::dont_use_nlink> if you're using AFS, -since AFS cheats. - Here's another interesting wanted function. It will find all symbolic links that don't resolve: @@ -195,6 +192,23 @@ module. =head1 CAVEAT +=over 2 + +=item $dont_use_nlink + +You can set the variable C<$File::Find::dont_use_nlink> to 1, if you want to +force File::Find to always stat directories. This was used for systems +that do not have the correct C<nlink> count for directories. Examples are +ISO-9660 (CD-R), AFS, and operating systems like OS/2, DOS and a couple of +others. + +Since now File::Find should now detect such things on-the-fly and switch it +self to using stat, this will probably not a problem to you. + +If you do set $dont_use_nlink to 1, you will notice slow-downs. + +=item symlinks + Be aware that the option to follow symbolic links can be dangerous. Depending on the structure of the directory tree (including symbolic links to directories) you might traverse a given (physical) directory @@ -203,6 +217,8 @@ Furthermore, deleting or changing files in a symbolically linked directory might cause very unpleasant surprises, since you delete or change files in an unknown directory. +=back + =head1 NOTES =over 4 @@ -643,6 +659,7 @@ sub _find_dir($$$) { my $dir_pref; my $dir_rel = $File::Find::current_dir; my $tainted = 0; + my $no_nlink; if ($Is_MacOS) { $dir_pref= ($p_dir =~ /:$/) ? $p_dir : "$p_dir:"; # preface @@ -736,7 +753,13 @@ sub _find_dir($$$) { @filenames = &$pre_process(@filenames) if $pre_process; push @Stack,[$CdLvl,$dir_name,"",-2] if $post_process; - if ($nlink == 2 && !$avoid_nlink) { + # default: use whatever was specifid + # (if $nlink >= 2, and $avoid_nlink == 0, this will switch back) + $no_nlink = $avoid_nlink; + # if dir has wrong nlink count, force switch to slower stat method + $no_nlink = 1 if ($nlink < 2); + + if ($nlink == 2 && !$no_nlink) { # This dir has no subdirectories. for my $FN (@filenames) { next if $FN =~ $File::Find::skip_pattern; @@ -753,7 +776,7 @@ sub _find_dir($$$) { for my $FN (@filenames) { next if $FN =~ $File::Find::skip_pattern; - if ($subcount > 0 || $avoid_nlink) { + if ($subcount > 0 || $no_nlink) { # Seen all the subdirs? # check for directoriness. # stat is faster for a file in the current directory diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index 01e0e9161e..957c272549 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -2,12 +2,12 @@ package Getopt::Long; -# RCS Status : $Id: GetoptLong.pl,v 2.28 2001-08-05 18:41:09+02 jv Exp $ +# RCS Status : $Id: GetoptLong.pm,v 2.45 2001-09-27 17:39:47+02 jv Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Sun Aug 5 18:41:06 2001 -# Update Count : 751 +# Last Modified On: Thu Sep 27 17:38:47 2001 +# Update Count : 980 # Status : Released ################ Copyright ################ @@ -34,13 +34,13 @@ use 5.004; use strict; -use vars qw($VERSION $VERSION_STRING); -$VERSION = 2.26; +use vars qw($VERSION); +$VERSION = 2.26_02; # For testing versions only. -#$VERSION_STRING = "2.25_13"; +use vars qw($VERSION_STRING); +$VERSION_STRING = "2.26_02"; use Exporter; -use AutoLoader qw(AUTOLOAD); use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); @ISA = qw(Exporter); @@ -67,7 +67,9 @@ sub GetOptions; # Private subroutines. sub ConfigDefaults (); -sub FindOption ($$$$$$$); +sub ParseOptionSpec ($$); +sub OptCtl ($); +sub FindOption ($$$$); sub Croak (@); # demand loading the real Croak ################ Local Variables ################ @@ -196,7 +198,14 @@ sub getoptions { # Call main routine. my $ret = 0; $Getopt::Long::caller = $self->{caller_pkg}; - eval { $ret = Getopt::Long::GetOptions (@_); }; + + eval { + # Locally set exception handler to default, otherwise it will + # be called implicitly here, and again explicitly when we try + # to deliver the messages. + local ($SIG{__DIE__}) = '__DEFAULT__'; + $ret = Getopt::Long::GetOptions (@_); + }; # Restore saved settings. Getopt::Long::Configure ($save); @@ -208,49 +217,49 @@ sub getoptions { package Getopt::Long; -################ Package return ################ +# Indices in option control info. +use constant CTL_TYPE => 0; +#use constant CTL_TYPE_FLAG => ''; +#use constant CTL_TYPE_NEG => '!'; +#use constant CTL_TYPE_INCR => '+'; +#use constant CTL_TYPE_INT => 'i'; +#use constant CTL_TYPE_XINT => 'o'; +#use constant CTL_TYPE_FLOAT => 'f'; +#use constant CTL_TYPE_STRING => 's'; -1; +use constant CTL_MAND => 1; -__END__ +use constant CTL_DEST => 2; + use constant CTL_DEST_SCALAR => 0; + use constant CTL_DEST_ARRAY => 1; + use constant CTL_DEST_HASH => 2; + use constant CTL_DEST_CODE => 3; -################ AutoLoading subroutines ################ +use constant CTL_RANGE => 3; -package Getopt::Long; +use constant CTL_REPEAT => 4; -use strict; - -# RCS Status : $Id: GetoptLongAl.pl,v 2.34 2001-08-05 18:42:45+02 jv Exp $ -# Author : Johan Vromans -# Created On : Fri Mar 27 11:50:30 1998 -# Last Modified By: Johan Vromans -# Last Modified On: Sat Aug 4 17:32:13 2001 -# Update Count : 128 -# Status : Released +use constant CTL_CNAME => 5; sub GetOptions { my @optionlist = @_; # local copy of the option descriptions my $argend = '--'; # option list terminator - my %opctl = (); # table of arg.specs (long and abbrevs) - my %bopctl = (); # table of arg.specs (bundles) + my %opctl = (); # table of option specs my $pkg = $caller || (caller)[0]; # current context # Needed if linkage is omitted. - my %aliases= (); # alias table my @ret = (); # accum for non-options my %linkage; # linkage my $userlinkage; # user supplied HASH my $opt; # current option - my $genprefix = $genprefix; # so we can call the same module many times - my @opctl; # the possible long option names + my $prefix = $genprefix; # current prefix $error = ''; - print STDERR ("GetOpt::Long $Getopt::Long::VERSION ", + print STDERR ("GetOpt::Long $Getopt::Long::VERSION (", + '$Revision: 2.45 $', ") ", "called from package \"$pkg\".", "\n ", - 'GetOptionsAl $Revision: 2.34 $ ', - "\n ", "ARGV: (@ARGV)", "\n ", "autoabbrev=$autoabbrev,". @@ -282,20 +291,20 @@ sub GetOptions { && !($optionlist[0] eq '<>' && @optionlist > 0 && ref($optionlist[1])) ) { - $genprefix = shift (@optionlist); + $prefix = shift (@optionlist); # Turn into regexp. Needs to be parenthesized! - $genprefix =~ s/(\W)/\\$1/g; - $genprefix = "([" . $genprefix . "])"; + $prefix =~ s/(\W)/\\$1/g; + $prefix = "([" . $prefix . "])"; + print STDERR ("=> prefix=\"$prefix\"\n") if $debug; } # Verify correctness of optionlist. %opctl = (); - %bopctl = (); while ( @optionlist ) { my $opt = shift (@optionlist); # Strip leading prefix so people can specify "--foo=i" if they like. - $opt = $+ if $opt =~ /^$genprefix+(.*)$/s; + $opt = $+ if $opt =~ /^$prefix+(.*)$/s; if ( $opt eq '<>' ) { if ( (defined $userlinkage) @@ -313,82 +322,24 @@ sub GetOptions { next; } - # Match option spec. Allow '?' as an alias only. - if ( $opt !~ /^((\w+[-\w]*)(\|(\?|\w[-\w]*)?)*)?([!~+]|[=:][ionfse][@%]?)?$/ ) { - $error .= "Error in option spec: \"$opt\"\n"; + # Parse option spec. + my ($name, $orig) = ParseOptionSpec ($opt, \%opctl); + unless ( defined $name ) { + # Failed. $orig contains the error message. Sorry for the abuse. + $error .= $orig; next; } - my ($o, $c, $a) = ($1, $5); - $c = '' unless defined $c; - - # $linko keeps track of the primary name the user specified. - # This name will be used for the internal or external linkage. - # In other words, if the user specifies "FoO|BaR", it will - # match any case combinations of 'foo' and 'bar', but if a global - # variable needs to be set, it will be $opt_FoO in the exact case - # as specified. - my $linko; - - if ( ! defined $o ) { - # empty -> '-' option - $linko = $o = ''; - $opctl{''} = $c; - $bopctl{''} = $c if $bundling; - } - else { - # Handle alias names - my @o = split (/\|/, $o); - $linko = $o = $o[0]; - # Force an alias if the option name is not locase. - $a = $o unless $o eq lc($o); - $o = lc ($o) - if $ignorecase > 1 - || ($ignorecase - && ($bundling ? length($o) > 1 : 1)); - - foreach ( @o ) { - if ( $bundling && length($_) == 1 ) { - $_ = lc ($_) if $ignorecase > 1; - if ( $c eq '!' ) { - $opctl{"no$_"} = $c; - # warn ("Ignoring '!' modifier for short option $_\n"); - $opctl{$_} = $bopctl{$_} = ''; - } - else { - $opctl{$_} = $bopctl{$_} = $c; - } - } - else { - $_ = lc ($_) if $ignorecase; - if ( $c eq '!' ) { - $opctl{"no$_"} = $c; - $opctl{$_} = '' - } - else { - $opctl{$_} = $c; - } - } - if ( defined $a ) { - # Note alias. - $aliases{$_} = $a; - } - else { - # Set primary name. - $a = $_; - } - } - } # If no linkage is supplied in the @optionlist, copy it from # the userlinkage if available. if ( defined $userlinkage ) { unless ( @optionlist > 0 && ref($optionlist[0]) ) { - if ( exists $userlinkage->{$linko} && - ref($userlinkage->{$linko}) ) { - print STDERR ("=> found userlinkage for \"$linko\": ", - "$userlinkage->{$linko}\n") + if ( exists $userlinkage->{$orig} && + ref($userlinkage->{$orig}) ) { + print STDERR ("=> found userlinkage for \"$orig\": ", + "$userlinkage->{$orig}\n") if $debug; - unshift (@optionlist, $userlinkage->{$linko}); + unshift (@optionlist, $userlinkage->{$orig}); } else { # Do nothing. Being undefined will be handled later. @@ -399,26 +350,18 @@ sub GetOptions { # Copy the linkage. If omitted, link to global variable. if ( @optionlist > 0 && ref($optionlist[0]) ) { - print STDERR ("=> link \"$linko\" to $optionlist[0]\n") + print STDERR ("=> link \"$orig\" to $optionlist[0]\n") if $debug; - if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) { - $linkage{$linko} = shift (@optionlist); + my $rl = ref($linkage{$orig} = shift (@optionlist)); + + if ( $rl eq "ARRAY" ) { + $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY; } - elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) { - $linkage{$linko} = shift (@optionlist); - $opctl{$o} .= '@' - if $opctl{$o} ne '' and $opctl{$o} !~ /\@$/; - $bopctl{$o} .= '@' - if $bundling and defined $bopctl{$o} and - $bopctl{$o} ne '' and $bopctl{$o} !~ /\@$/; + elsif ( $rl eq "HASH" ) { + $opctl{$name}[CTL_DEST] = CTL_DEST_HASH; } - elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) { - $linkage{$linko} = shift (@optionlist); - $opctl{$o} .= '%' - if $opctl{$o} ne '' and $opctl{$o} !~ /\%$/; - $bopctl{$o} .= '%' - if $bundling and defined $bopctl{$o} and - $bopctl{$o} ne '' and $bopctl{$o} !~ /\%$/; + elsif ( $rl eq "SCALAR" || $rl eq "CODE" ) { + # Ok. } else { $error .= "Invalid option linkage for \"$opt\"\n"; @@ -427,22 +370,22 @@ sub GetOptions { else { # Link to global $opt_XXX variable. # Make sure a valid perl identifier results. - my $ov = $linko; + my $ov = $orig; $ov =~ s/\W/_/g; - if ( $c =~ /@/ ) { - print STDERR ("=> link \"$linko\" to \@$pkg","::opt_$ov\n") + if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) { + print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n") if $debug; - eval ("\$linkage{\$linko} = \\\@".$pkg."::opt_$ov;"); + eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;"); } - elsif ( $c =~ /%/ ) { - print STDERR ("=> link \"$linko\" to \%$pkg","::opt_$ov\n") + elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) { + print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n") if $debug; - eval ("\$linkage{\$linko} = \\\%".$pkg."::opt_$ov;"); + eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;"); } else { - print STDERR ("=> link \"$linko\" to \$$pkg","::opt_$ov\n") + print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n") if $debug; - eval ("\$linkage{\$linko} = \\\$".$pkg."::opt_$ov;"); + eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;"); } } } @@ -451,20 +394,12 @@ sub GetOptions { die ($error) if $error; $error = 0; - # Sort the possible long option names. - @opctl = sort(keys (%opctl)) if $autoabbrev; - # Show the options tables if debugging. if ( $debug ) { my ($arrow, $k, $v); $arrow = "=> "; while ( ($k,$v) = each(%opctl) ) { - print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n"); - $arrow = " "; - } - $arrow = "=> "; - while ( ($k,$v) = each(%bopctl) ) { - print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n"); + print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n"); $arrow = " "; } } @@ -473,31 +408,22 @@ sub GetOptions { my $goon = 1; while ( $goon && @ARGV > 0 ) { - #### Get next argument #### - + # Get next argument. $opt = shift (@ARGV); - print STDERR ("=> option \"", $opt, "\"\n") if $debug; - - #### Determine what we have #### + print STDERR ("=> arg \"", $opt, "\"\n") if $debug; # Double dash is option list terminator. - if ( $opt eq $argend ) { - # Finish. Push back accumulated arguments and return. - unshift (@ARGV, @ret) - if $order == $PERMUTE; - return ($error == 0); - } + last if $opt eq $argend; + # Look it up. my $tryopt = $opt; my $found; # success status - my $dsttype; # destination type ('@' or '%') - my $incr; # destination increment my $key; # key (if hash type) my $arg; # option argument + my $ctl; # the opctl entry - ($found, $opt, $arg, $dsttype, $incr, $key) = - FindOption ($genprefix, $argend, $opt, - \%opctl, \%bopctl, \@opctl, \%aliases); + ($found, $opt, $ctl, $arg, $key) = + FindOption ($prefix, $argend, $opt, \%opctl); if ( $found ) { @@ -505,18 +431,18 @@ sub GetOptions { next unless defined $opt; if ( defined $arg ) { - if ( defined $aliases{$opt} ) { - print STDERR ("=> alias \"$opt\" -> \"$aliases{$opt}\"\n") - if $debug; - $opt = $aliases{$opt}; - } + + # Get the canonical name. + print STDERR ("=> cname for \"$opt\" is ") if $debug; + $opt = $ctl->[CTL_CNAME]; + print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug; if ( defined $linkage{$opt} ) { print STDERR ("=> ref(\$L{$opt}) -> ", ref($linkage{$opt}), "\n") if $debug; if ( ref($linkage{$opt}) eq 'SCALAR' ) { - if ( $incr ) { + if ( $ctl->[CTL_TYPE] eq '+' ) { print STDERR ("=> \$\$L{$opt} += \"$arg\"\n") if $debug; if ( defined ${$linkage{$opt}} ) { @@ -543,11 +469,16 @@ sub GetOptions { $linkage{$opt}->{$key} = $arg; } elsif ( ref($linkage{$opt}) eq 'CODE' ) { - print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n") + print STDERR ("=> &L{$opt}(\"$opt\"", + $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "", + ", \"$arg\")\n") if $debug; local ($@); eval { - &{$linkage{$opt}}($opt, $arg); + local $SIG{__DIE__} = '__DEFAULT__'; + &{$linkage{$opt}}($opt, + $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (), + $arg); }; print STDERR ("=> die($@)\n") if $debug && $@ ne ''; if ( $@ =~ /^!/ ) { @@ -567,7 +498,7 @@ sub GetOptions { } } # No entry in linkage means entry in userlinkage. - elsif ( $dsttype eq '@' ) { + elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) { if ( defined $userlinkage->{$opt} ) { print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n") if $debug; @@ -579,7 +510,7 @@ sub GetOptions { $userlinkage->{$opt} = [$arg]; } } - elsif ( $dsttype eq '%' ) { + elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { if ( defined $userlinkage->{$opt} ) { print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n") if $debug; @@ -592,7 +523,7 @@ sub GetOptions { } } else { - if ( $incr ) { + if ( $ctl->[CTL_TYPE] eq '+' ) { print STDERR ("=> \$L{$opt} += \"$arg\"\n") if $debug; if ( defined $userlinkage->{$opt} ) { @@ -616,7 +547,10 @@ sub GetOptions { my $cb; if ( (defined ($cb = $linkage{'<>'})) ) { local ($@); + print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n") + if $debug; eval { + local $SIG{__DIE__} = '__DEFAULT__'; &$cb ($tryopt); }; print STDERR ("=> die($@)\n") if $debug && $@ ne ''; @@ -648,41 +582,132 @@ sub GetOptions { } # Finish. - if ( $order == $PERMUTE ) { + if ( @ret && $order == $PERMUTE ) { # Push back accumulated arguments print STDERR ("=> restoring \"", join('" "', @ret), "\"\n") - if $debug && @ret > 0; - unshift (@ARGV, @ret) if @ret > 0; + if $debug; + unshift (@ARGV, @ret); } return ($error == 0); } +# A readable representation of what's in an optbl. +sub OptCtl ($) { + my ($v) = @_; + my @v = map { defined($_) ? ($_) : ("<undef>") } @$v; + "[". + join(",", + "\"$v[CTL_TYPE]\"", + $v[CTL_MAND] ? "O" : "M", + ("\$","\@","\%","\&")[$v[CTL_DEST] || 0], + $v[CTL_RANGE] || '', + $v[CTL_REPEAT] || '', + "\"$v[CTL_CNAME]\"", + ). "]"; +} + +# Parse an option specification and fill the tables. +sub ParseOptionSpec ($$) { + my ($opt, $opctl) = @_; + + # Match option spec. Allow '?' as an alias only. + if ( $opt !~ m;^ + ( + # Option name + (?: \w+[-\w]* ) + # Alias names, or "?" + (?: \| (?: \? | \w[-\w]* )? )* + )? + ( + # Either modifiers ... + [!+] + | + # ... or a value/dest specification. + [=:][ionfs][@%]? + )? + $;x ) { + return (undef, "Error in option spec: \"$opt\"\n"); + } + + my ($names, $spec) = ($1, $2); + $spec = '' unless defined $spec; + + # $orig keeps track of the primary name the user specified. + # This name will be used for the internal or external linkage. + # In other words, if the user specifies "FoO|BaR", it will + # match any case combinations of 'foo' and 'bar', but if a global + # variable needs to be set, it will be $opt_FoO in the exact case + # as specified. + my $orig; + + my @names; + if ( defined $names ) { + @names = split (/\|/, $names); + $orig = $names[0]; + } + else { + @names = (''); + $orig = ''; + } + + # Construct the opctl entries. + my $entry; + if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) { + $entry = [$spec,0,CTL_DEST_SCALAR,undef,undef,$orig]; + } + else { + my ($mand, $type, $dest) = $spec =~ /([=:])([ionfs])([@%])?/; + $type = 'i' if $type eq 'n'; + $dest ||= '$'; + $dest = $dest eq '@' ? CTL_DEST_ARRAY + : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR; + $entry = [$type,$mand eq '=',$dest,undef,undef,$orig]; + } + + # Process all names. First is canonical, the rest are aliases. + foreach ( @names ) { + + $_ = lc ($_) + if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0); + + if ( $spec eq '!' ) { + $opctl->{"no$_"} = $entry; + $opctl->{$_} = [@$entry]; + $opctl->{$_}->[CTL_TYPE] = ''; + } + else { + $opctl->{$_} = $entry; + } + } + + ($names[0], $orig); +} + # Option lookup. -sub FindOption ($$$$$$$) { +sub FindOption ($$$$) { - # returns (1, $opt, $arg, $dsttype, $incr, $key) if okay, + # returns (1, $opt, $ctl, $arg, $key) if okay, + # returns (1, undef) if option in error, # returns (0) otherwise. - my ($prefix, $argend, $opt, $opctl, $bopctl, $names, $aliases) = @_; - my $key; # hash key for a hash option - my $arg; + my ($prefix, $argend, $opt, $opctl) = @_; - print STDERR ("=> find \"$opt\", prefix=\"$prefix\"\n") if $debug; + print STDERR ("=> find \"$opt\"\n") if $debug; - return 0 unless $opt =~ /^$prefix(.*)$/s; - return 0 if $opt eq "-" && !defined $opctl->{""}; + return (0) unless $opt =~ /^$prefix(.*)$/s; + return (0) if $opt eq "-" && !defined $opctl->{""}; $opt = $+; - my ($starter) = $1; + my $starter = $1; print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug; - my $optarg = undef; # value supplied with --opt=value - my $rest = undef; # remainder from unbundling + my $optarg; # value supplied with --opt=value + my $rest; # remainder from unbundling # If it is a long option, it may include the value. - # With getopt_compat, not if bundling. + # With getopt_compat, only if not bundling. if ( ($starter eq "--" || ($getopt_compat && ($bundling == 0 || $bundling == 2))) && $opt =~ /^([^=]+)=(.*)$/s ) { @@ -694,50 +719,51 @@ sub FindOption ($$$$$$$) { #### Look it up ### - my $tryopt = $opt; # option to try - my $optbl = $opctl; # table to look it up (long names) - my $type; - my $dsttype = ''; - my $incr = 0; + my $tryopt; # option to try if ( $bundling && $starter eq '-' ) { - # Unbundle single letter option. - $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : ""; - $tryopt = substr ($tryopt, 0, 1); - $tryopt = lc ($tryopt) if $ignorecase > 1; - print STDERR ("=> $starter$tryopt unbundled from ", - "$starter$tryopt$rest\n") if $debug; - $rest = undef unless $rest ne ''; - $optbl = $bopctl; # look it up in the short names table + + # To try overides, obey case ignore. + $tryopt = $ignorecase ? lc($opt) : $opt; # If bundling == 2, long options can override bundles. - if ( $bundling == 2 and - defined ($rest) and - defined ($type = $opctl->{$tryopt.$rest}) ) { - print STDERR ("=> $starter$tryopt rebundled to ", + if ( $bundling == 2 && defined ($opctl->{$tryopt}) ) { + print STDERR ("=> $starter$tryopt overrides unbundling\n") + if $debug; + } + else { + $tryopt = $opt; + # Unbundle single letter option. + $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : ""; + $tryopt = substr ($tryopt, 0, 1); + $tryopt = lc ($tryopt) if $ignorecase > 1; + print STDERR ("=> $starter$tryopt unbundled from ", "$starter$tryopt$rest\n") if $debug; - $tryopt .= $rest; - undef $rest; + $rest = undef unless $rest ne ''; } } # Try auto-abbreviation. elsif ( $autoabbrev ) { + # Sort the possible long option names. + my @names = sort(keys (%$opctl)); # Downcase if allowed. - $tryopt = $opt = lc ($opt) if $ignorecase; + $opt = lc ($opt) if $ignorecase; + $tryopt = $opt; # Turn option name into pattern. my $pat = quotemeta ($opt); # Look up in option names. - my @hits = grep (/^$pat/, @{$names}); + my @hits = grep (/^$pat/, @names); print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ", - "out of ", scalar(@{$names}), "\n") if $debug; + "out of ", scalar(@names), "\n") if $debug; # Check for ambiguous results. unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) { # See if all matches are for the same option. my %hit; foreach ( @hits ) { - $_ = $aliases->{$_} if defined $aliases->{$_}; + $_ = $opctl->{$_}->[CTL_CNAME] + if defined $opctl->{$_}->[CTL_CNAME]; $hit{$_} = 1; } # Now see if it really is ambiguous. @@ -746,8 +772,7 @@ sub FindOption ($$$$$$$) { warn ("Option ", $opt, " is ambiguous (", join(", ", @hits), ")\n"); $error++; - undef $opt; - return (1, $opt,$arg,$dsttype,$incr,$key); + return (1, undef); } @hits = keys(%hit); } @@ -767,20 +792,24 @@ sub FindOption ($$$$$$$) { } # Check validity by fetching the info. - $type = $optbl->{$tryopt} unless defined $type; - unless ( defined $type ) { + my $ctl = $opctl->{$tryopt}; + unless ( defined $ctl ) { return (0) if $passthrough; warn ("Unknown option: ", $opt, "\n"); $error++; - return (1, $opt,$arg,$dsttype,$incr,$key); + return (1, undef); } # Apparently valid. $opt = $tryopt; - print STDERR ("=> found \"$type\" for \"", $opt, "\"\n") if $debug; + print STDERR ("=> found ", OptCtl($ctl), + " for \"", $opt, "\"\n") if $debug; #### Determine argument status #### # If it is an option w/o argument, we're almost finished with it. + my $type = $ctl->[CTL_TYPE]; + my $arg; + if ( $type eq '' || $type eq '!' || $type eq '+' ) { if ( defined $optarg ) { return (0) if $passthrough; @@ -790,26 +819,24 @@ sub FindOption ($$$$$$$) { } elsif ( $type eq '' || $type eq '+' ) { $arg = 1; # supply explicit value - $incr = $type eq '+'; } else { - substr ($opt, 0, 2) = ''; # strip NO prefix + $opt =~ s/^no//i; # strip NO prefix $arg = 0; # supply explicit value } unshift (@ARGV, $starter.$rest) if defined $rest; - return (1, $opt,$arg,$dsttype,$incr,$key); + return (1, $opt, $ctl, $arg); } # Get mandatory status and type info. - my $mand; - ($mand, $type, $dsttype, $key) = $type =~ /^(.)(.)([@%]?)$/; + my $mand = $ctl->[CTL_MAND]; # Check if there is an option argument available. if ( $gnu_compat ) { - return (1, $opt, $optarg, $dsttype, $incr, $key) + return (1, $opt, $ctl, $optarg) if defined $optarg; - return (1, $opt, $type eq "s" ? '' : 0, $dsttype, $incr, $key) - if $mand eq ':'; + return (1, $opt, $ctl, $type eq "s" ? '' : 0) + unless $mand; } # Check if there is an option argument available. @@ -817,13 +844,13 @@ sub FindOption ($$$$$$$) { ? ($optarg eq '') : !(defined $rest || @ARGV > 0) ) { # Complain if this option needs an argument. - if ( $mand eq "=" ) { + if ( $mand ) { return (0) if $passthrough; warn ("Option ", $opt, " requires an argument\n"); $error++; - undef $opt; + return (1, undef); } - return (1, $opt, $type eq "s" ? '' : 0, $dsttype, $incr, $key); + return (1, $opt, $ctl, $type eq "s" ? '' : 0); } # Get (possibly optional) argument. @@ -831,8 +858,8 @@ sub FindOption ($$$$$$$) { : (defined $optarg ? $optarg : shift (@ARGV))); # Get key if this is a "name=value" pair for a hash option. - $key = undef; - if ($dsttype eq '%' && defined $arg) { + my $key; + if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) { ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2) : ($arg, 1); } @@ -840,12 +867,12 @@ sub FindOption ($$$$$$$) { if ( $type eq "s" ) { # string # A mandatory string takes anything. - return (1, $opt,$arg,$dsttype,$incr,$key) if $mand eq "="; + return (1, $opt, $ctl, $arg, $key) if $mand; # An optional string takes almost anything. - return (1, $opt,$arg,$dsttype,$incr,$key) + return (1, $opt, $ctl, $arg, $key) if defined $optarg || defined $rest; - return (1, $opt,$arg,$dsttype,$incr,$key) if $arg eq "-"; # ?? + return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ?? # Check for option or option list terminator. if ($arg eq $argend || @@ -857,7 +884,7 @@ sub FindOption ($$$$$$$) { } } - elsif ( $type eq "n" || $type eq "i" # numeric/integer + elsif ( $type eq "i" # numeric/integer || $type eq "o" ) { # dec/oct/hex/bin value my $o_valid = @@ -874,7 +901,7 @@ sub FindOption ($$$$$$$) { $arg = ($type eq "o" && $arg =~ /^0/) ? oct($arg) : 0+$arg; } else { - if ( defined $optarg || $mand eq "=" ) { + if ( defined $optarg || $mand ) { if ( $passthrough ) { unshift (@ARGV, defined $rest ? $starter.$rest : $arg) unless defined $optarg; @@ -885,9 +912,9 @@ sub FindOption ($$$$$$$) { $type eq "o" ? "extended " : "", "number expected)\n"); $error++; - undef $opt; # Push back. unshift (@ARGV, $starter.$rest) if defined $rest; + return (1, undef); } else { # Push back. @@ -909,7 +936,7 @@ sub FindOption ($$$$$$$) { unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; } elsif ( $arg !~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/ ) { - if ( defined $optarg || $mand eq "=" ) { + if ( defined $optarg || $mand ) { if ( $passthrough ) { unshift (@ARGV, defined $rest ? $starter.$rest : $arg) unless defined $optarg; @@ -918,9 +945,9 @@ sub FindOption ($$$$$$$) { warn ("Value \"", $arg, "\" invalid for option ", $opt, " (real number expected)\n"); $error++; - undef $opt; # Push back. unshift (@ARGV, $starter.$rest) if defined $rest; + return (1, undef); } else { # Push back. @@ -933,7 +960,7 @@ sub FindOption ($$$$$$$) { else { Croak ("GetOpt::Long internal error (Can't happen)\n"); } - return (1, $opt, $arg, $dsttype, $incr, $key); + return (1, $opt, $ctl, $arg, $key); } # Getopt::Long Configuration. @@ -978,7 +1005,7 @@ sub Configure (@) { $gnu_compat = 1; $bundling = 1; $getopt_compat = 0; - $permute = 1; + $order = $PERMUTE; } } elsif ( $try eq 'gnu_compat' ) { @@ -1283,9 +1310,12 @@ Ultimate control over what should be done when (actually: each time) an option is encountered on the command line can be achieved by designating a reference to a subroutine (or an anonymous subroutine) as the option destination. When GetOptions() encounters the option, it -will call the subroutine with two arguments: the name of the option, -and the value to be assigned. It is up to the subroutine to store the -value, or do whatever it thinks is appropriate. +will call the subroutine with two or three arguments. The first +argument is the name of the option. For a scalar or array destination, +the second argument is the value to be stored. For a hash destination, +the second arguments is the key to the hash, and the third argument +the value to be stored. It is up to the subroutine to store the value, +or do whatever it thinks is appropriate. A trivial application of this mechanism is to implement options that are related to each other. For example: @@ -1607,12 +1637,12 @@ example: A lone dash on the command line will now be a legal option, and using it will set variable C<$stdio>. -=head2 Argument call-back +=head2 Argument callback A special option 'name' C<<>> can be used to designate a subroutine to handle non-option arguments. When GetOptions() encounters an argument that does not look like an option, it will immediately call this -subroutine and passes it the argument as a parameter. +subroutine and passes it one parameter: the argument name. For example: @@ -1709,14 +1739,14 @@ is equivalent to --foo --bar arg1 arg2 arg3 -If an argument call-back routine is specified, C<@ARGV> will always be +If an argument callback routine is specified, C<@ARGV> will always be empty upon succesful return of GetOptions() since all options have been processed. The only exception is when C<--> is used: --foo arg1 --bar arg2 -- arg3 -will call the call-back routine for arg1 and arg2, and terminate -GetOptions() leaving C<"arg2"> in C<@ARGV>. +This will call the callback routine for arg1 and arg2, and then +terminate GetOptions() leaving C<"arg2"> in C<@ARGV>. If C<require_order> is enabled, options processing terminates when the first non-option is encountered. @@ -1894,13 +1924,44 @@ long names only, e.g., That's why they're called 'options'. +=head2 GetOptions does not split the command line correctly + +The command line is not split by GetOptions, but by the command line +interpreter (CLI). On Unix, this is the shell. On Windows, it is +COMMAND.COM or CMD.EXE. Other operating systems have other CLIs. + +It is important to know that these CLIs may behave different when the +command line contains special characters, in particular quotes or +backslashes. For example, with Unix shells you can use single quotes +(C<'>) and double quotes (C<">) to group words together. The following +alternatives are equivalent on Unix: + + "two words" + 'two words' + two\ words + +In case of doubt, insert the following statement in front of your Perl +program: + + print STDERR (join("|",@ARGV),"\n"); + +to verify how your CLI passes the arguments to the program. + +=head2 How do I put a "-?" option into a Getopt::Long? + +You can only obtain this using an alias, and Getopt::Long of at least +version 2.13. + + use Getopt::Long; + GetOptions ("help|?"); # -help and -? will both set $opt_help + =head1 AUTHOR Johan Vromans <jvromans@squirrel.nl> =head1 COPYRIGHT AND DISCLAIMER -This program is Copyright 2000,1990 by Johan Vromans. +This program is Copyright 2001,1990 by Johan Vromans. This program is free software; you can redistribute it and/or modify it under the terms of the Perl Artistic License or the GNU General Public License as published by the Free Software diff --git a/lib/Getopt/Long/CHANGES b/lib/Getopt/Long/CHANGES index b43606a5d6..deaa472fb2 100644 --- a/lib/Getopt/Long/CHANGES +++ b/lib/Getopt/Long/CHANGES @@ -1,3 +1,23 @@ +Changes in version 2.27 +----------------------- + +* Fix several problems with internal and external use of 'die' and + signal handlers. + +* Fixed some bugs with subtle combinations of bundling_override and + ignore_case. + +* A callback routine that is associated with a hash-valued option will + now have both the hask key and the value passed. It used to get only + the value passed. + +* Eliminated the use of autoloading. Autoloading kept generating + problems during development, and when using perlcc. + +* Lots of internal restructoring to make room for extensions. + +* Redesigned the regression tests. + Changes in version 2.26 ----------------------- diff --git a/lib/Net/Config.pm b/lib/Net/Config.pm index db503b5876..9dd66ba227 100644 --- a/lib/Net/Config.pm +++ b/lib/Net/Config.pm @@ -107,8 +107,8 @@ C<Net::Config> holds configuration data for the modules in the libnet distribuion. During installation you will be asked for these values. The configuration data is held globally in a file in the perl installation -tree, but a user may override any of these values by providing thier own. This -can be done by having a C<.libnetrc> file in thier home directory. This file +tree, but a user may override any of these values by providing their own. This +can be done by having a C<.libnetrc> file in their home directory. This file should return a reference to a HASH containing the keys described below. For example @@ -175,8 +175,8 @@ C<"hostname:port"> (eg C<"hostname:99">) =item ftp_firewall_type -There are many different ftp firewall products avaliable. But unfortunately there -is not standard for how to traverse a firewall. The list below shows the +There are many different ftp firewall products available. But unfortunately +there is no standard for how to traverse a firewall. The list below shows the sequence of commands that Net::FTP will use user Username for remote host @@ -248,14 +248,14 @@ FTP servers normally work on a non-passive mode. That is when you want to transfer data you have to tell the server the address and port to connect to. -With some firewalls this does not work as te server cannot -connect to your machine (because you are beind a firewall) and the firewall -does not re-write te command. In this case you should set C<ftp_ext_passive> +With some firewalls this does not work as the server cannot +connect to your machine (because you are behind a firewall) and the firewall +does not re-write the command. In this case you should set C<ftp_ext_passive> to a I<true> value. Some servers are configured to only work in passive mode. If you have one of these you can force C<Net::FTP> to always transfer in passive -mode, when not going via a firewall, by cetting C<ftp_int_passive> to +mode; when not going via a firewall, by setting C<ftp_int_passive> to a I<true> value. =item local_netmask @@ -273,12 +273,12 @@ libnet package =item test_hosts -If true them C<make test> may attempt to connect to hosts given in the +If true then C<make test> may attempt to connect to hosts given in the configuration. =item test_exists -If true the C<Configure> will check each hostname given that it exists +If true then C<Configure> will check each hostname given that it exists =back diff --git a/lib/Pod/Checker.pm b/lib/Pod/Checker.pm index 79bb2f616e..b1753b95a2 100644 --- a/lib/Pod/Checker.pm +++ b/lib/Pod/Checker.pm @@ -290,7 +290,7 @@ LE<lt>...E<gt>. =item * (section) in '$page' deprecated There is a section detected in the page name of LE<lt>...E<gt>, e.g. -C<LE<gt>passwd(2)E<gt>>. POD hyperlinks may point to POD documents only. +C<LE<lt>passwd(2)E<gt>>. POD hyperlinks may point to POD documents only. Please write C<CE<lt>passwd(2)E<gt>> instead. Some formatters are able to expand this to appropriate code. For links to (builtin) functions, please say C<LE<lt>perlfunc/mkdirE<gt>>, without (). diff --git a/lib/Pod/Man.pm b/lib/Pod/Man.pm index 9c6eba0a55..ffb35dc4c3 100644 --- a/lib/Pod/Man.pm +++ b/lib/Pod/Man.pm @@ -1074,7 +1074,7 @@ sub outindex { $$self{INDEX} = []; my $output; if (@entries) { - my $output = '.IX Xref "' + $output = '.IX Xref "' . join (' ', map { s/\"/\"\"/; $_ } @entries) . '"' . "\n"; } @@ -1132,10 +1132,10 @@ sub switchquotes { # changes for nroff in =item tags, since they're unnecessary. $nroff =~ s/\\f\(CW(.*)\\f[PR]/$1/g; - # Now finally output the command. Only bother with .if if the nroff + # Now finally output the command. Only bother with .ie if the nroff # and troff output isn't the same. if ($nroff ne $troff) { - return ".if n $command $nroff\n.el $command $troff\n"; + return ".ie n $command $nroff\n.el $command $troff\n"; } else { return "$command $nroff\n"; } diff --git a/lib/Pod/Text.pm b/lib/Pod/Text.pm index 9ebca63418..3a1dc7b441 100644 --- a/lib/Pod/Text.pm +++ b/lib/Pod/Text.pm @@ -1,5 +1,5 @@ # Pod::Text -- Convert POD data to formatted ASCII text. -# $Id: Text.pm,v 2.11 2001/07/10 11:08:10 eagle Exp $ +# $Id: Text.pm,v 2.13 2001/10/20 08:07:21 eagle Exp $ # # Copyright 1999, 2000, 2001 by Russ Allbery <rra@stanford.edu> # @@ -41,7 +41,7 @@ use vars qw(@ISA @EXPORT %ESCAPES $VERSION); # Don't use the CVS revision as the version, since this module is also in Perl # core and too many things could munge CVS magic revision strings. This # number should ideally be the same as the CVS revision in podlators, however. -$VERSION = 2.11; +$VERSION = 2.13; ############################################################################## @@ -194,6 +194,9 @@ sub initialize { $$self{MARGIN} = $$self{indent}; # Current left margin in spaces. $self->SUPER::initialize; + + # Tell Pod::Parser that we want the non-POD stuff too if code was set. + $self->parseopts ('-want_nonPODs' => 1) if $$self{code}; } @@ -306,13 +309,15 @@ sub interior_sequence { local $_ = shift; return '' if ($command eq 'X' || $command eq 'Z'); - # Expand escapes into the actual character now, carping if invalid. + # Expand escapes into the actual character now, warning if invalid. if ($command eq 'E') { if (/^\d+$/) { return chr; } else { return $ESCAPES{$_} if defined $ESCAPES{$_}; - carp "Unknown escape: E<$_>"; + my $seq = shift; + my ($file, $line) = $seq->file_line; + warn "$file:$line: Unknown escape: E<$_>\n"; return "E<$_>"; } } @@ -334,15 +339,22 @@ sub interior_sequence { elsif ($command eq 'F') { return $self->seq_f ($_) } elsif ($command eq 'I') { return $self->seq_i ($_) } elsif ($command eq 'L') { return $self->seq_l ($_) } - else { carp "Unknown sequence $command<$_>" } + else { + my $seq = shift; + my ($file, $line) = $seq->file_line; + warn "$file:$line: Unknown sequence $command<$_>\n"; + } } # Called for each paragraph that's actually part of the POD. We take -# advantage of this opportunity to untabify the input. +# advantage of this opportunity to untabify the input. Also, if given the +# code option, we may see paragraphs that aren't part of the POD and need to +# output them directly. sub preprocess_paragraph { my $self = shift; local $_ = shift; 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me; + $self->output_code ($_) if $self->cutting; $_; } @@ -417,10 +429,12 @@ sub cmd_over { # End a list. sub cmd_back { - my $self = shift; + my ($self, $text, $line, $paragraph) = @_; $$self{MARGIN} = pop @{ $$self{INDENTS} }; unless (defined $$self{MARGIN}) { - carp "Unmatched =back"; + my $file; + ($file, $line) = $paragraph->file_line; + warn "$file:$line: Unmatched =back\n"; $$self{MARGIN} = $$self{indent}; } } @@ -576,7 +590,7 @@ sub item { local $_ = shift; my $tag = $$self{ITEM}; unless (defined $tag) { - carp "item called without tag"; + carp "Item called without tag"; return; } undef $$self{ITEM}; @@ -650,6 +664,11 @@ sub reformat { # Output text to the output device. sub output { $_[1] =~ tr/\01/ /; print { $_[0]->output_handle } $_[1] } +# Output a block of code (something that isn't part of the POD text). Called +# by preprocess_paragraph only if we were given the code option. Exists here +# only so that it can be overridden by subclasses. +sub output_code { $_[0]->output ($_[1]) } + ############################################################################## # Backwards compatibility @@ -740,6 +759,12 @@ If set to a true value, selects an alternate output format that, among other things, uses a different heading style and marks C<=item> entries with a colon in the left margin. Defaults to false. +=item code + +If set to a true value, the non-POD parts of the input file will be included +in the output. Useful for viewing code documented with POD blocks with the +POD rendered and the code left intact. + =item indent The number of spaces to indent regular text, and the default indentation for @@ -792,8 +817,10 @@ details. =item Bizarre space in item -(W) Something has gone wrong in internal C<=item> processing. This message -indicates a bug in Pod::Text; you should never see it. +=item Item called without tag + +(W) Something has gone wrong in internal C<=item> processing. These +messages indicate a bug in Pod::Text; you should never see them. =item Can't open %s for reading: %s @@ -810,17 +837,17 @@ invalid. A quote specification must be one, two, or four characters long. (W) The POD source contained a non-standard command paragraph (something of the form C<=command args>) that Pod::Man didn't know about. It was ignored. -=item Unknown escape: %s +=item %s:%d: Unknown escape: %s (W) The POD source contained an C<EE<lt>E<gt>> escape that Pod::Text didn't know about. -=item Unknown sequence: %s +=item %s:%d: Unknown sequence: %s (W) The POD source contained a non-standard internal sequence (something of the form C<XE<lt>E<gt>>) that Pod::Text didn't know about. -=item Unmatched =back +=item %s:%d: Unmatched =back (W) Pod::Text encountered a C<=back> command that didn't correspond to an C<=over> command. diff --git a/lib/Pod/Text/Color.pm b/lib/Pod/Text/Color.pm index f747a967ec..35f0b4b295 100644 --- a/lib/Pod/Text/Color.pm +++ b/lib/Pod/Text/Color.pm @@ -1,7 +1,7 @@ # Pod::Text::Color -- Convert POD data to formatted color ASCII text -# $Id: Color.pm,v 1.0 2001/07/10 11:03:43 eagle Exp $ +# $Id: Color.pm,v 1.1 2001/10/20 08:08:39 eagle Exp $ # -# Copyright 1999 by Russ Allbery <rra@stanford.edu> +# Copyright 1999, 2001 by Russ Allbery <rra@stanford.edu> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. @@ -29,7 +29,7 @@ use vars qw(@ISA $VERSION); # Don't use the CVS revision as the version, since this module is also in Perl # core and too many things could munge CVS magic revision strings. This # number should ideally be the same as the CVS revision in podlators, however. -$VERSION = 1.00; +$VERSION = 1.01; ############################################################################## @@ -57,6 +57,13 @@ sub seq_b { return colored ($_[1], 'bold') } sub seq_f { return colored ($_[1], 'cyan') } sub seq_i { return colored ($_[1], 'yellow') } +# Output any included code in green. +sub output_code { + my ($self, $code) = @_; + $code = colored ($code, 'green'); + $self->output ($code); +} + # We unfortunately have to override the wrapping code here, since the normal # wrapping code gets really confused by all the escape sequences. sub wrap { @@ -126,7 +133,7 @@ Russ Allbery <rra@stanford.edu>. =head1 COPYRIGHT AND LICENSE -Copyright 1999 by Russ Allbery <rra@stanford.edu>. +Copyright 1999, 2001 by Russ Allbery <rra@stanford.edu>. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/lib/Pod/Text/Overstrike.pm b/lib/Pod/Text/Overstrike.pm index be159f4080..c405235f3f 100644 --- a/lib/Pod/Text/Overstrike.pm +++ b/lib/Pod/Text/Overstrike.pm @@ -1,5 +1,5 @@ # Pod::Text::Overstrike -- Convert POD data to formatted overstrike text -# $Id: Overstrike.pm,v 1.2 2001/07/10 11:04:36 eagle Exp $ +# $Id: Overstrike.pm,v 1.3 2001/10/20 08:11:29 eagle Exp $ # # Created by Joe Smith <Joe.Smith@inwap.com> 30-Nov-2000 # (based on Pod::Text::Color by Russ Allbery <rra@stanford.edu>) @@ -36,7 +36,7 @@ use vars qw(@ISA $VERSION); # Don't use the CVS revision as the version, since this module is also in Perl # core and too many things could munge CVS magic revision strings. This # number should ideally be the same as the CVS revision in podlators, however. -$VERSION = 1.02; +$VERSION = 1.03; ############################################################################## @@ -81,6 +81,13 @@ sub seq_b { local $_ = $_[1]; s/(.)\cH\1//g; s/_\cH//g; s/(.)/$1\b$1/g; $_ } sub seq_f { local $_ = $_[1]; s/(.)\cH\1//g; s/_\cH//g; s/(.)/_\b$1/g; $_ } sub seq_i { local $_ = $_[1]; s/(.)\cH\1//g; s/_\cH//g; s/(.)/_\b$1/g; $_ } +# Output any included code in bold. +sub output_code { + my ($self, $code) = @_; + $code =~ s/(.)/$1\b$1/g; + $self->output ($code); +} + # We unfortunately have to override the wrapping code here, since the normal # wrapping code gets really confused by all the escape sequences. sub wrap { @@ -90,7 +97,7 @@ sub wrap { my $spaces = ' ' x $$self{MARGIN}; my $width = $$self{width} - $$self{MARGIN}; while (length > $width) { - if (s/^((?:(?:[^\n]\cH)?[^\n]){0,$width})\s+// + if (s/^((?:(?:[^\n]\cH)?[^\n]){0,$width})(\Z|\s+)// || s/^((?:(?:[^\n]\cH)?[^\n]){$width})//) { $output .= $spaces . $1 . "\n"; } else { @@ -159,6 +166,7 @@ Joe Smith <Joe.Smith@inwap.com>, using the framework created by Russ Allbery =head1 COPYRIGHT AND LICENSE Copyright 2000 by Joe Smith <Joe.Smith@inwap.com>. +Copyright 2001 by Russ Allbery <rra@stanford.edu>. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/lib/Pod/Text/Termcap.pm b/lib/Pod/Text/Termcap.pm index c49e2c3f96..9e11e01387 100644 --- a/lib/Pod/Text/Termcap.pm +++ b/lib/Pod/Text/Termcap.pm @@ -1,7 +1,7 @@ # Pod::Text::Termcap -- Convert POD data to ASCII text with format escapes. -# $Id: Termcap.pm,v 1.1 2001/07/10 11:04:36 eagle Exp $ +# $Id: Termcap.pm,v 1.2 2001/10/20 08:09:30 eagle Exp $ # -# Copyright 1999 by Russ Allbery <rra@stanford.edu> +# Copyright 1999, 2001 by Russ Allbery <rra@stanford.edu> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. @@ -30,7 +30,7 @@ use vars qw(@ISA $VERSION); # Don't use the CVS revision as the version, since this module is also in Perl # core and too many things could munge CVS magic revision strings. This # number should ideally be the same as the CVS revision in podlators, however. -$VERSION = 1.01; +$VERSION = 1.02; ############################################################################## @@ -82,6 +82,12 @@ sub cmd_head2 { sub seq_b { my $self = shift; return "$$self{BOLD}$_[0]$$self{NORM}" } sub seq_i { my $self = shift; return "$$self{UNDL}$_[0]$$self{NORM}" } +# Output any included code in bold. +sub output_code { + my ($self, $code) = @_; + $self->output ($$self{BOLD} . $code . $$self{NORM}); +} + # Override the wrapping code to igore the special sequences. sub wrap { my $self = shift; @@ -143,7 +149,7 @@ Russ Allbery <rra@stanford.edu>. =head1 COPYRIGHT AND LICENSE -Copyright 1999 by Russ Allbery <rra@stanford.edu>. +Copyright 1999, 2001 by Russ Allbery <rra@stanford.edu>. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/lib/Term/Complete.t b/lib/Term/Complete.t index 81253cc1d6..7386474c99 100644 --- a/lib/Term/Complete.t +++ b/lib/Term/Complete.t @@ -15,7 +15,7 @@ SKIP: { use_ok( 'Term::Complete' ); # this skips tests AND prevents the "used only once" warning - skip('No stty, Term::Complete will not run here', 8) + skip('No stty, Term::Complete will not run here', 7) unless defined $Term::Complete::tty_raw_noecho && defined $Term::Complete::tty_restore; diff --git a/lib/Test/Simple/t/output.t b/lib/Test/Simple/t/output.t index ef89a0705b..69682e47ae 100644 --- a/lib/Test/Simple/t/output.t +++ b/lib/Test/Simple/t/output.t @@ -35,7 +35,7 @@ close *$out; undef $out; open(IN, 'foo') or die $!; chomp(my $line = <IN>); - +close IN; ok($line eq 'hi!'); open(FOO, ">>foo") or die $!; diff --git a/lib/newgetopt.pl b/lib/newgetopt.pl index 0b7eed8bfe..95eef220fe 100644 --- a/lib/newgetopt.pl +++ b/lib/newgetopt.pl @@ -1,6 +1,13 @@ -# newgetopt.pl -- new options parsing. -# Now just a wrapper around the Getopt::Long module. -# $Id: newgetopt.pl,v 1.17 1996-10-02 11:17:16+02 jv Exp $ +# $Id: newgetopt.pl,v 1.18 2001-09-21 15:34:59+02 jv Exp $ + +# This library is no longer being maintained, and is included for backward +# compatibility with Perl 4 programs which may require it. +# It is now just a wrapper around the Getopt::Long module. +# +# In particular, this should not be used as an example of modern Perl +# programming techniques. +# +# Suggested alternative: Getopt::Long { package newgetopt; diff --git a/makedef.pl b/makedef.pl index 68fbd3e43a..54d766f6c5 100644 --- a/makedef.pl +++ b/makedef.pl @@ -200,10 +200,6 @@ sub emit_symbols { } } -unless ($PLATFORM eq 'vms') { - skip_symbols [qw(PL_my_inv_rand_max)]; -} - if ($PLATFORM eq 'win32') { skip_symbols [qw( PL_statusvalue_vms @@ -5432,6 +5432,15 @@ Perl_ck_delete(pTHX_ OP *o) } OP * +Perl_ck_die(pTHX_ OP *o) +{ +#ifdef VMS + if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; +#endif + return ck_fun(o); +} + +OP * Perl_ck_eof(pTHX_ OP *o) { I32 type = o->op_type; @@ -5500,6 +5509,7 @@ Perl_ck_exit(pTHX_ OP *o) if (svp && *svp && SvTRUE(*svp)) o->op_private |= OPpEXIT_VMSISH; } + if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; #endif return ck_fun(o); } @@ -197,7 +197,8 @@ Deprecated. Use C<GIMME_V> instead. #define OPpOPEN_OUT_RAW 64 /* binmode(F,":raw") on output fh */ #define OPpOPEN_OUT_CRLF 128 /* binmode(F,":crlf") on output fh */ -/* Private for OP_EXIT */ +/* Private for OP_EXIT, HUSH also for OP_DIE */ +#define OPpHUSH_VMSISH 64 /* hush DCL exit msg vmsish mode*/ #define OPpEXIT_VMSISH 128 /* exit(0) vs. exit(1) vmsish mode*/ struct op { @@ -1273,7 +1273,7 @@ EXT OP * (CPERLscope(*PL_check)[]) (pTHX_ OP *op) = { MEMBER_TO_FPTR(Perl_ck_null), /* leavesublv */ MEMBER_TO_FPTR(Perl_ck_fun), /* caller */ MEMBER_TO_FPTR(Perl_ck_fun), /* warn */ - MEMBER_TO_FPTR(Perl_ck_fun), /* die */ + MEMBER_TO_FPTR(Perl_ck_die), /* die */ MEMBER_TO_FPTR(Perl_ck_fun), /* reset */ MEMBER_TO_FPTR(Perl_ck_null), /* lineseq */ MEMBER_TO_FPTR(Perl_ck_null), /* nextstate */ @@ -652,7 +652,7 @@ leavesub subroutine exit ck_null 1 leavesublv lvalue subroutine return ck_null 1 caller caller ck_fun t% S? warn warn ck_fun imst@ L -die die ck_fun dimst@ L +die die ck_die dimst@ L reset symbol reset ck_fun is% S? lineseq line sequence ck_null @ diff --git a/patchlevel.h b/patchlevel.h index fe2a1afd20..d62ee798fb 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -70,7 +70,7 @@ #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT) static char *local_patches[] = { NULL - ,"DEVEL12493" + ,"DEVEL12535" ,NULL }; @@ -1492,6 +1492,9 @@ perl_run(pTHXx) #endif oldscope = PL_scopestack_ix; +#ifdef VMS + VMSISH_HUSHED = 0; +#endif #ifdef PERL_FLEXIBLE_EXCEPTIONS redo_body: @@ -425,10 +425,10 @@ int usleep(unsigned int); # define MYSWAP #endif -/* Cannot include embed.h here on Win32 as win32.h has not +/* Cannot include embed.h here on Win32 as win32.h has not yet been included and defines some config variables e.g. HAVE_INTERP_INTERN */ -#if !defined(PERL_FOR_X2P) && !defined(WIN32) +#if !defined(PERL_FOR_X2P) && !(defined(WIN32)||defined(VMS)) # include "embed.h" #endif @@ -1757,6 +1757,7 @@ typedef struct clone_params CLONE_PARAMS; #else # if defined(VMS) # include "vmsish.h" +# include "embed.h" # else # if defined(PLAN9) # include "./plan9/plan9ish.h" diff --git a/perlvars.h b/perlvars.h index e70dd7f772..704192422a 100644 --- a/perlvars.h +++ b/perlvars.h @@ -40,7 +40,3 @@ PERLVAR(Gop_mutex, perl_mutex) /* Mutex for op refcounting */ PERLVAR(Gsharedsv_space, PerlInterpreter*) /* The shared sv space */ PERLVAR(Gsharedsv_space_mutex, perl_mutex) /* Mutex protecting the shared sv space */ #endif - -#if defined(VMS) && defined(Drand01_is_rand) -PERLVAR(Gmy_inv_rand_max, float) /* nasty compiler bug workaround */ -#endif diff --git a/pod/perlintro.pod b/pod/perlintro.pod index 8a80ef4cee..0d96c97dcc 100644 --- a/pod/perlintro.pod +++ b/pod/perlintro.pod @@ -311,7 +311,7 @@ There's also a negated version of it: ... } -This is provided as a more readable version of C<if (! condition)>. +This is provided as a more readable version of C<if (!I<condition>)>. Note that the braces are required in Perl, even if you've only got one line in the block. However, there is a clever way of making your one-line @@ -374,7 +374,7 @@ this overview) see L<perlsyn>. Perl comes with a wide selection of builtin functions. Some of the ones we've already seen include C<print>, C<sort> and C<reverse>. A list of them is given at the start of L<perlfunc> and you can easily read -about any given function by using C<perldoc -f functionname>. +about any given function by using C<perldoc -f I<functionname>>. Perl operators are documented in full in L<perlop>, but here are a few of the most common ones: @@ -627,9 +627,9 @@ also available from CPAN. To learn how to install modules you download from CPAN, read L<perlmodinstall> -To learn how to use a particular module, use C<perldoc Module::Name>. -Typically you will want to C<use Module::Name>, which will then give you -access to exported functions or an OO interface to the module. +To learn how to use a particular module, use C<perldoc I<Module::Name>>. +Typically you will want to C<use I<Module::Name>>, which will then give +you access to exported functions or an OO interface to the module. L<perlfaq> contains questions and answers related to many common tasks, and often provides suggestions for good CPAN modules to use. diff --git a/pod/pod2man.PL b/pod/pod2man.PL index cef507bc8e..5a1deeaed3 100644 --- a/pod/pod2man.PL +++ b/pod/pod2man.PL @@ -36,7 +36,7 @@ $Config{startperl} print OUT <<'!NO!SUBS!'; # pod2man -- Convert POD data to formatted *roff input. -# $Id: pod2man.PL,v 1.6 2001/07/10 11:23:46 eagle Exp $ +# $Id: pod2man.PL,v 1.7 2001/10/20 08:24:15 eagle Exp $ # # Copyright 1999, 2000, 2001 by Russ Allbery <rra@stanford.edu> # @@ -51,6 +51,9 @@ use Pod::Usage qw(pod2usage); use strict; +# Silence -w warnings. +use vars qw($running_under_some_shell); + # Insert -- into @ARGV before any single dash argument to hide it from # Getopt::Long; we want to interpret it as meaning stdin (which Pod::Parser # does correctly). @@ -64,7 +67,7 @@ Getopt::Long::config ('bundling_override'); GetOptions (\%options, 'section|s=s', 'release|r=s', 'center|c=s', 'date|d=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s', 'fixedbolditalic=s', 'official|o', 'quotes|q=s', 'lax|l', - 'help|h') or exit 1; + 'help|h', 'verbose|v') or exit 1; pod2usage (0) if $options{help}; # Official sets --center, but don't override things explicitly set. @@ -72,12 +75,17 @@ if ($options{official} && !defined $options{center}) { $options{center} = 'Perl Programmers Reference Guide'; } +# Verbose is only our flag, not a Pod::Man flag. +my $verbose = $options{verbose}; +delete $options{verbose}; + # Initialize and run the formatter, pulling a pair of input and output off at # a time. my $parser = Pod::Man->new (%options); my @files; do { @files = splice (@ARGV, 0, 2); + print " $files[1]\n" if $verbose; $parser->parse_from_file (@files); } while (@ARGV); @@ -93,7 +101,7 @@ pod2man [B<--section>=I<manext>] [B<--release>=I<version>] [B<--center>=I<string>] [B<--date>=I<string>] [B<--fixed>=I<font>] [B<--fixedbold>=I<font>] [B<--fixeditalic>=I<font>] [B<--fixedbolditalic>=I<font>] [B<--official>] [B<--lax>] -[B<--quotes>=I<quotes>] [I<input> [I<output>] ...] +[B<--quotes>=I<quotes>] [B<--verbose>] [I<input> [I<output>] ...] pod2man B<--help> @@ -217,6 +225,10 @@ that are reliably consistent are 1, 2, and 3. By default, section 1 will be used unless the file ends in .pm in which case section 3 will be selected. +=item B<-v>, B<--verbose> + +Print out the name of each output file as it is being generated. + =back =head1 DIAGNOSTICS diff --git a/pod/pod2text.PL b/pod/pod2text.PL index 54a22790a4..e038021c70 100644 --- a/pod/pod2text.PL +++ b/pod/pod2text.PL @@ -37,7 +37,7 @@ print OUT <<'!NO!SUBS!'; # pod2text -- Convert POD data to formatted ASCII text. # -# Copyright 1999, 2000 by Russ Allbery <rra@stanford.edu> +# Copyright 1999, 2000, 2001 by Russ Allbery <rra@stanford.edu> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. @@ -53,6 +53,9 @@ use Pod::Usage qw(pod2usage); use strict; +# Silence -w warnings. +use vars qw($running_under_some_shell); + # Take an initial pass through our options, looking for one of the form # -<number>. We turn that into -w <number> for compatibility with the # original pod2text script. @@ -74,7 +77,7 @@ my $stdin; my %options; $options{sentence} = 0; Getopt::Long::config ('bundling'); -GetOptions (\%options, 'alt|a', 'color|c', 'help|h', 'indent|i=i', +GetOptions (\%options, 'alt|a', 'code', 'color|c', 'help|h', 'indent|i=i', 'loose|l', 'overstrike|o', 'quotes|q=s', 'sentence|s', 'termcap|t', 'width|w=i') or exit 1; pod2usage (1) if $options{help}; @@ -107,8 +110,8 @@ pod2text - Convert POD data to formatted ASCII text =head1 SYNOPSIS -pod2text [B<-aclost>] [B<-i> I<indent>] [B<-q> I<quotes>] [B<-w> I<width>] -[I<input> [I<output>]] +pod2text [B<-aclost>] [B<--code>] [B<-i> I<indent>] S<[B<-q> I<quotes>]> +S<[B<-w> I<width>]> [I<input> [I<output>]] pod2text B<-h> @@ -132,6 +135,12 @@ given, the formatted output is written to STDOUT. Use an alternate output format that, among other things, uses a different heading style and marks C<=item> entries with a colon in the left margin. +=item B<--code> + +Include any non-POD text from the input file in the output as well. Useful +for viewing code documented with POD blocks with the POD rendered and the +code left intact. + =item B<-c>, B<--color> Format the output with ANSI color escape sequences. Using this option @@ -9,6 +9,7 @@ Perl_ck_bitop Perl_ck_concat Perl_ck_defined Perl_ck_delete +Perl_ck_die Perl_ck_eof Perl_ck_eval Perl_ck_exec @@ -2593,6 +2593,7 @@ PP(pp_exit) #ifdef VMS if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH)) anum = 0; + VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH); #endif } PL_exit_flags |= PERL_EXIT_EXPECTED; diff --git a/pp_proto.h b/pp_proto.h index 86ab4c2550..566074e0f2 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -8,6 +8,7 @@ PERL_CKDEF(Perl_ck_bitop) PERL_CKDEF(Perl_ck_concat) PERL_CKDEF(Perl_ck_defined) PERL_CKDEF(Perl_ck_delete) +PERL_CKDEF(Perl_ck_die) PERL_CKDEF(Perl_ck_eof) PERL_CKDEF(Perl_ck_eval) PERL_CKDEF(Perl_ck_exec) @@ -433,6 +433,9 @@ PP(pp_die) SV *tmpsv; STRLEN len; bool multiarg = 0; +#ifdef VMS + VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH); +#endif if (SP - MARK != 1) { dTARGET; do_join(TARG, &PL_sv_no, MARK, SP); @@ -306,23 +306,21 @@ EOT warn "Failed $bad test scripts out of $files, $pct% okay.\n"; } warn <<'SHRDLU'; - ### Since not all tests were successful, you may want to run some - ### of them individually and examine any diagnostic messages they - ### produce. See the INSTALL document's section on "make test". + ### Since not all tests were successful, you may want to run some of + ### them individually and examine any diagnostic messages they produce. + ### See the INSTALL document's section on "make test". SHRDLU warn <<'SHRDLU' if $good / $total > 0.8; - ### Since most tests were successful you have a good chance - ### to get information better granularity by running + ### You have a good chance to get more information by running ### ./perl harness - ### in the 't' directory. + ### in the 't' directory since most (>=80%) of the tests succeeded. SHRDLU use Config; if ($Config{ldlibpthname}) { warn <<SHRDLU; - ### Since you seem to have a dynamic library search path, - ### $Config{ldlibpthname}, you probably should set that - ### to point to the build directory before running the harness. - ### Depending on your shell style: + ### You may have to set your dynamic library search path, + ### $Config{ldlibpthname}, to point to the build directory + ### before running the harness-- depending on your shell style: ### setenv $Config{ldlibpthname} `pwd`; cd t; ./perl harness ### $Config{ldlibpthname}=`pwd`; export $Config{ldlibpthname}; cd t; ./perl harness ### export $Config{ldlibpthname}=`pwd`; cd t; ./perl harness diff --git a/t/op/pack.t b/t/op/pack.t index f944aafab5..cfb55018e4 100755 --- a/t/op/pack.t +++ b/t/op/pack.t @@ -1,6 +1,6 @@ #!./perl -w -print "1..611\n"; +print "1..613\n"; BEGIN { chdir 't' if -d 't'; @@ -661,3 +661,13 @@ foreach ( my @u = unpack($t, $p); ok(@u == 2 && $u[0] eq $u && $u[1] eq $v); } + +{ + # 612 + + ok((unpack("w/a*", "\x02abc"))[0] eq "ab"); + + # 613: "w/a*" should be seen as one unit + + ok(scalar unpack("w/a*", "\x02abc") eq "ab"); +} diff --git a/t/op/pat.t b/t/op/pat.t index 66179212b2..9937e363b7 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -2235,7 +2235,10 @@ print "# some Unicode properties\n"; print "not " unless "a" =~ /\p{LowercaseLetter}/; print "ok 745\n"; - print "not " if "A" =~ /\p{LowercaseLetter}/; + print "not " if "A" =~ /\p{ + Lowercase + Letter + }/x; print "ok 746\n"; } diff --git a/utils/perldoc.PL b/utils/perldoc.PL index 22fdd1cfdb..7f8216a006 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -371,9 +371,13 @@ sub page { close TMP or die "Can't close while $tmp: $!"; } else { - foreach my $pager (@pagers) { + # On VMS, quoting prevents logical expansion, and temp files with no + # extension get the wrong default extension (such as .LIS for TYPE) + + $tmp = VMS::Filespec::rmsexpand($tmp, '.') if ($Is_VMS); + foreach my $pager (@pagers) { if ($Is_VMS) { - last if system("$pager $tmp") == 0; # quoting prevents logical expansion + last if system("$pager $tmp") == 0; } else { last if system("$pager \"$tmp\"") == 0; } diff --git a/vms/ext/vmsish.pm b/vms/ext/vmsish.pm index c51863a4f3..89ec72c28c 100644 --- a/vms/ext/vmsish.pm +++ b/vms/ext/vmsish.pm @@ -11,7 +11,10 @@ vmsish - Perl pragma to control VMS-specific language features use vmsish 'status'; # or '$?' use vmsish 'exit'; use vmsish 'time'; + use vmsish 'hushed'; + no vmsish 'hushed'; + vmsish::hushed($hush); use vmsish; no vmsish 'time'; @@ -44,13 +47,59 @@ default of Universal Time (a.k.a Greenwich Mean Time, or GMT). =item C<vmsish hushed> -This suppresses printing of VMS status messages to SYS$OUTPUT and SYS$ERROR -if Perl terminates with an error status. This primarily effects error -exits from things like Perl compiler errors or "standard Perl" runtime errors, -where text error messages are also generated by Perl. - -The error exits from inside the core are generally more serious, and are -not supressed. +This suppresses printing of VMS status messages to SYS$OUTPUT and +SYS$ERROR if Perl terminates with an error status. and allows +programs that are expecting "unix-style" Perl to avoid having to parse +VMS error messages. It does not supress any messages from Perl +itself, just the messages generated by DCL after Perl exits. The DCL +symbol $STATUS will still have the termination status, but with a +high-order bit set: + +EXAMPLE: + $ perl -e"exit 44;" Non-hushed error exit + %SYSTEM-F-ABORT, abort DCL message + $ show sym $STATUS + $STATUS == "%X0000002C" + + $ perl -e"use vmsish qw(hushed); exit 44;" Hushed error exit + $ show sym $STATUS + $STATUS == "%X1000002C" + +The 'hushed' flag has a global scope during compilation: the exit() or +die() commands that are compiled after 'vmsish hushed' will be hushed +when they are executed. Doing a "no vmsish 'hushed'" turns off the +hushed flag. + +The status of the hushed flag also affects output of VMS error +messages from compilation errors. Again, you still get the Perl +error message (and the code in $STATUS) + +EXAMPLE: + use vmsish 'hushed'; # turn on hushed flag + use Carp; # Carp compiled hushed + exit 44; # will be hushed + croak('I die'); # will be hushed + no vmsish 'hushed'; # turn off hushed flag + exit 44; # will not be hushed + croak('I die2'): # WILL be hushed, croak was compiled hushed + +You can also control the 'hushed' flag at run-time, using the built-in +routine vmsish::hushed(). Without argument, it returns the hushed status. +Since vmsish::hushed is built-in, you do not need to "use vmsish" to call +it. + +EXAMPLE: + if ($quiet_exit) { + vmsish::hushed(1); + } + print "Sssshhhh...I'm hushed...\n" if vmsish::hushed(); + exit 44; + +Note that an exit() or die() that is compiled 'hushed' because of "use +vmsish" is not un-hushed by calling vmsish::hushed(0) at runtime. + +The messages from error exits from inside the Perl core are generally +more serious, and are not supressed. =back @@ -67,7 +116,6 @@ sub bits { my $bits = 0; my $sememe; foreach $sememe (@_) { - $bits |= 0x20000000, next if $sememe eq 'hushed'; $bits |= 0x40000000, next if $sememe eq 'status' || $sememe eq '$?'; $bits |= 0x80000000, next if $sememe eq 'time'; } @@ -76,21 +124,23 @@ sub bits { sub import { shift; - $^H |= bits(@_ ? @_ : qw(status time hushed)); + $^H |= bits(@_ ? @_ : qw(status time)); my $sememe; - foreach $sememe (@_ ? @_ : qw(exit)) { + foreach $sememe (@_ ? @_ : qw(exit hushed)) { $^H{'vmsish_exit'} = 1 if $sememe eq 'exit'; + vmsish::hushed(1) if $sememe eq 'hushed'; } } sub unimport { shift; - $^H &= ~ bits(@_ ? @_ : qw(status time hushed)); + $^H &= ~ bits(@_ ? @_ : qw(status time)); my $sememe; - foreach $sememe (@_ ? @_ : qw(exit)) { + foreach $sememe (@_ ? @_ : qw(exit hushed)) { $^H{'vmsish_exit'} = 0 if $sememe eq 'exit'; + vmsish::hushed(0) if $sememe eq 'hushed'; } } diff --git a/vms/ext/vmsish.t b/vms/ext/vmsish.t index d63da57235..0f3c0ec1eb 100644 --- a/vms/ext/vmsish.t +++ b/vms/ext/vmsish.t @@ -3,31 +3,27 @@ BEGIN { unshift @INC, '[-.lib]'; } my $Invoke_Perl = qq(MCR $^X "-I[-.lib]"); -print "1..17\n"; +require "test.pl"; +plan(tests => 24); #========== vmsish status ========== `$Invoke_Perl -e 1`; # Avoid system() from a pipe from harness. Mutter. -if ($?) { print "not ok 1 # POSIX status is $?\n"; } -else { print "ok 1\n"; } +is($?,0,"simple Perl invokation: POSIX success status"); { use vmsish qw(status); - if (not ($? & 1)) { print "not ok 2 # vmsish status is $?\n"; } - else { print "ok 2\n"; } + is(($? & 1),1, "importing vmsish [vmsish status]"); { - no vmsish '$?'; # check unimport function - if ($?) { print "not ok 3 # POSIX status is $?\n"; } - else { print "ok 3\n"; } + no vmsish qw(status); # check unimport function + is($?,0, "unimport vmsish [POSIX STATUS]"); } # and lexical scoping - if (not ($? & 1)) { print "not ok 4 # vmsish status is $?\n"; } - else { print "ok 4\n"; } + is(($? & 1),1,"lex scope of vmsish [vmsish status]"); } -if ($?) { print "not ok 5 # POSIX status is $?\n"; } -else { print "ok 5\n"; } +is($?,0,"outer lex scope of vmsish [POSIX status]"); + { use vmsish qw(exit); # check import function - if ($?) { print "not ok 6 # POSIX status is $?\n"; } - else { print "ok 6\n"; } + is($?,0,"importing vmsish exit [POSIX status]"); } #========== vmsish exit, messages ========== @@ -35,39 +31,54 @@ else { print "ok 5\n"; } use vmsish qw(status); $msg = do_a_perl('-e "exit 1"'); - if ($msg !~ /ABORT/) { $msg =~ s/\n/\\n/g; # keep output on one line - print "not ok 7 # subprocess output: |$msg|\n"; - } - else { print "ok 7\n"; } - if ($? & 1) { print "not ok 8 # subprocess VMS status: $?\n"; } - else { print "ok 8\n"; } + like($msg,'ABORT', "POSIX ERR exit, DCL error message check"); + is($?&1,0,"vmsish status check, POSIX ERR exit"); $msg = do_a_perl('-e "use vmsish qw(exit); exit 1"'); - if (length $msg) { $msg =~ s/\n/\\n/g; # keep output on one line - print "not ok 9 # subprocess output: |$msg|\n"; - } - else { print "ok 9\n"; } - if (not ($? & 1)) { print "not ok 10 # subprocess VMS status: $?\n"; } - else { print "ok 10\n"; } + ok(length($msg)==0,"vmsish OK exit, DCL error message check"); + is($?&1,1, "vmsish status check, vmsish OK exit"); $msg = do_a_perl('-e "use vmsish qw(exit); exit 44"'); - if ($msg !~ /ABORT/) { $msg =~ s/\n/\\n/g; # keep output on one line - print "not ok 11 # subprocess output: |$msg|\n"; - } - else { print "ok 11\n"; } - if ($? & 1) { print "not ok 12 # subprocess VMS status: $?\n"; } - else { print "ok 12\n"; } + like($msg, 'ABORT', "vmsish ERR exit, DCL error message check"); + is($?&1,0,"vmsish ERR exit, vmsish status check"); + + $msg = do_a_perl('-e "use vmsish qw(hushed); exit 1"'); + $msg =~ s/\n/\\n/g; # keep output on one line + ok(($msg !~ /ABORT/),"POSIX ERR exit, vmsish hushed, DCL error message check"); $msg = do_a_perl('-e "use vmsish qw(exit hushed); exit 44"'); - if ($msg =~ /ABORT/) { $msg =~ s/\n/\\n/g; # keep output on one line - print "not ok 13 # subprocess output: |$msg|\n"; - } - else { print "ok 13\n"; } - + ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed, DCL error message check"); + + $msg = do_a_perl('-e "use vmsish qw(exit hushed); no vmsish qw(hushed); exit 44"'); + $msg =~ s/\n/\\n/g; # keep output on one line + like($msg,'ABORT',"vmsish ERR exit, no vmsish hushed, DCL error message check"); + + $msg = do_a_perl('-e "use vmsish qw(hushed); die(qw(blah));"'); + $msg =~ s/\n/\\n/g; # keep output on one line + ok(($msg !~ /ABORT/),"die, vmsish hushed, DCL error message check"); + + $msg = do_a_perl('-e "use vmsish qw(hushed); use Carp; croak(qw(blah));"'); + $msg =~ s/\n/\\n/g; # keep output on one line + ok(($msg !~ /ABORT/),"croak, vmsish hushed, DCL error message check"); + + $msg = do_a_perl('-e "use vmsish qw(exit); vmsish::hushed(1); exit 44;"'); + $msg =~ s/\n/\\n/g; # keep output on one line + ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed at runtime, DCL error message check"); + + local *TEST; + open(TEST,'>vmsish_test.pl') || die('not ok ?? : unable to open "vmsish_test.pl" for writing'); + print TEST "#! perl\n"; + print TEST "use vmsish qw(hushed);\n"; + print TEST "\$obvious = (\$compile(\$error;\n"; + close TEST; + $msg = do_a_perl('vmsish_test.pl'); + $msg =~ s/\n/\\n/g; # keep output on one line + ok(($msg !~ /ABORT/),"compile ERR exit, vmsish hushed, DCL error message check"); + unlink 'vmsish_test.pl'; } @@ -84,7 +95,7 @@ else { print "ok 5\n"; } gmtime(0); # Force reset of tz offset } { - use vmsish qw(time); + use_ok('vmsish qw(time)'); $vmstime = time; @vmslocal = localtime($vmstime); @vmsgmtime = gmtime($vmstime); @@ -101,33 +112,21 @@ else { print "ok 5\n"; } # since it's unlikely local time will differ from UTC by so small # an amount, and it renders the test resistant to delays from # things like stat() on a file mounted over a slow network link. - if ($utctime - $vmstime + $offset > 10) { - print "not ok 14 # (time) UTC: $utctime VMS: $vmstime\n"; - } - else { print "ok 14\n"; } + ok($utctime - $vmstime +$offset <= 10,"(time) UTC:$utctime VMS:$vmstime"); $utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 + $utclocal[2] * 3600 + $utclocal[1] * 60 + $utclocal[0]; $vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 + $vmslocal[2] * 3600 + $vmslocal[1] * 60 + $vmslocal[0]; - if ($vmsval - $utcval + $offset > 10) { - print "not ok 15 # (localtime)\n# UTC: @utclocal\n# VMS: @vmslocal\n"; - } - else { print "ok 15\n"; } + ok($vmsval - $utcval + $offset <= 10, "(localtime)\n# UTC: @utclocal\n# VMS: @vmslocal"); $utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 + $utcgmtime[2] * 3600 + $utcgmtime[1] * 60 + $utcgmtime[0]; $vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 + $vmsgmtime[2] * 3600 + $vmsgmtime[1] * 60 + $vmsgmtime[0]; - if ($vmsval - $utcval + $offset > 10) { - print "not ok 16 # (gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime\n"; - } - else { print "ok 16\n"; } + ok($vmsval - $utcval + $offset <= 10, "(gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime"); - if ($vmsmtime - $utcmtime + $offset > 10) { - print "not ok 17 # (stat) UTC: $utcmtime VMS: $vmsmtime\n"; - } - else { print "ok 17\n"; } + ok($vmsmtime - $utcmtime + $offset <= 10,"(stat) UTC: $utcmtime VMS: $vmsmtime"); } #====== need this to make sure error messages come out, even if @@ -6911,6 +6911,44 @@ mod2fname(pTHX_ CV *cv) } void +hushexit_fromperl(pTHX_ CV *cv) +{ + dXSARGS; + + if (items > 0) { + VMSISH_HUSHED = SvTRUE(ST(0)); + } + ST(0) = boolSV(VMSISH_HUSHED); + XSRETURN(1); +} + +void +Perl_sys_intern_dup(pTHX_ struct interp_intern *src, + struct interp_intern *dst) +{ + memcpy(dst,src,sizeof(struct interp_intern)); +} + +void +Perl_sys_intern_clear(pTHX) +{ +} + +void +Perl_sys_intern_init(pTHX) +{ + int ix = RAND_MAX; + float x; + + VMSISH_HUSHED = 0; + + x = (float)ix; + MY_INV_RAND_MAX = 1./x; +} + + + +void init_os_extras() { dTHX; @@ -6932,18 +6970,10 @@ init_os_extras() newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$"); newXSproto("DynaLoader::mod2fname", mod2fname, file, "$"); newXS("File::Copy::rmscopy",rmscopy_fromperl,file); + newXSproto("vmsish::hushed",hushexit_fromperl,file,";$"); store_pipelocs(aTHX); -#ifdef Drand01_is_rand -/* this hackery brought to you by a bug in DECC for /ieee=denorm */ - { - int ix = RAND_MAX; - float x = (float)ix; - PL_my_inv_rand_max = 1./x; - } -#endif - return; } diff --git a/vms/vmsish.h b/vms/vmsish.h index 93af772415..34062b7a07 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -285,16 +285,24 @@ #define COMPLEX_STATUS 1 /* We track both "POSIX" and VMS values */ #define HINT_V_VMSISH 24 -#define HINT_M_VMSISH_HUSHED 0x20000000 /* stifle error msgs on exit */ #define HINT_M_VMSISH_STATUS 0x40000000 /* system, $? return VMS status */ #define HINT_M_VMSISH_TIME 0x80000000 /* times are local, not UTC */ #define NATIVE_HINTS (PL_hints >> HINT_V_VMSISH) /* used in op.c */ #define TEST_VMSISH(h) (PL_curcop->op_private & ((h) >> HINT_V_VMSISH)) -#define VMSISH_HUSHED TEST_VMSISH(HINT_M_VMSISH_HUSHED) #define VMSISH_STATUS TEST_VMSISH(HINT_M_VMSISH_STATUS) #define VMSISH_TIME TEST_VMSISH(HINT_M_VMSISH_TIME) +/* VMS-specific data storage */ + +#define HAVE_INTERP_INTERN +struct interp_intern { + int hushed; + float inv_rand_max; +}; +#define VMSISH_HUSHED (PL_sys_intern.hushed) +#define MY_INV_RAND_MAX (PL_sys_intern.inv_rand_max) + /* Flags for vmstrnenv() */ #define PERL__TRNENV_SECURE 0x01 |