diff options
105 files changed, 6939 insertions, 271 deletions
@@ -6,6 +6,7 @@ alan.burlison Alan Burlison Alan.Burlison@UK.Sun.com allen Norton T. Allen allen@huarp.harvard.edu +bradapp Brad Appleton bradapp@enteract.com cbail Charles Bailey bailey@newman.upenn.edu dgris Daniel Grisinger dgris@dimensional.com dmulholl Daniel Yacob dmulholl@cs.indiana.edu @@ -427,9 +427,15 @@ lib/Net/hostent.pm tchrist lib/Net/netent.pm tchrist lib/Net/protoent.pm tchrist lib/Net/servent.pm tchrist +lib/Pod/Checker.pm bradapp lib/Pod/Functions.pm lib/Pod/Html.pm tchrist +lib/Pod/InputObjects.pm bradapp +lib/Pod/Parser.pm bradapp +lib/Pod/PlainText.pm bradapp +lib/Pod/Select.pm bradapp lib/Pod/Text.pm tchrist +lib/Pod/Usage.pm bradapp lib/Search/Dict.pm lib/SelectSaver.pm lib/SelfLoader.pm @@ -549,6 +555,9 @@ perly.fixer perly.h perly.y plan9/* plan9 +pod/pod2usage.PL bradapp +pod/podchecker.PL bradapp +pod/podselect.PL bradapp pod/* doc pod/buildtoc pod/checkpods.PL @@ -809,6 +818,7 @@ t/op/unshift.t t/op/vec.t t/op/wantarray.t t/op/write.t +t/pod/* bradapp t/pragma/constant.t t/pragma/locale.t locale t/pragma/overload.t ilya @@ -33,6 +33,7 @@ Porting/patchls Flexible patch file listing utility Porting/pumpkin.pod Guidelines and hints for Perl maintainers README The Instructions README.amiga Notes about AmigaOS port +README.apollo Notes about Apollo DomainOS port README.beos Notes about BeOS port README.cygwin32 Notes about Cygwin32 port README.dos Notes about dos/djgpp port @@ -55,6 +56,7 @@ Todo The Wishlist Todo-5.005 What needs doing before 5.005 release XSlock.h Include file for extensions built with PERL_OBJECT defined XSUB.h Include file for extension subroutines +apollo/netinet/in.h Apollo DomainOS port: C header file frontend av.c Array value code av.h Array value header beos/nm.c BeOS port @@ -581,9 +583,15 @@ lib/Net/hostent.pm By-name interface to Perl's builtin gethost* lib/Net/netent.pm By-name interface to Perl's builtin getnet* lib/Net/protoent.pm By-name interface to Perl's builtin getproto* lib/Net/servent.pm By-name interface to Perl's builtin getserv* +lib/Pod/Checker.pm Pod-Parser - check POD documents for syntax errors lib/Pod/Functions.pm used by pod/splitpod lib/Pod/Html.pm Convert POD data to HTML +lib/Pod/InputObjects.pm Pod-Parser - define objects for input streams +lib/Pod/Parser.pm Pod-Parser - define base class for parsing POD +lib/Pod/PlainText.pm Pod-Parser - convert POD data to formatted ASCII text +lib/Pod/Select.pm Pod-Parser - select portions of POD docs lib/Pod/Text.pm Convert POD data to formatted ASCII text +lib/Pod/Usage.pm Pod-Parser - print usage messages lib/Search/Dict.pm Perform binary search on dictionaries lib/SelectSaver.pm Enforce proper select scoping lib/SelfLoader.pm Load functions only on demand @@ -992,6 +1000,9 @@ pod/pod2html.PL Precursor for translator to turn pod into HTML pod/pod2latex.PL Precursor for translator to turn pod into LaTeX pod/pod2man.PL Precursor for translator to turn pod into manpage pod/pod2text.PL Precursor for translator to turn pod into text +pod/pod2usage.PL Pod-Parser - print usage messages from POD docs +pod/podchecker.PL Pod-Parser - Pod::Checker::podchecker() CLI +pod/podselect.PL Pod-Parser - Pod::Select::podselect() CLI pod/roffitall troff the whole man page set pod/rofftoc Generate a table of contents in troff format pod/splitman Splits perlfunc into multiple man pages @@ -1086,6 +1097,7 @@ t/lib/fields.t See if base/fields works t/lib/filecache.t See if FileCache works t/lib/filecopy.t See if File::Copy works t/lib/filefind.t See if File::Find works +t/lib/filefunc.t See if File::Spec::Functions works t/lib/filehand.t See if FileHandle works t/lib/filepath.t See if File::Path works t/lib/filespec.t See if File::Spec works @@ -1225,6 +1237,31 @@ t/op/unshift.t See if unshift works t/op/vec.t See if vectors work t/op/wantarray.t See if wantarray works t/op/write.t See if write works +t/pod/emptycmd.t Test empty pod directives +t/pod/emptycmd.xr Expected results for emptycmd.t +t/pod/for.t Test =for directive +t/pod/for.xr Expected results for for.t +t/pod/headings.t Test =head directives +t/pod/headings.xr Expected results for headings.t +t/pod/include.t Test =include directive +t/pod/include.xr Expected results for include.t +t/pod/included.t Test =include directive +t/pod/included.xr Expected results for included.t +t/pod/lref.t Test L<...> sequences +t/pod/lref.xr Expected results for lref.t +t/pod/nested_items.t Test nested =items +t/pod/nested_items.xr Expected results for nested_items.t +t/pod/nested_seqs.t Test nested interior sequences +t/pod/nested_seqs.xr Expected results for nested_seqs.t +t/pod/oneline_cmds.t Test single paragraph ==cmds +t/pod/oneline_cmds.xr Expected results for oneline_cmds.t +t/pod/poderrs.t Test POD errors +t/pod/poderrs.xr Expected results for emptycmd.t +t/pod/special_seqs.t Test "special" interior sequences +t/pod/special_seqs.xr Expected results for emptycmd.t +t/pod/testcmp.pl Module to compare output against expected results +t/pod/testp2pt.pl Module to test Pod::PlainText for a given file +t/pod/testpchk.pl Module to test Pod::Checker for a given file t/pragma/constant.t See if compile-time constants work t/pragma/locale.t See if locale support (i18n and l10n) works t/pragma/overload.t See if operator overloading works @@ -1233,6 +1270,7 @@ t/pragma/strict-subs Tests of "use strict 'subs'" for strict.t t/pragma/strict-vars Tests of "use strict 'vars'" for strict.t t/pragma/strict.t See if strictures work t/pragma/subs.t See if subroutine pseudo-importation works +t/pragma/utf8.t See if utf8 operations work t/pragma/warn/1global Tests of global warnings for warning.t t/pragma/warn/2use Tests for "use warning" for warning.t t/pragma/warn/3both Tests for interaction of $^W and "use warning" diff --git a/README.apollo b/README.apollo new file mode 100644 index 0000000000..6de115c073 --- /dev/null +++ b/README.apollo @@ -0,0 +1,11 @@ +The following tests are known to fail as of Perl 5.005_03: + +comp/decl..........FAILED at test 0 +op/write...........FAILED at test 0 +lib/filefind.......FAILED at test 2 +lib/io_udp.........FAILED at test 2 +lib/findbin........stat(/ressel/ABT/USER/vta/jk/proj.local/perl/perl5.005_03-MAINT_TRIAL_5/t/lib/): No such file or directory at ../lib/FindBin.pm line 162 +stat(/ressel/ABT/USER/vta/jk/proj.local/perl/perl5.005_03-MAINT_TRIAL_5/t/lib/): No such file or directory at ../lib/FindBin.pm line 163 +FAILED at test 1 + +Johann Klasek <jk@auto.tuwien.ac.at> diff --git a/README.hurd b/README.hurd index 2afa0e659e..40e1ba996d 100644 --- a/README.hurd +++ b/README.hurd @@ -1,39 +1,40 @@ Notes on Perl on the Hurd -Last Updated: Fri, 12 Feb 1999 21:11:14 +0100 +Last Updated: Sat, 6 Mar 1999 16:07:59 +0100 Written by: Mark Kettenis <kettenis@gnu.org> -* Known Problems +If you want to use Perl on the Hurd, I recommend using the Debian +GNU/Hurd distribution (see http://www.debian.org), even if an +official, stable release has not yet been made. The old `gnu-0.2' +binary distribution will most certainly have additional problems. -There are several problems with Perl on the Hurd. Most of them are -related to bugs in the OS, some might be actual bugs in Perl. +* Known Problems -The database code has problems that make Perl crash. When running the -test-suite one of the tests will crash. Note that on the Hurd when a -program crashes, the crash server suspends the program. Continuing -the program will cause it to exit. +The Perl testsuite may still report some errors on the Hurd. The +`lib/anydbm.t' and `op/stat.t' tests will most certainly fail. The +first fails because Berkeley DB 2 does not allow empty keys and the +test tries to use them anyway. This is not really a Hurd bug. The +same test fails on Linux with version 2.1 of the GNU C Library. The +second failure is caused by a bug in the Hurd's filesystem servers, +that we have not been able to fix yet. I don't think it is crucial. The socket tests may fail if the network is not configured. You have to make `/hurd/pfinet' the translator for `/servers/socket/2', giving it the right arguments. Try `/hurd/pfinet --help' for more -information. It seems that it is currently not possible to do this -right when you do not have a supported network device. Therefore all -tests that use INET sockets fail on my system, suggesting that the -`localhost' address may not be defined. +information. Here are the statistics for Perl 5.005_03 on my system: Failed Test Status Wstat Total Fail Failed List of failed ------------------------------------------------------------------------------- -lib/anydbm.t 12 3 25.00% 1, 4, 9 -lib/db-btree.t 0 11 ?? ?? % ?? -lib/db-hash.t 255 65280 62 42 67.74% 15, 22-62 -lib/db-recno.t 2 512 78 61 78.21% 17, 19-78 -lib/io_pipe.t 10 ?? % ?? -lib/io_sock.t 46 11776 5 5 100.00% 1-5 -lib/io_udp.t 46 11776 3 3 100.00% 1-3 -lib/socket.t 6 6 100.00% 1-6 +lib/anydbm.t 12 1 8.33% 12 op/stat.t 58 1 1.72% 4 -op/time.t 5 1 20.00% 2 5 tests skipped, plus 14 subtests skipped. -Failed 10/188 test scripts, 94.68% okay. 121/6467 subtests failed, 98.13% okay. +Failed 2/189 test scripts, 98.94% okay. 2/6669 subtests failed, 99.97% okay. + +There are quite a few systems out there that do worse! + +However, since I am running a very recent Hurd snapshot, in which a lot of +bugs that were exposed by the Perl testsuite have been fixed, you may +encounter more failures. Likely candidates are: `lib/io_pipe.t', +`lib/io_sock.t', `lib/io_udp.t' and `lib/time.t'. diff --git a/README.os390 b/README.os390 index 94e7eda617..5fcdfc0121 100644 --- a/README.os390 +++ b/README.os390 @@ -1,12 +1,28 @@ -This is a fully ported perl for OS/390 Release 3. It may work on -other versions, but that's the one we've tested it on. +This document is written in pod format hence there are punctuation +characters in in odd places. Do not worry, you've apparently got +the ASCII->EBCDIC translation worked out correctly. You can read +more about pod in pod/perlpod.pod or the short summary in the +INSTALL file. -If you've downloaded the binary distribution, it needs to be -installed below /usr/local. Source code distributions have an -automated `make install` step that means you do not need to extract -the source code below /usr/local (though that is where it will be -installed by default). You may need to worry about the networking -configuration files discussed in the last bullet below. +=head1 NAME + +README.os390 - building and installing Perl for OS/390. + +=head1 SYNOPSIS + +This document will help you Configure, build, test and install Perl +on OS/390 Unix System Services. + +=head1 DESCRIPTION + +This is a fully ported perl for OS/390 Release 3, 5 and 6. +It may work on other versions, but those are the ones we've +tested it on. + +You may need to carry out some system configuration tasks before +running the Configure script for perl. + +=head2 Unpacking Gunzip/gzip for OS/390 is discussed at: @@ -16,41 +32,83 @@ to extract an ASCII tar archive on OS/390, try this: pax -o to=IBM-1047,from=ISO8859-1 -r < latest.tar +=head2 Setup and utilities + +Be sure that your yacc installation is in place including any necessary +parser template files. If you have not already done so then be sure to: + + cp /samples/yyparse.c /etc + +This may also be a good time to ensure that your /etc/protocol file +and either your /etc/resolv.conf or /etc/hosts files are in place. + GNU make for OS/390, which may be required for the build of perl, is available from: http://www.mks.com/s390/gnu/index.htm -Once you've unpacked the distribution, run Configure (see INSTALL for -full discussion of the Configure options), and then run make, then -"make test" then "make install" (this last step may require UID=0 -privileges) +=head2 Configure + +Once you've unpacked the distribution, run "sh Configure" (see INSTALL +for a full discussion of the Configure options). There is a "hints" file +for os390 that specifies the correct values for most things. Some things +to watch out for include: + +=over 4 + +=item * + +Some of the parser default template files in /samples are needed in /etc. +In particular be sure that you at least copy /samples/yyparse.c to /etc +before running perl's Configure. This step ensures successful extraction +of EBCDIC versions of parser files such as perly.c. + +=item * + +This port doesn't support dynamic loading. Although +OS/390 has support for DLLs, there are some differences +that cause problems for perl. + +=item * -There is a "hints" file for os390 that specifies the correct values -for most things. Some things to watch out for are +You may see a "WHOA THERE!!!" message for $d_shmatprototype +it is OK to keep the recommended "define". - - this port doesn't support dynamic loading. Although - OS/390 has support for DLLs, there are some differences - that cause problems for perl. +=item * - - You may see a "WHOA THERE!!!" message for $d_shmatprototype - it is OK to keep the recommended "define". +Don't turn on the compiler optimization flag "-O". There's +a bug in either the optimizer or perl that causes perl to +not work correctly when the optimizer is on. - - Don't turn on the compiler optimization flag "-O". There's - a bug in either the optimizer or perl that causes perl to - not work correctly when the optimizer is on. +=item * - - Some of the configuration files in /etc used by the - networking APIs are either missing or have the wrong - names. In particular, make sure that there's either - an /etc/resolv.conf or and /etc/hosts, so that - gethostbyname() works, and make sure that the file - /etc/proto has been renamed to /etc/protocol (NOT - /etc/protocols, as used by other Unix systems). +Some of the configuration files in /etc used by the +networking APIs are either missing or have the wrong +names. In particular, make sure that there's either +an /etc/resolv.conf or and /etc/hosts, so that +gethostbyname() works, and make sure that the file +/etc/proto has been renamed to /etc/protocol (NOT +/etc/protocols, as used by other Unix systems). - - Some of the parser default files in /sample are needed in /etc. - In particular be sure that you at least copy /sample/yy* to /etc - before running perl's Configure. +=back + +=head2 Build, test, install + +Simply put: + + sh Configure + make + make test + +if everything looks ok then: + + make install + +this last step may or may not require UID=0 privileges depending +on how you answered the questions that Configure asked and whether +or not you have write access to the directories you specified. + +=head2 Usage Hints When using perl on OS/390 please keep in mind that the EBCDIC and ASCII character sets are different. Perl builtin functions that may behave @@ -65,22 +123,36 @@ See: for an example of how to use the "eval exec" trick to ask the shell to have perl run your scripts for you. -perl-mvs mailing list: The Perl Institute (http://www.perl.org/) -maintains a mailing list of interest to all folks building and/or +=head2 Extensions + +You can build xs based extensions to Perl for OS/390 but will need to +follow the instructions in ExtUtils::MakeMaker for building statically +linked perl binaries. In most cases people have reported better +results with GNU make rather than the system's /bin/make. + +=head1 AUTHORS + +David Fiander and Peter Prymmer. + +=head1 SEE ALSO + +L<INSTALL>, L<perlport>, L<ExtUtils::MakeMaker>. + +=head2 Mailing list + +The Perl Institute (http://www.perl.org/) maintains a perl-mvs +mailing list of interest to all folks building and/or using perl on EBCDIC platforms. To subscibe, send a message of: subscribe perl-mvs to majordomo@perl.org. -Regression tests: as the 5.005 kit was was being assembled -the following "failures" were known to appear on some machines -during `make test` (mostly due to ASCII vs. EBCDIC conflicts), -your results may differ: - -comp/cpp..........FAILED at test 0 -op/pack...........FAILED at test 58 -op/stat...........Out of memory! -op/taint..........FAILED at test 73 -lib/errno.........FAILED at test 1 -lib/posix.........FAILED at test 19 +=head1 HISTORY + +This document was originally written by David Fiander for the 5.005 +release of Perl. + +This document was podified for the 5.005_03 release of perl 11 March 1999. + +=cut @@ -203,6 +203,7 @@ # define telldir PerlDir_tell # define putenv PerlEnv_putenv # define getenv PerlEnv_getenv +# define uname PerlEnv_uname # define stdin PerlIO_stdin() # define stdout PerlIO_stdout() # define stderr PerlIO_stderr() diff --git a/apollo/netinet/in.h b/apollo/netinet/in.h new file mode 100644 index 0000000000..cfbc0485d0 --- /dev/null +++ b/apollo/netinet/in.h @@ -0,0 +1,8 @@ +/* Apollo's <netinet/in.h> isn't protected against multiple inclusion. */ + +#ifndef _NETINET_IN_INCLUDED +#define _NETINET_IN_INCLUDED + +#include "/bsd4.3/usr/include/netinet/in.h" + +#endif /* _NETINET_IN_INCLUDED */ diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm index 759b9cd8a7..302b790782 100644 --- a/ext/B/B/C.pm +++ b/ext/B/B/C.pm @@ -748,45 +748,45 @@ sub B::GV::save { # warn "GV::save saving subfields\n"; # debug my $gvsv = $gv->SV; if ($$gvsv) { + $gvsv->save; $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv)); # warn "GV::save \$$name\n"; # debug - $gvsv->save; } my $gvav = $gv->AV; if ($$gvav) { + $gvav->save; $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav)); # warn "GV::save \@$name\n"; # debug - $gvav->save; } my $gvhv = $gv->HV; if ($$gvhv) { + $gvhv->save; $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv)); # warn "GV::save \%$name\n"; # debug - $gvhv->save; } my $gvcv = $gv->CV; if ($$gvcv && !$skip_cv) { + $gvcv->save; $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv)); # warn "GV::save &$name\n"; # debug - $gvcv->save; } my $gvfilegv = $gv->FILEGV; if ($$gvfilegv) { + $gvfilegv->save; $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv)); # warn "GV::save GvFILEGV(*$name)\n"; # debug - $gvfilegv->save; } my $gvform = $gv->FORM; if ($$gvform) { + $gvform->save; $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform)); # warn "GV::save GvFORM(*$name)\n"; # debug - $gvform->save; } my $gvio = $gv->IO; if ($$gvio) { + $gvio->save; $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio)); # warn "GV::save GvIO(*$name)\n"; # debug - $gvio->save; } } return $sym; @@ -1226,7 +1226,8 @@ sub should_save if (exists $unused_sub_packages{$package}) { # warn "Cached $package is ".$unused_sub_packages{$package}."\n"; - return $unused_sub_packages{$package} + delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ; + return $unused_sub_packages{$package}; } # Omit the packages which we use (and which cause grief # because of fancy "goto &$AUTOLOAD" stuff). @@ -1234,6 +1235,7 @@ sub should_save if ($package eq "FileHandle" || $package eq "Config" || $package eq "SelectSaver" || $package =~/^(B|IO)::/) { + delete_unsaved_hashINC($package); return $unused_sub_packages{$package} = 0; } # Now see if current package looks like an OO class this is probably too strong. @@ -1245,9 +1247,16 @@ sub should_save return mark_package($package); } } + delete_unsaved_hashINC($package); return $unused_sub_packages{$package} = 0; } - +sub delete_unsaved_hashINC{ + my $packname=shift; + $packname =~ s/\:\:/\//g; + $packname .= '.pm'; + warn "deleting $packname" if $INC{$packname} ;# debug + delete $INC{$packname}; +} sub walkpackages { my ($symref, $recurse, $prefix) = @_; @@ -1300,7 +1309,6 @@ sub descend_marked_unused { mark_package($pack); } } - sub save_main { warn "Starting compile\n"; diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm index d44a119222..f6f4f0f9dd 100644 --- a/ext/B/B/CC.pm +++ b/ext/B/B/CC.pm @@ -1107,7 +1107,7 @@ sub pp_range { } write_back_lexicals(); write_back_stack(); - if (!($flags & OPf_WANT_LIST)) { + unless (($flags & OPf_WANT)== OPf_WANT_LIST) { # We need to save our UNOP structure since pp_flop uses # it to find and adjust out targ. We don't need it ourselves. $op->save; @@ -1124,7 +1124,7 @@ sub pp_flip { if (!($flags & OPf_WANT)) { error("context of flip unknown at compile-time"); } - if ($flags & OPf_WANT_LIST) { + if (($flags & OPf_WANT)==OPf_WANT_LIST) { return $op->first->false; } write_back_lexicals(); @@ -1418,12 +1418,13 @@ sub cc_main { my $curpad_nam = $comppadlist[0]->save; my $curpad_sym = $comppadlist[1]->save; my $init_av = init_av->save; - my $inc_hv = svref_2object(\%INC)->save; - my $inc_av = svref_2object(\@INC)->save; my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist); + # Do save_unused_subs before saving inc_hv save_unused_subs(); cc_recurse(); + my $inc_hv = svref_2object(\%INC)->save; + my $inc_av = svref_2object(\@INC)->save; return if $errors; if (!defined($module)) { $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), diff --git a/ext/B/defsubs.h.PL b/ext/B/defsubs.h.PL index e485ac3300..c24eb94170 100644 --- a/ext/B/defsubs.h.PL +++ b/ext/B/defsubs.h.PL @@ -1,7 +1,11 @@ +# Do not remove the following line; MakeMaker relies on it to identify +# this file as a template for defsubs.h +# Extracting defsubs.h (with variable substitutions) #!perl my ($out) = __FILE__ =~ /(^.*)[._]PL/i; if ($^O eq 'VMS') { $out =~ s/(^.*)[._](.*$)/$1.$2/;} open(OUT,">$out") || die "Cannot open $file:$!"; +print "Extracting $out . . .\n"; foreach my $const (qw(AVf_REAL HEf_SVKEY SVf_IOK SVf_NOK SVf_POK SVf_ROK SVp_IOK SVp_POK )) diff --git a/ext/DB_File/Changes b/ext/DB_File/Changes index c71d5b8c34..2fab919229 100644 --- a/ext/DB_File/Changes +++ b/ext/DB_File/Changes @@ -229,3 +229,6 @@ mapping problem with O_RDONLY on the Hurd * Updated the message that db-recno.t prints when tests 51, 53 or 55 fail. +1.65 6th March 1999 + * Fixed a bug in the recno PUSH logic. + * The BOOT version check now needs 2.3.4 when using Berkeley DB version 2 diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index 738de7ce85..e5759ff558 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -1,8 +1,8 @@ # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (Paul.Marquess@btinternet.com) -# last modified 21st February 1999 -# version 1.64 +# last modified 6th March 1999 +# version 1.65 # # Copyright (c) 1995-9 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or @@ -145,7 +145,7 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO $db_ver use Carp; -$VERSION = "1.64" ; +$VERSION = "1.65" ; #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; $DB_BTREE = new DB_File::BTREEINFO ; diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index 540fa9cd97..94113eb4e2 100644 --- a/ext/DB_File/DB_File.xs +++ b/ext/DB_File/DB_File.xs @@ -3,8 +3,8 @@ DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess <Paul.Marquess@btinternet.com> - last modified 21st February 1999 - version 1.64 + last modified 6th March 1999 + version 1.65 All comments/suggestions/problems are welcome @@ -63,6 +63,8 @@ 1.64 - Tidied up the 1.x to 2.x flags mapping code. Added a patch from Mark Kettenis <kettenis@wins.uva.nl> to fix a flag mapping problem with O_RDONLY on the Hurd + 1.65 - Fixed a bug in the PUSH logic. + Added BOOT check that using 2.3.4 or greater @@ -346,9 +348,9 @@ GetVersionInfo() (void)db_version(&Major, &Minor, &Patch) ; - /* check that libdb is recent enough */ - if (Major == 2 && Minor == 0 && Patch < 5) - croak("DB_File needs Berkeley DB 2.0.5 or greater, you have %d.%d.%d\n", + /* check that libdb is recent enough -- we need 2.3.4 or greater */ + if (Major == 2 && (Minor < 3 || (Minor == 3 && Patch < 4))) + croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n", Major, Minor, Patch) ; #if PERL_VERSION > 3 @@ -1228,7 +1230,6 @@ db_FIRSTKEY(db) { DBTKEY key ; DBT value ; - DB * Db = db->dbp ; DBT_flags(key) ; DBT_flags(value) ; @@ -1245,7 +1246,6 @@ db_NEXTKEY(db, key) CODE: { DBT value ; - DB * Db = db->dbp ; DBT_flags(value) ; CurrentDB = db ; @@ -1308,7 +1308,6 @@ pop(db) { DBTKEY key ; DBT value ; - DB * Db = db->dbp ; DBT_flags(key) ; DBT_flags(value) ; @@ -1336,7 +1335,6 @@ shift(db) { DBT value ; DBTKEY key ; - DB * Db = db->dbp ; DBT_flags(key) ; DBT_flags(value) ; @@ -1363,7 +1361,6 @@ push(db, ...) CODE: { DBTKEY key ; - DBTKEY * keyptr = &key ; DBT value ; DB * Db = db->dbp ; int i ; @@ -1372,34 +1369,34 @@ push(db, ...) DBT_flags(key) ; DBT_flags(value) ; CurrentDB = db ; - /* Set the Cursor to the Last element */ - RETVAL = do_SEQ(db, key, value, R_LAST) ; - if (RETVAL >= 0) - { - if (RETVAL == 1) - keyptr = &empty ; #ifdef DB_VERSION_MAJOR + RETVAL = 0 ; + key = empty ; for (i = 1 ; i < items ; ++i) { - - ++ (* (int*)key.data) ; value.data = SvPV(ST(i), n_a) ; value.size = n_a ; - RETVAL = (Db->put)(Db, NULL, &key, &value, 0) ; + RETVAL = (Db->put)(Db, NULL, &key, &value, DB_APPEND) ; if (RETVAL != 0) break; } #else + /* Set the Cursor to the Last element */ + RETVAL = do_SEQ(db, key, value, R_LAST) ; + if (RETVAL >= 0) + { + if (RETVAL == 1) + key = empty ; for (i = items - 1 ; i > 0 ; --i) { value.data = SvPV(ST(i), n_a) ; value.size = n_a ; - RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ; + RETVAL = (Db->put)(Db, &key, &value, R_IAFTER) ; if (RETVAL != 0) break; } -#endif } +#endif } OUTPUT: RETVAL diff --git a/ext/DB_File/typemap b/ext/DB_File/typemap index 3463ec0b0f..994ba27232 100644 --- a/ext/DB_File/typemap +++ b/ext/DB_File/typemap @@ -2,7 +2,7 @@ # # written by Paul Marquess <Paul.Marquess@btinternet.com> # last modified 21st February 1999 -# version 1.64 +# version 1.65 # #################################### DB SECTION # diff --git a/ext/re/re.pm b/ext/re/re.pm index 09f52d6086..842e39ad75 100644 --- a/ext/re/re.pm +++ b/ext/re/re.pm @@ -74,6 +74,8 @@ See L<perlmodlib/Pragmatic Modules>. =cut +# N.B. File::Basename contains a literal for 'taint' as a fallback. If +# taint is changed here, File::Basename must be updated as well. my %bitmask = ( taint => 0x00100000, eval => 0x00200000, diff --git a/hints/apollo.sh b/hints/apollo.sh index 8c361aa051..05f433dfc1 100644 --- a/hints/apollo.sh +++ b/hints/apollo.sh @@ -1,13 +1,17 @@ # Info from Johann Klasek <jk@auto.tuwien.ac.at> # Merged by Andy Dougherty <doughera@lafcol.lafayette.edu> -# Last revised Fri Jun 2 11:21:27 EDT 1995 +# Last revised Tue Mar 16 19:12:22 EET 1999 by +# Jarkko Hietaniemi <jhi@iki.fi> # uname -a looks like # DomainOS newton 10.4.1 bsd4.3 425t # We want to use both BSD includes and some of the features from the # /sys5 includes. -ccflags="$ccflags -A cpu,mathchip -I/usr/include -I/sys5/usr/include" +ccflags="$ccflags -A cpu,mathchip -I`pwd`/apollo -I/usr/include -I/sys5/usr/include" + +# When Apollo runs a script with "#!", it sets argv[0] to the script name. +toke_cflags='ccflags="$ccflags -DARG_ZERO_IS_SCRIPT"' # These adjustments are necessary (why?) to compile malloc.c. freetype='void' diff --git a/installperl b/installperl index 417357b96f..93b9947d94 100755 --- a/installperl +++ b/installperl @@ -50,7 +50,8 @@ umask 022 unless $Is_VMS; my @scripts = qw(utils/c2ph utils/h2ph utils/h2xs utils/perlbug utils/perldoc utils/pl2pm utils/splain utils/perlcc x2p/s2p x2p/find2perl - pod/pod2man pod/pod2html pod/pod2latex pod/pod2text); + pod/pod2man pod/pod2html pod/pod2latex pod/pod2text + pod/pod2usage pod/podchecker pod/podselect); if ($scr_ext) { @scripts = map { "$_$scr_ext" } @scripts; } diff --git a/iperlsys.h b/iperlsys.h index 67ef90aec1..03e3c08267 100644 --- a/iperlsys.h +++ b/iperlsys.h @@ -450,10 +450,12 @@ public: virtual int Putenv(const char *envstring, int &err) = 0; virtual char * LibPath(char *patchlevel) =0; virtual char * SiteLibPath(char *patchlevel) =0; + virtual int Uname(struct utsname *name, int &err) =0; }; #define PerlEnv_putenv(str) PL_piENV->Putenv((str), ErrorNo()) #define PerlEnv_getenv(str) PL_piENV->Getenv((str), ErrorNo()) +#define PerlEnv_uname(name) PL_piENV->Uname((name), ErrorNo()) #ifdef WIN32 #define PerlEnv_lib_path(str) PL_piENV->LibPath((str)) #define PerlEnv_sitelib_path(str) PL_piENV->SiteLibPath((str)) @@ -463,6 +465,7 @@ public: #define PerlEnv_putenv(str) putenv((str)) #define PerlEnv_getenv(str) getenv((str)) +#define PerlEnv_uname(name) uname((name)) #endif /* PERL_OBJECT */ diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index dae3125d90..13e4e29e88 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -362,7 +362,7 @@ sub _vms_ext { return ('', '', $crtlstr, ''); } - my(@dirs,@libs,$dir,$lib,%sh,%olb,%obj,$ldlib); + my(@dirs,@libs,$dir,$lib,%found,@fndlibs,$ldlib); my $cwd = cwd(); my($so,$lib_ext,$obj_ext) = @Config{'so','lib_ext','obj_ext'}; # List of common Unix library names and there VMS equivalents @@ -430,28 +430,28 @@ sub _vms_ext { warn "\tChecking $name\n" if $verbose > 2; if (-f ($test = VMS::Filespec::rmsexpand($name))) { # It's got its own suffix, so we'll have to figure out the type - if ($test =~ /(?:$so|exe)$/i) { $type = 'sh'; } - elsif ($test =~ /(?:$lib_ext|olb)$/i) { $type = 'olb'; } + if ($test =~ /(?:$so|exe)$/i) { $type = 'SHR'; } + elsif ($test =~ /(?:$lib_ext|olb)$/i) { $type = 'OLB'; } elsif ($test =~ /(?:$obj_ext|obj)$/i) { warn "Note (probably harmless): " ."Plain object file $test found in library list\n"; - $type = 'obj'; + $type = 'OBJ'; } else { warn "Note (probably harmless): " ."Unknown library type for $test; assuming shared\n"; - $type = 'sh'; + $type = 'SHR'; } } elsif (-f ($test = VMS::Filespec::rmsexpand($name,$so)) or -f ($test = VMS::Filespec::rmsexpand($name,'.exe'))) { - $type = 'sh'; + $type = 'SHR'; $name = $test unless $test =~ /exe;?\d*$/i; } elsif (not length($ctype) and # If we've got a lib already, don't bother ( -f ($test = VMS::Filespec::rmsexpand($name,$lib_ext)) or -f ($test = VMS::Filespec::rmsexpand($name,'.olb')))) { - $type = 'olb'; + $type = 'OLB'; $name = $test unless $test =~ /olb;?\d*$/i; } elsif (not length($ctype) and # If we've got a lib already, don't bother @@ -459,17 +459,18 @@ sub _vms_ext { -f ($test = VMS::Filespec::rmsexpand($name,'.obj')))) { warn "Note (probably harmless): " ."Plain object file $test found in library list\n"; - $type = 'obj'; + $type = 'OBJ'; $name = $test unless $test =~ /obj;?\d*$/i; } if (defined $type) { $ctype = $type; $cand = $name; - last if $ctype eq 'sh'; + last if $ctype eq 'SHR'; } } if ($ctype) { - eval '$' . $ctype . "{'$cand'}++"; - die "Error recording library: $@" if $@; + # This has to precede any other CRTLs, so just make it first + if ($cand eq 'VAXCCURSE') { unshift @{$found{$ctype}}, $cand; } + else { push @{$found{$ctype}}, $cand; } warn "\tFound as $cand (really $test), type $ctype\n" if $verbose > 1; next LIB; } @@ -478,15 +479,10 @@ sub _vms_ext { ."No library found for $lib\n"; } - @libs = sort keys %obj; - # This has to precede any other CRTLs, so just make it first - if ($olb{VAXCCURSE}) { - push(@libs,"$olb{VAXCCURSE}/Library"); - delete $olb{VAXCCURSE}; - } - push(@libs, map { "$_/Library" } sort keys %olb); - push(@libs, map { "$_/Share" } sort keys %sh); - $lib = join(' ',@libs); + push @fndlibs, @{$found{OBJ}} if exists $found{OBJ}; + push @fndlibs, map { "$_/Library" } @{$found{OLB}} if exists $found{OLB}; + push @fndlibs, map { "$_/Share" } @{$found{SHR}} if exists $found{SHR}; + $lib = join(' ',@fndlibs); $ldlib = $crtlstr ? "$lib $crtlstr" : $lib; warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose; diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 38bb061e66..8d09668ff8 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -1320,10 +1320,12 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) $h{$name} = 1; } elsif ($name =~ /\.PL$/) { ($pl_files{$name} = $name) =~ s/\.PL$// ; - } elsif ($Is_VMS && $name =~ /\.pl$/) { # case-insensitive filesystem + } elsif ($Is_VMS && $name =~ /[._]pl$/i) { + # case-insensitive filesystem, one dot per name, so foo.h.PL + # under Unix appears as foo.h_pl under VMS local($/); open(PL,$name); my $txt = <PL>; close PL; if ($txt =~ /Extracting \S+ \(with variable substitutions/) { - ($pl_files{$name} = $name) =~ s/\.pl$// ; + ($pl_files{$name} = $name) =~ s/[._]pl$//i ; } else { $pm{$name} = $self->catfile('$(INST_LIBDIR)',$name); } } elsif ($name =~ /\.(p[ml]|pod)$/){ diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index 8f8ac1787c..3b8352823f 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -1465,8 +1465,8 @@ $(INST_STATIC) : $(OBJECT) $(MYEXTLIB) push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n"); } - foreach $lib (split $self->{EXTRALIBS}) { - $lib = '""' if $lib eq '"'; + push @m, "\t\$(NOECHO) \$(PERL) -e 1 >\$(INST_ARCHAUTODIR)extralibs.ld\n"; + foreach $lib (split ' ', $self->{EXTRALIBS}) { push(@m,"\t",'$(NOECHO) $(PERL) -e "print qq{',$lib,'\n}" >>$(INST_ARCHAUTODIR)extralibs.ld',"\n"); } push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); @@ -2312,7 +2312,7 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) $tmp = $self->fixpath($tmp,1); if (@optlibs) { $extralist = join(' ',@optlibs); } else { $extralist = ''; } - # Let ExtUtils::Liblist find the necessary for us (but skip PerlShr; + # Let ExtUtils::Liblist find the necessary libs for us (but skip PerlShr) # that's what we're building here). push @optlibs, grep { !/PerlShr/i } split +($self->ext())[2]; if ($libperl) { diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm index 69bb1fa5fd..191eff970a 100644 --- a/lib/File/Basename.pm +++ b/lib/File/Basename.pm @@ -124,7 +124,17 @@ directory name to be F<.>). ## use strict; -use re 'taint'; +# A bit of juggling to insure that C<use re 'taint';> awlays works, since +# File::Basename is used during the Perl build, when the re extension may +# not be available. +BEGIN { + unless (eval { require re; }) + { eval ' sub re::import { $^H |= 0x00100000; } ' } + import re 'taint'; +} + + + require Exporter; @ISA = qw(Exporter); diff --git a/lib/File/Spec/Functions.pm b/lib/File/Spec/Functions.pm index 77561abf09..ffc1199523 100644 --- a/lib/File/Spec/Functions.pm +++ b/lib/File/Spec/Functions.pm @@ -3,7 +3,7 @@ package File::Spec::Functions; use File::Spec; use strict; -use vars qw(@ISA @EXPORT); +use vars qw(@ISA @EXPORT @EXPORT_OK); require Exporter; @@ -14,13 +14,16 @@ require Exporter; catdir catfile curdir - devnull rootdir - tmpdir updir no_upwards file_name_is_absolute path +); + +@EXPORT_OK = qw( + devnull + tmpdir splitpath splitdir catpath @@ -28,9 +31,10 @@ require Exporter; rel2abs ); -foreach my $meth (@EXPORT) { +foreach my $meth (@EXPORT, @EXPORT_OK) { + my $sub = File::Spec->can($meth); no strict 'refs'; - *{$meth} = File::Spec->can($meth); + *{$meth} = sub {&$sub('File::Spec', @_)}; } @@ -64,13 +68,17 @@ The following functions are exported by default. catdir catfile curdir - devnull rootdir - tmpdir updir no_upwards file_name_is_absolute path + + +The following functions are exported only by request. + + devnull + tmpdir splitpath splitdir catpath diff --git a/lib/File/Spec/Win32.pm b/lib/File/Spec/Win32.pm index 0e00af711d..0ea4970b41 100644 --- a/lib/File/Spec/Win32.pm +++ b/lib/File/Spec/Win32.pm @@ -99,7 +99,7 @@ sub canonpath { my ($self,$path,$reduce_ricochet) = @_; $path =~ s/^([a-z]:)/\u$1/; $path =~ s|/|\\|g; - $path =~ s|([^\\])\\+|\1\\|g; # xx////xx -> xx/xx + $path =~ s|([^\\])\\+|$1\\|g; # xx////xx -> xx/xx $path =~ s|(\\\.)+\\|\\|g; # xx/././xx -> xx/xx $path =~ s|^(\.\\)+|| unless $path eq ".\\"; # ./xx -> xx $path =~ s|\\$|| diff --git a/lib/Pod/Checker.pm b/lib/Pod/Checker.pm new file mode 100644 index 0000000000..1eaab71a8d --- /dev/null +++ b/lib/Pod/Checker.pm @@ -0,0 +1,224 @@ +############################################################################# +# Pod/Checker.pm -- check pod documents for syntax errors +# +# Based on Tom Christiansen's Pod::Text::pod2text() function +# (with modifications). +# +# Copyright (C) 1994-1999 Tom Christiansen. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::Checker; + +use vars qw($VERSION); +$VERSION = 1.08; ## Current version of this package +require 5.004; ## requires this Perl version or later + +=head1 NAME + +Pod::Checker, podchecker() - check pod documents for syntax errors + +=head1 SYNOPSIS + + use Pod::Checker; + + $syntax_okay = podchecker($filepath, $outputpath); + +=head1 OPTIONS/ARGUMENTS + +C<$filepath> is the input POD to read and C<$outputpath> is +where to write POD syntax error messages. Either argument may be a scalar +indcating a file-path, or else a reference to an open filehandle. +If unspecified, the input-file it defaults to C<\*STDIN>, and +the output-file defaults to C<\*STDERR>. + + +=head1 DESCRIPTION + +B<podchecker> will perform syntax checking of Perl5 POD format documentation. + +I<NOTE THAT THIS MODULE IS CURRENTLY IN THE INITIAL DEVELOPMENT STAGE!> +As of this writing, all it does is check for unknown '=xxxx' commands, +unknown 'X<...>' interior-sequences, and unterminated interior sequences. + +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>. + +=head1 EXAMPLES + +I<[T.B.D.]> + +=head1 AUTHOR + +Brad Appleton E<lt>bradapp@enteract.comE<gt> (initial version) + +Based on code for B<Pod::Text::pod2text()> written by +Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> + +=cut + +############################################################################# + +use strict; +#use diagnostics; +use Carp; +use Exporter; +use Pod::Parser; + +use vars qw(@ISA @EXPORT); +@ISA = qw(Pod::Parser); +@EXPORT = qw(&podchecker); + +use vars qw(%VALID_COMMANDS %VALID_SEQUENCES); + +my %VALID_COMMANDS = ( + 'pod' => 1, + 'cut' => 1, + 'head1' => 1, + 'head2' => 1, + 'over' => 1, + 'back' => 1, + 'item' => 1, + 'for' => 1, + 'begin' => 1, + 'end' => 1, +); + +my %VALID_SEQUENCES = ( + 'I' => 1, + 'B' => 1, + 'S' => 1, + 'C' => 1, + 'L' => 1, + 'F' => 1, + 'X' => 1, + 'Z' => 1, + 'E' => 1, +); + +##--------------------------------------------------------------------------- + +##--------------------------------- +## Function definitions begin here +##--------------------------------- + +sub podchecker( $ ; $ ) { + my ($infile, $outfile) = @_; + local $_; + + ## Set defaults + $infile ||= \*STDIN; + $outfile ||= \*STDERR; + + ## Now create a pod checker + my $checker = new Pod::Checker(); + + ## Now check the pod document for errors + $checker->parse_from_file($infile, $outfile); + + ## Return the number of errors found + return $checker->num_errors(); +} + +##--------------------------------------------------------------------------- + +##------------------------------- +## Method definitions begin here +##------------------------------- + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my %params = @_; + my $self = {%params}; + bless $self, $class; + $self->initialize(); + return $self; +} + +sub initialize { + my $self = shift; + $self->num_errors(0); +} + +sub num_errors { + return (@_ > 1) ? ($_[0]->{_NUM_ERRORS} = $_[1]) : $_[0]->{_NUM_ERRORS}; +} + +sub end_pod { + ## Print the number of errors found + my $self = shift; + my $infile = $self->input_file(); + my $out_fh = $self->output_handle(); + + my $num_errors = $self->num_errors(); + if ($num_errors > 0) { + printf $out_fh ("$infile has $num_errors pod syntax %s.\n", + ($num_errors == 1) ? "error" : "errors"); + } + else { + print $out_fh "$infile pod syntax OK.\n"; + } +} + +sub command { + my ($self, $command, $paragraph, $line_num, $pod_para) = @_; + my ($file, $line) = $pod_para->file_line; + my $out_fh = $self->output_handle(); + ## Check the command syntax + if (! $VALID_COMMANDS{$command}) { + ++($self->{_NUM_ERRORS}); + _invalid_cmd($out_fh, $command, $paragraph, $file, $line); + } + else { + ## check syntax of particular command + } + ## Check the interior sequences in the command-text + my $expansion = $self->interpolate($paragraph, $line_num); +} + +sub verbatim { + ## Nothing to check + ## my ($self, $paragraph, $line_num, $pod_para) = @_; +} + +sub textblock { + my ($self, $paragraph, $line_num, $pod_para) = @_; + my $out_fh = $self->output_handle(); + ## Check the interior sequences in the text (set $SIG{__WARN__} to + ## send parse_text warnings about untermnated sequences to $out_fh) + local $SIG{__WARN__} = sub { + ++($self->{_NUM_ERRORS}); + print $out_fh @_ + }; + my $expansion = $self->interpolate($paragraph, $line_num); +} + +sub interior_sequence { + my ($self, $seq_cmd, $seq_arg, $pod_seq) = @_; + my ($file, $line) = $pod_seq->file_line; + my $out_fh = $self->output_handle(); + ## Check the sequence syntax + if (! $VALID_SEQUENCES{$seq_cmd}) { + ++($self->{_NUM_ERRORS}); + _invalid_seq($out_fh, $seq_cmd, $seq_arg, $file, $line); + } + else { + ## check syntax of the particular sequence + } +} + +sub _invalid_cmd { + my ($fh, $cmd, $text, $file, $line) = @_; + print $fh "*** ERROR: Unknown command \"$cmd\"" + . " at line $line of file $file\n"; +} + +sub _invalid_seq { + my ($fh, $cmd, $text, $file, $line) = @_; + print $fh "*** ERROR: Unknown interior-sequence \"$cmd\"" + . " at line $line of file $file\n"; +} + diff --git a/lib/Pod/InputObjects.pm b/lib/Pod/InputObjects.pm new file mode 100644 index 0000000000..9bbc6cf7ac --- /dev/null +++ b/lib/Pod/InputObjects.pm @@ -0,0 +1,903 @@ +############################################################################# +# Pod/InputObjects.pm -- package which defines objects for input streams +# and paragraphs and commands when parsing POD docs. +# +# Copyright (C) 1996-1999 Tom Christiansen. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::InputObjects; + +use vars qw($VERSION); +$VERSION = 1.08; ## Current version of this package +require 5.004; ## requires this Perl version or later + +############################################################################# + +=head1 NAME + +Pod::InputObjects - objects representing POD input paragraphs, commands, etc. + +=head1 SYNOPSIS + + use Pod::InputObjects; + +=head1 REQUIRES + +perl5.004, Carp + +=head1 EXPORTS + +Nothing. + +=head1 DESCRIPTION + +This module defines some basic input objects used by B<Pod::Parser> when +reading and parsing POD text from an input source. The following objects +are defined: + +=over 4 + +=begin __PRIVATE__ + +=item B<Pod::InputSource> + +An object corresponding to a source of POD input text. It is mostly a +wrapper around a filehandle or C<IO::Handle>-type object (or anything +that implements the C<getline()> method) which keeps track of some +additional information relevant to the parsing of PODs. + +=end __PRIVATE__ + +=item B<Pod::Paragraph> + +An object corresponding to a paragraph of POD input text. It may be a +plain paragraph, a verbatim paragraph, or a command paragraph (see +L<perlpod>). + +=item B<Pod::InteriorSequence> + +An object corresponding to an interior sequence command from the POD +input text (see L<perlpod>). + +=item B<Pod::ParseTree> + +An object corresponding to a tree of parsed POD text. Each "node" in +a parse-tree (or I<ptree>) is either a text-string or a reference to +a B<Pod::InteriorSequence> object. The nodes appear in the parse-tree +in they order in which they were parsed from left-to-right. + +=back + +Each of these input objects are described in further detail in the +sections which follow. + +=cut + +############################################################################# + +use strict; +#use diagnostics; +#use Carp; + +############################################################################# + +package Pod::InputSource; + +##--------------------------------------------------------------------------- + +=begin __PRIVATE__ + +=head1 B<Pod::InputSource> + +This object corresponds to an input source or stream of POD +documentation. When parsing PODs, it is necessary to associate and store +certain context information with each input source. All of this +information is kept together with the stream itself in one of these +C<Pod::InputSource> objects. Each such object is merely a wrapper around +an C<IO::Handle> object of some kind (or at least something that +implements the C<getline()> method). They have the following +methods/attributes: + +=end __PRIVATE__ + +=cut + +##--------------------------------------------------------------------------- + +=begin __PRIVATE__ + +=head2 B<new()> + + my $pod_input1 = Pod::InputSource->new(-handle => $filehandle); + my $pod_input2 = new Pod::InputSource(-handle => $filehandle, + -name => $name); + my $pod_input3 = new Pod::InputSource(-handle => \*STDIN); + my $pod_input4 = Pod::InputSource->new(-handle => \*STDIN, + -name => "(STDIN)"); + +This is a class method that constructs a C<Pod::InputSource> object and +returns a reference to the new input source object. It takes one or more +keyword arguments in the form of a hash. The keyword C<-handle> is +required and designates the corresponding input handle. The keyword +C<-name> is optional and specifies the name associated with the input +handle (typically a file name). + +=end __PRIVATE__ + +=cut + +sub new { + ## Determine if we were called via an object-ref or a classname + my $this = shift; + my $class = ref($this) || $this; + + ## Any remaining arguments are treated as initial values for the + ## hash that is used to represent this object. Note that we default + ## certain values by specifying them *before* the arguments passed. + ## If they are in the argument list, they will override the defaults. + my $self = { -name => '(unknown)', + -handle => undef, + -was_cutting => 0, + @_ }; + + ## Bless ourselves into the desired class and perform any initialization + bless $self, $class; + return $self; +} + +##--------------------------------------------------------------------------- + +=begin __PRIVATE__ + +=head2 B<name()> + + my $filename = $pod_input->name(); + $pod_input->name($new_filename_to_use); + +This method gets/sets the name of the input source (usually a filename). +If no argument is given, it returns a string containing the name of +the input source; otherwise it sets the name of the input source to the +contents of the given argument. + +=end __PRIVATE__ + +=cut + +sub name { + (@_ > 1) and $_[0]->{'-name'} = $_[1]; + return $_[0]->{'-name'}; +} + +## allow 'filename' as an alias for 'name' +*filename = \&name; + +##--------------------------------------------------------------------------- + +=begin __PRIVATE__ + +=head2 B<handle()> + + my $handle = $pod_input->handle(); + +Returns a reference to the handle object from which input is read (the +one used to contructed this input source object). + +=end __PRIVATE__ + +=cut + +sub handle { + return $_[0]->{'-handle'}; +} + +##--------------------------------------------------------------------------- + +=begin __PRIVATE__ + +=head2 B<was_cutting()> + + print "Yes.\n" if ($pod_input->was_cutting()); + +The value of the C<cutting> state (that the B<cutting()> method would +have returned) immediately before any input was read from this input +stream. After all input from this stream has been read, the C<cutting> +state is restored to this value. + +=end __PRIVATE__ + +=cut + +sub was_cutting { + (@_ > 1) and $_[0]->{-was_cutting} = $_[1]; + return $_[0]->{-was_cutting}; +} + +##--------------------------------------------------------------------------- + +############################################################################# + +package Pod::Paragraph; + +##--------------------------------------------------------------------------- + +=head1 B<Pod::Paragraph> + +An object representing a paragraph of POD input text. +It has the following methods/attributes: + +=cut + +##--------------------------------------------------------------------------- + +=head2 B<new()> + + my $pod_para1 = Pod::Paragraph->new(-text => $text); + my $pod_para2 = Pod::Paragraph->new(-name => $cmd, + -text => $text); + my $pod_para3 = new Pod::Paragraph(-text => $text); + my $pod_para4 = new Pod::Paragraph(-name => $cmd, + -text => $text); + my $pod_para5 = Pod::Paragraph->new(-name => $cmd, + -text => $text, + -file => $filename, + -line => $line_number); + +This is a class method that constructs a C<Pod::Paragraph> object and +returns a reference to the new paragraph object. It may be given one or +two keyword arguments. The C<-text> keyword indicates the corresponding +text of the POD paragraph. The C<-name> keyword indicates the name of +the corresponding POD command, such as C<head1> or C<item> (it should +I<not> contain the C<=> prefix); this is needed only if the POD +paragraph corresponds to a command paragraph. The C<-file> and C<-line> +keywords indicate the filename and line number corresponding to the +beginning of the paragraph + +=cut + +sub new { + ## Determine if we were called via an object-ref or a classname + my $this = shift; + my $class = ref($this) || $this; + + ## Any remaining arguments are treated as initial values for the + ## hash that is used to represent this object. Note that we default + ## certain values by specifying them *before* the arguments passed. + ## If they are in the argument list, they will override the defaults. + my $self = { + -name => undef, + -text => (@_ == 1) ? $_[0] : undef, + -file => '<unknown-file>', + -line => 0, + -prefix => '=', + -separator => ' ', + -ptree => [], + @_ + }; + + ## Bless ourselves into the desired class and perform any initialization + bless $self, $class; + return $self; +} + +##--------------------------------------------------------------------------- + +=head2 B<cmd_name()> + + my $para_cmd = $pod_para->cmd_name(); + +If this paragraph is a command paragraph, then this method will return +the name of the command (I<without> any leading C<=> prefix). + +=cut + +sub cmd_name { + (@_ > 1) and $_[0]->{'-name'} = $_[1]; + return $_[0]->{'-name'}; +} + +## let name() be an alias for cmd_name() +*name = \&cmd_name; + +##--------------------------------------------------------------------------- + +=head2 B<text()> + + my $para_text = $pod_para->text(); + +This method will return the corresponding text of the paragraph. + +=cut + +sub text { + (@_ > 1) and $_[0]->{'-text'} = $_[1]; + return $_[0]->{'-text'}; +} + +##--------------------------------------------------------------------------- + +=head2 B<raw_text()> + + my $raw_pod_para = $pod_para->raw_text(); + +This method will return the I<raw> text of the POD paragraph, exactly +as it appeared in the input. + +=cut + +sub raw_text { + return $_[0]->{'-text'} unless (defined $_[0]->{'-name'}); + return $_[0]->{'-prefix'} . $_[0]->{'-name'} . + $_[0]->{'-separator'} . $_[0]->{'-text'}; +} + +##--------------------------------------------------------------------------- + +=head2 B<cmd_prefix()> + + my $prefix = $pod_para->cmd_prefix(); + +If this paragraph is a command paragraph, then this method will return +the prefix used to denote the command (which should be the string "=" +or "=="). + +=cut + +sub cmd_prefix { + return $_[0]->{'-prefix'}; +} + +##--------------------------------------------------------------------------- + +=head2 B<cmd_separator()> + + my $separator = $pod_para->cmd_separator(); + +If this paragraph is a command paragraph, then this method will return +the text used to separate the command name from the rest of the +paragraph (if any). + +=cut + +sub cmd_separator { + return $_[0]->{'-separator'}; +} + +##--------------------------------------------------------------------------- + +=head2 B<parse_tree()> + + my $ptree = $pod_parser->parse_text( $pod_para->text() ); + $pod_para->parse_tree( $ptree ); + $ptree = $pod_para->parse_tree(); + +This method will get/set the corresponding parse-tree of the paragraph's text. + +=cut + +sub parse_tree { + (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; + return $_[0]->{'-ptree'}; +} + +## let ptree() be an alias for parse_tree() +*ptree = \&parse_tree; + +##--------------------------------------------------------------------------- + +=head2 B<file_line()> + + my ($filename, $line_number) = $pod_para->file_line(); + my $position = $pod_para->file_line(); + +Returns the current filename and line number for the paragraph +object. If called in an array context, it returns a list of two +elements: first the filename, then the line number. If called in +a scalar context, it returns a string containing the filename, followed +by a colon (':'), followed by the line number. + +=cut + +sub file_line { + my @loc = ($_[0]->{'-file'} || '<unknown-file>', + $_[0]->{'-line'} || 0); + return (wantarray) ? @loc : join(':', @loc); +} + +##--------------------------------------------------------------------------- + +############################################################################# + +package Pod::InteriorSequence; + +##--------------------------------------------------------------------------- + +=head1 B<Pod::InteriorSequence> + +An object representing a POD interior sequence command. +It has the following methods/attributes: + +=cut + +##--------------------------------------------------------------------------- + +=head2 B<new()> + + my $pod_seq1 = Pod::InteriorSequence->new(-name => $cmd + -ldelim => $delimiter); + my $pod_seq2 = new Pod::InteriorSequence(-name => $cmd, + -ldelim => $delimiter); + my $pod_seq3 = new Pod::InteriorSequence(-name => $cmd, + -ldelim => $delimiter, + -file => $filename, + -line => $line_number); + +This is a class method that constructs a C<Pod::InteriorSequence> object +and returns a reference to the new interior sequence object. It should +be given two keyword arguments. The C<-ldelim> keyword indicates the +corresponding left-delimiter of the interior sequence (e.g. 'E<lt>'). +The C<-name> keyword indicates the name of the corresponding interior +sequence command, such as C<I> or C<B> or C<C>. The C<-file> and +C<-line> keywords indicate the filename and line number corresponding +to the beginning of the interior sequence. + +=cut + +sub new { + ## Determine if we were called via an object-ref or a classname + my $this = shift; + my $class = ref($this) || $this; + + ## Any remaining arguments are treated as initial values for the + ## hash that is used to represent this object. Note that we default + ## certain values by specifying them *before* the arguments passed. + ## If they are in the argument list, they will override the defaults. + my $self = { + -name => (@_ == 1) ? $_[0] : undef, + -file => '<unknown-file>', + -line => 0, + -ldelim => '<', + -rdelim => '>', + -ptree => new Pod::ParseTree(), + @_ + }; + + ## Bless ourselves into the desired class and perform any initialization + bless $self, $class; + return $self; +} + +##--------------------------------------------------------------------------- + +=head2 B<cmd_name()> + + my $seq_cmd = $pod_seq->cmd_name(); + +The name of the interior sequence command. + +=cut + +sub cmd_name { + (@_ > 1) and $_[0]->{'-name'} = $_[1]; + return $_[0]->{'-name'}; +} + +## let name() be an alias for cmd_name() +*name = \&cmd_name; + +##--------------------------------------------------------------------------- + +## Private subroutine to set the parent pointer of all the given +## children that are interior-sequences to be $self + +sub _set_child2parent_links { + my ($self, @children) = @_; + ## Make sure any sequences know who their parent is + for (@children) { + next unless ref $_; + if ($_->isa('Pod::InteriorSequence') or $_->can('nested')) { + $_->nested($self); + } + } +} + +## Private subroutine to unset child->parent links + +sub _unset_child2parent_links { + my $self = shift; + $self->{'-parent_sequence'} = undef; + my $ptree = $self->{'-ptree'}; + for (@$ptree) { + next unless ($_ and ref $_ and $_->isa('Pod::InteriorSequence')); + $_->_unset_child2parent_links(); + } +} + +##--------------------------------------------------------------------------- + +=head2 B<prepend()> + + $pod_seq->prepend($text); + $pod_seq1->prepend($pod_seq2); + +Prepends the given string or parse-tree or sequence object to the parse-tree +of this interior sequence. + +=cut + +sub prepend { + my $self = shift; + $self->{'-ptree'}->prepend(@_); + _set_child2parent_links($self, @_); + return $self; +} + +##--------------------------------------------------------------------------- + +=head2 B<append()> + + $pod_seq->append($text); + $pod_seq1->append($pod_seq2); + +Appends the given string or parse-tree or sequence object to the parse-tree +of this interior sequence. + +=cut + +sub append { + my $self = shift; + $self->{'-ptree'}->append(@_); + _set_child2parent_links($self, @_); + return $self; +} + +##--------------------------------------------------------------------------- + +=head2 B<nested()> + + $outer_seq = $pod_seq->nested || print "not nested"; + +If this interior sequence is nested inside of another interior +sequence, then the outer/parent sequence that contains it is +returned. Otherwise C<undef> is returned. + +=cut + +sub nested { + my $self = shift; + (@_ == 1) and $self->{'-parent_sequence'} = shift; + return $self->{'-parent_sequence'} || undef; +} + +##--------------------------------------------------------------------------- + +=head2 B<raw_text()> + + my $seq_raw_text = $pod_seq->raw_text(); + +This method will return the I<raw> text of the POD interior sequence, +exactly as it appeared in the input. + +=cut + +sub raw_text { + my $self = shift; + my $text = $self->{'-name'} . $self->{'-ldelim'}; + for ( $self->{'-ptree'}->children ) { + $text .= (ref $_) ? $_->raw_text : $_; + } + $text .= $self->{'-rdelim'}; + return $text; +} + +##--------------------------------------------------------------------------- + +=head2 B<left_delimiter()> + + my $ldelim = $pod_seq->left_delimiter(); + +The leftmost delimiter beginning the argument text to the interior +sequence (should be "<"). + +=cut + +sub left_delimiter { + (@_ > 1) and $_[0]->{'-ldelim'} = $_[1]; + return $_[0]->{'-ldelim'}; +} + +## let ldelim() be an alias for left_delimiter() +*ldelim = \&left_delimiter; + +##--------------------------------------------------------------------------- + +=head2 B<right_delimiter()> + +The rightmost delimiter beginning the argument text to the interior +sequence (should be ">"). + +=cut + +sub right_delimiter { + (@_ > 1) and $_[0]->{'-rdelim'} = $_[1]; + return $_[0]->{'-rdelim'}; +} + +## let rdelim() be an alias for right_delimiter() +*rdelim = \&right_delimiter; + +##--------------------------------------------------------------------------- + +=head2 B<parse_tree()> + + my $ptree = $pod_parser->parse_text($paragraph_text); + $pod_seq->parse_tree( $ptree ); + $ptree = $pod_seq->parse_tree(); + +This method will get/set the corresponding parse-tree of the interior +sequence's text. + +=cut + +sub parse_tree { + (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; + return $_[0]->{'-ptree'}; +} + +## let ptree() be an alias for parse_tree() +*ptree = \&parse_tree; + +##--------------------------------------------------------------------------- + +=head2 B<file_line()> + + my ($filename, $line_number) = $pod_seq->file_line(); + my $position = $pod_seq->file_line(); + +Returns the current filename and line number for the interior sequence +object. If called in an array context, it returns a list of two +elements: first the filename, then the line number. If called in +a scalar context, it returns a string containing the filename, followed +by a colon (':'), followed by the line number. + +=cut + +sub file_line { + my @loc = ($_[0]->{'-file'} || '<unknown-file>', + $_[0]->{'-line'} || 0); + return (wantarray) ? @loc : join(':', @loc); +} + +##--------------------------------------------------------------------------- + +=head2 B<DESTROY()> + +This method performs any necessary cleanup for the interior-sequence. +If you override this method then it is B<imperative> that you invoke +the parent method from within your own method, otherwise +I<interior-sequence storage will not be reclaimed upon destruction!> + +=cut + +sub DESTROY { + ## We need to get rid of all child->parent pointers throughout the + ## tree so their reference counts will go to zero and they can be + ## garbage-collected + _unset_child2parent_links(@_); +} + +##--------------------------------------------------------------------------- + +############################################################################# + +package Pod::ParseTree; + +##--------------------------------------------------------------------------- + +=head1 B<Pod::ParseTree> + +This object corresponds to a tree of parsed POD text. As POD text is +scanned from left to right, it is parsed into an ordered list of +text-strings and B<Pod::InteriorSequence> objects (in order of +appearance). A B<Pod::ParseTree> object corresponds to this list of +strings and sequences. Each interior sequence in the parse-tree may +itself contain a parse-tree (since interior sequences may be nested). + +=cut + +##--------------------------------------------------------------------------- + +=head2 B<new()> + + my $ptree1 = Pod::ParseTree->new; + my $ptree2 = new Pod::ParseTree; + my $ptree4 = Pod::ParseTree->new($array_ref); + my $ptree3 = new Pod::ParseTree($array_ref); + +This is a class method that constructs a C<Pod::Parse_tree> object and +returns a reference to the new parse-tree. If a single-argument is given, +it mist be a reference to an array, and is used to initialize the root +(top) of the parse tree. + +=cut + +sub new { + ## Determine if we were called via an object-ref or a classname + my $this = shift; + my $class = ref($this) || $this; + + my $self = (@_ == 1 and ref $_[0]) ? $_[0] : []; + + ## Bless ourselves into the desired class and perform any initialization + bless $self, $class; + return $self; +} + +##--------------------------------------------------------------------------- + +=head2 B<top()> + + my $top_node = $ptree->top(); + $ptree->top( $top_node ); + $ptree->top( @children ); + +This method gets/sets the top node of the parse-tree. If no arguments are +given, it returns the topmost node in the tree (the root), which is also +a B<Pod::ParseTree>. If it is given a single argument that is a reference, +then the reference is assumed to a parse-tree and becomes the new top node. +Otherwise, if arguments are given, they are treated as the new list of +children for the top node. + +=cut + +sub top { + my $self = shift; + if (@_ > 0) { + @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_; + } + return $self; +} + +## let parse_tree() & ptree() be aliases for the 'top' method +*parse_tree = *ptree = \⊤ + +##--------------------------------------------------------------------------- + +=head2 B<children()> + +This method gets/sets the children of the top node in the parse-tree. +If no arguments are given, it returns the list (array) of children +(each of which should be either a string or a B<Pod::InteriorSequence>. +Otherwise, if arguments are given, they are treated as the new list of +children for the top node. + +=cut + +sub children { + my $self = shift; + if (@_ > 0) { + @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_; + } + return @{ $self }; +} + +##--------------------------------------------------------------------------- + +=head2 B<prepend()> + +This method prepends the given text or parse-tree to the current parse-tree. +If the first item on the parse-tree is text and the argument is also text, +then the text is prepended to the first item (not added as a separate string). +Otherwise the argument is added as a new string or parse-tree I<before> +the current one. + +=cut + +use vars qw(@ptree); ## an alias used for performance reasons + +sub prepend { + my $self = shift; + local *ptree = $self; + for (@_) { + next unless $_; + if (@ptree and !(ref $ptree[0]) and !(ref $_)) { + $ptree[0] = $_ . $ptree[0]; + } + else { + unshift @ptree, $_; + } + } +} + +##--------------------------------------------------------------------------- + +=head2 B<append()> + +This method appends the given text or parse-tree to the current parse-tree. +If the last item on the parse-tree is text and the argument is also text, +then the text is appended to the last item (not added as a separate string). +Otherwise the argument is added as a new string or parse-tree I<after> +the current one. + +=cut + +sub append { + my $self = shift; + local *ptree = $self; + for (@_) { + next unless $_; + if (@ptree and !(ref $ptree[-1]) and !(ref $_)) { + $ptree[-1] .= $_; + } + else { + push @ptree, $_; + } + } +} + +=head2 B<raw_text()> + + my $ptree_raw_text = $ptree->raw_text(); + +This method will return the I<raw> text of the POD parse-tree +exactly as it appeared in the input. + +=cut + +sub raw_text { + my $self = shift; + my $text = ""; + for ( @$self ) { + $text .= (ref $_) ? $_->raw_text : $_; + } + return $text; +} + +##--------------------------------------------------------------------------- + +## Private routines to set/unset child->parent links + +sub _unset_child2parent_links { + my $self = shift; + local *ptree = $self; + for (@ptree) { + next unless ($_ and ref $_ and $_->isa('Pod::InteriorSequence')); + $_->_unset_child2parent_links(); + } +} + +sub _set_child2parent_links { + ## nothing to do, Pod::ParseTrees cant have parent pointers +} + +=head2 B<DESTROY()> + +This method performs any necessary cleanup for the parse-tree. +If you override this method then it is B<imperative> +that you invoke the parent method from within your own method, +otherwise I<parse-tree storage will not be reclaimed upon destruction!> + +=cut + +sub DESTROY { + ## We need to get rid of all child->parent pointers throughout the + ## tree so their reference counts will go to zero and they can be + ## garbage-collected + _unset_child2parent_links(@_); +} + +############################################################################# + +=head1 SEE ALSO + +See L<Pod::Parser>, L<Pod::Select>, and L<Pod::Callbacks>. + +=head1 AUTHOR + +Brad Appleton E<lt>bradapp@enteract.comE<gt> + +=cut + +1; diff --git a/lib/Pod/Parser.pm b/lib/Pod/Parser.pm new file mode 100644 index 0000000000..b81b080cdb --- /dev/null +++ b/lib/Pod/Parser.pm @@ -0,0 +1,1393 @@ +############################################################################# +# Pod/Parser.pm -- package which defines a base class for parsing POD docs. +# +# Based on Tom Christiansen's Pod::Text module +# (with extensive modifications). +# +# Copyright (C) 1996-1999 Tom Christiansen. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::Parser; + +use vars qw($VERSION); +$VERSION = 1.08; ## Current version of this package +require 5.004; ## requires this Perl version or later + +############################################################################# + +=head1 NAME + +Pod::Parser - base class for creating POD filters and translators + +=head1 SYNOPSIS + + use Pod::Parser; + + package MyParser; + @ISA = qw(Pod::Parser); + + sub command { + my ($parser, $command, $paragraph, $line_num) = @_; + ## Interpret the command and its text; sample actions might be: + if ($command eq 'head1') { ... } + elsif ($command eq 'head2') { ... } + ## ... other commands and their actions + my $out_fh = $parser->output_handle(); + my $expansion = $parser->interpolate($paragraph, $line_num); + print $out_fh $expansion; + } + + sub verbatim { + my ($parser, $paragraph, $line_num) = @_; + ## Format verbatim paragraph; sample actions might be: + my $out_fh = $parser->output_handle(); + print $out_fh $paragraph; + } + + sub textblock { + my ($parser, $paragraph, $line_num) = @_; + ## Translate/Format this block of text; sample actions might be: + my $out_fh = $parser->output_handle(); + my $expansion = $parser->interpolate($paragraph, $line_num); + print $out_fh $expansion; + } + + sub interior_sequence { + my ($parser, $seq_command, $seq_argument) = @_; + ## Expand an interior sequence; sample actions might be: + return "*$seq_argument*" if ($seq_command = 'B'); + return "`$seq_argument'" if ($seq_command = 'C'); + return "_${seq_argument}_'" if ($seq_command = 'I'); + ## ... other sequence commands and their resulting text + } + + package main; + + ## Create a parser object and have it parse file whose name was + ## given on the command-line (use STDIN if no files were given). + $parser = new MyParser(); + $parser->parse_from_filehandle(\*STDIN) if (@ARGV == 0); + for (@ARGV) { $parser->parse_from_file($_); } + +=head1 REQUIRES + +perl5.004, Pod::InputObjects, Exporter, FileHandle, Carp + +=head1 EXPORTS + +Nothing. + +=head1 DESCRIPTION + +B<Pod::Parser> is a base class for creating POD filters and translators. +It handles most of the effort involved with parsing the POD sections +from an input stream, leaving subclasses free to be concerned only with +performing the actual translation of text. + +B<Pod::Parser> parses PODs, and makes method calls to handle the various +components of the POD. Subclasses of B<Pod::Parser> override these methods +to translate the POD into whatever output format they desire. + +=head1 QUICK OVERVIEW + +To create a POD filter for translating POD documentation into some other +format, you create a subclass of B<Pod::Parser> which typically overrides +just the base class implementation for the following methods: + +=over 2 + +=item * + +B<command()> + +=item * + +B<verbatim()> + +=item * + +B<textblock()> + +=item * + +B<interior_sequence()> + +=back + +You may also want to override the B<begin_input()> and B<end_input()> +methods for your subclass (to perform any needed per-file and/or +per-document initialization or cleanup). + +If you need to perform any preprocesssing of input before it is parsed +you may want to override one or more of B<preprocess_line()> and/or +B<preprocess_paragraph()>. + +Sometimes it may be necessary to make more than one pass over the input +files. If this is the case you have several options. You can make the +first pass using B<Pod::Parser> and override your methods to store the +intermediate results in memory somewhere for the B<end_pod()> method to +process. You could use B<Pod::Parser> for several passes with an +appropriate state variable to control the operation for each pass. If +your input source can't be reset to start at the beginning, you can +store it in some other structure as a string or an array and have that +structure implement a B<getline()> method (which is all that +B<parse_from_filehandle()> uses to read input). + +Feel free to add any member data fields you need to keep track of things +like current font, indentation, horizontal or vertical position, or +whatever else you like. Be sure to read L<"PRIVATE METHODS AND DATA"> +to avoid name collisions. + +For the most part, the B<Pod::Parser> base class should be able to +do most of the input parsing for you and leave you free to worry about +how to intepret the commands and translate the result. + +=cut + +############################################################################# + +use vars qw(@ISA); +use strict; +#use diagnostics; +use Pod::InputObjects; +use Carp; +use FileHandle; +use Exporter; +@ISA = qw(Exporter); + +## These "variables" are used as local "glob aliases" for performance +use vars qw(%myData @input_stack); + +############################################################################# + +=head1 RECOMMENDED SUBROUTINE/METHOD OVERRIDES + +B<Pod::Parser> provides several methods which most subclasses will probably +want to override. These methods are as follows: + +=cut + +##--------------------------------------------------------------------------- + +=head1 B<command()> + + $parser->command($cmd,$text,$line_num,$pod_para); + +This method should be overridden by subclasses to take the appropriate +action when a POD command paragraph (denoted by a line beginning with +"=") is encountered. When such a POD directive is seen in the input, +this method is called and is passed: + +=over 3 + +=item C<$cmd> + +the name of the command for this POD paragraph + +=item C<$text> + +the paragraph text for the given POD paragraph command. + +=item C<$line_num> + +the line-number of the beginning of the paragraph + +=item C<$pod_para> + +a reference to a C<Pod::Paragraph> object which contains further +information about the paragraph command (see L<Pod::InputObjects> +for details). + +=back + +B<Note> that this method I<is> called for C<=pod> paragraphs. + +The base class implementation of this method simply treats the raw POD +command as normal block of paragraph text (invoking the B<textblock()> +method with the command paragraph). + +=cut + +sub command { + my ($self, $cmd, $text, $line_num, $pod_para) = @_; + ## Just treat this like a textblock + $self->textblock($pod_para->raw_text(), $line_num, $pod_para); +} + +##--------------------------------------------------------------------------- + +=head1 B<verbatim()> + + $parser->verbatim($text,$line_num,$pod_para); + +This method may be overridden by subclasses to take the appropriate +action when a block of verbatim text is encountered. It is passed the +following parameters: + +=over 3 + +=item C<$text> + +the block of text for the verbatim paragraph + +=item C<$line_num> + +the line-number of the beginning of the paragraph + +=item C<$pod_para> + +a reference to a C<Pod::Paragraph> object which contains further +information about the paragraph (see L<Pod::InputObjects> +for details). + +=back + +The base class implementation of this method simply prints the textblock +(unmodified) to the output filehandle. + +=cut + +sub verbatim { + my ($self, $text, $line_num, $pod_para) = @_; + my $out_fh = $self->{_OUTPUT}; + print $out_fh $text; +} + +##--------------------------------------------------------------------------- + +=head1 B<textblock()> + + $parser->textblock($text,$line_num,$pod_para); + +This method may be overridden by subclasses to take the appropriate +action when a normal block of POD text is encountered (although the base +class method will usually do what you want). It is passed the following +parameters: + +=over 3 + +=item C<$text> + +the block of text for the a POD paragraph + +=item C<$line_num> + +the line-number of the beginning of the paragraph + +=item C<$pod_para> + +a reference to a C<Pod::Paragraph> object which contains further +information about the paragraph (see L<Pod::InputObjects> +for details). + +=back + +In order to process interior sequences, subclasses implementations of +this method will probably want to invoke either B<interpolate()> or +B<parse_text()>, passing it the text block C<$text>, and the corresponding +line number in C<$line_num>, and then perform any desired processing upon +the returned result. + +The base class implementation of this method simply prints the text block +as it occurred in the input stream). + +=cut + +sub textblock { + my ($self, $text, $line_num, $pod_para) = @_; + my $out_fh = $self->{_OUTPUT}; + print $out_fh $self->interpolate($text, $line_num); +} + +##--------------------------------------------------------------------------- + +=head1 B<interior_sequence()> + + $parser->interior_sequence($seq_cmd,$seq_arg,$pod_seq); + +This method should be overridden by subclasses to take the appropriate +action when an interior sequence is encountered. An interior sequence is +an embedded command within a block of text which appears as a command +name (usually a single uppercase character) followed immediately by a +string of text which is enclosed in angle brackets. This method is +passed the sequence command C<$seq_cmd> and the corresponding text +C<$seq_arg>. It is invoked by the B<interpolate()> method for each interior +sequence that occurs in the string that it is passed. It should return +the desired text string to be used in place of the interior sequence. +The C<$pod_seq> argument is a reference to a C<Pod::InteriorSequence> +object which contains further information about the interior sequence. +Please see L<Pod::InputObjects> for details if you need to access this +additional information. + +Subclass implementations of this method may wish to invoke the +B<nested()> method of C<$pod_seq> to see if it is nested inside +some other interior-sequence (and if so, which kind). + +The base class implementation of the B<interior_sequence()> method +simply returns the raw text of the interior sequence (as it occurred +in the input) to the caller. + +=cut + +sub interior_sequence { + my ($self, $seq_cmd, $seq_arg, $pod_seq) = @_; + ## Just return the raw text of the interior sequence + return $pod_seq->raw_text(); +} + +############################################################################# + +=head1 OPTIONAL SUBROUTINE/METHOD OVERRIDES + +B<Pod::Parser> provides several methods which subclasses may want to override +to perform any special pre/post-processing. These methods do I<not> have to +be overridden, but it may be useful for subclasses to take advantage of them. + +=cut + +##--------------------------------------------------------------------------- + +=head1 B<new()> + + my $parser = Pod::Parser->new(); + +This is the constructor for B<Pod::Parser> and its subclasses. You +I<do not> need to override this method! It is capable of constructing +subclass objects as well as base class objects, provided you use +any of the following constructor invocation styles: + + my $parser1 = MyParser->new(); + my $parser2 = new MyParser(); + my $parser3 = $parser2->new(); + +where C<MyParser> is some subclass of B<Pod::Parser>. + +Using the syntax C<MyParser::new()> to invoke the constructor is I<not> +recommended, but if you insist on being able to do this, then the +subclass I<will> need to override the B<new()> constructor method. If +you do override the constructor, you I<must> be sure to invoke the +B<initialize()> method of the newly blessed object. + +Using any of the above invocations, the first argument to the +constructor is always the corresponding package name (or object +reference). No other arguments are required, but if desired, an +associative array (or hash-table) my be passed to the B<new()> +constructor, as in: + + my $parser1 = MyParser->new( MYDATA => $value1, MOREDATA => $value2 ); + my $parser2 = new MyParser( -myflag => 1 ); + +All arguments passed to the B<new()> constructor will be treated as +key/value pairs in a hash-table. The newly constructed object will be +initialized by copying the contents of the given hash-table (which may +have been empty). The B<new()> constructor for this class and all of its +subclasses returns a blessed reference to the initialized object (hash-table). + +=cut + +sub new { + ## Determine if we were called via an object-ref or a classname + my $this = shift; + my $class = ref($this) || $this; + ## Any remaining arguments are treated as initial values for the + ## hash that is used to represent this object. + my %params = @_; + my $self = { %params }; + ## Bless ourselves into the desired class and perform any initialization + bless $self, $class; + $self->initialize(); + return $self; +} + +##--------------------------------------------------------------------------- + +=head1 B<initialize()> + + $parser->initialize(); + +This method performs any necessary object initialization. It takes no +arguments (other than the object instance of course, which is typically +copied to a local variable named C<$self>). If subclasses override this +method then they I<must> be sure to invoke C<$self-E<gt>SUPER::initialize()>. + +=cut + +sub initialize { + #my $self = shift; + #return; +} + +##--------------------------------------------------------------------------- + +=head1 B<begin_pod()> + + $parser->begin_pod(); + +This method is invoked at the beginning of processing for each POD +document that is encountered in the input. Subclasses should override +this method to perform any per-document initialization. + +=cut + +sub begin_pod { + #my $self = shift; + #return; +} + +##--------------------------------------------------------------------------- + +=head1 B<begin_input()> + + $parser->begin_input(); + +This method is invoked by B<parse_from_filehandle()> immediately I<before> +processing input from a filehandle. The base class implementation does +nothing, however, subclasses may override it to perform any per-file +initializations. + +Note that if multiple files are parsed for a single POD document +(perhaps the result of some future C<=include> directive) this method +is invoked for every file that is parsed. If you wish to perform certain +initializations once per document, then you should use B<begin_pod()>. + +=cut + +sub begin_input { + #my $self = shift; + #return; +} + +##--------------------------------------------------------------------------- + +=head1 B<end_input()> + + $parser->end_input(); + +This method is invoked by B<parse_from_filehandle()> immediately I<after> +processing input from a filehandle. The base class implementation does +nothing, however, subclasses may override it to perform any per-file +cleanup actions. + +Please note that if multiple files are parsed for a single POD document +(perhaps the result of some kind of C<=include> directive) this method +is invoked for every file that is parsed. If you wish to perform certain +cleanup actions once per document, then you should use B<end_pod()>. + +=cut + +sub end_input { + #my $self = shift; + #return; +} + +##--------------------------------------------------------------------------- + +=head1 B<end_pod()> + + $parser->end_pod(); + +This method is invoked at the end of processing for each POD document +that is encountered in the input. Subclasses should override this method +to perform any per-document finalization. + +=cut + +sub end_pod { + #my $self = shift; + #return; +} + +##--------------------------------------------------------------------------- + +=head1 B<preprocess_line()> + + $textline = $parser->preprocess_line($text, $line_num); + +This method should be overridden by subclasses that wish to perform +any kind of preprocessing for each I<line> of input (I<before> it has +been determined whether or not it is part of a POD paragraph). The +parameter C<$text> is the input line; and the parameter C<$line_num> is +the line number of the corresponding text line. + +The value returned should correspond to the new text to use in its +place. If the empty string or an undefined value is returned then no +further processing will be performed for this line. + +Please note that the B<preprocess_line()> method is invoked I<before> +the B<preprocess_paragraph()> method. After all (possibly preprocessed) +lines in a paragraph have been assembled together and it has been +determined that the paragraph is part of the POD documentation from one +of the selected sections, then B<preprocess_paragraph()> is invoked. + +The base class implementation of this method returns the given text. + +=cut + +sub preprocess_line { + my ($self, $text, $line_num) = @_; + return $text; +} + +##--------------------------------------------------------------------------- + +=head1 B<preprocess_paragraph()> + + $textblock = $parser->preprocess_paragraph($text, $line_num); + +This method should be overridden by subclasses that wish to perform any +kind of preprocessing for each block (paragraph) of POD documentation +that appears in the input stream. The parameter C<$text> is the POD +paragraph from the input file; and the parameter C<$line_num> is the +line number for the beginning of the corresponding paragraph. + +The value returned should correspond to the new text to use in its +place If the empty string is returned or an undefined value is +returned, then the given C<$text> is ignored (not processed). + +This method is invoked after gathering up all thelines in a paragraph +but before trying to further parse or interpret them. After +B<preprocess_paragraph()> returns, the current cutting state (which +is returned by C<$self-E<gt>cutting()>) is examined. If it evaluates +to false then input text (including the given C<$text>) is cut (not +processed) until the next POD directive is encountered. + +Please note that the B<preprocess_line()> method is invoked I<before> +the B<preprocess_paragraph()> method. After all (possibly preprocessed) +lines in a paragraph have been assembled together and it has been +determined that the paragraph is part of the POD documentation from one +of the selected sections, then B<preprocess_paragraph()> is invoked. + +The base class implementation of this method returns the given text. + +=cut + +sub preprocess_paragraph { + my ($self, $text, $line_num) = @_; + return $text; +} + +############################################################################# + +=head1 METHODS FOR PARSING AND PROCESSING + +B<Pod::Parser> provides several methods to process input text. These +methods typically won't need to be overridden, but subclasses may want +to invoke them to exploit their functionality. + +=cut + +##--------------------------------------------------------------------------- + +=head1 B<parse_text()> + + $ptree1 = $parser->parse_text($text, $line_num); + $ptree2 = $parser->parse_text({%opts}, $text, $line_num); + $ptree3 = $parser->parse_text(\%opts, $text, $line_num); + +This method is useful if you need to perform your own interpolation +of interior sequences and can't rely upon B<interpolate> to expand +them in simple bottom-up order order. + +The parameter C<$text> is a string or block of text to be parsed +for interior sequences; and the parameter C<$line_num> is the +line number curresponding to the beginning of C<$text>. + +B<parse_text()> will parse the given text into a parse-tree of "nodes." +and interior-sequences. Each "node" in the parse tree is either a +text-string, or a B<Pod::InteriorSequence>. The result returned is a +parse-tree of type B<Pod::ParseTree>. Please see L<Pod::InputObjects> +for more information about B<Pod::InteriorSequence> and B<Pod::ParseTree>. + +If desired, an optional hash-ref may be specified as the first argument +to customize certain aspects of the parse-tree that is created and +returned. The set of recognized option keywords are: + +=over 3 + +=item B<-expand_seq> =E<gt> I<code-ref>|I<method-name> + +Normally, the parse-tree returned by B<parse_text()> will contain an +unexpanded C<Pod::InteriorSequence> object for each interior-sequence +encountered. Specifying B<-expand_seq> tells B<parse_text()> to "expand" +every interior-sequence it sees by invoking the referenced function +(or named method of the parser object) and using the return value as the +expanded result. + +If a subroutine reference was given, it is invoked as: + + &$code_ref( $parser, $sequence ) + +and if a method-name was given, it is invoked as: + + $parser->method_name( $sequence ) + +where C<$parser> is a reference to the parser object, and C<$sequence> +is a reference to the interior-sequence object. +[I<NOTE>: If the B<interior_sequence()> method is specified, then it is +invoked according to the interface specified in L<"interior_sequence()">]. + +=item B<-expand_ptree> =E<gt> I<code-ref>|I<method-name> + +Rather than returning a C<Pod::ParseTree>, pass the parse-tree as an +argument to the referenced subroutine (or named method of the parser +object) and return the result instead of the parse-tree object. + +If a subroutine reference was given, it is invoked as: + + &$code_ref( $parser, $ptree ) + +and if a method-name was given, it is invoked as: + + $parser->method_name( $ptree ) + +where C<$parser> is a reference to the parser object, and C<$ptree> +is a reference to the parse-tree object. + +=back + +=cut + +## This global regex is used to see if the text before a '>' inside +## an interior sequence looks like '-' or '=', but not '--' or '==' +use vars qw( $ARROW_RE ); +$ARROW_RE = join('', qw{ (?: [^=]+= | [^-]+- )$ }); + +sub parse_text { + my $self = shift; + local $_ = ''; + + ## Get options and set any defaults + my %opts = (ref $_[0]) ? %{ shift() } : (); + my $expand_seq = $opts{'-expand_seq'} || undef; + my $expand_ptree = $opts{'-expand_ptree'} || undef; + + my $text = shift; + my $line = shift; + my $file = $self->input_file(); + my ($cmd, $prev) = ('', ''); + + ## Convert method calls into closures, for our convenience + my $xseq_sub = $expand_seq; + my $xptree_sub = $expand_ptree; + if ($expand_seq eq 'interior_sequence') { + ## If 'interior_sequence' is the method to use, we have to pass + ## more than just the sequence object, we also need to pass the + ## sequence name and text. + $xseq_sub = sub { + my ($self, $iseq) = @_; + my $args = join("", $iseq->parse_tree->children); + return $self->interior_sequence($iseq->name, $args, $iseq); + }; + } + ref $xseq_sub or $xseq_sub = sub { shift()->$expand_seq(@_) }; + ref $xptree_sub or $xptree_sub = sub { shift()->$expand_ptree(@_) }; + + ## Keep track of the "current" interior sequence, and maintain a stack + ## of "in progress" sequences. + ## + ## NOTE that we push our own "accumulator" at the very beginning of the + ## stack. It's really a parse-tree, not a sequence; but it implements + ## the methods we need so we can use it to gather-up all the sequences + ## and strings we parse. Thus, by the end of our parsing, it should be + ## the only thing left on our stack and all we have to do is return it! + ## + my $seq = Pod::ParseTree->new(); + my @seq_stack = ($seq); + + ## Iterate over all sequence starts/stops, newlines, & text + ## (NOTE: split with capturing parens keeps the delimiters) + $_ = $text; + for ( split /([A-Z]<|>|\n)/ ) { + ## Keep track of line count + ++$line if ($_ eq "\n"); + ## Look for the beginning of a sequence + if ( /^([A-Z])(<)$/ ) { + ## Push a new sequence onto the stack on of those "in-progress" + $seq = Pod::InteriorSequence->new( + -name => ($cmd = $1), + -ldelim => $2, -rdelim => '', + -file => $file, -line => $line + ); + (@seq_stack > 1) and $seq->nested($seq_stack[-1]); + push @seq_stack, $seq; + } + ## Look for sequence ending (preclude '->' and '=>' inside C<...>) + elsif ( (@seq_stack > 1) and + /^>$/ and ($cmd ne 'C' or $prev !~ /$ARROW_RE/o) ) + { + ## End of current sequence, record terminating delimiter + $seq->rdelim($_); + ## Pop it off the stack of "in progress" sequences + pop @seq_stack; + ## Append result to its parent in current parse tree + $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) : $seq); + ## Remember the current cmd-name + $cmd = (@seq_stack > 1) ? $seq_stack[-1]->name : ''; + } + else { + ## In the middle of a sequence, append this text to it + $seq->append($_) if $_; + } + ## Remember the "current" sequence and the previously seen token + ($seq, $prev) = ( $seq_stack[-1], $_ ); + } + + ## Handle unterminated sequences + while (@seq_stack > 1) { + ($cmd, $file, $line) = ($seq->name, $seq->file_line); + pop @seq_stack; + warn "** Unterminated $cmd<...> at $file line $line\n"; + $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) : $seq); + $seq = $seq_stack[-1]; + } + + ## Return the resulting parse-tree + my $ptree = (pop @seq_stack)->parse_tree; + return $expand_ptree ? &$xptree_sub($self, $ptree) : $ptree; +} + +##--------------------------------------------------------------------------- + +=head1 B<interpolate()> + + $textblock = $parser->interpolate($text, $line_num); + +This method translates all text (including any embedded interior sequences) +in the given text string C<$text> and returns the interpolated result. The +parameter C<$line_num> is the line number corresponding to the beginning +of C<$text>. + +B<interpolate()> merely invokes a private method to recursively expand +nested interior sequences in bottom-up order (innermost sequences are +expanded first). If there is a need to expand nested sequences in +some alternate order, use B<parse_text> instead. + +=cut + +sub interpolate { + my($self, $text, $line_num) = @_; + my %parse_opts = ( -expand_seq => 'interior_sequence' ); + my $ptree = $self->parse_text( \%parse_opts, $text, $line_num ); + return join "", $ptree->children(); +} + +##--------------------------------------------------------------------------- + +=begin __PRIVATE__ + +=head1 B<parse_paragraph()> + + $parser->parse_paragraph($text, $line_num); + +This method takes the text of a POD paragraph to be processed, along +with its corresponding line number, and invokes the appropriate method +(one of B<command()>, B<verbatim()>, or B<textblock()>). + +This method does I<not> usually need to be overridden by subclasses. + +=end __PRIVATE__ + +=cut + +sub parse_paragraph { + my ($self, $text, $line_num) = @_; + local *myData = $self; ## an alias to avoid deref-ing overhead + local $_; + + ## This is the end of a non-empty paragraph + ## Ignore up until next POD directive if we are cutting + if ($myData{_CUTTING}) { + return unless ($text =~ /^={1,2}\S/); + $myData{_CUTTING} = 0; + } + + ## Now we know this is block of text in a POD section! + + ##----------------------------------------------------------------- + ## This is a hook (hack ;-) for Pod::Select to do its thing without + ## having to override methods, but also without Pod::Parser assuming + ## $self is an instance of Pod::Select (if the _SELECTED_SECTIONS + ## field exists then we assume there is an is_selected() method for + ## us to invoke (calling $self->can('is_selected') could verify this + ## but that is more overhead than I want to incur) + ##----------------------------------------------------------------- + + ## Ignore this block if it isnt in one of the selected sections + if (exists $myData{_SELECTED_SECTIONS}) { + $self->is_selected($text) or return ($myData{_CUTTING} = 1); + } + + ## Perform any desired preprocessing and re-check the "cutting" state + $text = $self->preprocess_paragraph($text, $line_num); + return 1 unless ((defined $text) and (length $text)); + return 1 if ($myData{_CUTTING}); + + ## Look for one of the three types of paragraphs + my ($pfx, $cmd, $arg, $sep) = ('', '', '', ''); + my $pod_para = undef; + if ($text =~ /^(={1,2})(?=\S)/) { + ## Looks like a command paragraph. Capture the command prefix used + ## ("=" or "=="), as well as the command-name, its paragraph text, + ## and whatever sequence of characters was used to separate them + $pfx = $1; + $_ = substr($text, length $pfx); + $sep = /(\s+)(?=\S)/ ? $1 : ''; + ($cmd, $text) = split(" ", $_, 2); + ## If this is a "cut" directive then we dont need to do anything + ## except return to "cutting" mode. + if ($cmd eq 'cut') { + $myData{_CUTTING} = 1; + return; + } + } + ## Save the attributes indicating how the command was specified. + $pod_para = new Pod::Paragraph( + -name => $cmd, + -text => $text, + -prefix => $pfx, + -separator => $sep, + -file => $myData{_INFILE}, + -line => $line_num + ); + # ## Invoke appropriate callbacks + # if (exists $myData{_CALLBACKS}) { + # ## Look through the callback list, invoke callbacks, + # ## then see if we need to do the default actions + # ## (invoke_callbacks will return true if we do). + # return 1 unless $self->invoke_callbacks($cmd, $text, $line_num, $pod_para); + # } + if (length $cmd) { + ## A command paragraph + $self->command($cmd, $text, $line_num, $pod_para); + } + elsif ($text =~ /^\s+/) { + ## Indented text - must be a verbatim paragraph + $self->verbatim($text, $line_num, $pod_para); + } + else { + ## Looks like an ordinary block of text + $self->textblock($text, $line_num, $pod_para); + } + return 1; +} + +##--------------------------------------------------------------------------- + +=head1 B<parse_from_filehandle()> + + $parser->parse_from_filehandle($in_fh,$out_fh); + +This method takes an input filehandle (which is assumed to already be +opened for reading) and reads the entire input stream looking for blocks +(paragraphs) of POD documentation to be processed. If no first argument +is given the default input filehandle C<STDIN> is used. + +The C<$in_fh> parameter may be any object that provides a B<getline()> +method to retrieve a single line of input text (hence, an appropriate +wrapper object could be used to parse PODs from a single string or an +array of strings). + +Using C<$in_fh-E<gt>getline()>, input is read line-by-line and assembled +into paragraphs or "blocks" (which are separated by lines containing +nothing but whitespace). For each block of POD documentation +encountered it will invoke a method to parse the given paragraph. + +If a second argument is given then it should correspond to a filehandle where +output should be sent (otherwise the default output filehandle is +C<STDOUT> if no output filehandle is currently in use). + +B<NOTE:> For performance reasons, this method caches the input stream at +the top of the stack in a local variable. Any attempts by clients to +change the stack contents during processing when in the midst executing +of this method I<will not affect> the input stream used by the current +invocation of this method. + +This method does I<not> usually need to be overridden by subclasses. + +=cut + +sub parse_from_filehandle { + my $self = shift; + my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : (); + my ($in_fh, $out_fh) = @_; + local $_; + + ## Put this stream at the top of the stack and do beginning-of-input + ## processing. NOTE that $in_fh might be reset during this process. + my $topstream = $self->_push_input_stream($in_fh, $out_fh); + (exists $opts{-cutting}) and $self->cutting( $opts{-cutting} ); + + ## Initialize line/paragraph + my ($textline, $paragraph) = ('', ''); + my ($nlines, $plines) = (0, 0); + + ## Use <$fh> instead of $fh->getline where possible (for speed) + $_ = ref $in_fh; + my $tied_fh = (/^(?:GLOB|FileHandle|IO::\w+)$/ or tied $in_fh); + + ## Read paragraphs line-by-line + while (defined ($textline = $tied_fh ? <$in_fh> : $in_fh->getline)) { + $textline = $self->preprocess_line($textline, ++$nlines); + next unless ((defined $textline) && (length $textline)); + $_ = $paragraph; ## save previous contents + + if ((! length $paragraph) && ($textline =~ /^==/)) { + ## '==' denotes a one-line command paragraph + $paragraph = $textline; + $plines = 1; + $textline = ''; + } else { + ## Append this line to the current paragraph + $paragraph .= $textline; + ++$plines; + } + + ## See of this line is blank and ends the current paragraph. + ## If it isnt, then keep iterating until it is. + next unless (($textline =~ /^\s*$/) && (length $paragraph)); + + ## Now process the paragraph + parse_paragraph($self, $paragraph, ($nlines - $plines) + 1); + $paragraph = ''; + $plines = 0; + } + ## Dont forget about the last paragraph in the file + if (length $paragraph) { + parse_paragraph($self, $paragraph, ($nlines - $plines) + 1) + } + + ## Now pop the input stream off the top of the input stack. + $self->_pop_input_stream(); +} + +##--------------------------------------------------------------------------- + +=head1 B<parse_from_file()> + + $parser->parse_from_file($filename,$outfile); + +This method takes a filename and does the following: + +=over 2 + +=item * + +opens the input and output files for reading +(creating the appropriate filehandles) + +=item * + +invokes the B<parse_from_filehandle()> method passing it the +corresponding input and output filehandles. + +=item * + +closes the input and output files. + +=back + +If the special input filename "-" or "<&STDIN" is given then the STDIN +filehandle is used for input (and no open or close is performed). If no +input filename is specified then "-" is implied. + +If a second argument is given then it should be the name of the desired +output file. If the special output filename "-" or ">&STDOUT" is given +then the STDOUT filehandle is used for output (and no open or close is +performed). If the special output filename ">&STDERR" is given then the +STDERR filehandle is used for output (and no open or close is +performed). If no output filehandle is currently in use and no output +filename is specified, then "-" is implied. + +This method does I<not> usually need to be overridden by subclasses. + +=cut + +sub parse_from_file { + my $self = shift; + my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : (); + my ($infile, $outfile) = @_; + my ($in_fh, $out_fh) = (undef, undef); + my ($close_input, $close_output) = (0, 0); + local *myData = $self; + local $_; + + ## Is $infile a filename or a (possibly implied) filehandle + $infile = '-' unless ((defined $infile) && (length $infile)); + if (($infile eq '-') || ($infile =~ /^<&(STDIN|0)$/i)) { + ## Not a filename, just a string implying STDIN + $myData{_INFILE} = "<standard input>"; + $in_fh = \*STDIN; + } + elsif (ref $infile) { + ## Must be a filehandle-ref (or else assume its a ref to an object + ## that supports the common IO read operations). + $myData{_INFILE} = ${$infile}; + $in_fh = $infile; + } + else { + ## We have a filename, open it for reading + $myData{_INFILE} = $infile; + $in_fh = FileHandle->new("< $infile") or + croak "Can't open $infile for reading: $!\n"; + $close_input = 1; + } + + ## NOTE: we need to be *very* careful when "defaulting" the output + ## file. We only want to use a default if this is the beginning of + ## the entire document (but *not* if this is an included file). We + ## determine this by seeing if the input stream stack has been set-up + ## already + ## + unless ((defined $outfile) && (length $outfile)) { + (defined $myData{_TOP_STREAM}) && ($out_fh = $myData{_OUTPUT}) + || ($outfile = '-'); + } + ## Is $outfile a filename or a (possibly implied) filehandle + if ((defined $outfile) && (length $outfile)) { + if (($outfile eq '-') || ($outfile =~ /^>&?(?:STDOUT|1)$/i)) { + ## Not a filename, just a string implying STDOUT + $myData{_OUTFILE} = "<standard output>"; + $out_fh = \*STDOUT; + } + elsif ($outfile =~ /^>&(STDERR|2)$/i) { + ## Not a filename, just a string implying STDERR + $myData{_OUTFILE} = "<standard error>"; + $out_fh = \*STDERR; + } + elsif (ref $outfile) { + ## Must be a filehandle-ref (or else assume its a ref to an + ## object that supports the common IO write operations). + $myData{_OUTFILE} = ${$outfile};; + $out_fh = $outfile; + } + else { + ## We have a filename, open it for writing + $myData{_OUTFILE} = $outfile; + $out_fh = FileHandle->new("> $outfile") or + croak "Can't open $outfile for writing: $!\n"; + $close_output = 1; + } + } + + ## Whew! That was a lot of work to set up reasonably/robust behavior + ## in the case of a non-filename for reading and writing. Now we just + ## have to parse the input and close the handles when we're finished. + $self->parse_from_filehandle(\%opts, $in_fh, $out_fh); + + $close_input and + close($in_fh) || croak "Can't close $infile after reading: $!\n"; + $close_output and + close($out_fh) || croak "Can't close $outfile after writing: $!\n"; +} + +############################################################################# + +=head1 ACCESSOR METHODS + +Clients of B<Pod::Parser> should use the following methods to access +instance data fields: + +=cut + +##--------------------------------------------------------------------------- + +=head1 B<cutting()> + + $boolean = $parser->cutting(); + +Returns the current C<cutting> state: a boolean-valued scalar which +evaluates to true if text from the input file is currently being "cut" +(meaning it is I<not> considered part of the POD document). + + $parser->cutting($boolean); + +Sets the current C<cutting> state to the given value and returns the +result. + +=cut + +sub cutting { + return (@_ > 1) ? ($_[0]->{_CUTTING} = $_[1]) : $_[0]->{_CUTTING}; +} + +##--------------------------------------------------------------------------- + +=head1 B<output_file()> + + $fname = $parser->output_file(); + +Returns the name of the output file being written. + +=cut + +sub output_file { + return $_[0]->{_OUTFILE}; +} + +##--------------------------------------------------------------------------- + +=head1 B<output_handle()> + + $fhandle = $parser->output_handle(); + +Returns the output filehandle object. + +=cut + +sub output_handle { + return $_[0]->{_OUTPUT}; +} + +##--------------------------------------------------------------------------- + +=head1 B<input_file()> + + $fname = $parser->input_file(); + +Returns the name of the input file being read. + +=cut + +sub input_file { + return $_[0]->{_INFILE}; +} + +##--------------------------------------------------------------------------- + +=head1 B<input_handle()> + + $fhandle = $parser->input_handle(); + +Returns the current input filehandle object. + +=cut + +sub input_handle { + return $_[0]->{_INPUT}; +} + +##--------------------------------------------------------------------------- + +=begin __PRIVATE__ + +=head1 B<input_streams()> + + $listref = $parser->input_streams(); + +Returns a reference to an array which corresponds to the stack of all +the input streams that are currently in the middle of being parsed. + +While parsing an input stream, it is possible to invoke +B<parse_from_file()> or B<parse_from_filehandle()> to parse a new input +stream and then return to parsing the previous input stream. Each input +stream to be parsed is pushed onto the end of this input stack +before any of its input is read. The input stream that is currently +being parsed is always at the end (or top) of the input stack. When an +input stream has been exhausted, it is popped off the end of the +input stack. + +Each element on this input stack is a reference to C<Pod::InputSource> +object. Please see L<Pod::InputObjects> for more details. + +This method might be invoked when printing diagnostic messages, for example, +to obtain the name and line number of the all input files that are currently +being processed. + +=end __PRIVATE__ + +=cut + +sub input_streams { + return $_[0]->{_INPUT_STREAMS}; +} + +##--------------------------------------------------------------------------- + +=begin __PRIVATE__ + +=head1 B<top_stream()> + + $hashref = $parser->top_stream(); + +Returns a reference to the hash-table that represents the element +that is currently at the top (end) of the input stream stack +(see L<"input_streams()">). The return value will be the C<undef> +if the input stack is empty. + +This method might be used when printing diagnostic messages, for example, +to obtain the name and line number of the current input file. + +=end __PRIVATE__ + +=cut + +sub top_stream { + return $_[0]->{_TOP_STREAM} || undef; +} + +############################################################################# + +=head1 PRIVATE METHODS AND DATA + +B<Pod::Parser> makes use of several internal methods and data fields +which clients should not need to see or use. For the sake of avoiding +name collisions for client data and methods, these methods and fields +are briefly discussed here. Determined hackers may obtain further +information about them by reading the B<Pod::Parser> source code. + +Private data fields are stored in the hash-object whose reference is +returned by the B<new()> constructor for this class. The names of all +private methods and data-fields used by B<Pod::Parser> begin with a +prefix of "_" and match the regular expression C</^_\w+$/>. + +=cut + +##--------------------------------------------------------------------------- + +=begin _PRIVATE_ + +=head1 B<_push_input_stream()> + + $hashref = $parser->_push_input_stream($in_fh,$out_fh); + +This method will push the given input stream on the input stack and +perform any necessary beginning-of-document or beginning-of-file +processing. The argument C<$in_fh> is the input stream filehandle to +push, and C<$out_fh> is the corresponding output filehandle to use (if +it is not given or is undefined, then the current output stream is used, +which defaults to standard output if it doesnt exist yet). + +The value returned will be reference to the hash-table that represents +the new top of the input stream stack. I<Please Note> that it is +possible for this method to use default values for the input and output +file handles. If this happens, you will need to look at the C<INPUT> +and C<OUTPUT> instance data members to determine their new values. + +=end _PRIVATE_ + +=cut + +sub _push_input_stream { + my ($self, $in_fh, $out_fh) = @_; + local *myData = $self; + + ## Initialize stuff for the entire document if this is *not* + ## an included file. + ## + ## NOTE: we need to be *very* careful when "defaulting" the output + ## filehandle. We only want to use a default value if this is the + ## beginning of the entire document (but *not* if this is an included + ## file). + unless (defined $myData{_TOP_STREAM}) { + $out_fh = \*STDOUT unless (defined $out_fh); + $myData{_CUTTING} = 1; ## current "cutting" state + $myData{_INPUT_STREAMS} = []; ## stack of all input streams + } + + ## Initialize input indicators + $myData{_OUTFILE} = '(unknown)' unless (defined $myData{_OUTFILE}); + $myData{_OUTPUT} = $out_fh if (defined $out_fh); + $in_fh = \*STDIN unless (defined $in_fh); + $myData{_INFILE} = '(unknown)' unless (defined $myData{_INFILE}); + $myData{_INPUT} = $in_fh; + my $input_top = $myData{_TOP_STREAM} + = new Pod::InputSource( + -name => $myData{_INFILE}, + -handle => $in_fh, + -was_cutting => $myData{_CUTTING} + ); + local *input_stack = $myData{_INPUT_STREAMS}; + push(@input_stack, $input_top); + + ## Perform beginning-of-document and/or beginning-of-input processing + $self->begin_pod() if (@input_stack == 1); + $self->begin_input(); + + return $input_top; +} + +##--------------------------------------------------------------------------- + +=begin _PRIVATE_ + +=head1 B<_pop_input_stream()> + + $hashref = $parser->_pop_input_stream(); + +This takes no arguments. It will perform any necessary end-of-file or +end-of-document processing and then pop the current input stream from +the top of the input stack. + +The value returned will be reference to the hash-table that represents +the new top of the input stream stack. + +=end _PRIVATE_ + +=cut + +sub _pop_input_stream { + my ($self) = @_; + local *myData = $self; + local *input_stack = $myData{_INPUT_STREAMS}; + + ## Perform end-of-input and/or end-of-document processing + $self->end_input() if (@input_stack > 0); + $self->end_pod() if (@input_stack == 1); + + ## Restore cutting state to whatever it was before we started + ## parsing this file. + my $old_top = pop(@input_stack); + $myData{_CUTTING} = $old_top->was_cutting(); + + ## Dont forget to reset the input indicators + my $input_top = undef; + if (@input_stack > 0) { + $input_top = $myData{_TOP_STREAM} = $input_stack[-1]; + $myData{_INFILE} = $input_top->name(); + $myData{_INPUT} = $input_top->handle(); + } else { + delete $myData{_TOP_STREAM}; + delete $myData{_INPUT_STREAMS}; + } + + return $input_top; +} + +############################################################################# + +=head1 SEE ALSO + +L<Pod::InputObjects>, L<Pod::Select> + +B<Pod::InputObjects> defines POD input objects corresponding to +command paragraphs, parse-trees, and interior-sequences. + +B<Pod::Select> is a subclass of B<Pod::Parser> which provides the ability +to selectively include and/or exclude sections of a POD document from being +translated based upon the current heading, subheading, subsubheading, etc. + +=for __PRIVATE__ +B<Pod::Callbacks> is a subclass of B<Pod::Parser> which gives its users +the ability the employ I<callback functions> instead of, or in addition +to, overriding methods of the base class. + +=for __PRIVATE__ +B<Pod::Select> and B<Pod::Callbacks> do not override any +methods nor do they define any new methods with the same name. Because +of this, they may I<both> be used (in combination) as a base class of +the same subclass in order to combine their functionality without +causing any namespace clashes due to multiple inheritance. + +=head1 AUTHOR + +Brad Appleton E<lt>bradapp@enteract.comE<gt> + +Based on code for B<Pod::Text> written by +Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> + +=cut + +1; diff --git a/lib/Pod/PlainText.pm b/lib/Pod/PlainText.pm new file mode 100644 index 0000000000..e629fc81c3 --- /dev/null +++ b/lib/Pod/PlainText.pm @@ -0,0 +1,650 @@ +############################################################################# +# Pod/PlainText.pm -- convert POD data to formatted ASCII text +# +# Derived from Tom Christiansen's Pod::PlainText module +# (with extensive modifications). +# +# Copyright (C) 1994-1999 Tom Christiansen. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::PlainText; + +use vars qw($VERSION); +$VERSION = 1.08; ## Current version of this package +require 5.004; ## requires this Perl version or later + +=head1 NAME + +pod2plaintext - function to convert POD data to formatted ASCII text + +Pod::PlainText - a class for converting POD data to formatted ASCII text + +=head1 SYNOPSIS + + use Pod::PlainText; + pod2plaintext("perlfunc.pod"); + +or + + use Pod::PlainText; + package MyParser; + @ISA = qw(Pod::PlainText); + + sub new { + ## constructor code ... + } + + ## implementation of appropriate subclass methods ... + + package main; + $parser = new MyParser; + @ARGV = ('-') unless (@ARGV > 0); + for (@ARGV) { + $parser->parse_from_file($_); + } + +=head1 REQUIRES + +perl5.004, Pod::Select, Term::Cap, Exporter, Carp + +=head1 EXPORTS + +pod2plaintext() + +=head1 DESCRIPTION + +Pod::PlainText is a module that can convert documentation in the POD +format (such as can be found throughout the Perl distribution) into +formatted ASCII. Termcap is optionally supported for +boldface/underline, and can be enabled via C<$Pod::PlainText::termcap=1>. +If termcap has not been enabled, then backspaces will be used to +simulate bold and underlined text. + +A separate F<pod2plaintext> program is included that is primarily a wrapper +for C<Pod::PlainText::pod2plaintext()>. + +The single function C<pod2plaintext()> can take one or two arguments. The first +should be the name of a file to read the pod from, or "<&STDIN" to read from +STDIN. A second argument, if provided, should be a filehandle glob where +output should be sent. + +=head1 SEE ALSO + +L<Pod::Parser>. + +=head1 AUTHOR + +Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> + +Modified to derive from B<Pod::Parser> by +Brad Appleton E<lt>bradapp@enteract.comE<gt> + +=cut + +############################################################################# + +use strict; +#use diagnostics; +use Carp; +use Exporter; +use Pod::Select; +use Term::Cap; +use vars qw(@ISA @EXPORT %HTML_Escapes); + +@ISA = qw(Exporter Pod::Select); +@EXPORT = qw(&pod2plaintext); + +%HTML_Escapes = ( + 'amp' => '&', # ampersand + 'lt' => '<', # left chevron, less-than + 'gt' => '>', # right chevron, greater-than + 'quot' => '"', # double quote + + "Aacute" => "\xC1", # capital A, acute accent + "aacute" => "\xE1", # small a, acute accent + "Acirc" => "\xC2", # capital A, circumflex accent + "acirc" => "\xE2", # small a, circumflex accent + "AElig" => "\xC6", # capital AE diphthong (ligature) + "aelig" => "\xE6", # small ae diphthong (ligature) + "Agrave" => "\xC0", # capital A, grave accent + "agrave" => "\xE0", # small a, grave accent + "Aring" => "\xC5", # capital A, ring + "aring" => "\xE5", # small a, ring + "Atilde" => "\xC3", # capital A, tilde + "atilde" => "\xE3", # small a, tilde + "Auml" => "\xC4", # capital A, dieresis or umlaut mark + "auml" => "\xE4", # small a, dieresis or umlaut mark + "Ccedil" => "\xC7", # capital C, cedilla + "ccedil" => "\xE7", # small c, cedilla + "Eacute" => "\xC9", # capital E, acute accent + "eacute" => "\xE9", # small e, acute accent + "Ecirc" => "\xCA", # capital E, circumflex accent + "ecirc" => "\xEA", # small e, circumflex accent + "Egrave" => "\xC8", # capital E, grave accent + "egrave" => "\xE8", # small e, grave accent + "ETH" => "\xD0", # capital Eth, Icelandic + "eth" => "\xF0", # small eth, Icelandic + "Euml" => "\xCB", # capital E, dieresis or umlaut mark + "euml" => "\xEB", # small e, dieresis or umlaut mark + "Iacute" => "\xCD", # capital I, acute accent + "iacute" => "\xED", # small i, acute accent + "Icirc" => "\xCE", # capital I, circumflex accent + "icirc" => "\xEE", # small i, circumflex accent + "Igrave" => "\xCD", # capital I, grave accent + "igrave" => "\xED", # small i, grave accent + "Iuml" => "\xCF", # capital I, dieresis or umlaut mark + "iuml" => "\xEF", # small i, dieresis or umlaut mark + "Ntilde" => "\xD1", # capital N, tilde + "ntilde" => "\xF1", # small n, tilde + "Oacute" => "\xD3", # capital O, acute accent + "oacute" => "\xF3", # small o, acute accent + "Ocirc" => "\xD4", # capital O, circumflex accent + "ocirc" => "\xF4", # small o, circumflex accent + "Ograve" => "\xD2", # capital O, grave accent + "ograve" => "\xF2", # small o, grave accent + "Oslash" => "\xD8", # capital O, slash + "oslash" => "\xF8", # small o, slash + "Otilde" => "\xD5", # capital O, tilde + "otilde" => "\xF5", # small o, tilde + "Ouml" => "\xD6", # capital O, dieresis or umlaut mark + "ouml" => "\xF6", # small o, dieresis or umlaut mark + "szlig" => "\xDF", # small sharp s, German (sz ligature) + "THORN" => "\xDE", # capital THORN, Icelandic + "thorn" => "\xFE", # small thorn, Icelandic + "Uacute" => "\xDA", # capital U, acute accent + "uacute" => "\xFA", # small u, acute accent + "Ucirc" => "\xDB", # capital U, circumflex accent + "ucirc" => "\xFB", # small u, circumflex accent + "Ugrave" => "\xD9", # capital U, grave accent + "ugrave" => "\xF9", # small u, grave accent + "Uuml" => "\xDC", # capital U, dieresis or umlaut mark + "uuml" => "\xFC", # small u, dieresis or umlaut mark + "Yacute" => "\xDD", # capital Y, acute accent + "yacute" => "\xFD", # small y, acute accent + "yuml" => "\xFF", # small y, dieresis or umlaut mark + + "lchevron" => "\xAB", # left chevron (double less than) + "rchevron" => "\xBB", # right chevron (double greater than) +); + +##--------------------------------- +## Function definitions begin here +##--------------------------------- + + ## Try to find #columns for the tty +my %NotUnix = map {($_ => 1)} qw(MacOS MSWin32 VMS MVS); +sub get_screen { + ((defined $ENV{TERMCAP}) && ($ENV{TERMCAP} =~ /co#(\d+)/)[0]) + or ((defined $ENV{COLUMNS}) && $ENV{COLUMNS}) + or (!$NotUnix{$^O} && (`stty -a 2>/dev/null` =~ /(\d+) columns/)[0]) + or 72; + +} + +sub pod2plaintext { + my ($infile, $outfile) = @_; + local $_; + my $text_parser = new Pod::PlainText; + $text_parser->parse_from_file($infile, $outfile); +} + +##------------------------------- +## Method definitions begin here +##------------------------------- + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my %params = @_; + my $self = {%params}; + bless $self, $class; + $self->initialize(); + return $self; +} + +sub initialize { + my $self = shift; + $self->SUPER::initialize(); + return; +} + +sub makespace { + my $self = shift; + my $out_fh = $self->output_handle(); + if ($self->{NEEDSPACE}) { + print $out_fh "\n"; + $self->{NEEDSPACE} = 0; + } +} + +sub bold { + my $self = shift; + my $line = shift; + my $map = $self->{FONTMAP}; + return $line if $self->{USE_FORMAT}; + if ($self->{TERMCAP}) { + $line = "$map->{BOLD}$line$map->{NORM}"; + } + else { + $line =~ s/(.)/$1\b$1/g; + } +# $line = "$map->{BOLD}$line$map->{NORM}" if $self->{ANSIFY}; + return $line; +} + +sub italic { + my $self = shift; + my $line = shift; + my $map = $self->{FONTMAP}; + return $line if $self->{USE_FORMAT}; + if ($self->{TERMCAP}) { + $line = "$map->{UNDL}$line$map->{NORM}"; + } + else { + $line =~ s/(.)/$1\b_/g; + } +# $line = "$map->{UNDL}$line$map->{NORM}" if $self->{ANSIFY}; + return $line; +} + +# Fill a paragraph including underlined and overstricken chars. +# It's not perfect for words longer than the margin, and it's probably +# slow, but it works. +sub fill { + my $self = shift; + local $_ = shift; + my $par = ""; + my $indent_space = " " x $self->{INDENT}; + my $marg = $self->{SCREEN} - $self->{INDENT}; + my $line = $indent_space; + my $line_length; + foreach (split) { + my $word_length = length; + $word_length -= 2 while /\010/g; # Subtract backspaces + + if ($line_length + $word_length > $marg) { + $par .= $line . "\n"; + $line= $indent_space . $_; + $line_length = $word_length; + } + else { + if ($line_length) { + $line_length++; + $line .= " "; + } + $line_length += $word_length; + $line .= $_; + } + } + $par .= "$line\n" if $line; + $par .= "\n"; + return $par; +} + +## Handle a pending "item" paragraph. The paragraph (if given) is the +## corresponding item text. (the item tag should be in $self->{ITEM}). +sub item { + my $self = shift; + my $cmd = shift; + local $_ = shift; + my $line = shift; + $cmd = '' unless (defined $cmd); + $_ = '' unless (defined $_); + my $out_fh = $self->output_handle(); + return unless (defined $self->{ITEM}); + my $paratag = $self->{ITEM}; + my $prev_indent = $self->{INDENTS}->[-1] || $self->{DEF_INDENT}; + ## reset state + undef $self->{ITEM}; + #$self->rm_callbacks('*'); + + my $over = $self->{INDENT}; + $over -= $prev_indent if ($prev_indent < $over); + if (length $cmd) { # tricked - this is another command + $self->output($paratag, INDENT => $prev_indent); + $self->command($cmd, $_); + } + elsif (/^\s+/o) { # verbatim + $self->output($paratag, INDENT => $prev_indent); + s/\s+\Z//; + $self->verbatim($_); + } + else { # plain textblock + $_ = $self->interpolate($_, $line); + s/\s+\Z//; + if ((length $_) && (length($paratag) <= $over)) { + $self->IP_output($paratag, $_); + } + else { + $self->output($paratag, INDENT => $prev_indent); + $self->output($_, REFORMAT => 1); + } + } +} + +sub remap_whitespace { + my $self = shift; + local($_) = shift; + tr/\000-\177/\200-\377/; + return $_; +} + +sub unmap_whitespace { + my $self = shift; + local($_) = shift; + tr/\200-\377/\000-\177/; + return $_; +} + +sub IP_output { + my $self = shift; + my $tag = shift; + local($_) = @_; + my $out_fh = $self->output_handle(); + my $tag_indent = $self->{INDENTS}->[-1] || $self->{DEF_INDENT}; + my $tag_cols = $self->{SCREEN} - $tag_indent; + my $cols = $self->{SCREEN} - $self->{INDENT}; + $tag =~ s/\s*$//; + s/\s+/ /g; + s/^ //; + my $fmt_name = '_Pod_Text_IP_output_format_'; + my $str = "format $fmt_name = \n" + . (" " x ($tag_indent)) + . '@' . ('<' x ($self->{INDENT} - $tag_indent - 1)) + . "^" . ("<" x ($cols - 1)) . "\n" + . '$tag, $_' + . "\n~~" + . (" " x ($self->{INDENT} - 2)) + . "^" . ("<" x ($cols - 5)) . "\n" + . '$_' . "\n\n.\n1"; + #warn $str; warn "tag is $tag, _ is $_"; + { + ## reset format (turn off warning about redefining a format) + local($^W) = 0; + eval $str; + croak if ($@); + } + select((select($out_fh), $~ = $fmt_name)[0]); + local($:) = ($self->curr_headings(1) eq 'SYNOPSIS') ? "\n " : $: ; + write $out_fh; +} + +sub output { + my $self = shift; + local $_ = shift; + $_ = '' unless (defined $_); + return unless (length $_); + my $out_fh = $self->output_handle(); + my %options; + if (@_ > 1) { + ## usage was $self->output($text, NAME=>VALUE, ...); + %options = @_; + } + elsif (@_ == 1) { + if (ref $_[0]) { + ## usage was $self->output($text, { NAME=>VALUE, ... } ); + %options = %{$_[0]}; + } + else { + ## usage was $self->output($text, $number); + $options{"REFORMAT"} = shift; + } + } + $options{"INDENT"} = $self->{INDENT} unless (defined $options{"INDENT"}); + if ((defined $options{"REFORMAT"}) && $options{"REFORMAT"}) { + my $cols = $self->{SCREEN} - $options{"INDENT"}; + s/\s+/ /g; + s/^ //; + my $fmt_name = '_Pod_Text_output_format_'; + my $str = "format $fmt_name = \n~~" + . (" " x ($options{"INDENT"} - 2)) + . "^" . ("<" x ($cols - 5)) . "\n" + . '$_' . "\n\n.\n1"; + { + ## reset format (turn off warning about redefining a format) + local($^W) = 0; + eval $str; + croak if ($@); + } + select((select($out_fh), $~ = $fmt_name)[0]); + local($:) = ($self->curr_headings(1) eq 'SYNOPSIS') ? "\n " : $: ; + write $out_fh; + } + else { + s/^/' ' x $options{"INDENT"}/gem; + s/^\s+\n$/\n/gm; + print $out_fh $_; + } +} + +sub internal_lrefs { + my $self = shift; + local $_ = shift; + s{L</([^>]+)>}{$1}g; + my(@items) = split( /(?:,?\s+(?:and\s+)?)/ ); + my $retstr = "the "; + my $i; + for ($i = 0; $i <= $#items; $i++) { + $retstr .= "C<$items[$i]>"; + $retstr .= ", " if @items > 2 && $i != $#items; + $retstr .= " and " if $i+2 == @items; + } + + $retstr .= " entr" . ( @items > 1 ? "ies" : "y" ) + . " elsewhere in this document "; + + return $retstr; +} + +sub begin_pod { + my $self = shift; + + $self->{BEGUN} = []; + $self->{TERMCAP} = 0; + #$self->{USE_FORMAT} = 1; + + $self->{FONTMAP} = { + UNDL => "\x1b[4m", + INV => "\x1b[7m", + BOLD => "\x1b[1m", + NORM => "\x1b[0m", + }; + if ($self->{TERMCAP} and (! defined $self->{SETUPTERMCAP})) { + $self->{SETUPTERMCAP} = 1; + my ($term) = Tgetent Term::Cap { TERM => undef, OSPEED => 9600 }; + $self->{FONTMAP}->{UNDL} = $term->{'_us'}; + $self->{FONTMAP}->{INV} = $term->{'_mr'}; + $self->{FONTMAP}->{BOLD} = $term->{'_md'}; + $self->{FONTMAP}->{NORM} = $term->{'_me'}; + } + + $self->{SCREEN} = &get_screen; + $self->{FANCY} = 0; + $self->{DEF_INDENT} = 4; + $self->{INDENTS} = []; + $self->{INDENT} = $self->{DEF_INDENT}; + $self->{NEEDSPACE} = 0; +} + +sub end_pod { + my $self = shift; + $self->item('', '', '', 0) if (defined $self->{ITEM}); +} + +sub begun_excluded { + my $self = shift; + my @begun = @{ $self->{BEGUN} }; + return (@begun > 0) ? ($begun[-1] ne 'text') : 0; +} + +sub command { + my $self = shift; + my $cmd = shift; + local $_ = shift; + my $line = shift; + $cmd = '' unless (defined $cmd); + $_ = '' unless (defined $_); + my $out_fh = $self->output_handle(); + + return if (($cmd ne 'end') and $self->begun_excluded()); + return $self->item($cmd, $_, $line) if (defined $self->{ITEM}); + $_ = $self->interpolate($_, $line); + s/\s+\Z/\n/; + + return if ($cmd eq 'pod'); + if ($cmd eq 'head1') { + $self->makespace(); + print $out_fh $_; + # print $out_fh uc($_); + } + elsif ($cmd eq 'head2') { + $self->makespace(); + # s/(\w+)/\u\L$1/g; + #print ' ' x $self->{DEF_INDENT}, $_; + # print "\xA7"; + s/(\w)/\xA7 $1/ if $self->{FANCY}; + print $out_fh ' ' x ($self->{DEF_INDENT}/2), $_, "\n"; + } + elsif ($cmd eq 'over') { + /^[-+]?\d+$/ or $_ = $self->{DEF_INDENT}; + push(@{$self->{INDENTS}}, $self->{INDENT}); + $self->{INDENT} += ($_ + 0); + } + elsif ($cmd eq 'back') { + $self->{INDENT} = pop(@{$self->{INDENTS}}); + unless (defined $self->{INDENT}) { + carp "Unmatched =back\n"; + $self->{INDENT} = $self->{DEF_INDENT}; + } + } + elsif ($cmd eq 'begin') { + my ($kind) = /^(\S*)/; + push( @{ $self->{BEGUN} }, $kind ); + } + elsif ($cmd eq 'end') { + pop( @{ $self->{BEGUN} } ); + } + elsif ($cmd eq 'for') { + $self->textblock($1) if /^text\b\s*(.*)$/s; + } + elsif ($cmd eq 'item') { + $self->makespace(); + # s/\A(\s*)\*/$1\xb7/ if $self->{FANCY}; + # s/^(\s*\*\s+)/$1 /; + $self->{ITEM} = $_; + #$self->add_callbacks('*', SUB => \&item); + } + else { + carp "Unrecognized directive: $cmd\n"; + } +} + +sub verbatim { + my $self = shift; + local $_ = shift; + my $line = shift; + return if $self->begun_excluded(); + return $self->item('', $_, $line) if (defined $self->{ITEM}); + $self->output($_); + #$self->{NEEDSPACE} = 1; +} + +sub textblock { + my $self = shift; + my $text = shift; + my $line = shift; + return if $self->begun_excluded(); + return $self->item('', $text, $line) if (defined $self->{ITEM}); + local($_) = $self->interpolate($text, $line); + s/\s*\Z/\n/; + $self->makespace(); + $self->output($_, REFORMAT => 1); +} + +sub interior_sequence { + my $self = shift; + my $cmd = shift; + my $arg = shift; + local($_) = $arg; + if ($cmd eq 'C') { + my ($pre, $post) = ("`", "'"); + ($pre, $post) = ($HTML_Escapes{"lchevron"}, $HTML_Escapes{"rchevron"}) + if ((defined $self->{FANCY}) && $self->{FANCY}); + $_ = $pre . $_ . $post; + } + elsif ($cmd eq 'E') { + if (defined $HTML_Escapes{$_}) { + $_ = $HTML_Escapes{$_}; + } + else { + carp "Unknown escape: E<$_>"; + $_ = "E<$_>"; + } + # } + # elsif ($cmd eq 'B') { + # $_ = $self->bold($_); + } + elsif ($cmd eq 'I') { + # $_ = $self->italic($_); + $_ = "*" . $_ . "*"; + } + elsif (($cmd eq 'X') || ($cmd eq 'Z')) { + $_ = ''; + } + elsif ($cmd eq 'S') { + # Escape whitespace until we are ready to print + #$_ = $self->remap_whitespace($_); + } + elsif ($cmd eq 'L') { + s/\s+/ /g; + my ($text, $manpage, $sec, $ref) = ('', $_, '', ''); + if (/\A(.*?)\|(.*)\Z/) { + $text = $1; + $manpage = $_ = $2; + } + if (/^\s*"\s*(.*)\s*"\s*$/o) { + ($manpage, $sec) = ('', "\"$1\""); + } + elsif (m|\s*/\s*|s) { + ($manpage, $sec) = split(/\s*\/\s*/, $_, 2); + } + if (! length $sec) { + $ref .= "the $manpage manpage" if (length $manpage); + } + elsif ($sec =~ /^\s*"\s*(.*)\s*"\s*$/o) { + $ref .= "the section on \"$1\""; + $ref .= " in the $manpage manpage" if (length $manpage); + } + else { + $ref .= "the \"$sec\" entry"; + $ref .= (length $manpage) ? " in the $manpage manpage" + : " in this manpage" + } + $_ = $text || $ref; + #if ( m{^ ([a-zA-Z][^\s\/]+) (\([^\)]+\))? $}x ) { + # ## LREF: a manpage(3f) + # $_ = "the $1$2 manpage"; + #} + #elsif ( m{^ ([^/]+) / ([:\w]+(\(\))?) $}x ) { + # ## LREF: an =item on another manpage + # $_ = "the \"$2\" entry in the $1 manpage"; + #} + #elsif ( m{^ / ([:\w]+(\(\))?) $}x ) { + # ## LREF: an =item on this manpage + # $_ = $self->internal_lrefs($1); + #} + #elsif ( m{^ (?: ([a-zA-Z]\S+?) / )? "?(.*?)"? $}x ) { + # ## LREF: a =head2 (head1?), maybe on a manpage, maybe right here + # ## the "func" can disambiguate + # $_ = ((defined $1) && $1) + # ? "the section on \"$2\" in the $1 manpage" + # : "the section on \"$2\""; + #} + } + return $_; +} + +1; diff --git a/lib/Pod/Select.pm b/lib/Pod/Select.pm new file mode 100644 index 0000000000..96377d4002 --- /dev/null +++ b/lib/Pod/Select.pm @@ -0,0 +1,748 @@ +############################################################################# +# Pod/Select.pm -- function to select portions of POD docs +# +# Based on Tom Christiansen's pod2text() function +# (with extensive modifications). +# +# Copyright (C) 1996-1999 Tom Christiansen. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::Select; + +use vars qw($VERSION); +$VERSION = 1.08; ## Current version of this package +require 5.004; ## requires this Perl version or later + +############################################################################# + +=head1 NAME + +Pod::Select, podselect() - extract selected sections of POD from input + +=head1 SYNOPSIS + + use Pod::Select; + + ## Select all the POD sections for each file in @filelist + ## and print the result on standard output. + podselect(@filelist); + + ## Same as above, but write to tmp.out + podselect({-output => "tmp.out"}, @filelist): + + ## Select from the given filelist, only those POD sections that are + ## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS. + podselect({-sections => ["NAME|SYNOPSIS", "OPTIONS"]}, @filelist): + + ## Select the "DESCRIPTION" section of the PODs from STDIN and write + ## the result to STDERR. + podselect({-output => ">&STDERR", -sections => ["DESCRIPTION"]}, \*STDIN); + +or + + use Pod::Select; + + ## Create a parser object for selecting POD sections from the input + $parser = new Pod::Select(); + + ## Select all the POD sections for each file in @filelist + ## and print the result to tmp.out. + $parser->parse_from_file("<&STDIN", "tmp.out"); + + ## Select from the given filelist, only those POD sections that are + ## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS. + $parser->select("NAME|SYNOPSIS", "OPTIONS"); + for (@filelist) { $parser->parse_from_file($_); } + + ## Select the "DESCRIPTION" and "SEE ALSO" sections of the PODs from + ## STDIN and write the result to STDERR. + $parser->select("DESCRIPTION"); + $parser->add_selection("SEE ALSO"); + $parser->parse_from_filehandle(\*STDIN, \*STDERR); + +=head1 REQUIRES + +perl5.004, Pod::Parser, Exporter, FileHandle, Carp + +=head1 EXPORTS + +podselect() + +=head1 DESCRIPTION + +B<podselect()> is a function which will extract specified sections of +pod documentation from an input stream. This ability is provided by the +B<Pod::Select> module which is a subclass of B<Pod::Parser>. +B<Pod::Select> provides a method named B<select()> to specify the set of +POD sections to select for processing/printing. B<podselect()> merely +creates a B<Pod::Select> object and then invokes the B<podselect()> +followed by B<parse_from_file()>. + +=head1 SECTION SPECIFICATIONS + +B<podselect()> and B<Pod::Select::select()> may be given one or more +"section specifications" to restrict the text processed to only the +desired set of sections and their corresponding subsections. A section +specification is a string containing one or more Perl-style regular +expressions separated by forward slashes ("/"). If you need to use a +forward slash literally within a section title you can escape it with a +backslash ("\/"). + +The formal syntax of a section specification is: + +=over 4 + +=item + +I<head1-title-regex>/I<head2-title-regex>/... + +=back + +Any omitted or empty regular expressions will default to ".*". +Please note that each regular expression given is implicitly +anchored by adding "^" and "$" to the beginning and end. Also, if a +given regular expression starts with a "!" character, then the +expression is I<negated> (so C<!foo> would match anything I<except> +C<foo>). + +Some example section specifications follow. + +=over 4 + +=item +Match the C<NAME> and C<SYNOPSIS> sections and all of their subsections: + +C<NAME|SYNOPSIS> + +=item +Match only the C<Question> and C<Answer> subsections of the C<DESCRIPTION> +section: + +C<DESCRIPTION/Question|Answer> + +=item +Match the C<Comments> subsection of I<all> sections: + +C</Comments> + +=item +Match all subsections of C<DESCRIPTION> I<except> for C<Comments>: + +C<DESCRIPTION/!Comments> + +=item +Match the C<DESCRIPTION> section but do I<not> match any of its subsections: + +C<DESCRIPTION/!.+> + +=item +Match all top level sections but none of their subsections: + +C</!.+> + +=back + +=begin _NOT_IMPLEMENTED_ + +=head1 RANGE SPECIFICATIONS + +B<podselect()> and B<Pod::Select::select()> may be given one or more +"range specifications" to restrict the text processed to only the +desired ranges of paragraphs in the desired set of sections. A range +specification is a string containing a single Perl-style regular +expression (a regex), or else two Perl-style regular expressions +(regexs) separated by a ".." (Perl's "range" operator is ".."). +The regexs in a range specification are delimited by forward slashes +("/"). If you need to use a forward slash literally within a regex you +can escape it with a backslash ("\/"). + +The formal syntax of a range specification is: + +=over 4 + +=item + +/I<start-range-regex>/[../I<end-range-regex>/] + +=back + +Where each the item inside square brackets (the ".." followed by the +end-range-regex) is optional. Each "range-regex" is of the form: + + =cmd-expr text-expr + +Where I<cmd-expr> is intended to match the name of one or more POD +commands, and I<text-expr> is intended to match the paragraph text for +the command. If a range-regex is supposed to match a POD command, then +the first character of the regex (the one after the initial '/') +absolutely I<must> be an single '=' character; it may not be anything +else (not even a regex meta-character) if it is supposed to match +against the name of a POD command. + +If no I<=cmd-expr> is given then the text-expr will be matched against +plain textblocks unless it is preceded by a space, in which case it is +matched against verbatim text-blocks. If no I<text-expr> is given then +only the command-portion of the paragraph is matched against. + +Note that these two expressions are each implicitly anchored. This +means that when matching against the command-name, there will be an +implicit '^' and '$' around the given I<=cmd-expr>; and when matching +against the paragraph text there will be an implicit '\A' and '\Z' +around the given I<text-expr>. + +Unlike with section-specs, the '!' character does I<not> have any special +meaning (negation or otherwise) at the beginning of a range-spec! + +Some example range specifications follow. + +=over 4 + +=item +Match all C<=for html> paragraphs: + +C</=for html/> + +=item +Match all paragraphs between C<=begin html> and C<=end html> +(note that this will I<not> work correctly if such sections +are nested): + +C</=begin html/../=end html/> + +=item +Match all paragraphs between the given C<=item> name until the end of the +current section: + +C</=item mine/../=head\d/> + +=item +Match all paragraphs between the given C<=item> until the next item, or +until the end of the itemized list (note that this will I<not> work as +desired if the item contains an itemized list nested within it): + +C</=item mine/../=(item|back)/> + +=back + +=end _NOT_IMPLEMENTED_ + +=cut + +############################################################################# + +use strict; +#use diagnostics; +use Carp; +use Pod::Parser 1.04; +use vars qw(@ISA @EXPORT $MAX_HEADING_LEVEL); + +@ISA = qw(Pod::Parser); +@EXPORT = qw(&podselect); + +## Maximum number of heading levels supported for '=headN' directives +*MAX_HEADING_LEVEL = \3; + +############################################################################# + +=head1 OBJECT METHODS + +The following methods are provided in this module. Each one takes a +reference to the object itself as an implicit first parameter. + +=cut + +##--------------------------------------------------------------------------- + +## =begin _PRIVATE_ +## +## =head1 B<_init_headings()> +## +## Initialize the current set of active section headings. +## +## =cut +## +## =end _PRIVATE_ + +use vars qw(%myData @section_headings); + +sub _init_headings { + my $self = shift; + local *myData = $self; + + ## Initialize current section heading titles if necessary + unless (defined $myData{_SECTION_HEADINGS}) { + local *section_headings = $myData{_SECTION_HEADINGS} = []; + for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { + $section_headings[$i] = ''; + } + } +} + +##--------------------------------------------------------------------------- + +=head1 B<curr_headings()> + + ($head1, $head2, $head3, ...) = $parser->curr_headings(); + $head1 = $parser->curr_headings(1); + +This method returns a list of the currently active section headings and +subheadings in the document being parsed. The list of headings returned +corresponds to the most recently parsed paragraph of the input. + +If an argument is given, it must correspond to the desired section +heading number, in which case only the specified section heading is +returned. If there is no current section heading at the specified +level, then C<undef> is returned. + +=cut + +sub curr_headings { + my $self = shift; + $self->_init_headings() unless (defined $self->{_SECTION_HEADINGS}); + my @headings = @{ $self->{_SECTION_HEADINGS} }; + return (@_ > 0 and $_[0] =~ /^\d+$/) ? $headings[$_[0] - 1] : @headings; +} + +##--------------------------------------------------------------------------- + +=head1 B<select()> + + $parser->select($section_spec1,$section_spec2,...); + +This method is used to select the particular sections and subsections of +POD documentation that are to be printed and/or processed. The existing +set of selected sections is I<replaced> with the given set of sections. +See B<add_selection()> for adding to the current set of selected +sections. + +Each of the C<$section_spec> arguments should be a section specification +as described in L<"SECTION SPECIFICATIONS">. The section specifications +are parsed by this method and the resulting regular expressions are +stored in the invoking object. + +If no C<$section_spec> arguments are given, then the existing set of +selected sections is cleared out (which means C<all> sections will be +processed). + +This method should I<not> normally be overridden by subclasses. + +=cut + +use vars qw(@selected_sections); + +sub select { + my $self = shift; + my @sections = @_; + local *myData = $self; + local $_; + +### NEED TO DISCERN A SECTION-SPEC FROM A RANGE-SPEC (look for m{^/.+/$}?) + + ##--------------------------------------------------------------------- + ## The following is a blatant hack for backward compatibility, and for + ## implementing add_selection(). If the *first* *argument* is the + ## string "+", then the remaining section specifications are *added* + ## to the current set of selections; otherwise the given section + ## specifications will *replace* the current set of selections. + ## + ## This should probably be fixed someday, but for the present time, + ## it seems incredibly unlikely that "+" would ever correspond to + ## a legitimate section heading + ##--------------------------------------------------------------------- + my $add = ($sections[0] eq "+") ? shift(@sections) : ""; + + ## Reset the set of sections to use + unless (@sections > 0) { + delete $myData{_SELECTED_SECTIONS} unless ($add); + return; + } + $myData{_SELECTED_SECTIONS} = [] + unless ($add && exists $myData{_SELECTED_SECTIONS}); + local *selected_sections = $myData{_SELECTED_SECTIONS}; + + ## Compile each spec + my $spec; + for $spec (@sections) { + if ( defined($_ = &_compile_section_spec($spec)) ) { + ## Store them in our sections array + push(@selected_sections, $_); + } + else { + carp "Ignoring section spec \"$spec\"!\n"; + } + } +} + +##--------------------------------------------------------------------------- + +=head1 B<add_selection()> + + $parser->add_selection($section_spec1,$section_spec2,...); + +This method is used to add to the currently selected sections and +subsections of POD documentation that are to be printed and/or +processed. See <select()> for replacing the currently selected sections. + +Each of the C<$section_spec> arguments should be a section specification +as described in L<"SECTION SPECIFICATIONS">. The section specifications +are parsed by this method and the resulting regular expressions are +stored in the invoking object. + +This method should I<not> normally be overridden by subclasses. + +=cut + +sub add_selection { + my $self = shift; + $self->select("+", @_); +} + +##--------------------------------------------------------------------------- + +=head1 B<clear_selections()> + + $parser->clear_selections(); + +This method takes no arguments, it has the exact same effect as invoking +<select()> with no arguments. + +=cut + +sub clear_selections { + my $self = shift; + $self->select(); +} + +##--------------------------------------------------------------------------- + +=head1 B<match_section()> + + $boolean = $parser->match_section($heading1,$heading2,...); + +Returns a value of true if the given section and subsection heading +titles match any of the currently selected section specifications in +effect from prior calls to B<select()> and B<add_selection()> (or if +there are no explictly selected/deselected sections). + +The arguments C<$heading1>, C<$heading2>, etc. are the heading titles of +the corresponding sections, subsections, etc. to try and match. If +C<$headingN> is omitted then it defaults to the current corresponding +section heading title in the input. + +This method should I<not> normally be overridden by subclasses. + +=cut + +sub match_section { + my $self = shift; + my (@headings) = @_; + local *myData = $self; + + ## Return true if no restrictions were explicitly specified + my $selections = (exists $myData{_SELECTED_SECTIONS}) + ? $myData{_SELECTED_SECTIONS} : undef; + return 1 unless ((defined $selections) && (@{$selections} > 0)); + + ## Default any unspecified sections to the current one + my @current_headings = $self->curr_headings(); + for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { + (defined $headings[$i]) or $headings[$i] = $current_headings[$i]; + } + + ## Look for a match against the specified section expressions + my ($section_spec, $regex, $negated, $match); + for $section_spec ( @{$selections} ) { + ##------------------------------------------------------ + ## Each portion of this spec must match in order for + ## the spec to be matched. So we will start with a + ## match-value of 'true' and logically 'and' it with + ## the results of matching a given element of the spec. + ##------------------------------------------------------ + $match = 1; + for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { + $regex = $section_spec->[$i]; + $negated = ($regex =~ s/^\!//); + $match &= ($negated ? ($headings[$i] !~ /${regex}/) + : ($headings[$i] =~ /${regex}/)); + last unless ($match); + } + return 1 if ($match); + } + return 0; ## no match +} + +##--------------------------------------------------------------------------- + +=head1 B<is_selected()> + + $boolean = $parser->is_selected($paragraph); + +This method is used to determine if the block of text given in +C<$paragraph> falls within the currently selected set of POD sections +and subsections to be printed or processed. This method is also +responsible for keeping track of the current input section and +subsections. It is assumed that C<$paragraph> is the most recently read +(but not yet processed) input paragraph. + +The value returned will be true if the C<$paragraph> and the rest of the +text in the same section as C<$paragraph> should be selected (included) +for processing; otherwise a false value is returned. + +=cut + +sub is_selected { + my ($self, $paragraph) = @_; + local $_; + local *myData = $self; + + $self->_init_headings() unless (defined $myData{_SECTION_HEADINGS}); + + ## Keep track of current sections levels and headings + $_ = $paragraph; + if (/^=((?:sub)*)(?:head(?:ing)?|sec(?:tion)?)(\d*)\s+(.*)\s*$/) { + ## This is a section heading command + my ($level, $heading) = ($2, $3); + $level = 1 + (length($1) / 3) if ((! length $level) || (length $1)); + ## Reset the current section heading at this level + $myData{_SECTION_HEADINGS}->[$level - 1] = $heading; + ## Reset subsection headings of this one to empty + for (my $i = $level; $i < $MAX_HEADING_LEVEL; ++$i) { + $myData{_SECTION_HEADINGS}->[$i] = ''; + } + } + + return $self->match_section(); +} + +############################################################################# + +=head1 EXPORTED FUNCTIONS + +The following functions are exported by this module. Please note that +these are functions (not methods) and therefore C<do not> take an +implicit first argument. + +=cut + +##--------------------------------------------------------------------------- + +=head1 B<podselect()> + + podselect(\%options,@filelist); + +B<podselect> will print the raw (untranslated) POD paragraphs of all +POD sections in the given input files specified by C<@filelist> +according to the given options. + +If any argument to B<podselect> is a reference to a hash +(associative array) then the values with the following keys are +processed as follows: + +=over 4 + +=item B<-output> + +A string corresponding to the desired output file (or ">&STDOUT" +or ">&STDERR"). The default is to use standard output. + +=item B<-sections> + +A reference to an array of sections specifications (as described in +L<"SECTION SPECIFICATIONS">) which indicate the desired set of POD +sections and subsections to be selected from input. If no section +specifications are given, then all sections of the PODs are used. + +=begin _NOT_IMPLEMENTED_ + +=item B<-ranges> + +A reference to an array of range specifications (as described in +L<"RANGE SPECIFICATIONS">) which indicate the desired range of POD +paragraphs to be selected from the desired input sections. If no range +specifications are given, then all paragraphs of the desired sections +are used. + +=end _NOT_IMPLEMENTED_ + +=back + +All other arguments should correspond to the names of input files +containing POD sections. A file name of "-" or "<&STDIN" will +be interpeted to mean standard input (which is the default if no +filenames are given). + +=cut + +sub podselect { + my(@argv) = @_; + my %defaults = (); + my $pod_parser = new Pod::Select(%defaults); + my $num_inputs = 0; + my $output = ">&STDOUT"; + my %opts = (); + local $_; + for (@argv) { + if (ref($_)) { + next unless (ref($_) eq 'HASH'); + %opts = (%defaults, %{$_}); + + ##------------------------------------------------------------- + ## Need this for backward compatibility since we formerly used + ## options that were all uppercase words rather than ones that + ## looked like Unix command-line options. + ## to be uppercase keywords) + ##------------------------------------------------------------- + %opts = map { + my ($key, $val) = (lc $_, $opts{$_}); + $key =~ s/^(?=\w)/-/; + $key =~ /^-se[cl]/ and $key = '-sections'; + #! $key eq '-range' and $key .= 's'; + ($key => $val); + } (keys %opts); + + ## Process the options + (exists $opts{'-output'}) and $output = $opts{'-output'}; + + ## Select the desired sections + $pod_parser->select(@{ $opts{'-sections'} }) + if ( (defined $opts{'-sections'}) + && ((ref $opts{'-sections'}) eq 'ARRAY') ); + + #! ## Select the desired paragraph ranges + #! $pod_parser->select(@{ $opts{'-ranges'} }) + #! if ( (defined $opts{'-ranges'}) + #! && ((ref $opts{'-ranges'}) eq 'ARRAY') ); + } + else { + $pod_parser->parse_from_file($_, $output); + ++$num_inputs; + } + } + $pod_parser->parse_from_file("-") unless ($num_inputs > 0); +} + +############################################################################# + +=head1 PRIVATE METHODS AND DATA + +B<Pod::Select> makes uses a number of internal methods and data fields +which clients should not need to see or use. For the sake of avoiding +name collisions with client data and methods, these methods and fields +are briefly discussed here. Determined hackers may obtain further +information about them by reading the B<Pod::Select> source code. + +Private data fields are stored in the hash-object whose reference is +returned by the B<new()> constructor for this class. The names of all +private methods and data-fields used by B<Pod::Select> begin with a +prefix of "_" and match the regular expression C</^_\w+$/>. + +=cut + +##--------------------------------------------------------------------------- + +=begin _PRIVATE_ + +=head1 B<_compile_section_spec()> + + $listref = $parser->_compile_section_spec($section_spec); + +This function (note it is a function and I<not> a method) takes a +section specification (as described in L<"SECTION SPECIFICATIONS">) +given in C<$section_sepc>, and compiles it into a list of regular +expressions. If C<$section_spec> has no syntax errors, then a reference +to the list (array) of corresponding regular expressions is returned; +otherwise C<undef> is returned and an error message is printed (using +B<carp>) for each invalid regex. + +=end _PRIVATE_ + +=cut + +sub _compile_section_spec { + my ($section_spec) = @_; + my (@regexs, $negated); + + ## Compile the spec into a list of regexs + local $_ = $section_spec; + s|\\\\|\001|g; ## handle escaped backward slashes + s|\\/|\002|g; ## handle escaped forward slashes + + ## Parse the regexs for the heading titles + @regexs = split('/', $_, $MAX_HEADING_LEVEL); + + ## Set default regex for ommitted levels + for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { + $regexs[$i] = '.*' unless ((defined $regexs[$i]) + && (length $regexs[$i])); + } + ## Modify the regexs as needed and validate their syntax + my $bad_regexs = 0; + for (@regexs) { + $_ .= '.+' if ($_ eq '!'); + s|\001|\\\\|g; ## restore escaped backward slashes + s|\002|\\/|g; ## restore escaped forward slashes + $negated = s/^\!//; ## check for negation + eval "/$_/"; ## check regex syntax + if ($@) { + ++$bad_regexs; + carp "Bad regular expression /$_/ in \"$section_spec\": $@\n"; + } + else { + ## Add the forward and rear anchors (and put the negator back) + $_ = '^' . $_ unless (/^\^/); + $_ = $_ . '$' unless (/\$$/); + $_ = '!' . $_ if ($negated); + } + } + return (! $bad_regexs) ? [ @regexs ] : undef; +} + +##--------------------------------------------------------------------------- + +=begin _PRIVATE_ + +=head2 $self->{_SECTION_HEADINGS} + +A reference to an array of the current section heading titles for each +heading level (note that the first heading level title is at index 0). + +=end _PRIVATE_ + +=cut + +##--------------------------------------------------------------------------- + +=begin _PRIVATE_ + +=head2 $self->{_SELECTED_SECTIONS} + +A reference to an array of references to arrays. Each subarray is a list +of anchored regular expressions (preceded by a "!" if the expression is to +be negated). The index of the expression in the subarray should correspond +to the index of the heading title in C<$self-E<gt>{_SECTION_HEADINGS}> +that it is to be matched against. + +=end _PRIVATE_ + +=cut + +############################################################################# + +=head1 SEE ALSO + +L<Pod::Parser> + +=head1 AUTHOR + +Brad Appleton E<lt>bradapp@enteract.comE<gt> + +Based on code for B<pod2text> written by +Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> + +=cut + +1; + diff --git a/lib/Pod/Usage.pm b/lib/Pod/Usage.pm new file mode 100644 index 0000000000..855dbf0624 --- /dev/null +++ b/lib/Pod/Usage.pm @@ -0,0 +1,502 @@ +############################################################################# +# Pod/Usage.pm -- print usage messages for the running script. +# +# Based on Tom Christiansen's Pod::Text::pod2text() function +# (with modifications). +# +# Copyright (C) 1994-1999 Tom Christiansen. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::Usage; + +use vars qw($VERSION); +$VERSION = 1.08; ## Current version of this package +require 5.004; ## requires this Perl version or later + +=head1 NAME + +Pod::Usage, pod2usage() - print a usage message from embedded pod documentation + +=head1 SYNOPSIS + + use Pod::Usage + + my $message_text = "This text precedes the usage message."; + my $exit_status = 2; ## The exit status to use + my $verbose_level = 0; ## The verbose level to use + my $filehandle = \*STDERR; ## The filehandle to write to + + pod2usage($message_text); + + pod2usage($exit_status); + + pod2usage( { -message => $message_text , + -exitval => $exit_status , + -verbose => $verbose_level, + -output => $filehandle } ); + + pod2usage( -msg => $message_text , + -exitval => $exit_status , + -verbose => $verbose_level, + -output => $filehandle ); + +=head1 ARGUMENTS + +B<pod2usage> should be given either a single argument, or a list of +arguments corresponding to an associative array (a "hash"). When a single +argument is given, it should correspond to exactly one of the following: + +=over + +=item * + +A string containing the text of a message to print I<before> printing +the usage message + +=item * + +A numeric value corresponding to the desired exit status + +=item * + +A reference to a hash + +=back + +If more than one argument is given then the entire argument list is +assumed to be a hash. If a hash is supplied (either as a reference or +as a list) it should contain one or more elements with the following +keys: + +=over + +=item C<-message> + +=item C<-msg> + +The text of a message to print immediately prior to printing the +program's usage message. + +=item C<-exitval> + +The desired exit status to pass to the B<exit()> function. + +=item C<-verbose> + +The desired level of "verboseness" to use when printing the usage +message. If the corresponding value is 0, then only the "SYNOPSIS" +section of the pod documentation is printed. If the corresponding value +is 1, then the "SYNOPSIS" section, along with any section entitled +"OPTIONS", "ARGUMENTS", or "OPTIONS AND ARGUMENTS" is printed. If the +corresponding value is 2 or more then the entire manpage is printed. + +=item C<-output> + +A reference to a filehandle, or the pathname of a file to which the +usage message should be written. The default is C<\*STDERR> unless the +exit value is less than 2 (in which case the default is C<\*STDOUT>). + +=item C<-input> + +A reference to a filehandle, or the pathname of a file from which the +invoking script's pod documentation should be read. It defaults to the +file indicated by C<$0> (C<$PROGRAM_NAME> for users of F<English.pm>). + +=item C<-pathlist> + +A list of directory paths. If the input file does not exist, then it +will be searched for in the given directory list (in the order the +directories appear in the list). It defaults to the list of directories +implied by C<$ENV{PATH}>. The list may be specified either by a reference +to an array, or by a string of directory paths which use the same path +separator as C<$ENV{PATH}> on your system (e.g., C<:> for Unix, C<;> for +MSWin32 and DOS). + +=back + +=head1 DESCRIPTION + +B<pod2usage> will print a usage message for the invoking script (using +its embedded pod documentation) and then exit the script with the +desired exit status. The usage message printed may have any one of three +levels of "verboseness": If the verbose level is 0, then only a synopsis +is printed. If the verbose level is 1, then the synopsis is printed +along with a description (if present) of the command line options and +arguments. If the verbose level is 2, then the entire manual page is +printed. + +Unless they are explicitly specified, the default values for the exit +status, verbose level, and output stream to use are determined as +follows: + +=over + +=item * + +If neither the exit status nor the verbose level is specified, then the +default is to use an exit status of 2 with a verbose level of 0. + +=item * + +If an exit status I<is> specified but the verbose level is I<not>, then the +verbose level will default to 1 if the exit status is less than 2 and +will default to 0 otherwise. + +=item * + +If an exit status is I<not> specified but verbose level I<is> given, then +the exit status will default to 2 if the verbose level is 0 and will +default to 1 otherwise. + +=item * + +If the exit status used is less than 2, then output is printed on +C<STDOUT>. Otherwise output is printed on C<STDERR>. + +=back + +Although the above may seem a bit confusing at first, it generally does +"the right thing" in most situations. This determination of the default +values to use is based upon the following typical Unix conventions: + +=over + +=item * + +An exit status of 0 implies "success". For example, B<diff(1)> exits +with a status of 0 if the two files have the same contents. + +=item * + +An exit status of 1 implies possibly abnormal, but non-defective, program +termination. For example, B<grep(1)> exits with a status of 1 if +it did I<not> find a matching line for the given regular expression. + +=item * + +An exit status of 2 or more implies a fatal error. For example, B<ls(1)> +exits with a status of 2 if you specify an illegal (unknown) option on +the command line. + +=item * + +Usage messages issued as a result of bad command-line syntax should go +to C<STDERR>. However, usage messages issued due to an explicit request +to print usage (like specifying B<-help> on the command line) should go +to C<STDOUT>, just in case the user wants to pipe the output to a pager +(such as B<more(1)>). + +=item * + +If program usage has been explicitly requested by the user, it is often +desireable to exit with a status of 1 (as opposed to 0) after issuing +the user-requested usage message. It is also desireable to give a +more verbose description of program usage in this case. + +=back + +B<pod2usage> doesn't force the above conventions upon you, but it will +use them by default if you don't expressly tell it to do otherwise. The +ability of B<pod2usage()> to accept a single number or a string makes it +convenient to use as an innocent looking error message handling function: + + use Pod::Usage; + use Getopt::Long; + + ## Parse options + GetOptions("help", "man", "flag1") || pod2usage(2); + pod2usage(1) if ($opt_help); + pod2usage(-verbose => 2) if ($opt_man); + + ## Check for too many filenames + pod2usage("$0: Too many files given.\n") if (@ARGV > 1); + +Some user's however may feel that the above "economy of expression" is +not particularly readable nor consistent and may instead choose to do +something more like the following: + + use Pod::Usage; + use Getopt::Long; + + ## Parse options + GetOptions("help", "man", "flag1") || pod2usage(-verbose => 0); + pod2usage(-verbose => 1) if ($opt_help); + pod2usage(-verbose => 2) if ($opt_man); + + ## Check for too many filenames + pod2usage(-verbose => 2, -message => "$0: Too many files given.\n") + if (@ARGV > 1); + +As with all things in Perl, I<there's more than one way to do it>, and +B<pod2usage()> adheres to this philosophy. If you are interested in +seeing a number of different ways to invoke B<pod2usage> (although by no +means exhaustive), please refer to L<"EXAMPLES">. + +=head1 EXAMPLES + +Each of the following invocations of C<pod2usage()> will print just the +"SYNOPSIS" section to C<STDERR> and will exit with a status of 2: + + pod2usage(); + + pod2usage(2); + + pod2usage(-verbose => 0); + + pod2usage(-exitval => 2); + + pod2usage({-exitval => 2, -output => \*STDERR}); + + pod2usage({-verbose => 0, -output => \*STDERR}); + + pod2usage(-exitval => 2, -verbose => 0); + + pod2usage(-exitval => 2, -verbose => 0, -output => \*STDERR); + +Each of the following invocations of C<pod2usage()> will print a message +of "Syntax error." (followed by a newline) to C<STDERR>, immediately +followed by just the "SYNOPSIS" section (also printed to C<STDERR>) and +will exit with a status of 2: + + pod2usage("Syntax error."); + + pod2usage(-message => "Syntax error.", -verbose => 0); + + pod2usage(-msg => "Syntax error.", -exitval => 2); + + pod2usage({-msg => "Syntax error.", -exitval => 2, -output => \*STDERR}); + + pod2usage({-msg => "Syntax error.", -verbose => 0, -output => \*STDERR}); + + pod2usage(-msg => "Syntax error.", -exitval => 2, -verbose => 0); + + pod2usage(-message => "Syntax error.", + -exitval => 2, + -verbose => 0, + -output => \*STDERR); + +Each of the following invocations of C<pod2usage()> will print the +"SYNOPSIS" section and any "OPTIONS" and/or "ARGUMENTS" sections to +C<STDOUT> and will exit with a status of 1: + + pod2usage(1); + + pod2usage(-verbose => 1); + + pod2usage(-exitval => 1); + + pod2usage({-exitval => 1, -output => \*STDOUT}); + + pod2usage({-verbose => 1, -output => \*STDOUT}); + + pod2usage(-exitval => 1, -verbose => 1); + + pod2usage(-exitval => 1, -verbose => 1, -output => \*STDOUT}); + +Each of the following invocations of C<pod2usage()> will print the +entire manual page to C<STDOUT> and will exit with a status of 1: + + pod2usage(-verbose => 2); + + pod2usage({-verbose => 2, -output => \*STDOUT}); + + pod2usage(-exitval => 1, -verbose => 2); + + pod2usage({-exitval => 1, -verbose => 2, -output => \*STDOUT}); + +=head2 Recommended Use + +Most scripts should print some type of usage message to C<STDERR> when a +command line syntax error is detected. They should also provide an +option (usually C<-H> or C<-help>) to print a (possibly more verbose) +usage message to C<STDOUT>. Some scripts may even wish to go so far as to +provide a means of printing their complete documentation to C<STDOUT> +(perhaps by allowing a C<-man> option). The following example uses +B<Pod::Usage> in combination with B<Getopt::Long> to do all of these +things: + + use Getopt::Long; + use Pod::Usage; + + ## Parse options and print usage if there is a syntax error, + ## or if usage was explicitly requested. + GetOptions("help", "man", "flag1") || pod2usage(2); + pod2usage(1) if ($opt_help); + pod2usage(-verbose => 2) if ($opt_man); + + ## If no arguments were given, then allow STDIN to be used only + ## if it's not connected to a terminal (otherwise print usage) + pod2usage("$0: No files given.") if ((@ARGV == 0) && (-t STDIN)); + +=head1 CAVEATS + +By default, B<pod2usage()> will use C<$0> as the path to the pod input +file. Unfortunately, not all systems on which Perl runs will set C<$0> +properly (although if C<$0> isn't found, B<pod2usage()> will search +C<$ENV{PATH}> or else the list specified by the C<-pathlist> option). +If this is the case for your system, you may need to explicitly specify +the path to the pod docs for the invoking script using something +similar to the following: + + pod2usage(-exitval => 2, -input => "/path/to/your/pod/docs"); + +=head1 AUTHOR + +Brad Appleton E<lt>bradapp@enteract.comE<gt> + +Based on code for B<Pod::Text::pod2text()> written by +Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> + +=head1 ACKNOWLEDGEMENTS + +Steven McDougall E<lt>swmcd@world.std.comE<gt> for his help and patience +with re-writing this manpage. + +=cut + +############################################################################# + +use strict; +#use diagnostics; +use Carp; +use Exporter; +use Pod::PlainText; +use File::Spec; + +use vars qw(@ISA @EXPORT); +@ISA = qw(Pod::PlainText); +@EXPORT = qw(&pod2usage); + +##--------------------------------------------------------------------------- + +##--------------------------------- +## Function definitions begin here +##--------------------------------- + +sub pod2usage { + local($_) = shift || ""; + my %opts; + ## Collect arguments + if (@_ > 0) { + ## Too many arguments - assume that this is a hash and + ## the user forgot to pass a reference to it. + %opts = ($_, @_); + } + elsif (ref $_) { + ## User passed a ref to a hash + %opts = %{$_} if (ref($_) eq 'HASH'); + } + elsif (/^[-+]?\d+$/o) { + ## User passed in the exit value to use + $opts{"-exitval"} = $_; + } + else { + ## User passed in a message to print before issuing usage. + $_ and $opts{"-message"} = $_; + } + + ## Need this for backward compatibility since we formerly used + ## options that were all uppercase words rather than ones that + ## looked like Unix command-line options. + ## to be uppercase keywords) + %opts = map { + my $val = $opts{$_}; + s/^(?=\w)/-/; + /^-msg/i and $_ = '-message'; + /^-exit/i and $_ = '-exitval'; + lc($_) => $val; + } (keys %opts); + + ## Now determine default -exitval and -verbose values to use + if ((! defined $opts{"-exitval"}) && (! defined $opts{"-verbose"})) { + $opts{"-exitval"} = 2; + $opts{"-verbose"} = 0; + } + elsif (! defined $opts{"-exitval"}) { + $opts{"-exitval"} = ($opts{"-verbose"} > 0) ? 1 : 2; + } + elsif (! defined $opts{"-verbose"}) { + $opts{"-verbose"} = ($opts{"-exitval"} < 2); + } + + ## Default the output file + $opts{"-output"} = ($opts{"-exitval"} < 2) ? \*STDOUT : \*STDERR + unless (defined $opts{"-output"}); + ## Default the input file + $opts{"-input"} = $0 unless (defined $opts{"-input"}); + + ## Look up input file in path if it doesnt exist. + unless ((ref $opts{"-input"}) || (-e $opts{"-input"})) { + my ($dirname, $basename) = ('', $opts{"-input"}); + my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/) ? ";" + : (($^O eq 'MacOS') ? ',' : ":"); + my $pathspec = $opts{"-pathlist"} || $ENV{PATH} || $ENV{PERL5LIB}; + + my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec); + for $dirname (@paths) { + $_ = File::Spec->catfile($dirname, $basename) if length; + last if (-e $_) && ($opts{"-input"} = $_); + } + } + + ## Now create a pod reader and constrain it to the desired sections. + my $parser = new Pod::Usage(USAGE_OPTIONS => \%opts); + if ($opts{"-verbose"} == 0) { + $parser->select("SYNOPSIS"); + } + elsif ($opts{"-verbose"} == 1) { + my $opt_re = '(?i)' . + '(?:OPTIONS|ARGUMENTS)' . + '(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?'; + $parser->select( 'SYNOPSIS', $opt_re, "DESCRIPTION/$opt_re" ); + } + + ## Now translate the pod document and then exit with the desired status + $parser->parse_from_file($opts{"-input"}, $opts{"-output"}); + exit($opts{"-exitval"}); +} + +##--------------------------------------------------------------------------- + +##------------------------------- +## Method definitions begin here +##------------------------------- + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my %params = @_; + my $self = {%params}; + bless $self, $class; + $self->initialize(); + return $self; +} + +sub begin_pod { + my $self = shift; + $self->SUPER::begin_pod(); ## Have to call superclass + my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1; + my $out_fh = $self->output_handle(); + print $out_fh "$msg\n"; +} + +sub preprocess_paragraph { + my $self = shift; + local $_ = shift; + my $line = shift; + ## See if this is a heading and we arent printing the entire manpage. + if (($self->{USAGE_OPTIONS}->{-verbose} < 2) && /^=head/o) { + ## Change the title of the SYNOPSIS section to USAGE + s/^=head1\s+SYNOPSIS\s*$/=head1 USAGE/o; + ## Try to do some lowercasing instead of all-caps in headings + s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge; + ## Use a colon to end all headings + s/\s*$/:/o unless (/:\s*$/o); + $_ .= "\n"; + } + return $self->SUPER::preprocess_paragraph($_); +} + diff --git a/lib/Time/Local.pm b/lib/Time/Local.pm index 2534028816..75bcc38eea 100644 --- a/lib/Time/Local.pm +++ b/lib/Time/Local.pm @@ -149,7 +149,7 @@ values, the following conventions are followed: Years greater than 999 are interpreted as being the actual year, rather than the offset from 1900. Thus, 1963 would indicate the year -of Martin Luther King's assassination, not the year 2863. +Martin Luther King won the Nobel prize, not the year 2863. =item * @@ -170,6 +170,7 @@ two digit dates. Whenever possible, use an absolute four digit year instead. The scheme above allows interpretation of a wide range of dates, particularly if 4-digit years are used. + Please note, however, that the range of dates that can be actually be handled depends on the size of an integer (time_t) on a given platform. Currently, this is 32 bits for most systems, yielding an approximate range diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 4d05e6d930..18196278d9 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -1051,7 +1051,7 @@ EOP pop(@hist) if length($cmd) > 1; $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist); $cmd = $hist[$i]; - print $OUT $cmd; + print $OUT $cmd, "\n"; redo CMD; }; $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do { &system($1); @@ -1067,7 +1067,7 @@ EOP next CMD; } $cmd = $hist[$i]; - print $OUT $cmd; + print $OUT $cmd, "\n"; redo CMD; }; $cmd =~ /^$sh$/ && do { &system($ENV{SHELL}||"/bin/sh"); diff --git a/pod/Makefile b/pod/Makefile index 77a181ea59..f70c11b173 100644 --- a/pod/Makefile +++ b/pod/Makefile @@ -1,4 +1,5 @@ -CONVERTERS = pod2html pod2latex pod2man pod2text checkpods +CONVERTERS = pod2html pod2latex pod2man pod2text checkpods \ + pod2usage podchecker podselect HTMLROOT = / # Change this to fix cross-references in HTML POD2HTML = pod2html \ @@ -308,6 +309,15 @@ pod2text: pod2text.PL ../lib/Config.pm checkpods: checkpods.PL ../lib/Config.pm $(PERL) -I ../lib checkpods.PL +pod2usage: pod2usage.PL ../lib/Config.pm + $(PERL) -I ../lib pod2usage.PL + +podchecker: podchecker.PL ../lib/Config.pm + $(PERL) -I ../lib podchecker.PL + +podselect: podselect.PL ../lib/Config.pm + $(PERL) -I ../lib podselect.PL + compile: all $(REALPERL) -I../lib ../utils/perlcc -regex 's/$$/.exe/' pod2latex pod2man pod2text checkpods -prog -verbose dcf -log ../compilelog; diff --git a/pod/perldelta.pod b/pod/perldelta.pod index e017fedcee..79a139b725 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -307,6 +307,11 @@ Benchmark: running a, b, each for at least 5 CPU seconds... New features: "each for at least N CPU seconds...", "wallclock secs", and the "@ operations/CPU second (n=operations)". +=item Devel::Peek + +The Devel::Peek module provides access to the internal representation +of Perl variables. It is a data debugging tool for the XS programmer. + =item Fcntl More Fcntl constants added: F_SETLK64, F_SETLKW64, O_LARGEFILE for @@ -315,6 +320,27 @@ working, though, so no need to get overly excited), Free/Net/OpenBSD locking behaviour flags F_FLOCK, F_POSIX, Linux F_SHLCK, and O_ACCMODE: the mask of O_RDONLY, O_WRONLY, and O_RDWR. +=item File::Spec + +New methods have been added to the File::Spec module: devnull() returns +the name of the null device (/dev/null on UNIX) and tmpdir() the name of +the temp directory (normally /tmp on UNIX). There are now also methods +to convert between absolute and relative filenames: abs2rel() and +rel2abs(). For compatibility with operating systems that specify volume +names in file paths, the splitpath(), splitdir() and catdir() methods +have been added. + +=item File::Spec::Functions + +The new File::Spec::Functions modules provides a function interface +to the File::Spec module. Allows shorthand + + $fullname = catfile($dir1, $dir2, $file); + +instead of + + $fullname = File::Spec->catfile($dir1, $dir2, $file); + =item Math::Complex The accessor methods Re, Im, arg, abs, rho, and theta, can now also @@ -331,6 +357,28 @@ The timelocal() and timegm() functions used to silently return bogus results when the date exceeded the machine's integer range. They consistently croak() if the date falls in an unsupported range. +=item Win32 + +The error return value in list context has been changed for all functions +that return a list of values. Previously these functions returned a list +with a single element C<undef> in case an error occurred. Now these functions +return the empty list in these situations. This applies to the following +functions: + + Win32::FsType + Win32::GetOSVersion + +The remaining functions are unchanged and continue to return C<undef> on +error even in list context. + +The Win32::SetLastError(ERROR) function has been added as a complement +to the Win32::GetLastError() function. + +The new Win32::GetFullPathName(FILENAME) returns the full absolute +pathname for FILENAME in scalar context. In list context it returns +a two element list containing the fully qualified directory name and +the filename. + =back =head2 Pragmata diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 81099d39f0..fb6d139e2b 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -1378,16 +1378,25 @@ logic, or you need to put a conditional in to guard against meaningless input. (F) You tried to divide a number by 0 to get the remainder. Most numbers don't take to this kindly. -=item Illegal octal digit +=item Illegal binary digit %s + +(F) You used a digit other than 0 and 1 in a binary number. + +=item Illegal octal digit %s (F) You used an 8 or 9 in a octal number. -=item Illegal octal digit ignored +=item Illegal binary digit %s ignored + +(W) You may have tried to use a digit other than 0 or 1 in a binary number. +Interpretation of the binary number stopped before the offending digit. + +=item Illegal octal digit %s ignored (W) You may have tried to use an 8 or 9 in a octal number. Interpretation of the octal number stopped before the 8 or 9. -=item Illegal hex digit ignored +=item Illegal hex digit %s ignored (W) You may have tried to use a character other than 0 - 9 or A - F in a hexadecimal number. Interpretation of the hexadecimal number stopped diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index b8580eddd4..c973d0c367 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -965,6 +965,27 @@ This is useful for propagating exceptions: If C<$@> is empty then the string C<"Died"> is used. +die() can also be called with a reference argument. If this happens to be +trapped within an eval(), $@ contains the reference. This behavior permits +a more elaborate exception handling implementation using objects that +maintain arbitary state about the nature of the exception. Such a scheme +is sometimes preferable to matching particular string values of $@ using +regular expressions. Here's an example: + + eval { ... ; die Some::Module::Exception->new( FOO => "bar" ) }; + if ($@) { + if (ref($@) && UNIVERSAL::isa($@,"Some::Module::Exception")) { + # handle Some::Module::Exception + } + else { + # handle all other possible exceptions + } + } + +Since perl will stringify uncaught exception messages before displaying +them, you may want to overload stringification operations on such custom +exception objects. See L<overload> for details about that. + You can arrange for a callback to be run just before the C<die()> does its deed, by setting the C<$SIG{__DIE__}> hook. The associated handler will be called with the error text and can change the error message, if @@ -2223,6 +2244,8 @@ element) and returns the list value composed of the results of each such evaluation. Evaluates BLOCK or EXPR in a list context, so each element of LIST may produce zero, one, or more elements in the returned value. +In scalar context, returns the total number of elements so generated. + @chars = map(chr, @nums); translates a list of numbers to the corresponding characters. And @@ -3038,7 +3061,7 @@ This is the internal function implementing the C<qx/EXPR/> operator, but you can use it directly. The C<qx/EXPR/> operator is discussed in more detail in L<perlop/"I/O Operators">. -=item recv SOCKET,SCALAR,LEN,FLAGS +=item recv SOCKET,SCALAR,LENGTH,FLAGS Receives a message on a socket. Attempts to receive LENGTH bytes of data into variable SCALAR from the specified SOCKET filehandle. diff --git a/pod/perlmodlib.pod b/pod/perlmodlib.pod index 6295d97359..2dc38dfd80 100644 --- a/pod/perlmodlib.pod +++ b/pod/perlmodlib.pod @@ -161,6 +161,10 @@ get pathname of current working directory access to Berkeley DB +=item Devel::Peek + +data debugging tool for the XS programmer + =item Devel::SelfStubber generate stubs for a SelfLoading module @@ -261,6 +265,14 @@ traverse a file tree create or remove a series of directories +=item File::Spec + +portably perform operations on file names + +=item File::Spec::Functions + +function call interface to File::Spec module + =item File::stat by-name interface to Perl's builtin stat() functions diff --git a/pod/perlop.pod b/pod/perlop.pod index 313ed583a5..f70311b8e1 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -830,10 +830,12 @@ Examples: ($one,$five,$fifteen) = (`uptime` =~ /(\d+\.\d+)/g); # scalar context - $/ = ""; $* = 1; # $* deprecated in modern perls - while (defined($paragraph = <>)) { - while ($paragraph =~ /[a-z]['")]*[.!?]+['")]*\s/g) { - $sentences++; + { + local $/ = ""; + while (defined($paragraph = <>)) { + while ($paragraph =~ /[a-z]['")]*[.!?]+['")]*\s/g) { + $sentences++; + } } } print "$sentences\n"; diff --git a/pod/pod2usage.PL b/pod/pod2usage.PL new file mode 100644 index 0000000000..fdaa955c69 --- /dev/null +++ b/pod/pod2usage.PL @@ -0,0 +1,179 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{'startperl'} + eval 'exec perl -S \$0 "\$@"' + if 0; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; + +############################################################################# +# pod2usage -- command to print usage messages from embedded pod docs +# +# Derived from Tom Christiansen's pod2text script. +# (with extensive modifications) +# +# Copyright (c) 1996 Bradford Appleton. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +use strict; +use diagnostics; + +=head1 NAME + +pod2usage - print usage messages from embedded pod docs in files + +=head1 SYNOPSIS + +=over 12 + +=item B<pod2usage> + +[B<-help>] +[B<-man>] +[B<-exit>S< >I<exitval>] +[B<-output>S< >I<outfile>] +[B<-verbose> I<level>] +[B<-pathlist> I<dirlist>] +I<file> + +=back + +=head1 OPTIONS AND ARGUMENTS + +=over 8 + +=item B<-help> + +Print a brief help message and exit. + +=item B<-man> + +Print this command's manual page and exit. + +=item B<-exit> I<exitval> + +The exit status value to return. + +=item B<-output> I<outfile> + +The output file to print to. If the special names "-" or ">&1" or ">&STDOUT" +are used then standard output is used. If ">&2" or ">&STDERR" is used then +standard error is used. + +=item B<-verbose> I<level> + +The desired level of verbosity to use: + + 1 : print SYNOPSIS only + 2 : print SYNOPSIS sections and any OPTIONS/ARGUMENTS sections + 3 : print the entire manpage (similar to running pod2text) + +=item B<-pathlist> I<dirlist> + +Specifies one or more directories to search for the input file if it +was not supplied with an absolute path. Each directory path in the given +list should be separated by a ':' on Unix (';' on MSWin32 and DOS). + +=item I<file> + +The pathname of a file containing pod documentation to be output in +usage mesage format (defaults to standard input). + +=back + +=head1 DESCRIPTION + +B<pod2usage> will read the given input file looking for pod +documentation and will print the corresponding usage message. +If no input file is specifed than standard input is read. + +B<pod2usage> invokes the B<pod2usage()> function in the B<Pod::Usage> +module. Please see L<Pod::Usage/pod2usage()>. + +=head1 SEE ALSO + +L<Pod::Usage>, L<pod2text(1)> + +=head1 AUTHOR + +Brad Appleton E<lt>bradapp@enteract.comE<gt> + +Based on code for B<pod2text(1)> written by +Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> + +=cut + +use Pod::Usage; +use Getopt::Long; + +## Define options +my %options = (); +my @opt_specs = ( + "help", + "man", + "exit=i", + "output=s", + "pathlist=s", + "verbose=i", +); + +## Parse options +GetOptions(\%options, @opt_specs) || pod2usage(2); +pod2usage(1) if ($options{help}); +pod2usage(VERBOSE => 2) if ($options{man}); + +## Dont default to STDIN if connected to a terminal +pod2usage(2) if ((@ARGV == 0) && (-t STDIN)); + +@ARGV = ("-") unless (@ARGV > 0); +if (@ARGV > 1) { + print STDERR "pod2usage: Too many filenames given\n\n"; + pod2usage(2); +} + +my %usage = (); +$usage{-input} = shift(@ARGV); +$usage{-exitval} = $options{"exit"} if (defined $options{"exit"}); +$usage{-output} = $options{"output"} if (defined $options{"output"}); +$usage{-verbose} = $options{"verbose"} if (defined $options{"verbose"}); +$usage{-pathlist} = $options{"pathlist"} if (defined $options{"pathlist"}); + +pod2usage(\%usage); + + +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/pod/podchecker.PL b/pod/podchecker.PL new file mode 100644 index 0000000000..1ca0d79eda --- /dev/null +++ b/pod/podchecker.PL @@ -0,0 +1,130 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{'startperl'} + eval 'exec perl -S \$0 "\$@"' + if 0; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; +############################################################################# +# podchecker -- command to invoke the podchecker function in Pod::Checker +# +# Derived from Tom Christiansen's pod2text script. +# (with extensive modifications) +# +# Copyright (c) 1998 Bradford Appleton. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +use strict; +use diagnostics; + +=head1 NAME + +podchecker - check the syntax of POD format documentation files + +=head1 SYNOPSIS + +B<podchecker> [B<-help>] [B<-man>] [I<file>S< >...] + +=head1 OPTIONS AND ARGUMENTS + +=over 8 + +=item B<-help> + +Print a brief help message and exit. + +=item B<-man> + +Print the manual page and exit. + +=item I<file> + +The pathname of a POD file to syntax-check (defaults to standard input). + +=back + +=head1 DESCRIPTION + +B<podchecker> will read the given input files looking for POD +syntax errors in the POD documentation and will print any errors +it find to STDERR. At the end, it will print a status message +indicating the number of errors found. + +B<podchecker> invokes the B<podchecker()> function exported by B<Pod::Checker> +Please see L<Pod::Checker/podchecker()> for more details. + +=head1 SEE ALSO + +L<Pod::Parser> and L<Pod::Checker> + +=head1 AUTHOR + +Brad Appleton E<lt>bradapp@enteract.comE<gt> + +Based on code for B<Pod::Text::pod2text(1)> written by +Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> + +=cut + + +use Pod::Checker; +use Pod::Usage; +use Getopt::Long; + +## Define options +my %options = ( + "help" => 0, + "man" => 0, +); + +## Parse options +GetOptions(\%options, "help", "man") || pod2usage(2); +pod2usage(1) if ($options{help}); +pod2usage(-verbose => 2) if ($options{man}); + +## Dont default to STDIN if connected to a terminal +pod2usage(2) if ((@ARGV == 0) && (-t STDIN)); + +## Invoke podchecker() +if(@ARGV) { + for (@ARGV) { podchecker($_) }; +} else { + podchecker("<&STDIN"); +} + +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/pod/podselect.PL b/pod/podselect.PL new file mode 100644 index 0000000000..0df830406e --- /dev/null +++ b/pod/podselect.PL @@ -0,0 +1,142 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{'startperl'} + eval 'exec perl -S \$0 "\$@"' + if 0; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; + +############################################################################# +# podselect -- command to invoke the podselect function in Pod::Select +# +# Derived from Tom Christiansen's pod2text script. +# (with extensive modifications) +# +# Copyright (c) 1996 Bradford Appleton. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +use strict; +use diagnostics; + +=head1 NAME + +podselect - print selected sections of pod documentation on standard output + +=head1 SYNOPSIS + +B<podselect> [B<-help>] [B<-man>] [B<-section>S< >I<section-spec>] +[I<file>S< >...] + +=head1 OPTIONS AND ARGUMENTS + +=over 8 + +=item B<-help> + +Print a brief help message and exit. + +=item B<-man> + +Print the manual page and exit. + +=item B<-section>S< >I<section-spec> + +Specify a section to include in the output. +See L<Pod::Parser/"SECTION SPECIFICATIONS"> +for the format to use for I<section-spec>. +This option may be given multiple times on the command line. + +=item I<file> + +The pathname of a file from which to select sections of pod +documentation (defaults to standard input). + +=back + +=head1 DESCRIPTION + +B<podselect> will read the given input files looking for pod +documentation and will print out (in raw pod format) all sections that +match one ore more of the given section specifications. If no section +specifications are given than all pod sections encountered are output. + +B<podselect> invokes the B<podselect()> function exported by B<Pod::Select> +Please see L<Pod::Select/podselect()> for more details. + +=head1 SEE ALSO + +L<Pod::Parser> and L<Pod::Select> + +=head1 AUTHOR + +Brad Appleton E<lt>bradapp@enteract.comE<gt> + +Based on code for B<Pod::Text::pod2text(1)> written by +Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> + +=cut + +use Pod::Select; +use Pod::Usage; +use Getopt::Long; + +## Define options +my %options = ( + "help" => 0, + "man" => 0, + "sections" => [], +); + +## Parse options +GetOptions(\%options, "help", "man", "sections|select=s@") || pod2usage(2); +pod2usage(1) if ($options{help}); +pod2usage(-verbose => 2) if ($options{man}); + +## Dont default to STDIN if connected to a terminal +pod2usage(2) if ((@ARGV == 0) && (-t STDIN)); + +## Invoke podselect(). +if (@{ $options{"sections"} } > 0) { + podselect({ -sections => $options{"sections"} }, @ARGV); +} +else { + podselect(@ARGV); +} + + +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; @@ -2155,8 +2155,13 @@ PP(pp_entersub) if (SP > PL_stack_base + TOPMARK) sv = *(PL_stack_base + TOPMARK + 1); else { - MUTEX_UNLOCK(CvMUTEXP(cv)); - croak("no argument for locked method call"); + AV *av = (AV*)PL_curpad[0]; + if (hasargs || !av || AvFILLp(av) < 0 + || !(sv = AvARRAY(av)[0])) + { + MUTEX_UNLOCK(CvMUTEXP(cv)); + croak("no argument for locked method call"); + } } if (SvROK(sv)) sv = SvRV(sv); @@ -2498,7 +2498,7 @@ regclassutf8(void) e = strchr(PL_regcomp_parse++, '}'); if (!e) FAIL("Missing right brace on \\x{}"); - value = scan_hex(PL_regcomp_parse + 1, e - PL_regcomp_parse, &numlen); + value = scan_hex(PL_regcomp_parse, e - PL_regcomp_parse, &numlen); PL_regcomp_parse = e + 1; } else { diff --git a/t/comp/require.t b/t/comp/require.t index fc72c079b0..581dcba75c 100755 --- a/t/comp/require.t +++ b/t/comp/require.t @@ -45,7 +45,7 @@ do_require "1"; print "# $@\nnot " if $@; print "ok ",$i++,"\n"; -END { unlink 'bleah.pm'; } +END { 1 while unlink 'bleah.pm'; } # ***interaction with pod (don't put any thing after here)*** diff --git a/t/lib/filefunc.t b/t/lib/filefunc.t new file mode 100755 index 0000000000..46a1e35774 --- /dev/null +++ b/t/lib/filefunc.t @@ -0,0 +1,17 @@ +#!./perl + +BEGIN { + $^O = ''; + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +print "1..1\n"; + +use File::Spec::Functions; + +if (catfile('a','b','c') eq 'a/b/c') { + print "ok 1\n"; +} else { + print "not ok 1\n"; +} diff --git a/t/lib/io_udp.t b/t/lib/io_udp.t index 1434873125..435533f6c4 100755 --- a/t/lib/io_udp.t +++ b/t/lib/io_udp.t @@ -13,7 +13,7 @@ BEGIN { if(-d "lib" && -f "TEST") { if ( ($Config{'extensions'} !~ /\bSocket\b/ || $Config{'extensions'} !~ /\bIO\b/ || - $^O eq 'os2') && + ($^O eq 'os2') || $^O eq 'apollo') && !(($^O eq 'VMS') && $Config{d_socket})) { print "1..0\n"; exit 0; diff --git a/t/lib/posix.t b/t/lib/posix.t index 6f72a8ee6b..4c6aa49a05 100755 --- a/t/lib/posix.t +++ b/t/lib/posix.t @@ -97,5 +97,5 @@ print POSIX::strftime("ok 18 # %H:%M, on %D\n", localtime()); $| = 0; # The following line assumes buffered output, which may be not true with EMX: -print '@#!*$@(!@#$' unless ($^O eq 'os2' || $^O eq 'uwin'); +print '@#!*$@(!@#$' unless ($^O eq 'os2' || $^O eq 'uwin' || $^O eq 'os390'); _exit(0); diff --git a/t/lib/thread.t b/t/lib/thread.t index 8d385236cc..61997cfc8b 100755 --- a/t/lib/thread.t +++ b/t/lib/thread.t @@ -13,7 +13,7 @@ BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } $| = 1; -print "1..14\n"; +print "1..18\n"; use Thread; print "ok 1\n"; @@ -71,3 +71,17 @@ sub islocked $t = Thread->new(\&islocked, "ok 13\n", "ok 14\n"); $t->join->join; +{ + package Loch::Ness; + sub new { bless [], shift } + sub monster { + use attrs qw(locked method); + my($s, $m) = @_; + print "ok $m\n"; + } + sub gollum { &monster } +} +Loch::Ness->monster(15); +Loch::Ness->new->monster(16); +Loch::Ness->gollum(17); +Loch::Ness->new->gollum(18); diff --git a/t/op/lex_assign.t b/t/op/lex_assign.t index cf16a46904..b2acd65d75 100755 --- a/t/op/lex_assign.t +++ b/t/op/lex_assign.t @@ -7,11 +7,12 @@ BEGIN { umask 0; $xref = \ ""; +$runme = ($^O eq 'VMS' ? 'MCR ' : '') . $^X; @a = (1..5); %h = (1..6); $aref = \@a; $href = \%h; -open OP, qq{$^X -le "print 'aaa Ok ok' for 1..100"|}; +open OP, qq{$runme -le "print 'aaa Ok ok' for 1..100"|}; $chopit = 'aaaaaa'; @chopar = (113 .. 119); $posstr = '123456'; @@ -62,7 +63,7 @@ EOE __END__ ref $xref # ref ref $cstr # ref nonref -`ls` # backtick skip(MSWin32) +`$runme -e "print qq[1\n]"` # backtick skip(MSWin32) `$undefed` # backtick undef skip(MSWin32) <*> # glob <OP> # readline @@ -187,7 +188,7 @@ readlink 'non-existent', 'non-existent1' # readlink '???' # fork '???' # wait '???' # waitpid -system "$^X -e 0" # system +system "$runme -e 0" # system skip(VMS) '???' # exec '???' # kill getppid # getppid diff --git a/t/op/taint.t b/t/op/taint.t index e25d4e0ef0..d75bc1807a 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -35,7 +35,7 @@ if ($Is_VMS) { END { \$ENV{PATH} = ''; warn "# Note: logical name 'PATH' may have been deleted\n"; - @ENV{keys %old} = values %old; + \@ENV{keys %old} = values %old; } EndOfCleanup } diff --git a/t/pod/emptycmd.t b/t/pod/emptycmd.t new file mode 100755 index 0000000000..59e395ea04 --- /dev/null +++ b/t/pod/emptycmd.t @@ -0,0 +1,21 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + +__END__ + +=pod + += this is a test +of the emergency +broadcast system + +=cut diff --git a/t/pod/emptycmd.xr b/t/pod/emptycmd.xr new file mode 100644 index 0000000000..f06d2dbb09 --- /dev/null +++ b/t/pod/emptycmd.xr @@ -0,0 +1,2 @@ + = this is a test of the emergency broadcast system + diff --git a/t/pod/for.t b/t/pod/for.t new file mode 100755 index 0000000000..44af44f17d --- /dev/null +++ b/t/pod/for.t @@ -0,0 +1,59 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=pod + +This is a test + +=for theloveofpete +You shouldn't see this +or this +or this + +=for text +pod2text should see this +and this +and this + +and everything should see this! + +=begin text + +Similarly, this line ... + +and this one ... + +as well this one, + +should all be in pod2text output + +=end text + +Tweedley-deedley-dee, Im as happy as can be! +Tweedley-deedley-dum, cuz youre my honey sugar plum! + +=begin atthebeginning + +But I expect to see neither hide ... + +nor tail ... + +of this text + +=end atthebeginning + +The rest of this should show up in everything. + diff --git a/t/pod/for.xr b/t/pod/for.xr new file mode 100644 index 0000000000..25794ab0fe --- /dev/null +++ b/t/pod/for.xr @@ -0,0 +1,19 @@ + This is a test + + pod2text should see this and this and this + + and everything should see this! + + Similarly, this line ... + + and this one ... + + as well this one, + + should all be in pod2text output + + Tweedley-deedley-dee, Im as happy as can be! Tweedley-deedley- + dum, cuz youre my honey sugar plum! + + The rest of this should show up in everything. + diff --git a/t/pod/headings.t b/t/pod/headings.t new file mode 100755 index 0000000000..78608d0fd9 --- /dev/null +++ b/t/pod/headings.t @@ -0,0 +1,140 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +################################################################# + use Pod::Usage; + pod2usage( VERBOSE => 2, EXIT => 1 ); + +=pod + +=head1 NAME + +B<rdb2pg> - insert an rdb table into a PostgreSQL database + +=head1 SYNOPSIS + +B<rdb2pg> [I<param>=I<value> ...] + +=head1 PARAMETERS + +B<rdb2pg> uses an IRAF-compatible parameter interface. +A template parameter file is in F</proj/axaf/simul/lib/uparm/rdb2pg.par>. + +=over 4 + +=item B<input> I<file> + +The B<RDB> file to insert into the database. If the given name +is the string C<stdin>, it reads from the UNIX standard input stream. + + +=back + +=head1 DESCRIPTION + +B<rdb2pg> will enter the data from an B<RDB> database into a +PostgreSQL database table, optionally creating the database and the +table if they do not exist. It automatically determines the +PostgreSQL data type from the column definition in the B<RDB> file, +but may be overriden via a series of definition files or directly +via one of its parameters. + +The target database and table are specified by the C<db> and C<table> +parameters. If they do not exist, and the C<createdb> parameter is +set, they will be created. Table field definitions are determined +in the following order: + +=cut + +################################################################# + +results in: + + +################################################################# + + rdb2pg - insert an rdb table into a PostgreSQL database + + rdb2pg [*param*=*value* ...] + + rdb2pg uses an IRAF-compatible parameter interface. A template + parameter file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. + + The RDB file to insert into the database. If the given name is + the string `stdin', it reads from the UNIX standard input + stream. + + rdb2pg will enter the data from an RDB database into a + PostgreSQL database table, optionally creating the database and + the table if they do not exist. It automatically determines the + PostgreSQL data type from the column definition in the RDB file, + but may be overriden via a series of definition files or + directly via one of its parameters. + + The target database and table are specified by the `db' and + `table' parameters. If they do not exist, and the `createdb' + parameter is set, they will be created. Table field definitions + are determined in the following order: + + +################################################################# + +while the original version of Text (using pod2text) gives + +################################################################# + +NAME + rdb2pg - insert an rdb table into a PostgreSQL database + +SYNOPSIS + rdb2pg [*param*=*value* ...] + +PARAMETERS + rdb2pg uses an IRAF-compatible parameter interface. A template + parameter file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. + + input *file* + The RDB file to insert into the database. If the given name + is the string `stdin', it reads from the UNIX standard input + stream. + +DESCRIPTION + rdb2pg will enter the data from an RDB database into a + PostgreSQL database table, optionally creating the database and + the table if they do not exist. It automatically determines the + PostgreSQL data type from the column definition in the RDB file, + but may be overriden via a series of definition files or + directly via one of its parameters. + + The target database and table are specified by the `db' and + `table' parameters. If they do not exist, and the `createdb' + parameter is set, they will be created. Table field definitions + are determined in the following order: + + +################################################################# + + +Thanks for any help. If, as your email indicates, you've not much +time to look at this, I can work around things by calling pod2text() +directly using the official Text.pm. + +Diab + +------------- +Diab Jerius +djerius@cfa.harvard.edu + diff --git a/t/pod/headings.xr b/t/pod/headings.xr new file mode 100644 index 0000000000..e1277b7e37 --- /dev/null +++ b/t/pod/headings.xr @@ -0,0 +1,29 @@ +NAME + rdb2pg - insert an rdb table into a PostgreSQL database + +SYNOPSIS + rdb2pg [*param*=*value* ...] + +PARAMETERS + rdb2pg uses an IRAF-compatible parameter interface. A template + parameter file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. + + input *file* + The RDB file to insert into the database. If the given name + is the string `stdin', it reads from the UNIX standard input + stream. + + +DESCRIPTION + rdb2pg will enter the data from an RDB database into a + PostgreSQL database table, optionally creating the database and + the table if they do not exist. It automatically determines the + PostgreSQL data type from the column definition in the RDB file, + but may be overriden via a series of definition files or + directly via one of its parameters. + + The target database and table are specified by the `db' and + `table' parameters. If they do not exist, and the `createdb' + parameter is set, they will be created. Table field definitions + are determined in the following order: + diff --git a/t/pod/include.t b/t/pod/include.t new file mode 100755 index 0000000000..4e73b78356 --- /dev/null +++ b/t/pod/include.t @@ -0,0 +1,36 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=pod + +This file tries to demonstrate a simple =include directive +for pods. It is used as follows: + + =include filename + +where "filename" is expected to be an absolute pathname, or else +reside be relative to the directory in which the current processed +podfile resides, or be relative to the current directory. + +Lets try it out with the file "included.t" shall we. + +***THIS TEXT IS IMMEDIATELY BEFORE THE INCLUDE*** + +=include included.t + +***THIS TEXT IS IMMEDIATELY AFTER THE INCLUDE*** + +So how did we do??? diff --git a/t/pod/include.xr b/t/pod/include.xr new file mode 100644 index 0000000000..1bac06adb1 --- /dev/null +++ b/t/pod/include.xr @@ -0,0 +1,23 @@ + This file tries to demonstrate a simple =include directive for + pods. It is used as follows: + + =include filename + + where "filename" is expected to be an absolute pathname, or else + reside be relative to the directory in which the current + processed podfile resides, or be relative to the current + directory. + + Lets try it out with the file "included.t" shall we. + + ***THIS TEXT IS IMMEDIATELY BEFORE THE INCLUDE*** + +###### begin =include included.t ##### + This is the text of the included file named "included.t". It + should appear in the final pod document from pod2xxx + +###### end =include included.t ##### + ***THIS TEXT IS IMMEDIATELY AFTER THE INCLUDE*** + + So how did we do??? + diff --git a/t/pod/included.t b/t/pod/included.t new file mode 100755 index 0000000000..4f171c454b --- /dev/null +++ b/t/pod/included.t @@ -0,0 +1,35 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +##------------------------------------------------------------ +# This file is =included by "include.t" +# +# This text should NOT be in the resultant pod document +# because we havent seen an =xxx pod directive in this file! +##------------------------------------------------------------ + +=pod + +This is the text of the included file named "included.t". +It should appear in the final pod document from pod2xxx + +=cut + +##------------------------------------------------------------ +# This text should NOT be in the resultant pod document +# because it is *after* an =cut an no other pod directives +# proceed it! +##------------------------------------------------------------ diff --git a/t/pod/included.xr b/t/pod/included.xr new file mode 100644 index 0000000000..f0bc03bf09 --- /dev/null +++ b/t/pod/included.xr @@ -0,0 +1,3 @@ + This is the text of the included file named "included.t". It + should appear in the final pod document from pod2xxx + diff --git a/t/pod/lref.t b/t/pod/lref.t new file mode 100755 index 0000000000..02e2c9e307 --- /dev/null +++ b/t/pod/lref.t @@ -0,0 +1,66 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=pod + +Try out I<LOTS> of different ways of specifying references: + +Reference the L<manpage/section> + +Reference the L<manpage / section> + +Reference the L<manpage/ section> + +Reference the L<manpage /section> + +Reference the L<"manpage/section"> + +Reference the L<"manpage"/section> + +Reference the L<manpage/"section"> + +Reference the L<manpage/ +section> + +Reference the L<manpage +/section> + +Now try it using the new "|" stuff ... + +Reference the L<thistext|manpage/section> + +Reference the L<thistext | manpage / section> + +Reference the L<thistext| manpage/ section> + +Reference the L<thistext |manpage /section> + +Reference the L<thistext| +"manpage/section"> + +Reference the L<thistext +|"manpage"/section> + +Reference the L<thistext|manpage/"section"> + +Reference the L<thistext| +manpage/ +section> + +Reference the L<thistext +|manpage +/section> + diff --git a/t/pod/lref.xr b/t/pod/lref.xr new file mode 100644 index 0000000000..d8455e3874 --- /dev/null +++ b/t/pod/lref.xr @@ -0,0 +1,40 @@ + Try out *LOTS* of different ways of specifying references: + + Reference the the "section" entry in the manpage manpage + + Reference the the "section" entry in the manpage manpage + + Reference the the "section" entry in the manpage manpage + + Reference the the "section" entry in the manpage manpage + + Reference the the section on "manpage/section" + + Reference the the "section" entry in the "manpage" manpage + + Reference the the section on "section" in the manpage manpage + + Reference the the "section" entry in the manpage manpage + + Reference the the "section" entry in the manpage manpage + + Now try it using the new "|" stuff ... + + Reference the thistext + + Reference the thistext + + Reference the thistext + + Reference the thistext + + Reference the thistext + + Reference the thistext + + Reference the thistext + + Reference the thistext + + Reference the thistext + diff --git a/t/pod/nested_items.t b/t/pod/nested_items.t new file mode 100755 index 0000000000..c8e9b22427 --- /dev/null +++ b/t/pod/nested_items.t @@ -0,0 +1,64 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=head1 Test nested item lists + +This is a test to ensure the nested =item paragraphs +get indented appropriately. + +=over 2 + +=item 1 + +First section. + +=over 2 + +=item a + +this is item a + +=item b + +this is item b + +=back + +=item 2 + +Second section. + +=over 2 + +=item a + +this is item a + +=item b + +this is item b + +=item c + +=item d + +This is item c & d. + +=back + +=back + +=cut diff --git a/t/pod/nested_items.xr b/t/pod/nested_items.xr new file mode 100644 index 0000000000..7d72bbe890 --- /dev/null +++ b/t/pod/nested_items.xr @@ -0,0 +1,19 @@ +Test nested item lists + This is a test to ensure the nested =item paragraphs get + indented appropriately. + + 1 First section. + + a this is item a + + b this is item b + + 2 Second section. + + a this is item a + + b this is item b + + c + d This is item c & d. + diff --git a/t/pod/nested_seqs.t b/t/pod/nested_seqs.t new file mode 100755 index 0000000000..8559f1f25f --- /dev/null +++ b/t/pod/nested_seqs.t @@ -0,0 +1,23 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=pod + +The statement: C<This is dog kind's I<finest> hour!> is a parody of a +quotation from Winston Churchill. + +=cut + diff --git a/t/pod/nested_seqs.xr b/t/pod/nested_seqs.xr new file mode 100644 index 0000000000..5a008c17e9 --- /dev/null +++ b/t/pod/nested_seqs.xr @@ -0,0 +1,3 @@ + The statement: `This is dog kind's *finest* hour!' is a parody + of a quotation from Winston Churchill. + diff --git a/t/pod/oneline_cmds.t b/t/pod/oneline_cmds.t new file mode 100755 index 0000000000..28bd1d09e5 --- /dev/null +++ b/t/pod/oneline_cmds.t @@ -0,0 +1,46 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +==head1 NAME +B<rdb2pg> - insert an rdb table into a PostgreSQL database + +==head1 SYNOPSIS +B<rdb2pg> [I<param>=I<value> ...] + +==head1 PARAMETERS +B<rdb2pg> uses an IRAF-compatible parameter interface. +A template parameter file is in F</proj/axaf/simul/lib/uparm/rdb2pg.par>. + +==over 4 +==item B<input> I<file> +The B<RDB> file to insert into the database. If the given name +is the string C<stdin>, it reads from the UNIX standard input stream. + +==back + +==head1 DESCRIPTION +B<rdb2pg> will enter the data from an B<RDB> database into a +PostgreSQL database table, optionally creating the database and the +table if they do not exist. It automatically determines the +PostgreSQL data type from the column definition in the B<RDB> file, +but may be overriden via a series of definition files or directly +via one of its parameters. + +The target database and table are specified by the C<db> and C<table> +parameters. If they do not exist, and the C<createdb> parameter is +set, they will be created. Table field definitions are determined +in the following order: + diff --git a/t/pod/oneline_cmds.xr b/t/pod/oneline_cmds.xr new file mode 100644 index 0000000000..e1277b7e37 --- /dev/null +++ b/t/pod/oneline_cmds.xr @@ -0,0 +1,29 @@ +NAME + rdb2pg - insert an rdb table into a PostgreSQL database + +SYNOPSIS + rdb2pg [*param*=*value* ...] + +PARAMETERS + rdb2pg uses an IRAF-compatible parameter interface. A template + parameter file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. + + input *file* + The RDB file to insert into the database. If the given name + is the string `stdin', it reads from the UNIX standard input + stream. + + +DESCRIPTION + rdb2pg will enter the data from an RDB database into a + PostgreSQL database table, optionally creating the database and + the table if they do not exist. It automatically determines the + PostgreSQL data type from the column definition in the RDB file, + but may be overriden via a series of definition files or + directly via one of its parameters. + + The target database and table are specified by the `db' and + `table' parameters. If they do not exist, and the `createdb' + parameter is set, they will be created. Table field definitions + are determined in the following order: + diff --git a/t/pod/poderrs.t b/t/pod/poderrs.t new file mode 100755 index 0000000000..591bd2a86d --- /dev/null +++ b/t/pod/poderrs.t @@ -0,0 +1,39 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testpchk.pl"; + import TestPodChecker; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodchecker \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=head1 NAME + +poderrors.t - test Pod::Checker on some pod syntax errors + +=unknown1 this is an unknown command with two N<unknownA> +and D<unknownB> interior sequences. + +This is some paragraph text with some unknown interior sequences, +such as Q<unknown2>, +A<unknown3>, +and Y<unknown4 V<unknown5>>. + +Now try some unterminated sequences like +I<hello mudda! +B<hello fadda! + +Here I am at C<camp granada! + +Camps is very, +entertaining. +And they say we'll have some fun if it stops raining! + +=cut diff --git a/t/pod/poderrs.xr b/t/pod/poderrs.xr new file mode 100644 index 0000000000..a7bc42d956 --- /dev/null +++ b/t/pod/poderrs.xr @@ -0,0 +1,11 @@ +*** ERROR: Unknown command "unknown1" at line 21 of file t/poderrs.t +*** ERROR: Unknown interior-sequence "N" at line 21 of file t/poderrs.t +*** ERROR: Unknown interior-sequence "D" at line 22 of file t/poderrs.t +*** ERROR: Unknown interior-sequence "Q" at line 25 of file t/poderrs.t +*** ERROR: Unknown interior-sequence "A" at line 26 of file t/poderrs.t +*** ERROR: Unknown interior-sequence "V" at line 27 of file t/poderrs.t +*** ERROR: Unknown interior-sequence "Y" at line 27 of file t/poderrs.t +** Unterminated B<...> at t/poderrs.t line 31 +** Unterminated I<...> at t/poderrs.t line 30 +** Unterminated C<...> at t/poderrs.t line 33 +t/poderrs.t has 10 pod syntax errors. diff --git a/t/pod/special_seqs.t b/t/pod/special_seqs.t new file mode 100755 index 0000000000..5352fd1ca6 --- /dev/null +++ b/t/pod/special_seqs.t @@ -0,0 +1,30 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=pod + +This is a test to see if I can do not only C<$self> and C<method()>, but +also C<$self->method()> and C<$self->{FIELDNAME}> and C<{FOO=>BAR}> without +resorting to escape sequences. + +Now for the grand finale of C<$self->method()->{FIELDNAME} = {FOO=>BAR}>. + +Of course I should still be able to do all this I<with> escape sequences +too: C<$self-E<gt>method()> and C<$self-E<gt>{FIELDNAME}> and C<{FOO=E<gt>BAR}>. + +Dont forget C<$self-E<gt>method()-E<gt>{FIELDNAME} = {FOO=E<gt>BAR}>. + +=cut diff --git a/t/pod/special_seqs.xr b/t/pod/special_seqs.xr new file mode 100644 index 0000000000..b6ae7fd5b6 --- /dev/null +++ b/t/pod/special_seqs.xr @@ -0,0 +1,13 @@ + This is a test to see if I can do not only `$self' and + `method()', but also `$self->method()' and `$self->{FIELDNAME}' + and `{FOO=>BAR}' without resorting to escape sequences. + + Now for the grand finale of `$self->method()->{FIELDNAME} = + {FOO=>BAR}'. + + Of course I should still be able to do all this *with* escape + sequences too: `$self->method()' and `$self->{FIELDNAME}' and + `{FOO=>BAR}'. + + Dont forget `$self->method()->{FIELDNAME} = {FOO=>BAR}'. + diff --git a/t/pod/testcmp.pl b/t/pod/testcmp.pl new file mode 100644 index 0000000000..d61bbff3a2 --- /dev/null +++ b/t/pod/testcmp.pl @@ -0,0 +1,90 @@ +package TestCompare; + +use vars qw(@ISA @EXPORT $MYPKG); +#use strict; +#use diagnostics; +use Carp; +use Exporter; +use File::Basename; +use File::Spec; + +@ISA = qw(Exporter); +@EXPORT = qw(&testcmp); +$MYPKG = eval { (caller)[0] }; + +##-------------------------------------------------------------------------- + +=head1 NAME + +testcmp -- compare two files line-by-line + +=head1 SYNOPSIS + + $is_diff = testcmp($file1, $file2); + +or + + $is_diff = testcmp({-cmplines => \&mycmp}, $file1, $file2); + +=head2 DESCRIPTION + +Compare two text files line-by-line and return 0 if they are the +same, 1 if they differ. Each of $file1 and $file2 may be a filenames, +or a filehandles (in which case it must already be open for reading). + +If the first argument is a hashref, then the B<-cmplines> key in the +hash may have a subroutine reference as its corresponding value. +The referenced user-defined subroutine should be a line-comparator +function that takes two pre-chomped text-lines as its arguments +(the first is from $file1 and the second is from $file2). It should +return 0 if it considers the two lines equivalent, and non-zero +otherwise. + +=cut + +##-------------------------------------------------------------------------- + +sub testcmp( $ $ ; $) { + my %opts = ref($_[0]) eq 'HASH' ? %{shift()} : (); + my ($file1, $file2) = @_; + my ($fh1, $fh2) = ($file1, $file2); + unless (ref $fh1) { + $fh1 = FileHandle->new($file1, "r") or die "Can't open $file1: $!"; + } + unless (ref $fh2) { + $fh2 = FileHandle->new($file2, "r") or die "Can't open $file2: $!"; + } + + my $cmplines = $opts{'-cmplines'} || undef; + my ($f1text, $f2text) = ("", ""); + my ($line, $diffs) = (0, 0); + + while ( defined($f1text) and defined($f2text) ) { + defined($f1text = <$fh1>) and chomp($f1text); + defined($f2text = <$fh2>) and chomp($f2text); + ++$line; + last unless ( defined($f1text) and defined($f2text) ); + $diffs = (ref $cmplines) ? &$cmplines($f1text, $f2text) + : ($f1text ne $f2text); + last if $diffs; + } + close($fh1) unless (ref $file1); + close($fh2) unless (ref $file2); + + $diffs = 1 if (defined($f1text) or defined($f2text)); + if ( defined($f1text) and defined($f2text) ) { + ## these two lines must be different + warn "$file1 and $file2 differ at line $line\n"; + } + elsif (defined($f1text) and (! defined($f1text))) { + ## file1 must be shorter + warn "$file1 is shorter than $file2\n"; + } + elsif (defined $f2text) { + ## file2 must be longer + warn "$file1 is shorter than $file2\n"; + } + return $diffs; +} + +1; diff --git a/t/pod/testp2pt.pl b/t/pod/testp2pt.pl new file mode 100644 index 0000000000..140de05a3a --- /dev/null +++ b/t/pod/testp2pt.pl @@ -0,0 +1,177 @@ +package TestPodIncPlainText; + +BEGIN { + use File::Basename; + use File::Spec; + push @INC, '..'; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testcmp.pl"; + import TestCompare; + my $PARENTDIR = dirname $THISDIR; + push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR); +} + +use Pod::PlainText; +use vars qw(@ISA @EXPORT $MYPKG); +#use strict; +#use diagnostics; +use Carp; +use Exporter; +#use File::Compare; + +@ISA = qw(Pod::PlainText); +@EXPORT = qw(&testpodplaintext); +$MYPKG = eval { (caller)[0] }; + +## Hardcode settings for TERMCAP and COLUMNS so we can try to get +## reproducible results between environments +@ENV{qw(TERMCAP COLUMNS)} = ('co=72:do=^J', 72); + +sub catfile(@) { File::Spec->catfile(@_); } + +## Find the path to the file to =include +sub findinclude { + my $self = shift; + my $incname = shift; + + ## See if its already found w/out any "searching; + return $incname if (-r $incname); + + ## Need to search for it. Look in the following directories ... + ## 1. the directory containing this pod file + my $thispoddir = dirname $self->input_file; + ## 2. the parent directory of the above + my $parentdir = ($thispoddir eq '.') ? '..' : dirname $thispoddir; + ## 3. any Pod/ or scripts/ subdirectory of these two + my @dirs = (); + for ($thispoddir, $parentdir) { + my $dir = $_; + for ( qw(scripts lib) ) { + push @dirs, $dir, catfile($dir, $_), + catfile($dir, 'Pod'), + catfile($dir, $_, 'Pod'); + } + } + my %dirs = (map { ($_ => 1) } @dirs); + my @podincdirs = (sort keys %dirs); + + for (@podincdirs) { + my $incfile = catfile($_, $incname); + return $incfile if (-r $incfile); + } + warn("*** Can't find =include file $incname in @podincdirs\n"); + return ""; +} + +sub command { + my $self = shift; + my ($cmd, $text, $line_num, $pod_para) = @_; + $cmd = '' unless (defined $cmd); + local $_ = $text || ''; + my $out_fh = $self->output_handle; + + ## Defer to the superclass for everything except '=include' + return $self->SUPER::command(@_) unless ($cmd eq "include"); + + ## We have an '=include' command + my $incdebug = 1; ## debugging + my @incargs = split; + if (@incargs == 0) { + warn("*** No filename given for '=include'\n"); + return; + } + my $incfile = $self->findinclude(shift @incargs) or return; + my $incbase = basename $incfile; + print $out_fh "###### begin =include $incbase #####\n" if ($incdebug); + $self->parse_from_file( {-cutting => 1}, $incfile ); + print $out_fh "###### end =include $incbase #####\n" if ($incdebug); +} + +sub podinc2plaintext( $ $ ) { + my ($infile, $outfile) = @_; + local $_; + my $text_parser = $MYPKG->new; + $text_parser->parse_from_file($infile, $outfile); +} + +sub testpodinc2plaintext( @ ) { + my %args = @_; + my $infile = $args{'-In'} || croak "No input file given!"; + my $outfile = $args{'-Out'} || croak "No output file given!"; + my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!"; + + my $different = ''; + my $testname = basename $cmpfile, '.t', '.xr'; + + unless (-e $cmpfile) { + my $msg = "*** Can't find comparison file $cmpfile for testing $infile"; + warn "$msg\n"; + return $msg; + } + + print "+ Running testpodinc2plaintext for '$testname'...\n"; + ## Compare the output against the expected result + podinc2plaintext($infile, $outfile); + if ( testcmp($outfile, $cmpfile) ) { + $different = "$outfile is different from $cmpfile"; + } + else { + unlink($outfile); + } + return $different; +} + +sub testpodplaintext( @ ) { + my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : (); + my @testpods = @_; + my ($testname, $testdir) = ("", ""); + my ($podfile, $cmpfile) = ("", ""); + my ($outfile, $errfile) = ("", ""); + my $passes = 0; + my $failed = 0; + local $_; + + print "1..", scalar @testpods, "\n" unless ($opts{'-xrgen'}); + + for $podfile (@testpods) { + ($testname, $_) = fileparse($podfile); + $testdir ||= $_; + $testname =~ s/\.t$//; + $cmpfile = $testdir . $testname . '.xr'; + $outfile = $testdir . $testname . '.OUT'; + + if ($opts{'-xrgen'}) { + if ($opts{'-force'} or ! -e $cmpfile) { + ## Create the comparison file + print "+ Creating expected result for \"$testname\"" . + " pod2plaintext test ...\n"; + podinc2plaintext($podfile, $cmpfile); + } + else { + print "+ File $cmpfile already exists" . + " (use '-force' to regenerate it).\n"; + } + next; + } + + my $failmsg = testpodinc2plaintext + -In => $podfile, + -Out => $outfile, + -Cmp => $cmpfile; + if ($failmsg) { + ++$failed; + print "+\tFAILED. ($failmsg)\n"; + print "not ok ", $failed+$passes, "\n"; + } + else { + ++$passes; + unlink($outfile); + print "+\tPASSED.\n"; + print "ok ", $failed+$passes, "\n"; + } + } + return $passes; +} + +1; diff --git a/t/pod/testpchk.pl b/t/pod/testpchk.pl new file mode 100644 index 0000000000..cd3c13816d --- /dev/null +++ b/t/pod/testpchk.pl @@ -0,0 +1,129 @@ +package TestPodChecker; + +BEGIN { + use File::Basename; + use File::Spec; + push @INC, '..'; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testcmp.pl"; + import TestCompare; + my $PARENTDIR = dirname $THISDIR; + push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR); +} + +use Pod::Checker; +use vars qw(@ISA @EXPORT $MYPKG); +#use strict; +#use diagnostics; +use Carp; +use Exporter; +#use File::Compare; + +@ISA = qw(Exporter); +@EXPORT = qw(&testpodchecker); +$MYPKG = eval { (caller)[0] }; + +sub stripname( $ ) { + local $_ = shift; + return /(\w[.\w]*)\s*$/ ? $1 : $_; +} + +sub msgcmp( $ $ ) { + ## filter out platform-dependent aspects of error messages + my ($line1, $line2) = @_; + for ($line1, $line2) { + if ( /^#*\s*(\S.*?)\s+(?:has \d+\s*)?pod syntax (?:error|OK)/ ) { + my $fname = $1; + s/^#*\s*// if ($^O eq 'MacOS'); + s/^\s*\Q$fname\E/stripname($fname)/e; + } + elsif ( /^#*\s*\*+\s*(?:ERROR|Unterminated)/ ) { + s/^#*\s*// if ($^O eq 'MacOS'); + s/of file\s+(\S.*?)\s*$/"of file ".stripname($1)/e; + s/at\s+(\S.*?)\s+line/"at ".stripname($1)." line"/e; + } + } + return $line1 ne $line2; +} + +sub testpodcheck( @ ) { + my %args = @_; + my $infile = $args{'-In'} || croak "No input file given!"; + my $outfile = $args{'-Out'} || croak "No output file given!"; + my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!"; + + my $different = ''; + my $testname = basename $cmpfile, '.t', '.xr'; + + unless (-e $cmpfile) { + my $msg = "*** Can't find comparison file $cmpfile for testing $infile"; + warn "$msg\n"; + return $msg; + } + + print "+ Running podchecker for '$testname'...\n"; + ## Compare the output against the expected result + podchecker($infile, $outfile); + if ( testcmp({'-cmplines' => \&msgcmp}, $outfile, $cmpfile) ) { + $different = "$outfile is different from $cmpfile"; + } + else { + unlink($outfile); + } + return $different; +} + +sub testpodchecker( @ ) { + my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : (); + my @testpods = @_; + my ($testname, $testdir) = ("", ""); + my ($podfile, $cmpfile) = ("", ""); + my ($outfile, $errfile) = ("", ""); + my $passes = 0; + my $failed = 0; + local $_; + + print "1..", scalar @testpods, "\n" unless ($opts{'-xrgen'}); + + for $podfile (@testpods) { + ($testname, $_) = fileparse($podfile); + $testdir ||= $_; + $testname =~ s/\.t$//; + $cmpfile = $testdir . $testname . '.xr'; + $outfile = $testdir . $testname . '.OUT'; + + if ($opts{'-xrgen'}) { + if ($opts{'-force'} or ! -e $cmpfile) { + ## Create the comparison file + print "+ Creating expected result for \"$testname\"" . + " podchecker test ...\n"; + podchecker($podfile, $cmpfile); + } + else { + print "+ File $cmpfile already exists" . + " (use '-force' to regenerate it).\n"; + } + next; + } + + my $failmsg = testpodcheck + -In => $podfile, + -Out => $outfile, + -Cmp => $cmpfile; + if ($failmsg) { + ++$failed; + print "+\tFAILED. ($failmsg)\n"; + print "not ok ", $failed+$passes, "\n"; + } + else { + ++$passes; + unlink($outfile); + print "+\tPASSED.\n"; + print "ok ", $failed+$passes, "\n"; + } + } + return $passes; +} + +1; diff --git a/t/pragma/utf8.t b/t/pragma/utf8.t new file mode 100755 index 0000000000..e5b3bb5cd3 --- /dev/null +++ b/t/pragma/utf8.t @@ -0,0 +1,37 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + $ENV{PERL5LIB} = '../lib'; +} + +print "1..3\n"; + +my $test = 1; + +sub ok { + my ($got,$expect) = @_; + print "# expected [$expect], got [$got]\nnot " if $got ne $expect; + print "ok $test\n"; +} + +{ + use utf8; + $_ = ">\x{263A}<"; + s/([\x{80}-\x{10ffff}])/"&#".ord($1).";"/eg; + ok $_, '>☺<'; + $test++; + + $_ = ">\x{263A}<"; + my $rx = "\x{80}-\x{10ffff}"; + s/([$rx])/"&#".ord($1).";"/eg; + ok $_, '>☺<'; + $test++; + + $_ = ">\x{263A}<"; + my $rx = "\\x{80}-\\x{10ffff}"; + s/([$rx])/"&#".ord($1).";"/eg; + ok $_, '>☺<'; + $test++; +} diff --git a/t/pragma/warn/util b/t/pragma/warn/util index b63f89e139..d58f4b70fa 100644 --- a/t/pragma/warn/util +++ b/t/pragma/warn/util @@ -14,16 +14,16 @@ __END__ use warning 'octal' ; my $a = oct "029" ; EXPECT -Illegal octal digit ignored at - line 3. +Illegal octal digit '9' ignored at - line 3. ######## # util.c use warning 'unsafe' ; *a = hex "0xv9" ; EXPECT -Illegal hex digit ignored at - line 3. +Illegal hex digit 'v' ignored at - line 3. ######## # util.c use warning 'unsafe' ; *a = oct "0b9" ; EXPECT -Illegal binary digit ignored at - line 3. +Illegal binary digit '9' ignored at - line 3. @@ -6058,17 +6058,17 @@ scan_num(char *start) /* 8 and 9 are not octal */ case '8': case '9': if (shift == 3) - yyerror("Illegal octal digit"); + yyerror(form("Illegal octal digit '%c'", *s)); else if (shift == 1) - yyerror("Illegal binary digit"); + yyerror(form("Illegal binary digit '%c'", *s)); /* FALL THROUGH */ /* octal digits */ case '2': case '3': case '4': case '5': case '6': case '7': if (shift == 1) - yyerror("Illegal binary digit"); + yyerror(form("Illegal binary digit '%c'", *s)); /* FALL THROUGH */ case '0': case '1': @@ -2421,7 +2421,7 @@ scan_bin(char *start, I32 len, I32 *retlen) if (len && (*s >= '2' || *s <= '9')) { dTHR; if (ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE, "Illegal binary digit ignored"); + warner(WARN_UNSAFE, "Illegal binary digit '%c' ignored", *s); } *retlen = s - start; return retval; @@ -2445,7 +2445,7 @@ scan_oct(char *start, I32 len, I32 *retlen) if (len && (*s == '8' || *s == '9')) { dTHR; if (ckWARN(WARN_OCTAL)) - warner(WARN_OCTAL, "Illegal octal digit ignored"); + warner(WARN_OCTAL, "Illegal octal digit '%c' ignored", *s); } *retlen = s - start; return retval; @@ -2469,7 +2469,7 @@ scan_hex(char *start, I32 len, I32 *retlen) dTHR; --s; if (ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE,"Illegal hex digit ignored"); + warner(WARN_UNSAFE,"Illegal hex digit '%c' ignored", *s); break; } } diff --git a/utils/perlcc.PL b/utils/perlcc.PL index 2ea822b2b4..7aca1d8726 100644 --- a/utils/perlcc.PL +++ b/utils/perlcc.PL @@ -314,10 +314,10 @@ sub _ccharness } my @sharedobjects = _getSharedObjects($sourceprog); - my $dynaloader="$Config{'installarchlib'}/auto/DynaLoader/DynaLoader.a"; - + my $dynaloader = "$Config{'installarchlib'}/auto/DynaLoader/DynaLoader.a"; + my $optimize = $Config{'optimize'} =~ /-O\d/ ? '' : $Config{'optimize'}; my $cccmd = - "$Config{cc} @Config{qw(ccflags optimize)} $incdir @sharedobjects @args $dynaloader $linkargs"; + "$Config{cc} @Config{qw(ccflags)} $optimize $incdir @sharedobjects @args $dynaloader $linkargs"; _print ("$cccmd\n", 36); diff --git a/utils/perldoc.PL b/utils/perldoc.PL index 6d175f19a5..ed533f518f 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -326,7 +326,7 @@ foreach (@pages) { unless ($opt_m) { if ($Is_VMS) { my($i,$trn); - for ($i = 0; $trn = $ENV{'DCL$PATH'.$i}; $i++) { + for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) { push(@searchdirs,$trn); } push(@searchdirs,'perl_root:[lib.pod]') # installed pods diff --git a/vms/ext/Stdio/Stdio.pm b/vms/ext/Stdio/Stdio.pm index 04b339725f..d485e0e159 100644 --- a/vms/ext/Stdio/Stdio.pm +++ b/vms/ext/Stdio/Stdio.pm @@ -1,8 +1,8 @@ # VMS::Stdio - VMS extensions to Perl's stdio calls # # Author: Charles Bailey bailey@genetics.upenn.edu -# Version: 2.1 -# Revised: 24-Mar-1998 +# Version: 2.2 +# Revised: 19-Jul-1998 # Docs revised: 13-Oct-1998 Dan Sugalski <sugalskd@ous.edu> package VMS::Stdio; @@ -13,17 +13,17 @@ use Carp '&croak'; use DynaLoader (); use Exporter (); -$VERSION = '2.1'; +$VERSION = '2.2'; @ISA = qw( Exporter DynaLoader IO::File ); @EXPORT = qw( &O_APPEND &O_CREAT &O_EXCL &O_NDELAY &O_NOWAIT &O_RDONLY &O_RDWR &O_TRUNC &O_WRONLY ); -@EXPORT_OK = qw( &flush &getname &remove &rewind &sync &setdef &tmpnam +@EXPORT_OK = qw( &binmode &flush &getname &remove &rewind &sync &setdef &tmpnam &vmsopen &vmssysopen &waitfh &writeof ); %EXPORT_TAGS = ( CONSTANTS => [ qw( &O_APPEND &O_CREAT &O_EXCL &O_NDELAY &O_NOWAIT &O_RDONLY &O_RDWR &O_TRUNC &O_WRONLY ) ], - FUNCTIONS => [ qw( &flush &getname &remove &rewind &setdef - &sync &tmpnam &vmsopen &vmssysopen + FUNCTIONS => [ qw( &binmode &flush &getname &remove &rewind + &setdef &sync &tmpnam &vmsopen &vmssysopen &waitfh &writeof ) ] ); bootstrap VMS::Stdio $VERSION; @@ -100,6 +100,7 @@ VMS::Stdio - standard I/O functions via VMS extensions close($fh); remove("another.file"); writeof($pipefh); + binmode($fh); =head1 DESCRIPTION @@ -147,6 +148,22 @@ update your code to use the new routines. =over +=item binmode + +This function causes the file handle to be reopened with the CRTL's +carriage control processing disabled; its effect is the same as that +of the C<b> access mode in C<vmsopen>. After the file is reopened, +the file pointer is positioned as close to its position before the +call as possible (I<i.e.> as close as fsetpos() can get it -- for +some record-structured files, it's not possible to return to the +exact byte offset in the file). Because the file must be reopened, +this function cannot be used on temporary-delete files. C<binmode> +returns true if successful, and C<undef> if not. + +Note that the effect of C<binmode> differs from that of the binmode() +function on operating systems such as Windows and MSDOS, and is not +needed to process most types of file. + =item flush This function causes the contents of stdio buffers for the specified diff --git a/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs index 53b491575d..22d9a7262c 100644 --- a/vms/ext/Stdio/Stdio.xs +++ b/vms/ext/Stdio/Stdio.xs @@ -1,8 +1,8 @@ /* VMS::Stdio - VMS extensions to stdio routines * - * Version: 2.1 - * Author: Charles Bailey bailey@genetics.upenn.edu - * Revised: 24-Mar-1998 + * Version: 2.2 + * Author: Charles Bailey bailey@newman.upenn.edu + * Revised: 18-Jul-1998 * */ @@ -125,6 +125,57 @@ constant(name) ST(0) = &PL_sv_undef; void +binmode(fh) + SV * fh + PROTOTYPE: $ + CODE: + IO *io = sv_2io(fh); + FILE *fp = io ? IoOFP(io) : NULL; + char iotype = io ? IoTYPE(io) : '\0'; + char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = Nullch; + int ret = 0, saverrno = errno, savevmserrno = vaxc$errno; + fpos_t pos; + if (fp == NULL || strchr(">was+-|",iotype) == Nullch) { + set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF; + } + if (!fgetname(fp,filespec)) XSRETURN_UNDEF; + for (s = filespec; *s; s++) { + if (*s == ':') colon = s; + else if (*s == ']' || *s == '>') dirend = s; + } + /* Looks like a tmpfile, which will go away if reopened */ + if (s == dirend + 3) { + set_errno(EBADF); set_vaxc_errno(RMS$_IOP); XSRETURN_UNDEF; + } + /* If we've got a non-file-structured device, clip off the trailing + * junk, and don't lose sleep if we can't get a stream position. */ + if (dirend == Nullch) *(colon+1) = '\0'; + if (iotype != '-' && (ret = fgetpos(fp, &pos)) == -1 && dirend) + XSRETURN_UNDEF; + switch (iotype) { + case '<': case 'r': acmode = "rb"; break; + case '>': case 'w': case '|': + /* use 'a' instead of 'w' to avoid creating new file; + fsetpos below will take care of restoring file position */ + case 'a': acmode = "ab"; break; + case '+': case 's': acmode = "rb+"; break; + case '-': acmode = fileno(fp) ? "ab" : "rb"; break; + /* iotype'll be null for the SYS$INPUT:/SYS$OUTPUT:/SYS$ERROR: files */ + /* since we didn't really open them and can't really */ + /* reopen them */ + case 0: XSRETURN_UNDEF; + default: + if (PL_dowarn) warn("Unrecognized iotype %c for %s in binmode", + iotype, filespec); + acmode = "rb+"; + } + if (freopen(filespec,acmode,fp) == NULL) XSRETURN_UNDEF; + if (iotype != '-' && ret != -1 && fsetpos(fp,&pos) == -1) XSRETURN_UNDEF; + if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); } + XSRETURN_YES; + + +void flush(fp) FILE * fp PROTOTYPE: $ @@ -365,8 +416,7 @@ writeof(mysv) IO *io = sv_2io(mysv); FILE *fp = io ? IoOFP(io) : NULL; if (fp == NULL || strchr(">was+-|",IoTYPE(io)) == Nullch) { - set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); - ST(0) = &PL_sv_undef; XSRETURN(1); + set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF; } if (fgetname(fp,devnam) == Nullch) { ST(0) = &PL_sv_undef; XSRETURN(1); } if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0'; diff --git a/vms/ext/Stdio/test.pl b/vms/ext/Stdio/test.pl index 37131deb01..2f735734c1 100755 --- a/vms/ext/Stdio/test.pl +++ b/vms/ext/Stdio/test.pl @@ -1,4 +1,4 @@ -# Tests for VMS::Stdio v2.1 +# Tests for VMS::Stdio v2.2 use VMS::Stdio; import VMS::Stdio qw(&flush &getname &rewind &sync &tmpnam); diff --git a/vms/subconfigure.com b/vms/subconfigure.com index 77dc15ce0e..5f0c6a8f3b 100644 --- a/vms/subconfigure.com +++ b/vms/subconfigure.com @@ -73,6 +73,8 @@ $ perl_i_sysmman="undef" $ perl_d_telldirproto="define" $ perl_i_sysmount="undef" $ perl_d_fstatfs="undef" +$ perl_i_machcthreads="undef" +$ perl_i_pthread="define" $ perl_d_fstatvfs="undef" $ perl_d_statfsflags="undef" $ perl_i_sysstatvfs="undef" @@ -3078,6 +3080,8 @@ $ WC "i_sysmount='" + perl_i_sysmount + "'" $ WC "d_fstatfs='" + perl_d_fstatfs + "'" $ WC "d_statfsflags='" + perl_d_statfsflags + "'" $ WC "i_sysstatvfs='" + perl_i_sysstatvfs + "'" +$ WC "i_machcthreads='" + perl_i_machcthreads + "'" +$ WC "i_pthread='" + perl_i_pthread + "'" $ WC "d_fstatvfs='" + perl_d_fstatvfs + "'" $ WC "i_mntent='" + perl_i_mntent + "'" $ WC "d_getmntent='" + perl_d_getmntent + "'" diff --git a/vms/test.com b/vms/test.com index 207aad9087..15c0e8a949 100644 --- a/vms/test.com +++ b/vms/test.com @@ -102,7 +102,8 @@ use Config; @compexcl=('cpp.t'); @ioexcl=('argv.t','dup.t','fs.t','pipe.t'); @libexcl=('db-btree.t','db-hash.t','db-recno.t', - 'gdbm.t','io_dup.t', 'io_pipe.t', 'io_sel.t', 'io_sock.t', + 'gdbm.t','io_dup.t', 'io_pipe.t', 'io_poll.t', 'io_sel.t', + 'io_sock.t', 'io_unix.t', 'ndbm.t','odbm.t','open2.t','open3.t', 'ph.t', 'posix.t'); # Note: POSIX is not part of basic build, but can be built diff --git a/vms/vmsish.h b/vms/vmsish.h index 7fce3afe0b..4b45cf4968 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -2,8 +2,8 @@ * * VMS-specific C header file for perl5. * - * Last revised: 18-Feb-1997 by Charles Bailey bailey@genetics.upenn.edu - * Version: 5.3.28 + * Last revised: 16-Sep-1998 by Charles Bailey bailey@newman.upenn.edu + * Version: 5.5.2 */ #ifndef __vmsish_h_included @@ -64,13 +64,17 @@ # define DONT_MASK_RTL_CALLS #endif - /* defined for vms.c so we can see CRTL | defined for a2p */ +/* Note that we do, in fact, have this */ +#define HAS_GETENV_SV + #ifndef DONT_MASK_RTL_CALLS # ifdef getenv # undef getenv # endif -# define getenv(v) my_getenv(v) /* getenv used for regular logical names */ + /* getenv used for regular logical names */ +# define getenv(v) my_getenv(v,TRUE) #endif +#define getenv_sv(v) my_getenv_sv(v,TRUE) /* DECC introduces this routine in the RTL as of VMS 7.0; for now, * we'll use ours, since it gives us the full VMS exit status. */ @@ -83,66 +87,68 @@ #define DONT_DECLARE_STD 1 /* Our own contribution to PerlShr's global symbols . . . */ -# define my_trnlnm Perl_my_trnlnm -# define my_getenv Perl_my_getenv -# define prime_env_iter Perl_prime_env_iter -# define my_setenv Perl_my_setenv -# define my_crypt Perl_my_crypt -# define my_waitpid Perl_my_waitpid -# define my_gconvert Perl_my_gconvert -# define do_rmdir Perl_do_rmdir -# define kill_file Perl_kill_file -# define my_mkdir Perl_my_mkdir -# define my_utime Perl_my_utime -# define rmsexpand Perl_rmsexpand -# define rmsexpand_ts Perl_rmsexpand_ts -# define fileify_dirspec Perl_fileify_dirspec -# define fileify_dirspec_ts Perl_fileify_dirspec_ts -# define pathify_dirspec Perl_pathify_dirspec -# define pathify_dirspec_ts Perl_pathify_dirspec_ts -# define tounixspec Perl_tounixspec -# define tounixspec_ts Perl_tounixspec_ts -# define tovmsspec Perl_tovmsspec -# define tovmsspec_ts Perl_tovmsspec_ts -# define tounixpath Perl_tounixpath -# define tounixpath_ts Perl_tounixpath_ts -# define tovmspath Perl_tovmspath -# define tovmspath_ts Perl_tovmspath_ts -# define vms_image_init Perl_vms_image_init -# define opendir Perl_opendir -# define readdir Perl_readdir -# define telldir Perl_telldir -# define seekdir Perl_seekdir -# define closedir Perl_closedir -# define vmsreaddirversions Perl_vmsreaddirversions -# define my_gmtime Perl_my_gmtime -# define my_localtime Perl_my_localtime -# define my_time Perl_my_time -# define my_sigemptyset Perl_my_sigemptyset -# define my_sigfillset Perl_my_sigfillset -# define my_sigaddset Perl_my_sigaddset -# define my_sigdelset Perl_my_sigdelset -# define my_sigismember Perl_my_sigismember -# define my_sigprocmask Perl_my_sigprocmask -# define cando_by_name Perl_cando_by_name -# define flex_fstat Perl_flex_fstat -# define flex_stat Perl_flex_stat -# define trim_unixpath Perl_trim_unixpath -# define my_vfork Perl_my_vfork -# define vms_do_aexec Perl_vms_do_aexec -# define vms_do_exec Perl_vms_do_exec -# define do_aspawn Perl_do_aspawn -# define do_spawn Perl_do_spawn -# define my_fwrite Perl_my_fwrite -# define my_flush Perl_my_flush -# define my_binmode Perl_my_binmode -# define my_getpwnam Perl_my_getpwnam -# define my_getpwuid Perl_my_getpwuid -# define my_getpwent Perl_my_getpwent -# define my_endpwent Perl_my_endpwent -# define my_getlogin Perl_my_getlogin -# define rmscopy Perl_rmscopy -# define init_os_extras Perl_init_os_extras +#define vmstrnenv Perl_vmstrnenv +#define my_trnlnm Perl_my_trnlnm +#define my_getenv Perl_my_getenv +#define my_getenv_sv Perl_my_getenv_sv +#define prime_env_iter Perl_prime_env_iter +#define vmssetenv Perl_vmssetenv +#define my_setenv Perl_my_setenv +#define my_crypt Perl_my_crypt +#define my_waitpid Perl_my_waitpid +#define my_gconvert Perl_my_gconvert +#define do_rmdir Perl_do_rmdir +#define kill_file Perl_kill_file +#define my_mkdir Perl_my_mkdir +#define my_utime Perl_my_utime +#define rmsexpand Perl_rmsexpand +#define rmsexpand_ts Perl_rmsexpand_ts +#define fileify_dirspec Perl_fileify_dirspec +#define fileify_dirspec_ts Perl_fileify_dirspec_ts +#define pathify_dirspec Perl_pathify_dirspec +#define pathify_dirspec_ts Perl_pathify_dirspec_ts +#define tounixspec Perl_tounixspec +#define tounixspec_ts Perl_tounixspec_ts +#define tovmsspec Perl_tovmsspec +#define tovmsspec_ts Perl_tovmsspec_ts +#define tounixpath Perl_tounixpath +#define tounixpath_ts Perl_tounixpath_ts +#define tovmspath Perl_tovmspath +#define tovmspath_ts Perl_tovmspath_ts +#define vms_image_init Perl_vms_image_init +#define opendir Perl_opendir +#define readdir Perl_readdir +#define telldir Perl_telldir +#define seekdir Perl_seekdir +#define closedir Perl_closedir +#define vmsreaddirversions Perl_vmsreaddirversions +#define my_gmtime Perl_my_gmtime +#define my_localtime Perl_my_localtime +#define my_time Perl_my_time +#define my_sigemptyset Perl_my_sigemptyset +#define my_sigfillset Perl_my_sigfillset +#define my_sigaddset Perl_my_sigaddset +#define my_sigdelset Perl_my_sigdelset +#define my_sigismember Perl_my_sigismember +#define my_sigprocmask Perl_my_sigprocmask +#define cando_by_name Perl_cando_by_name +#define flex_fstat Perl_flex_fstat +#define flex_stat Perl_flex_stat +#define trim_unixpath Perl_trim_unixpath +#define my_vfork Perl_my_vfork +#define vms_do_aexec Perl_vms_do_aexec +#define vms_do_exec Perl_vms_do_exec +#define do_aspawn Perl_do_aspawn +#define do_spawn Perl_do_spawn +#define my_fwrite Perl_my_fwrite +#define my_flush Perl_my_flush +#define my_getpwnam Perl_my_getpwnam +#define my_getpwuid Perl_my_getpwuid +#define my_getpwent Perl_my_getpwent +#define my_endpwent Perl_my_endpwent +#define my_getlogin Perl_my_getlogin +#define rmscopy Perl_rmscopy +#define init_os_extras Perl_init_os_extras /* Delete if at all possible, changing protections if necessary. */ #define unlink kill_file @@ -208,6 +214,9 @@ #define VMSISH_EXIT TEST_VMSISH(HINT_M_VMSISH_EXIT) #define VMSISH_TIME TEST_VMSISH(HINT_M_VMSISH_TIME) +/* Flags for vmstrnenv() */ +#define PERL__TRNENV_SECURE 0x01 + /* Handy way to vet calls to VMS system services and RTL routines. */ #define _ckvmssts(call) STMT_START { register unsigned long int __ckvms_sts; \ if (!((__ckvms_sts=(call))&1)) { \ @@ -277,7 +286,7 @@ * that a file is in "binary" mode -- that is, that no translation * of bytes occurs on read or write operations. */ -#define USEMYBINMODE +#undef USEMYBINMODE /* Stat_t: * This symbol holds the type used to declare buffers for information @@ -403,7 +412,8 @@ struct utimbuf { #define DYNAMIC_ENV_FETCH 1 #define ENV_HV_NAME "%EnV%VmS%" /* Special getenv function for retrieving %ENV elements. */ -#define ENV_getenv(v) my_getenv(v) +#define ENVgetenv(v) my_getenv(v,FALSE) +#define ENVgetenv_sv(v) my_getenv_sv(v,FALSE) /* Thin jacket around cuserid() tomatch Unix' calling sequence */ @@ -568,8 +578,11 @@ void prime_env_iter _((void)); void init_os_extras _(()); /* prototype section start marker; `typedef' passes through cpp */ typedef char __VMS_PROTOTYPES__; -int my_trnlnm _((char *, char *, unsigned long int)); -char * my_getenv _((const char *)); +int vmstrnenv _((const char *, char *, unsigned long int, struct dsc$descriptor_s **, unsigned long int)); +int my_trnlnm _((const char *, char *, unsigned long int)); +char * my_getenv _((const char *, bool)); +SV * my_getenv_sv _((const char *, bool)); +int vmssetenv _((char *, char *, struct dsc$descriptor_s **)); char * my_crypt _((const char *, const char *)); Pid_t my_waitpid _((Pid_t, int *, int)); char * my_gconvert _((double, int, int, char *)); @@ -620,7 +633,6 @@ unsigned long int do_aspawn _((void *, void **, void **)); unsigned long int do_spawn _((char *)); int my_fwrite _((void *, size_t, size_t, FILE *)); int my_flush _((FILE *)); -FILE * my_binmode _((FILE *, char)); struct passwd * my_getpwnam _((char *name)); struct passwd * my_getpwuid _((Uid_t uid)); struct passwd * my_getpwent _(()); diff --git a/vos/config.h b/vos/config.h index 7f4c1a257d..bed1a98851 100644 --- a/vos/config.h +++ b/vos/config.h @@ -1,7 +1,7 @@ /* This is config.h for Stratus VOS. It was created by hand from the distribution copy of config_h.SH. */ -/* Configuration time: September 4, 1998 +/* Configuration time: March 5, 1999 * Configured by: Paul Green * Target system: Stratus VOS */ @@ -1144,7 +1144,7 @@ * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. */ -#define CASTI32 /**/ +/*#define CASTI32 /**/ /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative @@ -1990,6 +1990,18 @@ */ #define ARCHNAME "vos" /**/ +/* I_MACH_CTHREADS: + * This symbol, if defined, indicates to the C program that it should + * include <mach/cthreads.h>. + */ +/*#define I_MACH_CTHREADS /**/ + +/* I_PTHREAD: + * This symbol, if defined, indicates to the C program that it should + * include <pthread.h>. + */ +/*#define I_PTHREAD /**/ + /* HAS_PTHREAD_YIELD: * This symbol, if defined, indicates that the pthread_yield * routine is available to yield the execution of the current diff --git a/vos/config_h.SH_orig b/vos/config_h.SH_orig index 49f86c7de7..819be2b63c 100755 --- a/vos/config_h.SH_orig +++ b/vos/config_h.SH_orig @@ -239,6 +239,54 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_fsetpos HAS_FSETPOS /**/ +/* I_SYS_MOUNT: + * This symbol, if defined, indicates to the C program that it should + * include <sys/mount.h>. + */ +#$i_sysmount I_SYS_MOUNT /**/ + +/* HAS_FSTATFS: + * This symbol, if defined, indicates that the fstatfs routine is + * available to stat the filesystem of a file descriptor. + */ +#$d_fstatfs HAS_FSTATFS /**/ + +/* HAS_STRUCT_STATFS_FLAGS: + * This symbol, if defined, indicates that the struct statfs has + * the f_flags member for mount flags. + */ +#$d_statfsflags HAS_STRUCT_STATFS_FLAGS /**/ + +/* I_SYS_STATVFS: + * This symbol, if defined, indicates to the C program that it should + * include <sys/statvfs.h>. + */ +#$i_sysstatvfs I_SYS_STATVFS /**/ + +/* HAS_FSTATVFS: + * This symbol, if defined, indicates that the fstatvfs routine is + * available to stat the filesystem of a file descriptor. + */ +#$d_fstatvfs HAS_FSTATVFS /**/ + +/* I_MNTENT: + * This symbol, if defined, indicates to the C program that it should + * include <mntent.h>. + */ +#$i_mntent I_MNTENT /**/ + +/* HAS_GETMNTENT: + * This symbol, if defined, indicates that the getmntent routine is + * available to lookup mount entries in some data base or other. + */ +#$d_getmntent HAS_GETMNTENT /**/ + +/* HAS_HASMNTOPT: + * This symbol, if defined, indicates that the hasmntopt routine is + * available to query mount entries returned by getmntent. + */ +#$d_hasmntopt HAS_HASMNTOPT /**/ + /* HAS_GETTIMEOFDAY: * This symbol, if defined, indicates that the gettimeofday() system * call is available for a sub-second accuracy clock. Usually, the file @@ -1813,7 +1861,7 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- * the sig_name list. */ #define SIG_NAME $sig_name_init /**/ -#define SIG_NUM $sig_num /**/ +#define SIG_NUM $sig_num_init /**/ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this @@ -1902,6 +1950,15 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- #define PRIVLIB "$privlib" /**/ #define PRIVLIB_EXP "$privlibexp" /**/ +/* SELECT_MIN_BITS: + * This symbol holds the minimum number of bits operated by select. + * That is, if you do select(n, ...), how many bits at least will be + * cleared in the masks if some activity is detected. Usually this + * is either n or 32*ceil(n/32), especially many little-endians do + * the latter. This is only useful if you have select(), naturally. + */ +#define SELECT_MIN_BITS $selectminbits /**/ + /* SITEARCH: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's @@ -2017,6 +2074,18 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #define ARCHNAME "$archname" /**/ +/* I_MACH_CTHREADS: + * This symbol, if defined, indicates to the C program that it should + * include <mach/cthreads.h>. + */ +/*#define I_MACH_CTHREADS /**/ + +/* I_PTHREAD: + * This symbol, if defined, indicates to the C program that it should + * include <pthread.h>. + */ +/*#define I_PTHREAD /**/ + /* HAS_PTHREAD_YIELD: * This symbol, if defined, indicates that the pthread_yield * routine is available to yield the execution of the current diff --git a/win32/GenCAPI.pl b/win32/GenCAPI.pl index af71291830..77e7aad8b8 100644 --- a/win32/GenCAPI.pl +++ b/win32/GenCAPI.pl @@ -990,6 +990,11 @@ int _win32_utime(const char *f, struct utimbuf *t) return pPerl->PL_piLIO->Utime((char*)f, t, ErrorNo()); } +int _win32_uname(struct utsname *name) +{ + return pPerl->PL_piENV->Uname(name, ErrorNo()); +} + char* _win32_getenv(const char *name) { return pPerl->PL_piENV->Getenv(name, ErrorNo()); diff --git a/win32/Makefile b/win32/Makefile index 7daffb3d34..49271f27cd 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -337,6 +337,9 @@ UTILS = \ ..\pod\pod2latex \ ..\pod\pod2man \ ..\pod\pod2text \ + ..\pod\pod2usage \ + ..\pod\podchecker \ + ..\pod\podselect \ ..\x2p\find2perl \ ..\x2p\s2p \ bin\runperl.pl \ diff --git a/win32/config.bc b/win32/config.bc index fa1daf9e8b..691dfbbcd4 100644 --- a/win32/config.bc +++ b/win32/config.bc @@ -339,7 +339,7 @@ d_truncate='undef' d_truncate64='undef' d_tzname='define' d_umask='define' -d_uname='undef' +d_uname='define' d_union_semun='define' d_vfork='undef' d_void_closedir='undef' diff --git a/win32/config.gc b/win32/config.gc index e270d49820..39b77015ae 100644 --- a/win32/config.gc +++ b/win32/config.gc @@ -339,7 +339,7 @@ d_truncate='undef' d_truncate64='undef' d_tzname='undef' d_umask='define' -d_uname='undef' +d_uname='define' d_union_semun='define' d_vfork='undef' d_void_closedir='undef' diff --git a/win32/config.vc b/win32/config.vc index 082b4c1db4..cf4799baa4 100644 --- a/win32/config.vc +++ b/win32/config.vc @@ -339,7 +339,7 @@ d_truncate='undef' d_truncate64='undef' d_tzname='define' d_umask='define' -d_uname='undef' +d_uname='define' d_union_semun='define' d_vfork='undef' d_void_closedir='undef' diff --git a/win32/config_H.bc b/win32/config_H.bc index 7437cf6b92..9a87054207 100644 --- a/win32/config_H.bc +++ b/win32/config_H.bc @@ -242,7 +242,7 @@ * even if used by a process with super-user privileges. */ #define HAS_GETHOSTNAME /**/ -/*#define HAS_UNAME /**/ +#define HAS_UNAME /**/ /*#define PHOSTNAME "" / * How to get the host name */ /* HAS_GETLOGIN: diff --git a/win32/config_H.gc b/win32/config_H.gc index ddb8524fad..271a6f51ff 100644 --- a/win32/config_H.gc +++ b/win32/config_H.gc @@ -242,7 +242,7 @@ * even if used by a process with super-user privileges. */ #define HAS_GETHOSTNAME /**/ -/*#define HAS_UNAME /**/ +#define HAS_UNAME /**/ /*#define PHOSTNAME "" / * How to get the host name */ /* HAS_GETLOGIN: diff --git a/win32/config_H.vc b/win32/config_H.vc index 4a8a097512..aab6935aca 100644 --- a/win32/config_H.vc +++ b/win32/config_H.vc @@ -242,7 +242,7 @@ * even if used by a process with super-user privileges. */ #define HAS_GETHOSTNAME /**/ -/*#define HAS_UNAME /**/ +#define HAS_UNAME /**/ /*#define PHOSTNAME "" / * How to get the host name */ /* HAS_GETLOGIN: diff --git a/win32/makedef.pl b/win32/makedef.pl index ce1009ba78..0a753fbfe1 100644 --- a/win32/makedef.pl +++ b/win32/makedef.pl @@ -451,6 +451,7 @@ win32_open_osfhandle win32_get_osfhandle win32_ioctl win32_utime +win32_uname win32_wait win32_waitpid win32_kill diff --git a/win32/makefile.mk b/win32/makefile.mk index 574fa6aa82..32056a9d33 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -429,6 +429,9 @@ UTILS = \ ..\pod\pod2latex \ ..\pod\pod2man \ ..\pod\pod2text \ + ..\pod\pod2usage \ + ..\pod\podchecker \ + ..\pod\podselect \ ..\x2p\find2perl \ ..\x2p\s2p \ bin\runperl.pl \ diff --git a/win32/perlhost.h b/win32/perlhost.h index e514bf1342..cc5b5e5cd4 100644 --- a/win32/perlhost.h +++ b/win32/perlhost.h @@ -98,6 +98,10 @@ public: { return g_win32_get_sitelib(pl); }; + virtual int Uname(struct utsname *name, int &err) + { + return win32_uname(name); + }; }; class CPerlSock : public IPerlSock diff --git a/win32/pod.mak b/win32/pod.mak index e5dd640e54..b1a1b9c56a 100644 --- a/win32/pod.mak +++ b/win32/pod.mak @@ -1,4 +1,5 @@ -CONVERTERS = pod2html pod2latex pod2man pod2text checkpods +CONVERTERS = pod2html pod2latex pod2man pod2text checkpods \ + pod2usage podchecker podselect HTMLROOT = / # Change this to fix cross-references in HTML POD2HTML = pod2html \ @@ -312,6 +313,15 @@ pod2text: pod2text.PL ../lib/Config.pm checkpods: checkpods.PL ../lib/Config.pm $(PERL) -I ../lib checkpods.PL +pod2usage: pod2usage.PL ../lib/Config.pm + $(PERL) -I ../lib pod2usage.PL + +podchecker: podchecker.PL ../lib/Config.pm + $(PERL) -I ../lib podchecker.PL + +podselect: podselect.PL ../lib/Config.pm + $(PERL) -I ../lib podselect.PL + compile: all $(REALPERL) -I../lib ../utils/perlcc -regex 's/$$/.exe/' pod2latex pod2man pod2text checkpods -prog -verbose dcf -log ../compilelog; diff --git a/win32/win32.c b/win32/win32.c index 4d7721edc6..5d2bdaa5f1 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -1133,6 +1133,91 @@ win32_utime(const char *filename, struct utimbuf *times) } DllExport int +win32_uname(struct utsname *name) +{ + struct hostent *hep; + STRLEN nodemax = sizeof(name->nodename)-1; + OSVERSIONINFO osver; + + memset(&osver, 0, sizeof(OSVERSIONINFO)); + osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + if (GetVersionEx(&osver)) { + /* sysname */ + switch (osver.dwPlatformId) { + case VER_PLATFORM_WIN32_WINDOWS: + strcpy(name->sysname, "Windows"); + break; + case VER_PLATFORM_WIN32_NT: + strcpy(name->sysname, "Windows NT"); + break; + case VER_PLATFORM_WIN32s: + strcpy(name->sysname, "Win32s"); + break; + default: + strcpy(name->sysname, "Win32 Unknown"); + break; + } + + /* release */ + sprintf(name->release, "%d.%d", + osver.dwMajorVersion, osver.dwMinorVersion); + + /* version */ + sprintf(name->version, "Build %d", + osver.dwPlatformId == VER_PLATFORM_WIN32_NT + ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff)); + if (osver.szCSDVersion[0]) { + char *buf = name->version + strlen(name->version); + sprintf(buf, " (%s)", osver.szCSDVersion); + } + } + else { + *name->sysname = '\0'; + *name->version = '\0'; + *name->release = '\0'; + } + + /* nodename */ + hep = win32_gethostbyname("localhost"); + if (hep) { + STRLEN len = strlen(hep->h_name); + if (len <= nodemax) { + strcpy(name->nodename, hep->h_name); + } + else { + strncpy(name->nodename, hep->h_name, nodemax); + name->nodename[nodemax] = '\0'; + } + } + else { + DWORD sz = nodemax; + if (!GetComputerName(name->nodename, &sz)) + *name->nodename = '\0'; + } + + /* machine (architecture) */ + { + SYSTEM_INFO info; + char *arch; + GetSystemInfo(&info); + switch (info.wProcessorArchitecture) { + case PROCESSOR_ARCHITECTURE_INTEL: + arch = "x86"; break; + case PROCESSOR_ARCHITECTURE_MIPS: + arch = "mips"; break; + case PROCESSOR_ARCHITECTURE_ALPHA: + arch = "alpha"; break; + case PROCESSOR_ARCHITECTURE_PPC: + arch = "ppc"; break; + default: + arch = "unknown"; break; + } + strcpy(name->machine, arch); + } + return 0; +} + +DllExport int win32_waitpid(int pid, int *status, int flags) { int retval = -1; diff --git a/win32/win32.h b/win32/win32.h index 0b8b710616..a072b875c9 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -83,6 +83,18 @@ struct tms { long tms_cstime; }; +#ifndef SYS_NMLN +#define SYS_NMLN 257 +#endif + +struct utsname { + char sysname[SYS_NMLN]; + char nodename[SYS_NMLN]; + char release[SYS_NMLN]; + char version[SYS_NMLN]; + char machine[SYS_NMLN]; +}; + #ifndef START_EXTERN_C #undef EXTERN_C #ifdef __cplusplus diff --git a/win32/win32iop.h b/win32/win32iop.h index c7a74444e0..a0649b1623 100644 --- a/win32/win32iop.h +++ b/win32/win32iop.h @@ -124,6 +124,7 @@ DllExport unsigned win32_alarm(unsigned int sec); DllExport int win32_stat(const char *path, struct stat *buf); DllExport int win32_ioctl(int i, unsigned int u, char *data); DllExport int win32_utime(const char *f, struct utimbuf *t); +DllExport int win32_uname(struct utsname *n); DllExport int win32_wait(int *status); DllExport int win32_waitpid(int pid, int *status, int flags); DllExport int win32_kill(int pid, int sig); @@ -153,6 +154,7 @@ END_EXTERN_C #undef alarm #undef ioctl #undef utime +#undef uname #undef wait #ifdef __BORLANDC__ @@ -261,6 +263,7 @@ END_EXTERN_C #define alarm win32_alarm #define ioctl win32_ioctl #define utime win32_utime +#define uname win32_uname #define wait win32_wait #define waitpid win32_waitpid #define kill win32_kill |