diff options
-rw-r--r-- | Makefile.SH | 3 | ||||
-rw-r--r-- | README.vms | 87 | ||||
-rw-r--r-- | av.c | 2 | ||||
-rw-r--r-- | configure.com | 50 | ||||
-rw-r--r-- | embed.h | 4 | ||||
-rwxr-xr-x | embed.pl | 1 | ||||
-rw-r--r-- | global.sym | 1 | ||||
-rwxr-xr-x | installperl | 2 | ||||
-rw-r--r-- | lib/ExtUtils/MM_Unix.pm | 57 | ||||
-rw-r--r-- | lib/ExtUtils/MM_VMS.pm | 2 | ||||
-rw-r--r-- | lib/Pod/Checker.pm | 198 | ||||
-rw-r--r-- | lib/Pod/InputObjects.pm | 2 | ||||
-rw-r--r-- | lib/Pod/ParseUtils.pm | 53 | ||||
-rw-r--r-- | lib/Pod/Parser.pm | 4 | ||||
-rw-r--r-- | lib/Pod/Select.pm | 2 | ||||
-rw-r--r-- | lib/Pod/Usage.pm | 2 | ||||
-rw-r--r-- | mg.h | 2 | ||||
-rw-r--r-- | objXSUB.h | 4 | ||||
-rwxr-xr-x | perlapi.c | 7 | ||||
-rw-r--r-- | pod/perlfunc.pod | 79 | ||||
-rw-r--r-- | pp_sys.c | 8 | ||||
-rw-r--r-- | proto.h | 1 | ||||
-rw-r--r-- | scope.c | 6 | ||||
-rwxr-xr-x | t/comp/use.t | 67 | ||||
-rwxr-xr-x | t/pod/poderrs.t | 4 | ||||
-rw-r--r-- | t/pod/poderrs.xr | 62 | ||||
-rw-r--r-- | toke.c | 31 | ||||
-rw-r--r-- | universal.c | 57 | ||||
-rw-r--r-- | vms/descrip_mms.template | 13 | ||||
-rw-r--r-- | vms/sockadapt.h | 2 | ||||
-rw-r--r-- | vms/subconfigure.com | 12 | ||||
-rw-r--r-- | vms/vms.c | 25 | ||||
-rw-r--r-- | vms/vmsish.h | 30 | ||||
-rw-r--r-- | win32/config.vc | 3 |
34 files changed, 644 insertions, 239 deletions
diff --git a/Makefile.SH b/Makefile.SH index 0817c99c2e..56c5d91f1c 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -534,7 +534,6 @@ extra.pods: miniperl $(LNS) ../$$x "pod/perl"$$nx".pod" ; \ echo "pod/perl"$$nx".pod" >> extra.pods ; \ done - -@test -f README.vms && $(LNS) ../README.vms pod/README_vms.pod && echo "pod/README_vms.pod" >> extra.pods -@test -f vms/perlvms.pod && $(LNS) ../vms/perlvms.pod pod/perlvms.pod && echo "pod/perlvms.pod" >> extra.pods install-strip: @@ -558,9 +557,7 @@ install.man: all installman # XXX Experimental. Hardwired values, but useful for testing. # Eventually Configure could ask for some of these values. install.html: all installhtml - -@test -f pod/README_vms.pod && rm -f pod/README_vms.pod -@test -f README.vms && $(LNS) ../README.vms vms/README_vms.pod - -@test -f pod/perlvms.pod && rm -f pod/perlvms.pod $(LDLIBPTH) ./perl installhtml \ --podroot=. --podpath=. --recurse \ --htmldir=$(privlib)/html \ diff --git a/README.vms b/README.vms index e58e6ddfd7..f6d970f05d 100644 --- a/README.vms +++ b/README.vms @@ -327,70 +327,73 @@ rebuild attempt. They might not, too, so it is best to be sure and do it. There are several steps you need to take to get Perl installed and running. -1) Create a directory somewhere and define the concealed logical PERL_ROOT -to point to it. For example, +=over 4 - CREATE/DIRECTORY dka200:[perl] - DEFINE/TRANS=(CONC,TERM) PERL_ROOT dka200:[perl.] +=item 1 -2) Run the install script via: +Check your default file protections with - MMS install + SHOW PROTECTION /DEFAULT -or +and adjust if necessary with SET PROTECTION=(code)/DEFAULT. - MMK install +=item 2 -If for some reason it complains about target INSTALL being up to date, -throw a /FORCE switch on the MMS or MMK command. +Create a directory somewhere and either run @perl_setup or +define the concealed logical PERL_ROOT to point to it by hand. +For example, -The DCL script [.VMS]PERL_SETUP.COM that is written by CONFIGURE.COM -will take care of most of the following: + CREATE/DIRECTORY dka200:[perl] + @PERL_SETUP + SHOW LOGICAL PERL_ROOT -3) Either create the global foreign symbol PERL somewhere, such as -SYS$MANAGER:SYLOGIN.COM, to be +or, - $ PERL :== "$PERL_ROOT:[000000]PERL.EXE" + CREATE/DIRECTORY dka200:[perl] + DEFINE/TRANS=(CONC,TERM) PERL_ROOT dka200:[perl.] -or install Perl into DCLTABLES.EXE (Check out the section "Installing Perl -into DCLTABLES (optional)" for more information), or put the image in a -directory that's in your DCL$PATH (if you're using VMS V6.2 or higher). -4) Either define the logical name PERLSHR somewhere -(such as in PERL_SETUP.COM) like so +=item 3 - $ DEFINE/NOLOG PERLSHR PERL_ROOT:[000000]PERLSHR.EXE +Run the install script via: -or copy the file into the system shareable library directory with + MMS install - copy perl_root:[000000]perlshr.exe sys$share: +or -5) Optionally define the command PERLDOC as + MMK install - $ PERLDOC == "$PERL_ROOT:[000000]PERL PERL_ROOT:[LIB.POD]PERLDOC.COM -t" +If for some reason it complains about target INSTALL being up to date, +throw a /FORCE switch on the MMS or MMK command. -(See above for where to find the B<most> pager for use with perldoc). +=back + +The DCL script PERL_SETUP.COM that is written by CONFIGURE.COM +will help you with the definition of PERL_ROOT, PERLSHR and the PERL +Foreign symbol. Take a look at PERL_SETUP.COM and modify it if you want +to. Then copy PERL_SETUP.COM to a place accessible to your perl users. +For example: -6) Optionally define the command PERLBUG (the Perl bug report generator) as + COPY PERL_SETUP.COM SYS$LIBRARY: - $ PERLBUG == "$PERL_ROOT:[000000]PERL PERL_ROOT:[LIB]PERLBUG.COM" +If you want to have everyone on the system have access to perl +then add a line that reads -7) Optionally define the command POD2MAN (Converts POD files to nroff -source suitable for converting to man pages. Also quiets complaints during -module builds) as + $ @sys$library:perl_setup - $ DEFINE/NOLOG POD2MAN PERL_ROOT:[LIB.POD]POD2MAN.COM - $ POD2MAN == "$PERL_ROOT:[000000]PERL POD2MAN" +to SYS$MANAGER:SYLOGIN.COM. -8) Optionally define the command POD2TEXT (Converts POD files to text, -which is required for B<perldoc -f> to work properly) as +Two alternatives to the foreign symbol would be to install PERL into +DCLTABLES.EXE (Check out the section "Installing Perl into DCLTABLES +(optional)" for more information), or put the image in a +directory that's in your DCL$PATH (if you're using VMS V6.2 or higher). - $ DEFINE/NOLOG POD2TEXT PERL_ROOT:[LIB.POD]POD2TEXT.COM - $ POD2TEXT == "$PERL_ROOT:[000000]PERL POD2TEXT" +An alternative to having PERL_SETUP.COM define the PERLSHR logical name +is to simply copy it into the system shareable library directory with: + + copy perl_root:[000000]perlshr.exe sys$share: -In all these cases, if you've got PERL defined as a foreign command symbol, -you can replace $PERL_ROOT:[000000]PERL with ''perl'. If you have installed -perl into DCLTABLES, replace it with just perl. +See also the "INSTALLing images (optional)" section. =head2 Installing Perl into DCLTABLES (optional) @@ -567,7 +570,7 @@ of extending vmsperl with CPAN modules after Perl has been installed. =head1 AUTHORS -Last revised 13-February-2000 by Peter Prymmer pvhp@best.com. +Last revised 25-February-2000 by Peter Prymmer pvhp@best.com. Revised 27-October-1999 by Craig Berry craig.berry@metamorgs.com. Revised 01-March-1999 by Dan Sugalski dan@sidhe.org. Originally by Charles Bailey bailey@newman.upenn.edu. @@ -601,6 +604,8 @@ missed someone. That said, special thanks are due to the following: the Stanford Synchrotron Radiation Laboratory and the Laboratory of Nuclear Studies at Cornell University for the opportunity to test and develop for the AXP, + John Hasstedt John.Hasstedt@sunysb.edu + for VAX VMS V7.2 support and to the entire VMSperl group for useful advice and suggestions. In addition the perl5-porters deserve credit for their creativity and @@ -393,7 +393,7 @@ Perl_av_clear(pTHX_ register AV *av) SV** ary; #ifdef DEBUGGING - if (SvREFCNT(av) <= 0 && ckWARN_d(WARN_DEBUGGING)) { + if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) { Perl_warner(aTHX_ WARN_DEBUGGING, "Attempt to clear deleted array"); } #endif diff --git a/configure.com b/configure.com index 813127ca4d..ccb66bd262 100644 --- a/configure.com +++ b/configure.com @@ -4,12 +4,12 @@ $! $! For example, if you unpacked perl into: [USER.PERL5_00n...] then you will $! want to cd into the tree and execute Configure: $! -$! $ SET DEFAULT [USER.PERL5_00n] +$! $ SET DEFAULT [USER.PERL5_xxx] $! $ @Configure $! $! or $! -$! $ SET DEFAULT [USER.PERL5_00n] +$! $ SET DEFAULT [USER.PERL5_xxx] $! $ @Configure "-des" $! $! That's it. If you get into a bind trying to build perl on VMS then @@ -19,7 +19,7 @@ $! $! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $! $! send suggestions to: -$! Dan Sugalski <sugalskd@ous.edu> +$! Dan Sugalski <dan@sidhe.org> $! Thank you!!!! $! $! Adapted and converted from Larry Wall & Andy Dougherty's @@ -39,7 +39,7 @@ $ cat = "type" $ gcc_symbol = "gcc" $ ans = "" $ macros = "" -$ use_vmsdebug_perl = "N" +$ use_vmsdebug_perl = "n" $ use_debugging_perl = "Y" $ use_64bitint = "n" $ C_Compiler_Replace = "CC=" @@ -167,8 +167,8 @@ $ P'i' = P'i' - "f" $ config_sh = P'i' $ IF (F$SEARCH(config_sh).NES."") $ THEN -$ test = F$FILE_ATTRIBUTES(config_sh,"PRO") -$ IF (F$LOCATE("R",test).NE.F$LENGTH(test)) +$ test_config_sh = F$FILE_ATTRIBUTES(config_sh,"PRO") +$ IF (F$LOCATE("R",test_config_sh).NE.F$LENGTH(test_config_sh)) $ THEN $ CONTINUE !at this point check UIC && if test allows... $ !to be continued ? @@ -395,7 +395,7 @@ $ ELSE $! MANIFEST. has been found and we have set def'ed there - $! time to bail out before it's too late. $ tmp = f$extract(1,3,f$edit(f$getsyi("VERSION"),"TRIM,COLLAPSE")) -$ IF tmp .GES. "7.2" THEN GOTO Beyond_depth_check +$ IF (tmp .GES. "7.2") .AND. (F$GETSYI("HW_MODEL") .GE. 1024) THEN GOTO Beyond_depth_check $ IF (F$ELEMENT(max_allowed_dir_depth,".",F$ENVIRONMENT("Default")).nes.".") $ THEN $ TYPE SYS$INPUT: @@ -590,7 +590,7 @@ $ user = F$EDIT(F$GETJPI("","USERNAME"),"TRIM,COLLAPSE") $ IF .NOT.(F$SEARCH("[-.CONFIG]INSTRUCT.").EQS."") $ THEN $ messages = F$ENVIRONMENT("MESSAGE") -$ SET MESSAGE/NOFAC/NOSEV/NOIDENT/NOTEXT !sorry :-( +$ SET MESSAGE/NOFAC/NOSEV/NOIDENT/NOTEXT $ contains /NOOUTPUT [-.CONFIG]INSTRUCT. 'user' $ IF .NOT.($status.EQ.%X08D78053) $ THEN @@ -600,7 +600,7 @@ $ rp = "Would you like to see the instructions? [''dflt'] " $ GOSUB myread $ if .NOT.ans THEN needman="" $ ENDIF -$ SET MESSAGE 'messages' !hope you made it here :-) +$ SET MESSAGE 'messages' $ ENDIF $ if (fastread.AND.silent.AND.(alldone.eqs."cont")) THEN needman="" $! @@ -618,9 +618,9 @@ brackets; typing carriage return will give you the default. $ READ SYS$COMMAND/PROMPT="Type carriage return to continue " ans $ TYPE SYS$INPUT: -In a hurry? You may run '@Configure -d'. This will bypass nearly all +In a hurry? You may run '@Configure "-d"'. This will bypass nearly all the questions and use the computed defaults (or the previous answers provided -there was already a config.sh file). Type '@Configure -h' for a list of +there was already a config.sh file). Type '@Configure "-h"' for a list of options. $ READ SYS$COMMAND/PROMPT="Type carriage return to continue " ans @@ -1925,9 +1925,9 @@ $Build_probe: $ build = F$ELEMENT(n,"/",builders) $ probe = F$ELEMENT(n,"!",probers) $ echo "Testing whether you have ''build' on your system..." -$ SET NOON !sorry :-( -$ ON CONTROL_Y THEN GOTO Reenable_messages_build !sorry :-( -$ SET MESSAGE/NOFAC/NOSEV/NOIDENT/NOTEXT !sorry :-( +$ SET NOON +$ ON CONTROL_Y THEN GOTO Reenable_messages_build +$ SET MESSAGE/NOFAC/NOSEV/NOIDENT/NOTEXT $ 'build' 'probe' $ IF ($SEVERITY .EQ. 1) $ THEN @@ -1942,9 +1942,9 @@ $ IF (.NOT. default_set) THEN dflt = build $ ELSE $ echo "Nope." $ ENDIF -$Reenable_messages_build: !hope you made it here :-) -$ SET MESSAGE 'messages' !hope you made it here :-) -$ SET ON !hope you made it here :-) +$Reenable_messages_build: +$ SET MESSAGE 'messages' +$ SET ON $ n = n + 1 $ IF (n .LT. max_build) THEN GOTO Build_probe $! @@ -2084,7 +2084,7 @@ $ ENDIF $ EXIT $ ENDSUBROUTINE ! Bad_environment $ echo "" -$ echo4 "%Config-I-VMS, Checking for dangerous pre extant global symbols and logical names." +$ echo4 "%Config-I-VMS, Checking for dangerous pre-existing global symbols and logical names." $ CALL Bad_environment "TMP" $ CALL Bad_environment "LIB" $ CALL Bad_environment "T" @@ -2097,7 +2097,7 @@ $! %Config-I-VMS, write perl_setup.com here $! $ echo "" $ echo4 "%Config-I-VMS, The perl_setup.com file is now being written..." -$ file_2_find = "[-.vms]perl_setup.com" +$ file_2_find = "[-]perl_setup.com" $ OPEN/WRITE CONFIG 'file_2_find' $ WRITE CONFIG "$!" $ WRITE CONFIG "$! Perl_Setup.com ''cf_time'" @@ -2126,6 +2126,9 @@ $ else $ WRITE CONFIG "$ perl :== $Perl_Root:[000000]Perl'ext'" $ WRITE CONFIG "$ define PerlShr Perl_Root:[000000]PerlShr'ext'" $ endif +$ WRITE CONFIG "$ define/nolog pod2text Perl_Root:[lib.pod]pod2text.com" +$ WRITE CONFIG "$ define/nolog pod2html Perl_Root:[lib.pod]pod2html.com" +$ WRITE CONFIG "$ define/nolog pod2man Perl_Root:[lib.pod]pod2man.com" $! $ IF (tzneedset) $ THEN @@ -2136,7 +2139,14 @@ $ ENDIF $ WRITE CONFIG "$!" $ WRITE CONFIG "$! Symbols for commonly used scripts:" $ WRITE CONFIG "$!" -$ WRITE CONFIG "$ Perldoc == ""'"+"'Perl' Perl_Root:[lib.pod]Perldoc.com -t""" +$ WRITE CONFIG "$ Perldoc == ""'"+"'Perl' Perl_Root:[lib.pod]Perldoc.com -t""" +$ WRITE CONFIG "$ pod2text == ""'"+"'Perl' pod2text""" +$ WRITE CONFIG "$ pod2html == ""'"+"'Perl' pod2html""" +$ WRITE CONFIG "$!pod2man == ""'"+"'Perl' pod2man""" +$ WRITE CONFIG "$!Perlbug == ""'"+"'Perl' Perl_Root:[lib]Perlbug.com""" +$ WRITE CONFIG "$!c2ph == ""'"+"'Perl' c2ph""" +$ WRITE CONFIG "$!h2ph == ""'"+"'Perl' h2ph""" +$ WRITE CONFIG "$!h2xs == ""'"+"'Perl' h2xs""" $ CLOSE CONFIG $! $ echo "" @@ -686,6 +686,7 @@ #define sv_usepvn Perl_sv_usepvn #define sv_vcatpvfn Perl_sv_vcatpvfn #define sv_vsetpvfn Perl_sv_vsetpvfn +#define str_to_version Perl_str_to_version #define swash_init Perl_swash_init #define swash_fetch Perl_swash_fetch #define taint_env Perl_taint_env @@ -2113,6 +2114,7 @@ #define sv_usepvn(a,b,c) Perl_sv_usepvn(aTHX_ a,b,c) #define sv_vcatpvfn(a,b,c,d,e,f,g) Perl_sv_vcatpvfn(aTHX_ a,b,c,d,e,f,g) #define sv_vsetpvfn(a,b,c,d,e,f,g) Perl_sv_vsetpvfn(aTHX_ a,b,c,d,e,f,g) +#define str_to_version(a) Perl_str_to_version(aTHX_ a) #define swash_init(a,b,c,d,e) Perl_swash_init(aTHX_ a,b,c,d,e) #define swash_fetch(a,b) Perl_swash_fetch(aTHX_ a,b) #define taint_env() Perl_taint_env(aTHX) @@ -4145,6 +4147,8 @@ #define sv_vcatpvfn Perl_sv_vcatpvfn #define Perl_sv_vsetpvfn CPerlObj::Perl_sv_vsetpvfn #define sv_vsetpvfn Perl_sv_vsetpvfn +#define Perl_str_to_version CPerlObj::Perl_str_to_version +#define str_to_version Perl_str_to_version #define Perl_swash_init CPerlObj::Perl_swash_init #define swash_init Perl_swash_init #define Perl_swash_fetch CPerlObj::Perl_swash_fetch @@ -2004,6 +2004,7 @@ Apd |void |sv_vcatpvfn |SV* sv|const char* pat|STRLEN patlen \ Apd |void |sv_vsetpvfn |SV* sv|const char* pat|STRLEN patlen \ |va_list* args|SV** svargs|I32 svmax \ |bool *maybe_tainted +Ap |NV |str_to_version |SV *sv Ap |SV* |swash_init |char* pkg|char* name|SV* listsv \ |I32 minbits|I32 none Ap |UV |swash_fetch |SV *sv|U8 *ptr diff --git a/global.sym b/global.sym index fee76148b9..b38fc6f519 100644 --- a/global.sym +++ b/global.sym @@ -431,6 +431,7 @@ Perl_sv_upgrade Perl_sv_usepvn Perl_sv_vcatpvfn Perl_sv_vsetpvfn +Perl_str_to_version Perl_swash_init Perl_swash_fetch Perl_taint_env diff --git a/installperl b/installperl index 920f0367b5..387f4b3560 100755 --- a/installperl +++ b/installperl @@ -240,7 +240,7 @@ my @corefiles; if ($Is_VMS) { # We did core file selection during build my $coredir = "lib/$Config{'arch'}/$ver"; $coredir =~ tr/./_/; - @corefiles = <$coredir/*.*>; + @corefiles = map { s|^$coredir/||i; } <$coredir/*.*>; } else { # [als] hard-coded 'libperl' name... not good! diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 428a3f7c67..5b4178b99a 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -2883,16 +2883,53 @@ $(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh push @m, q{ PERL_HDRS = \ -$(PERL_INC)/EXTERN.h $(PERL_INC)/gv.h $(PERL_INC)/pp.h \ -$(PERL_INC)/INTERN.h $(PERL_INC)/handy.h $(PERL_INC)/proto.h \ -$(PERL_INC)/XSUB.h $(PERL_INC)/hv.h $(PERL_INC)/regcomp.h \ -$(PERL_INC)/av.h $(PERL_INC)/keywords.h $(PERL_INC)/regexp.h \ -$(PERL_INC)/config.h $(PERL_INC)/mg.h $(PERL_INC)/scope.h \ -$(PERL_INC)/cop.h $(PERL_INC)/op.h $(PERL_INC)/sv.h \ -$(PERL_INC)/cv.h $(PERL_INC)/opcode.h $(PERL_INC)/unixish.h \ -$(PERL_INC)/dosish.h $(PERL_INC)/patchlevel.h $(PERL_INC)/util.h \ -$(PERL_INC)/embed.h $(PERL_INC)/perl.h $(PERL_INC)/iperlsys.h \ -$(PERL_INC)/form.h $(PERL_INC)/perly.h + $(PERL_INC)/EXTERN.h \ + $(PERL_INC)/INTERN.h \ + $(PERL_INC)/XSUB.h \ + $(PERL_INC)/av.h \ + $(PERL_INC)/cc_runtime.h \ + $(PERL_INC)/config.h \ + $(PERL_INC)/cop.h \ + $(PERL_INC)/cv.h \ + $(PERL_INC)/dosish.h \ + $(PERL_INC)/embed.h \ + $(PERL_INC)/embedvar.h \ + $(PERL_INC)/fakethr.h \ + $(PERL_INC)/form.h \ + $(PERL_INC)/gv.h \ + $(PERL_INC)/handy.h \ + $(PERL_INC)/hv.h \ + $(PERL_INC)/intrpvar.h \ + $(PERL_INC)/iperlsys.h \ + $(PERL_INC)/keywords.h \ + $(PERL_INC)/mg.h \ + $(PERL_INC)/nostdio.h \ + $(PERL_INC)/objXSUB.h \ + $(PERL_INC)/op.h \ + $(PERL_INC)/opcode.h \ + $(PERL_INC)/opnames.h \ + $(PERL_INC)/patchlevel.h \ + $(PERL_INC)/perl.h \ + $(PERL_INC)/perlapi.h \ + $(PERL_INC)/perlio.h \ + $(PERL_INC)/perlsdio.h \ + $(PERL_INC)/perlsfio.h \ + $(PERL_INC)/perlvars.h \ + $(PERL_INC)/perly.h \ + $(PERL_INC)/pp.h \ + $(PERL_INC)/pp_proto.h \ + $(PERL_INC)/proto.h \ + $(PERL_INC)/regcomp.h \ + $(PERL_INC)/regexp.h \ + $(PERL_INC)/regnodes.h \ + $(PERL_INC)/scope.h \ + $(PERL_INC)/sv.h \ + $(PERL_INC)/thrdvar.h \ + $(PERL_INC)/thread.h \ + $(PERL_INC)/unixish.h \ + $(PERL_INC)/utf8.h \ + $(PERL_INC)/util.h \ + $(PERL_INC)/warnings.h $(OBJECT) : $(PERL_HDRS) } if $self->{OBJECT}; diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index 5eccf78b8e..44fa7e2496 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -717,7 +717,7 @@ sub cflags { $self->{OPTIMIZE} ||= $flagoptstr || $Config{'optimize'}; if ($self->{OPTIMIZE} !~ m!/!) { - if ($self->{OPTIMIZE} =~ m!\b-g\b!) { $self->{OPTIMIZE} = '/Debug/NoOptimize' } + if ($self->{OPTIMIZE} =~ m!-g!) { $self->{OPTIMIZE} = '/Debug/NoOptimize' } elsif ($self->{OPTIMIZE} =~ /-O(\d*)/) { $self->{OPTIMIZE} = '/Optimize' . (defined($1) ? "=$1" : ''); } diff --git a/lib/Pod/Checker.pm b/lib/Pod/Checker.pm index b5f980bba7..281bd11be7 100644 --- a/lib/Pod/Checker.pm +++ b/lib/Pod/Checker.pm @@ -10,7 +10,7 @@ package Pod::Checker; use vars qw($VERSION); -$VERSION = 1.097; ## Current version of this package +$VERSION = 1.098; ## Current version of this package require 5.004; ## requires this Perl version or later use Pod::ParseUtils; ## for hyperlinks and lists @@ -26,6 +26,7 @@ Pod::Checker, podchecker() - check pod documents for syntax errors $syntax_okay = podchecker($filepath, $outputpath, %options); my $checker = new Pod::Checker %options; + $checker->parse_from_file($filepath, \*STDERR); =head1 OPTIONS/ARGUMENTS @@ -57,13 +58,13 @@ It is hoped that curious/ambitious user will help flesh out and add the additional features they wish to see in B<Pod::Checker> and B<podchecker> and verify that the checks are consistent with L<perlpod>. -The following checks are preformed: +The following checks are currently preformed: =over 4 =item * -Unknown '=xxxx' commands, unknown 'X<...>' interior-sequences, +Unknown '=xxxx' commands, unknown 'XE<lt>...E<gt>' interior-sequences, and unterminated interior sequences. =item * @@ -97,14 +98,6 @@ to something else. =back -=head2 Additional Features - -While checking, this module collects document properties, e.g. the nodes -for hyperlinks (C<=headX>, C<=item>). POD translators can use this feature -to syntax-check and get the nodes in a first pass before actually starting -to convert. This is expensive in terms of execution time, but allows for -very robust conversions. - =head1 DIAGNOSTICS =head2 Errors @@ -188,6 +181,10 @@ syntax described in L<perlpod>. The C<ZE<lt>E<gt>> sequence is supposed to be empty. +=item * empty XE<lt>E<gt> + +The index entry specified contains nothing but whitespace. + =item * Spurious text after =pod / =cut The commands C<=pod> and C<=cut> do not take any arguments. @@ -293,13 +290,13 @@ there were no POD commands at all found in the file. I<[T.B.D.]> -=head1 AUTHOR +=head1 INTERFACE -Brad Appleton E<lt>bradapp@enteract.comE<gt> (initial version), -Marek Rouchal E<lt>marek@saftsack.fs.uni-bayreuth.deE<gt> - -Based on code for B<Pod::Text::pod2text()> written by -Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> +While checking, this module collects document properties, e.g. the nodes +for hyperlinks (C<=headX>, C<=item>) and index entries (C<XE<lt>E<gt>>). +POD translators can use this feature to syntax-check and get the nodes in +a first pass before actually starting to convert. This is expensive in terms +of execution time, but allows for very robust conversions. =cut @@ -477,7 +474,7 @@ sub podchecker( $ ; $ % ) { ## Now check the pod document for errors $checker->parse_from_file($infile, $outfile); - + ## Return the number of errors found return $checker->num_errors(); } @@ -509,11 +506,42 @@ sub initialize { $self->{_have_begin} = ''; # stores =begin $self->{_links} = []; # stack for internal hyperlinks $self->{_nodes} = []; # stack for =head/=item nodes + $self->{_index} = []; # text in X<> # print warnings? $self->{-warnings} = 1 unless(defined $self->{-warnings}); $self->{_current_head1} = ''; # the current =head1 block } +################################## + +=over 4 + +=item C<$checker-E<gt>poderror( @args )> + +=item C<$checker-E<gt>poderror( {%opts}, @args )> + +Internal method for printing errors and warnings. If no options are +given, simply prints "@_". The following options are recognized and used +to form the output: + + -msg + +A message to print prior to C<@args>. + + -line + +The line number the error occurred in. + + -file + +The file (name) the error occurred in. + + -severity + +The error level, should be 'WARNING' or 'ERROR'. + +=cut + # Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args ) sub poderror { my $self = shift; @@ -537,18 +565,43 @@ sub poderror { if($self->{-warnings} || !%opts || $opts{-severity} ne 'WARNING'); } -# set/retrieve the number of errors found +################################## + +=item C<$checker-E<gt>num_errors()> + +Set (if argument specified) and retrieve the number of errors found. + +=cut + sub num_errors { return (@_ > 1) ? ($_[0]->{_NUM_ERRORS} = $_[1]) : $_[0]->{_NUM_ERRORS}; } -# set and/or retrieve canonical name of POD +################################## + +=item C<$checker-E<gt>name()> + +Set (if argument specified) and retrieve the canonical name of POD as +found in the C<=head1 NAME> section. + +=cut + sub name { return (@_ > 1 && $_[1]) ? ($_[0]->{-name} = $_[1]) : $_[0]->{-name}; } -# set/return nodes of the current POD +################################## + +=item C<$checker-E<gt>node()> + +Add (if argument specified) and retrieve the nodes (as defined by C<=headX> +and C<=item>) of the current POD. The nodes are returned in the order of +their occurence. They consist of plain text, each piece of whitespace is +collapsed to a single blank. + +=cut + sub node { my ($self,$text) = @_; if(defined $text) { @@ -557,12 +610,49 @@ sub node { # add node, order important! push(@{$self->{_nodes}}, $text); # keep also a uniqueness counter - $self->{_unique_nodes}->{$text}++; + $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s); return $text; } @{$self->{_nodes}}; } +################################## + +=item C<$checker-E<gt>idx()> + +Add (if argument specified) and retrieve the index entries (as defined by +C<XE<lt>E<gt>>) of the current POD. They consist of plain text, each piece +of whitespace is collapsed to a single blank. + +=cut + +# set/return index entries of current POD +sub idx { + my ($self,$text) = @_; + if(defined $text) { + $text =~ s/\s+$//s; # strip trailing whitespace + $text =~ s/\s+/ /gs; # collapse whitespace + # add node, order important! + push(@{$self->{_index}}, $text); + # keep also a uniqueness counter + $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s); + return $text; + } + @{$self->{_index}}; +} + +################################## + +=item C<$checker-E<gt>hyperlink()> + +Add (if argument specified) and retrieve the hyperlinks (as defined by +C<LE<lt>E<gt>>) of the current POD. They consist of an 2-item array: line +number and C<Pod::Hyperlink> object. + +=back + +=cut + # set/return hyperlinks of the current POD sub hyperlink { my $self = shift; @@ -605,14 +695,22 @@ sub end_pod { } } foreach($self->hyperlink()) { - my $line = ''; - s/^(\d+):// && ($line = $1); - if($_ && !$nodes{$_}) { - $self->poderror({ -line => $line, -file => $infile, - -severity => 'ERROR', - -msg => "unresolved internal link '$_'"}); + my ($line,$link) = @$_; + # _TODO_ what if there is a link to the page itself by the name, + # e.g. in Tk::Pod : L<Tk::Pod/"DESCRIPTION"> + if($link->node() && !$link->page() && $link->type() ne 'hyperlink') { + my $node = $self->_check_ptree($self->parse_text($link->node(), + $line), $line, $infile, 'L'); + if($node && !$nodes{$node}) { + $self->poderror({ -line => $line || '', -file => $infile, + -severity => 'ERROR', + -msg => "unresolved internal link '$node'"}); + } } } + + # check the internal nodes for uniqueness. This pertains to + # =headX, =item and X<...> foreach(grep($self->{_unique_nodes}->{$_} > 1, keys %{$self->{_unique_nodes}})) { $self->poderror({ -line => '-', -file => $infile, @@ -758,6 +856,7 @@ sub command { } } elsif($cmd =~ /^head(\d+)/) { + # check whether the previous =head section had some contents if(defined $self->{_commands_in_head} && $self->{_commands_in_head} == 0 && defined $self->{_last_head} && @@ -996,15 +1095,8 @@ sub _check_ptree { # check the link text $text .= $self->_check_ptree($self->parse_text($link->text(), $line), $line, $file, "$nestlist$cmd"); - my $node = ''; - # remember internal link - # _TODO_ what if there is a link to the page itself by the name, - # e.g. in Tk::Pod : L<Tk::Pod/"DESCRIPTION"> - if($link->node() && !$link->page() && $link->type() ne 'hyperlink') { - $node = $self->_check_ptree($self->parse_text($link->node(), - $line), $line, $file, "$nestlist$cmd"); - $self->hyperlink("$line:$node") if($node); - } + # remember link + $self->hyperlink([$line,$link]); } elsif($cmd =~ /[BCFIS]/) { # add the guts @@ -1017,16 +1109,26 @@ sub _check_ptree { -msg => "Nonempty Z<>"}); } } - else { # X<> - # check, but add nothing to $text - $self->_check_ptree($contents, $line, $file, "$nestlist$cmd"); + elsif($cmd eq 'X') { + my $idx = $self->_check_ptree($contents, $line, $file, "$nestlist$cmd"); + if($idx =~ /^\s*$/s) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "Empty X<>"}); + } + else { + # remember this node + $self->idx($idx); + } + } + else { + # not reached + die "internal error"; } } $text; } -# _TODO_ overloadable methods for BC..Z<...> expansion? - # process a block of verbatim text sub verbatim { ## Nothing particular to check @@ -1076,3 +1178,15 @@ sub _preproc_par 1; +__END__ + +=head1 AUTHOR + +Brad Appleton E<lt>bradapp@enteract.comE<gt> (initial version), +Marek Rouchal E<lt>marek@saftsack.fs.uni-bayreuth.deE<gt> + +Based on code for B<Pod::Text::pod2text()> written by +Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> + +=cut + diff --git a/lib/Pod/InputObjects.pm b/lib/Pod/InputObjects.pm index 7544fb76c5..2f89cb91f1 100644 --- a/lib/Pod/InputObjects.pm +++ b/lib/Pod/InputObjects.pm @@ -11,7 +11,7 @@ package Pod::InputObjects; use vars qw($VERSION); -$VERSION = 1.10; ## Current version of this package +$VERSION = 1.11; ## Current version of this package require 5.004; ## requires this Perl version or later ############################################################################# diff --git a/lib/Pod/ParseUtils.pm b/lib/Pod/ParseUtils.pm index 2b3734fef9..00f516e99c 100644 --- a/lib/Pod/ParseUtils.pm +++ b/lib/Pod/ParseUtils.pm @@ -320,6 +320,16 @@ sub parse { ($alttext, $page, $node) = ($1, $2, $3); $type = 'section'; } + # alttext and page + elsif(m!^(.+?)\s*[|]\s*($page_rx)$!o) { + ($alttext, $page) = ($1, $2); + $type = 'page'; + } + # alttext and "section" + elsif(m!^(.+?)\s*[|]\s*(?:/\s*|)"(.+)"$!) { + ($alttext, $node) = ($1,$2); + $type = 'section'; + } # page and "section" elsif(m!^($page_rx)\s*/\s*"(.+)"$!o) { ($page, $node) = ($1, $2); @@ -350,16 +360,6 @@ sub parse { ($alttext, $page, $node) = ($1, $2, $3); $type = 'item'; } - # alttext and page - elsif(m!^(.+?)\s*[|]\s*($page_rx)$!o) { - ($alttext, $page) = ($1, $2); - $type = 'page'; - } - # alttext and "section" - elsif(m!^(.+?)\s*[|]\s*(?:/\s*|)"(.+)"$!) { - ($alttext, $node) = ($1,$2); - $type = 'section'; - } # alttext and item elsif(m!^(.+?)\s*[|]\s*/(.+)$!) { ($alttext, $node) = ($1,$2); @@ -777,9 +777,9 @@ sub nodes { =item find_node($name) -Look for a node named C<$name> in the object's node list. Returns the -unique id of the node (i.e. the second element of the array stored in -the node arry) or undef if not found. +Look for a node or index entry named C<$name> in the object. +Returns the unique id of the node (i.e. the second element of the array +stored in the node arry) or undef if not found. =back @@ -787,7 +787,10 @@ the node arry) or undef if not found. sub find_node { my ($self,$node) = @_; - foreach(@{$self->{-nodes}}) { + my @search; + push(@search, @{$self->{-nodes}}) if($self->{-nodes}); + push(@search, @{$self->{-idx}}) if($self->{-idx}); + foreach(@search) { if($_->[0] eq $node) { return $_->[1]; # id } @@ -795,6 +798,28 @@ sub find_node { undef; } +=item idx() + +Add an index entry (or a list of them) to the document's index list. Note that +the order is kept, i.e. start with the first node and end with the last. +If no argument is given, the current list of index entries is returned in the +same order the entries have been added. +An index entry can be any scalar, but usually is a pair of string and +unique id. + +=cut + +# The POD index entries +sub idx { + my ($self,@idx) = @_; + if(@idx) { + push(@{$self->{-idx}}, @idx); + return @idx; + } + else { + return @{$self->{-idx}}; + } +} =head1 AUTHOR diff --git a/lib/Pod/Parser.pm b/lib/Pod/Parser.pm index 22b3e49c61..a00f0ee83b 100644 --- a/lib/Pod/Parser.pm +++ b/lib/Pod/Parser.pm @@ -10,7 +10,7 @@ package Pod::Parser; use vars qw($VERSION); -$VERSION = 1.10; ## Current version of this package +$VERSION = 1.11; ## Current version of this package require 5.004; ## requires this Perl version or later ############################################################################# @@ -1062,7 +1062,7 @@ sub parse_from_filehandle { next unless (($textline =~ /^(\s*)$/) && (length $paragraph)); ## Issue a warning about any non-empty blank lines - if ( length($1) > 1 ) { + if (length($1) > 1 and ! $self->{_CUTTING}) { my $errorsub = $self->errorsub(); my $file = $self->input_file(); my $errmsg = "*** WARNING: line containing nothing but whitespace". diff --git a/lib/Pod/Select.pm b/lib/Pod/Select.pm index 230dc8f03b..53e27e513a 100644 --- a/lib/Pod/Select.pm +++ b/lib/Pod/Select.pm @@ -10,7 +10,7 @@ package Pod::Select; use vars qw($VERSION); -$VERSION = 1.10; ## Current version of this package +$VERSION = 1.11; ## Current version of this package require 5.004; ## requires this Perl version or later ############################################################################# diff --git a/lib/Pod/Usage.pm b/lib/Pod/Usage.pm index 84a936e396..b8abe7d41b 100644 --- a/lib/Pod/Usage.pm +++ b/lib/Pod/Usage.pm @@ -10,7 +10,7 @@ package Pod::Usage; use vars qw($VERSION); -$VERSION = 1.10; ## Current version of this package +$VERSION = 1.11; ## Current version of this package require 5.004; ## requires this Perl version or later =head1 NAME @@ -40,7 +40,7 @@ struct magic { #define MgTAINTEDDIR_on(mg) (mg->mg_flags |= MGf_TAINTEDDIR) #define MgTAINTEDDIR_off(mg) (mg->mg_flags &= ~MGf_TAINTEDDIR) -#define MgPV(mg,lp) (((lp = (mg)->mg_len) == HEf_SVKEY) ? \ +#define MgPV(mg,lp) ((((int)(lp = (mg)->mg_len)) == HEf_SVKEY) ? \ SvPV((SV*)((mg)->mg_ptr),lp) : \ (mg)->mg_ptr) @@ -1737,6 +1737,10 @@ #define Perl_sv_vsetpvfn pPerl->Perl_sv_vsetpvfn #undef sv_vsetpvfn #define sv_vsetpvfn Perl_sv_vsetpvfn +#undef Perl_str_to_version +#define Perl_str_to_version pPerl->Perl_str_to_version +#undef str_to_version +#define str_to_version Perl_str_to_version #undef Perl_swash_init #define Perl_swash_init pPerl->Perl_swash_init #undef swash_init @@ -3140,6 +3140,13 @@ Perl_sv_vsetpvfn(pTHXo_ SV* sv, const char* pat, STRLEN patlen, va_list* args, S ((CPerlObj*)pPerl)->Perl_sv_vsetpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted); } +#undef Perl_str_to_version +NV +Perl_str_to_version(pTHXo_ SV *sv) +{ + return ((CPerlObj*)pPerl)->Perl_str_to_version(sv); +} + #undef Perl_swash_init SV* Perl_swash_init(pTHXo_ char* pkg, char* name, SV* listsv, I32 minbits, I32 none) diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index f9b4a6bac3..525d26ef7a 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -442,44 +442,51 @@ L<perlipc/"Sockets: Client/Server Communication">. =item binmode FILEHANDLE Arranges for FILEHANDLE to be read or written in "binary" mode on -systems whose run-time libraries force the programmer to guess -between binary and text files. If FILEHANDLE is an expression, the -value is taken as the name of the filehandle. binmode() should be -called after the C<open> but before any I/O is done on the filehandle. -The only way to reset binary mode on a filehandle is to reopen the -file. +systems where the run-time libraries distinguish between binary and +text files. If FILEHANDLE is an expression, the value is taken as the +name of the filehandle. binmode() should be called after open() but +before any I/O is done on the filehandle. The only way to reset +binary mode on a filehandle is to reopen the file. + +On many systems binmode() has no effect, and on some systems it is +necessary when you're not working with a text file. For the sake of +portability it is a good idea to always use it when appropriate, and +to never use it when it isn't appropriate. + +In other words: Regardless of platform, use binmode() on binary +files, and do not use binmode() on text files. The operating system, device drivers, C libraries, and Perl run-time -system all conspire to let the programmer conveniently treat a -simple, one-byte C<\n> as the line terminator, irrespective of its -external representation. On Unix and its brethren, the native file -representation exactly matches the internal representation, making -everyone's lives unbelievably simpler. Consequently, L<binmode> -has no effect under Unix, Plan9, or Mac OS, all of which use C<\n> -to end each line. (Unix and Plan9 think C<\n> means C<\cJ> and -C<\r> means C<\cM>, whereas the Mac goes the other way--it uses -C<\cM> for c<\n> and C<\cJ> to mean C<\r>. But that's ok, because -it's only one byte, and the internal and external representations -match.) - -In legacy systems like MS-DOS and its embellishments, your program -sees a C<\n> as a simple C<\cJ> (just as in Unix), but oddly enough, -that's not what's physically stored on disk. What's worse, these -systems refuse to help you with this; it's up to you to remember -what to do. And you mustn't go applying binmode() with wild abandon, -either, because if your system does care about binmode(), then using -it when you shouldn't is just as perilous as failing to use it when -you should. - -That means that on any version of Microsoft WinXX that you might -care to name (or not), binmode() causes C<\cM\cJ> sequences on disk -to be converted to C<\n> when read into your program, and causes -any C<\n> in your program to be converted back to C<\cM\cJ> on -output to disk. This sad discrepancy leads to no end of -problems in not just the readline operator, but also when using -seek(), tell(), and read() calls. See L<perlport> for other painful -details. See the C<$/> and C<$\> variables in L<perlvar> for how -to manually set your input and output line-termination sequences. +system all work together to let the programmer treat a single +character (C<\n>) as the line terminator, irrespective of the external +representation. On many operating systems, the native text file +representation matches the internal representation, but on some +platforms the external representation of C<\n> is made up of more than +one character. + +Mac OS and all variants of Unix use a single character to end each line +in the external representation of text (even though that single +character is not necessarily the same across these platforms). +Consequently binmode() has no effect on these operating systems. In +other systems like VMS, MS-DOS and the various flavors of MS-Windows +your program sees a C<\n> as a simple C<\cJ>, but what's stored in text +files are the two characters C<\cM\cJ>. That means that, if you don't +use binmode() on these systems, C<\cM\cJ> sequences on disk will be +converted to C<\n> on input, and any C<\n> in your program will be +converted back to C<\cM\cJ> on output. This is what you want for text +files, but it can be disastrous for binary files. + +Another consequence of using binmode() (on some systems) is that +special end-of-file markers will be seen as part of the data stream. +For systems from the Microsoft family this means that if your binary +data contains C<\cZ>, the I/O subsystem will ragard it as the end of +the file, unless you use binmode(). + +binmode() is not only important for readline() and print() operations, +but also when using read(), seek(), sysread(), syswrite() and tell() +(see L<perlport> for more details). See the C<$/> and C<$\> variables +in L<perlvar> for how to manually set your input and output +line-termination sequences. =item bless REF,CLASSNAME @@ -1076,7 +1076,7 @@ PP(pp_getc) GV *gv; MAGIC *mg; - if (MAXARG <= 0) + if (MAXARG == 0) gv = PL_stdingv; else gv = (GV*)POPs; @@ -1686,7 +1686,7 @@ PP(pp_eof) GV *gv; MAGIC *mg; - if (MAXARG <= 0) { + if (MAXARG == 0) { if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */ IO *io; gv = PL_last_in_gv = PL_argvgv; @@ -1730,7 +1730,7 @@ PP(pp_tell) GV *gv; MAGIC *mg; - if (MAXARG <= 0) + if (MAXARG == 0) gv = PL_last_in_gv; else gv = PL_last_in_gv = (GV*)POPs; @@ -1965,7 +1965,7 @@ PP(pp_flock) #ifdef FLOCK argtype = POPi; - if (MAXARG <= 0) + if (MAXARG == 0) gv = PL_last_in_gv; else gv = (GV*)POPs; @@ -768,6 +768,7 @@ PERL_CALLCONV bool Perl_sv_upgrade(pTHX_ SV* sv, U32 mt); PERL_CALLCONV void Perl_sv_usepvn(pTHX_ SV* sv, char* ptr, STRLEN len); PERL_CALLCONV void Perl_sv_vcatpvfn(pTHX_ SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted); PERL_CALLCONV void Perl_sv_vsetpvfn(pTHX_ SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted); +PERL_CALLCONV NV Perl_str_to_version(pTHX_ SV *sv); PERL_CALLCONV SV* Perl_swash_init(pTHX_ char* pkg, char* name, SV* listsv, I32 minbits, I32 none); PERL_CALLCONV UV Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr); PERL_CALLCONV void Perl_taint_env(pTHX); @@ -316,7 +316,7 @@ Perl_save_ary(pTHX_ GV *gv) av = GvAVn(gv); if (SvMAGIC(oav)) { SvMAGIC(av) = SvMAGIC(oav); - SvFLAGS(av) |= SvMAGICAL(oav); + SvFLAGS((SV*)av) |= SvMAGICAL(oav); SvMAGICAL_off(oav); SvMAGIC(oav) = 0; PL_localizing = 1; @@ -341,7 +341,7 @@ Perl_save_hash(pTHX_ GV *gv) hv = GvHVn(gv); if (SvMAGIC(ohv)) { SvMAGIC(hv) = SvMAGIC(ohv); - SvFLAGS(hv) |= SvMAGICAL(ohv); + SvFLAGS((SV*)hv) |= SvMAGICAL(ohv); SvMAGICAL_off(ohv); SvMAGIC(ohv) = 0; PL_localizing = 1; @@ -715,7 +715,7 @@ Perl_leave_scope(pTHX_ I32 base) if (GvAV(gv)) { AV *goner = GvAV(gv); SvMAGIC(av) = SvMAGIC(goner); - SvFLAGS(av) |= SvMAGICAL(goner); + SvFLAGS((SV*)av) |= SvMAGICAL(goner); SvMAGICAL_off(goner); SvMAGIC(goner) = 0; SvREFCNT_dec(goner); diff --git a/t/comp/use.t b/t/comp/use.t index dbbda5c038..c3cdb70709 100755 --- a/t/comp/use.t +++ b/t/comp/use.t @@ -5,7 +5,7 @@ BEGIN { unshift @INC, '../lib'; } -print "1..15\n"; +print "1..27\n"; my $i = 1; eval "use 5.000"; # implicit semicolon @@ -103,3 +103,68 @@ print "ok ",$i++,"\n"; print "not " if $INC[0] eq "freda"; print "ok ",$i++,"\n"; + +{ + local $lib::VERSION = 35.36; + eval "use lib v33.55"; + print "not " if $@; + print "ok ",$i++,"\n"; + + eval "use lib v100.105"; + unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) { + print "not "; + } + print "ok ",$i++,"\n"; + + eval "use lib 33.55"; + print "not " if $@; + print "ok ",$i++,"\n"; + + eval "use lib 100.105"; + unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) { + print "not "; + } + print "ok ",$i++,"\n"; + + local $lib::VERSION = '35.36'; + eval "use lib v33.55"; + print "not " if $@; + print "ok ",$i++,"\n"; + + eval "use lib v100.105"; + unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) { + print "not "; + } + print "ok ",$i++,"\n"; + + eval "use lib 33.55"; + print "not " if $@; + print "ok ",$i++,"\n"; + + eval "use lib 100.105"; + unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) { + print "not "; + } + print "ok ",$i++,"\n"; + + local $lib::VERSION = v35.36; + eval "use lib v33.55"; + print "not " if $@; + print "ok ",$i++,"\n"; + + eval "use lib v100.105"; + unless ($@ =~ /lib version v100\.105 required--this is only version v35\.36/) { + print "not "; + } + print "ok ",$i++,"\n"; + + eval "use lib 33.55"; + print "not " if $@; + print "ok ",$i++,"\n"; + + eval "use lib 100.105"; + unless ($@ =~ /lib version 100\.105 required--this is only version 35\.036/) { + print "not "; + } + print "ok ",$i++,"\n"; +} diff --git a/t/pod/poderrs.t b/t/pod/poderrs.t index bec2a198b6..ec632c2538 100755 --- a/t/pod/poderrs.t +++ b/t/pod/poderrs.t @@ -10,6 +10,10 @@ my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash my $passed = testpodchecker \%options, $0; exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; +### Deliberately throw in some blank but non-empty lines + +### The above line should contain spaces + __END__ diff --git a/t/pod/poderrs.xr b/t/pod/poderrs.xr index 2848faa46a..3e9c42b874 100644 --- a/t/pod/poderrs.xr +++ b/t/pod/poderrs.xr @@ -1,33 +1,33 @@ -*** ERROR: Unknown command 'unknown1' at line 21 in file pod/poderrs.t -*** ERROR: Unknown interior-sequence 'Q' at line 25 in file pod/poderrs.t -*** ERROR: Unknown interior-sequence 'A' at line 26 in file pod/poderrs.t -*** ERROR: Unknown interior-sequence 'Y' at line 27 in file pod/poderrs.t -*** ERROR: Unknown interior-sequence 'V' at line 27 in file pod/poderrs.t -*** WARNING: unterminated B<...> at line 31 in file pod/poderrs.t -*** WARNING: unterminated I<...> at line 30 in file pod/poderrs.t -*** WARNING: unterminated C<...> at line 33 in file pod/poderrs.t -*** WARNING: line containing nothing but whitespace in paragraph at line 41 in file pod/poderrs.t -*** ERROR: =item without previous =over at line 48 in file pod/poderrs.t -*** ERROR: =back without previous =over at line 52 in file pod/poderrs.t -*** ERROR: =over on line 56 without closing =back (at head2) at line 60 in file pod/poderrs.t -*** ERROR: =end without =begin at line 62 in file pod/poderrs.t -*** ERROR: Nested =begin's (first at line 66:html) at line 68 in file pod/poderrs.t -*** ERROR: =end without =begin at line 72 in file pod/poderrs.t -*** ERROR: nested commands C<...C<...>...> at line 76 in file pod/poderrs.t -*** ERROR: garbled entity E<alea iacta est> at line 80 in file pod/poderrs.t -*** ERROR: garbled entity E<C<auml>> at line 81 in file pod/poderrs.t -*** ERROR: garbled entity E<abcI<bla>> at line 82 in file pod/poderrs.t -*** WARNING: collapsing newlines to blanks at line 92 in file pod/poderrs.t -*** ERROR: malformed link L<> : empty link at line 94 in file pod/poderrs.t -*** WARNING: ignoring leading whitespace in link at line 100 in file pod/poderrs.t -*** WARNING: ignoring trailing whitespace in link at line 100 in file pod/poderrs.t -*** ERROR: Spurious character(s) after =back at line 106 in file pod/poderrs.t -*** WARNING: No items in =over (at line 114) / =back list at line 116 in file pod/poderrs.t -*** WARNING: 2 unescaped <> in paragraph at line 118 in file pod/poderrs.t -*** ERROR: unresolved internal link 'begin or begin' at line 86 in file pod/poderrs.t -*** ERROR: unresolved internal link 'end with begin' at line 87 in file pod/poderrs.t -*** ERROR: unresolved internal link 'OoPs' at line 88 in file pod/poderrs.t -*** ERROR: unresolved internal link 'abc def' at line 92 in file pod/poderrs.t -*** ERROR: unresolved internal link 'passwd(5)' at line 99 in file pod/poderrs.t +*** ERROR: Unknown command 'unknown1' at line 25 in file pod/poderrs.t +*** ERROR: Unknown interior-sequence 'Q' at line 29 in file pod/poderrs.t +*** ERROR: Unknown interior-sequence 'A' at line 30 in file pod/poderrs.t +*** ERROR: Unknown interior-sequence 'Y' at line 31 in file pod/poderrs.t +*** ERROR: Unknown interior-sequence 'V' at line 31 in file pod/poderrs.t +*** WARNING: unterminated B<...> at line 35 in file pod/poderrs.t +*** WARNING: unterminated I<...> at line 34 in file pod/poderrs.t +*** WARNING: unterminated C<...> at line 37 in file pod/poderrs.t +*** WARNING: line containing nothing but whitespace in paragraph at line 45 in file pod/poderrs.t +*** ERROR: =item without previous =over at line 52 in file pod/poderrs.t +*** ERROR: =back without previous =over at line 56 in file pod/poderrs.t +*** ERROR: =over on line 60 without closing =back (at head2) at line 64 in file pod/poderrs.t +*** ERROR: =end without =begin at line 66 in file pod/poderrs.t +*** ERROR: Nested =begin's (first at line 70:html) at line 72 in file pod/poderrs.t +*** ERROR: =end without =begin at line 76 in file pod/poderrs.t +*** ERROR: nested commands C<...C<...>...> at line 80 in file pod/poderrs.t +*** ERROR: garbled entity E<alea iacta est> at line 84 in file pod/poderrs.t +*** ERROR: garbled entity E<C<auml>> at line 85 in file pod/poderrs.t +*** ERROR: garbled entity E<abcI<bla>> at line 86 in file pod/poderrs.t +*** WARNING: collapsing newlines to blanks at line 96 in file pod/poderrs.t +*** ERROR: malformed link L<> : empty link at line 98 in file pod/poderrs.t +*** WARNING: ignoring leading whitespace in link at line 104 in file pod/poderrs.t +*** WARNING: ignoring trailing whitespace in link at line 104 in file pod/poderrs.t +*** ERROR: Spurious character(s) after =back at line 110 in file pod/poderrs.t +*** WARNING: No items in =over (at line 118) / =back list at line 120 in file pod/poderrs.t +*** WARNING: 2 unescaped <> in paragraph at line 122 in file pod/poderrs.t +*** ERROR: unresolved internal link 'begin or begin' at line 90 in file pod/poderrs.t +*** ERROR: unresolved internal link 'end with begin' at line 91 in file pod/poderrs.t +*** ERROR: unresolved internal link 'OoPs' at line 92 in file pod/poderrs.t +*** ERROR: unresolved internal link 'abc def' at line 96 in file pod/poderrs.t +*** ERROR: unresolved internal link 'passwd(5)' at line 103 in file pod/poderrs.t *** WARNING: multiple occurence of link target 'oops' at line - in file pod/poderrs.t pod/poderrs.t has 22 pod syntax errors. @@ -812,6 +812,31 @@ S_force_ident(pTHX_ register char *s, int kind) } } +NV +Perl_str_to_version(pTHX_ SV *sv) +{ + NV retval = 0.0; + NV nshift = 1.0; + STRLEN len; + char *start = SvPVx(sv,len); + bool utf = SvUTF8(sv); + char *end = start + len; + while (start < end) { + I32 skip; + UV n; + if (utf) + n = utf8_to_uv((U8*)start, &skip); + else { + n = *(U8*)start; + skip = 1; + } + retval += ((NV)n)/nshift; + start += skip; + nshift *= 1000; + } + return retval; +} + /* * S_force_version * Forces the next token to be a version number. @@ -833,12 +858,12 @@ S_force_version(pTHX_ char *s) if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) { SV *ver; s = scan_num(s); - /* real VERSION number -- GBARR */ version = yylval.opval; ver = cSVOPx(version)->op_sv; if (SvPOK(ver) && !SvNIOK(ver)) { - SvUPGRADE(ver, SVt_PVIV); - SvIOKp_on(ver); /* hint that it is a version */ + SvUPGRADE(ver, SVt_PVNV); + SvNVX(ver) = str_to_version(ver); + SvNOK_on(ver); /* hint that it is a version */ } } } diff --git a/universal.c b/universal.c index 6ccff2f003..0e5a89b2c0 100644 --- a/universal.c +++ b/universal.c @@ -197,11 +197,10 @@ XS(XS_UNIVERSAL_VERSION) GV *gv; SV *sv; char *undef; - NV req; - if(SvROK(ST(0))) { + if (SvROK(ST(0))) { sv = (SV*)SvRV(ST(0)); - if(!SvOBJECT(sv)) + if (!SvOBJECT(sv)) Perl_croak(aTHX_ "Cannot find version of an unblessed reference"); pkg = SvSTASH(sv); } @@ -222,12 +221,56 @@ XS(XS_UNIVERSAL_VERSION) undef = "(undef)"; } - if (items > 1 && (undef || (req = SvNV(ST(1)), req > SvNV(sv)))) { - STRLEN n_a; - Perl_croak(aTHX_ "%s version %s required--this is only version %s", - HvNAME(pkg), SvPV(ST(1),n_a), undef ? undef : SvPV(sv,n_a)); + if (items > 1) { + STRLEN len; + SV *req = ST(1); + + if (undef) + Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed", + HvNAME(pkg), HvNAME(pkg)); + + if (!SvNIOK(sv) && SvPOK(sv)) { + char *str = SvPVx(sv,len); + while (len) { + --len; + /* XXX could DWIM "1.2.3" here */ + if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_') + break; + } + if (len) { + if (SvNIOKp(req) && SvPOK(req)) { + /* they said C<use Foo v1.2.3> and $Foo::VERSION + * doesn't look like a float: do string compare */ + if (sv_cmp(req,sv) == 1) { + Perl_croak(aTHX_ "%s version v%vd required--" + "this is only version v%vd", + HvNAME(pkg), req, sv); + } + goto finish; + } + /* they said C<use Foo 1.002_003> and $Foo::VERSION + * doesn't look like a float: force numeric compare */ + SvUPGRADE(sv, SVt_PVNV); + SvNVX(sv) = str_to_version(sv); + SvPOK_off(sv); + SvNOK_on(sv); + } + } + /* if we get here, we're looking for a numeric comparison, + * so force the required version into a float, even if they + * said C<use Foo v1.2.3> */ + if (SvNIOKp(req) && SvPOK(req)) { + NV n = SvNV(req); + req = sv_newmortal(); + sv_setnv(req, n); + } + + if (SvNV(req) > SvNV(sv)) + Perl_croak(aTHX_ "%s version %s required--this is only version %s", + HvNAME(pkg), SvPV(req,len), SvPV(sv,len)); } +finish: ST(0) = sv; XSRETURN(1); diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index c07c6d98f6..9e426e925e 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -375,7 +375,7 @@ pod8 = [.lib.pod]perltoot.pod [.lib.pod]perltootc.pod [.lib.pod]perltrap.pod [.l pod9 = [.lib.pod]perlfaq.pod [.lib.pod]perlfaq1.pod [.lib.pod]perlfaq2.pod [.lib.pod]perlfaq3.pod [.lib.pod]perlfaq4.pod [.lib.pod]perlfaq5.pod pod10 = [.lib.pod]perlfaq6.pod [.lib.pod]perlfaq7.pod [.lib.pod]perlfaq8.pod [.lib.pod]perlfaq9.pod -perlpods : $(pod1) $(pod2) $(pod3) $(pod4) $(pod5) $(pod6) $(pod7) $(pod8) $(pod9) $(pod10) [.lib.pod]perlvms.pod [.lib.pod]README_vms.pod +perlpods : $(pod1) $(pod2) $(pod3) $(pod4) $(pod5) $(pod6) $(pod7) $(pod8) $(pod9) $(pod10) [.lib.pod]perlvms.pod @ $(NOOP) archcorefiles : $(ac) $(acth) $(ARCHAUTO)time.stamp @@ -850,13 +850,10 @@ preplibrary : $(MINIPERL_EXE) $(LIBPREREQ) $(SOCKPM) @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] @ Copy/Log $(MMS$SOURCE) $(MMS$TARGET) -[.lib.pod]README_vms.pod : README.vms - @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] - @ Copy/Log $(MMS$SOURCE) $(MMS$TARGET) - -[.lib.pod]perlwin32.pod : README.win32 - @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] - @ Copy/Log $(MMS$SOURCE) $(MMS$TARGET) +install.html : []perl_setup.com installhtml. install $(perlpods) + @ @perl_setup + @ If F$Search("[.lib]html.dir").eqs."" Then Create/Directory [.lib.html] + $(MINIPERL) installhtml. "--podroot=/perl_root --recurse --htmldir=lib/html --htmlroot=lib/html --splithead=pod/perlipc --splititem=pod/perlfunc --libpods=perlfunc:perlguts:perlvar:perlrun:perlop --verbose" printconfig : @ @[.vms]make_command $(MMS) $(MMSQUALIFIERS) $(MMSTARGETS) diff --git a/vms/sockadapt.h b/vms/sockadapt.h index 0ff309ab9a..97a49f8917 100644 --- a/vms/sockadapt.h +++ b/vms/sockadapt.h @@ -35,7 +35,7 @@ void setservent(int); void endservent(void); #endif -# if defined(__DECC) && defined(__DECC_VER) && (__DECC_VER >= 50200000) +# if defined(__DECC) && defined(__DECC_VER) && (__DECC_VER >= 50200000) && !defined(Sock_size_t) # define Sock_size_t unsigned int # endif diff --git a/vms/subconfigure.com b/vms/subconfigure.com index dae2bdaf07..dfa3482c88 100644 --- a/vms/subconfigure.com +++ b/vms/subconfigure.com @@ -141,6 +141,7 @@ $ perl_uselargefiles = "undef" $ perl_uselongdouble = "undef" $ perl_usemorebits = "undef" $ ENDIF +$ use_64bitall = use_64bitint ! until configure.com question is reworded? $ IF use_64bitall .eqs. "Y" $ THEN $ perl_use64bitall = "define" @@ -3349,7 +3350,12 @@ $ perl_d_gethostprotos="define" $ perl_d_getnetprotos="define" $ perl_d_getprotoprotos="define" $ perl_d_getservprotos="define" -$ perl_sock_size_type="int *" +$ IF ("''Using_Dec_C'".EQS."Yes") +$ THEN +$ perl_socksizetype="unsigned int" +$ ELSE +$ perl_socksizetype="int *" +$ ENDIF $ ELSE $ perl_d_vms_do_sockets="undef" $ perl_d_htonl="undef" @@ -3371,7 +3377,7 @@ $ perl_d_gethostprotos="undef" $ perl_d_getnetprotos="undef" $ perl_d_getprotoprotos="undef" $ perl_d_getservprotos="undef" -$ perl_sock_size_type="undef" +$ perl_socksizetype="undef" $ ENDIF $! Threads $ if ("''use_threads'".eqs."T") @@ -3919,7 +3925,7 @@ $ WC "netdb_host_type='" + perl_netdb_host_type + "'" $ WC "netdb_hlen_type='" + perl_netdb_hlen_type + "'" $ WC "netdb_name_type='" + perl_netdb_name_type + "'" $ WC "netdb_net_type='" + perl_netdb_net_type + "'" -$ WC "sock_size_type='" + perl_sock_size_type + "'" +$ WC "socksizetype='" + perl_socksizetype + "'" $ WC "baserev='" + perl_baserev + "'" $ WC "doublesize='" + perl_doublesize + "'" $ WC "ptrsize='" + perl_ptrsize + "'" @@ -3971,6 +3971,27 @@ static long int utc_offset_secs; # define RTL_USES_UTC 1 #endif +/* + * DEC C previous to 6.0 corrupts the behavior of the /prefix + * qualifier with the extern prefix pragma. This provisional + * hack circumvents this prefix pragma problem in previous + * precompilers. + */ +#if defined(__VMS_VER) && __VMS_VER >= 70000000 +# if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000) +# pragma __extern_prefix save +# pragma __extern_prefix "" /* set to empty to prevent prefixing */ +# define gmtime decc$__utctz_gmtime +# define localtime decc$__utctz_localtime +# define time decc$__utc_time +# pragma __extern_prefix restore + + struct tm *gmtime(), *localtime(); + +# endif +#endif + + static time_t toutc_dst(time_t loc) { struct tm *rsltmp; @@ -3979,7 +4000,7 @@ static time_t toutc_dst(time_t loc) { if (rsltmp->tm_isdst) loc -= 3600; return loc; } -#define _toutc(secs) ((secs) == -1 ? -1 : \ +#define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \ ((gmtime_emulation_type || my_time(NULL)), \ (gmtime_emulation_type == 1 ? toutc_dst(secs) : \ ((secs) - utc_offset_secs)))) @@ -3992,7 +4013,7 @@ static time_t toloc_dst(time_t utc) { if (rsltmp->tm_isdst) utc += 3600; return utc; } -#define _toloc(secs) ((secs) == -1 ? -1 : \ +#define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \ ((gmtime_emulation_type || my_time(NULL)), \ (gmtime_emulation_type == 1 ? toloc_dst(secs) : \ ((secs) + utc_offset_secs)))) diff --git a/vms/vmsish.h b/vms/vmsish.h index e9b47a0a9d..8d4a8caf6b 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -198,6 +198,16 @@ */ #define ALTERNATE_SHEBANG "$" +/* Lower case entry points for these are missing in some earlier RTLs + * so we borrow the defines and declares from errno.h and upcase them. + */ +#if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 50500000) +# define errno (*CMA$TIS_ERRNO_GET_ADDR()) +# define vaxc$errno (*CMA$TIS_VMSERRNO_GET_ADDR()) + int *CMA$TIS_ERRNO_GET_ADDR (void); /* UNIX style error code */ + int *CMA$TIS_VMSERRNO_GET_ADDR (void); /* VMS error (errno == EVMSERR) */ +#endif + /* Macros to set errno using the VAX thread-safe calls, if present */ #if (defined(__DECC) || defined(__DECCXX)) && !defined(__ALPHA) # define set_errno(v) (cma$tis_errno_set_value(v)) @@ -537,6 +547,25 @@ struct mystat }; typedef unsigned mydev_t; typedef unsigned myino_t; + +/* + * DEC C previous to 6.0 corrupts the behavior of the /prefix + * qualifier with the extern prefix pragma. This provisional + * hack circumvents this prefix pragma problem in previous + * precompilers. + */ +#if defined(__VMS_VER) && __VMS_VER >= 70000000 +# if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000) +# pragma __extern_prefix save +# pragma __extern_prefix "" /* set to empty to prevent prefixing */ +# define geteuid decc$__unix_geteuid +# define getuid decc$__unix_getuid +# define stat(__p1,__p2) decc$__utc_stat(__p1,__p2) +# define fstat(__p1,__p2) decc$__utc_fstat(__p1,__p2) +# pragma __extern_prefix restore +# endif +#endif + #ifndef DONT_MASK_RTL_CALLS /* defined for vms.c so we can see RTL calls */ # ifdef stat # undef stat @@ -556,6 +585,7 @@ typedef unsigned myino_t; #define S_IDGRP (S_IWGRP | S_IXGRP) #define S_IDOTH (S_IWOTH | S_IXOTH) + /* Prototypes for functions unique to vms.c. Don't include replacements * for routines in the mainline source files excluded by #ifndef VMS; * their prototypes are already in proto.h. diff --git a/win32/config.vc b/win32/config.vc index b98925bf66..ed981567fb 100644 --- a/win32/config.vc +++ b/win32/config.vc @@ -709,6 +709,7 @@ use5005threads='undef' use64bitall='undef' use64bitint='undef' usedl='define' +useithreads='undef' uselargefiles='undef' uselongdouble='undef' usemorebits='undef' @@ -744,8 +745,8 @@ xlibpth='/usr/lib/386 /lib/386' zcat='' zip='zip' PERL_REVISION='~PERL_REVISION~' -PERL_VERSION='~PERL_VERSION~' PERL_SUBVERSION='~PERL_SUBVERSION~' +PERL_VERSION='~PERL_VERSION~' PERL_API_REVISION='~PERL_API_REVISION~' PERL_API_SUBVERSION='~PERL_API_SUBVERSION~' PERL_API_VERSION='~PERL_API_VERSION~' |