diff options
Diffstat (limited to 'lib')
151 files changed, 3529 insertions, 2224 deletions
diff --git a/lib/AnyDBM_File.pm b/lib/AnyDBM_File.pm index 9cf9b31834..58ffda768e 100644 --- a/lib/AnyDBM_File.pm +++ b/lib/AnyDBM_File.pm @@ -1,7 +1,7 @@ package AnyDBM_File; -use vars qw(@ISA); -@ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA; +use 5.005_64; +our @ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA; my $mod; for $mod (@ISA) { diff --git a/lib/AutoLoader.pm b/lib/AutoLoader.pm index 4bbcb33e10..d62ceb0587 100644 --- a/lib/AutoLoader.pm +++ b/lib/AutoLoader.pm @@ -1,6 +1,7 @@ package AutoLoader; -# use vars qw(@EXPORT @EXPORT_OK $VERSION); +use 5.005_64; +our(@EXPORT, @EXPORT_OK, $VERSION); my $is_dosish; my $is_vms; diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index feecd58bf1..41d5489531 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -1,17 +1,16 @@ package AutoSplit; +use 5.005_64; use Exporter (); use Config qw(%Config); use Carp qw(carp); use File::Basename (); use File::Path qw(mkpath); use strict; -use vars qw( - $VERSION @ISA @EXPORT @EXPORT_OK - $Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime - ); +our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen, + $CheckForAutoloader, $CheckModTime); -$VERSION = "1.0304"; +$VERSION = "1.0305"; @ISA = qw(Exporter); @EXPORT = qw(&autosplit &autosplit_lib_modules); @EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime); @@ -150,7 +149,7 @@ my $Is_VMS = ($^O eq 'VMS'); # allow checking for valid ': attrlist' attachments my $nested; $nested = qr{ \( (?: (?> [^()]+ ) | (?p{ $nested }) )* \) }x; -my $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) [\s,]* }x; +my $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) (?:\s*\:\s*|\s+(?!\:)) }x; my $attr_list = qr{ \s* : \s* (?: $one_attr )* }x; @@ -353,8 +352,10 @@ EOT } $last_package = $this_package if defined $this_package; } - print OUT @cache,"1;\n# end of $last_package\::$subname\n"; - close(OUT); + if ($subname) { + print OUT @cache,"1;\n# end of $last_package\::$subname\n"; + close(OUT); + } close(IN); if (!$keep){ # don't keep any obsolete *.al files in the directory @@ -467,5 +468,5 @@ package Yet::Another::AutoSplit; sub testtesttesttest4_1 ($) { "another test 4\n"; } sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; } package Yet::More::Attributes; -sub test_a1 ($) : locked { 1; } +sub test_a1 ($) : locked :locked { 1; } sub test_a2 : locked { 1; } diff --git a/lib/Benchmark.pm b/lib/Benchmark.pm index 487ddd5717..3c10a5bc52 100644 --- a/lib/Benchmark.pm +++ b/lib/Benchmark.pm @@ -423,19 +423,19 @@ sub timestr { my @t = @$tr; warn "bad time value (@t)" unless @t==6; my($r, $pu, $ps, $cu, $cs, $n) = @t; - my($pt, $ct, $t) = ($tr->cpu_p, $tr->cpu_c, $tr->cpu_a); + my($pt, $ct, $tt) = ($tr->cpu_p, $tr->cpu_c, $tr->cpu_a); $f = $defaultfmt unless defined $f; # format a time in the required style, other formats may be added here $style ||= $defaultstyle; $style = ($ct>0) ? 'all' : 'noc' if $style eq 'auto'; my $s = "@t $style"; # default for unknown style $s=sprintf("%2d wallclock secs (%$f usr %$f sys + %$f cusr %$f csys = %$f CPU)", - @t,$t) if $style eq 'all'; + $r,$pu,$ps,$cu,$cs,$tt) if $style eq 'all'; $s=sprintf("%2d wallclock secs (%$f usr + %$f sys = %$f CPU)", $r,$pu,$ps,$pt) if $style eq 'noc'; $s=sprintf("%2d wallclock secs (%$f cusr + %$f csys = %$f CPU)", $r,$cu,$cs,$ct) if $style eq 'nop'; - $s .= sprintf(" @ %$f/s (n=$n)", $n / ( $pu + $ps )) if $n; + $s .= sprintf(" @ %$f/s (n=$n)", $n / ( $pu + $ps )) if $n && $pu+$ps; $s; } diff --git a/lib/CGI.pm b/lib/CGI.pm index c0cb5fd518..ad7cd02552 100644 --- a/lib/CGI.pm +++ b/lib/CGI.pm @@ -17,8 +17,8 @@ require 5.004; # The most recent version and complete docs are available at: # http://stein.cshl.org/WWW/software/CGI/ -$CGI::revision = '$Id: CGI.pm,v 1.18 1999/06/09 14:52:45 lstein Exp $'; -$CGI::VERSION='2.53'; +$CGI::revision = '$Id: CGI.pm,v 1.19 1999/08/31 17:04:37 lstein Exp $'; +$CGI::VERSION='2.56'; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. @@ -95,6 +95,8 @@ if ($OS=~/Win/i) { $OS = 'WINDOWS'; } elsif ($OS=~/vms/i) { $OS = 'VMS'; +} elsif ($OS=~/bsdos/i) { + $OS = 'UNIX'; } elsif ($OS=~/dos/i) { $OS = 'DOS'; } elsif ($OS=~/^MacOS$/i) { @@ -453,7 +455,7 @@ sub init { # We now have the query string in hand. We do slightly # different things for keyword lists and parameter lists. - if ($query_string ne '') { + if (defined $query_string && $query_string) { if ($query_string =~ /=/) { $self->parse_params($query_string); } else { @@ -518,7 +520,7 @@ sub cgi_error { # unescape URL-encoded data sub unescape { - shift() if ref($_[0]) || $_[0] eq $DefaultClass; + shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $DefaultClass); my $todecode = shift; return undef unless defined($todecode); $todecode =~ tr/+/ /; # pluses become spaces @@ -532,12 +534,11 @@ sub unescape { # URL-encode data sub escape { - shift() if ref($_[0]) || $_[0] eq $DefaultClass; - my $toencode = shift; - return undef unless defined($toencode); - $toencode=~s/ /+/g; - $toencode=~s/([^a-zA-Z0-9_.+-])/uc sprintf("%%%02x",ord($1))/eg; - return $toencode; + shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $DefaultClass); + my $toencode = shift; + return undef unless defined($toencode); + $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg; + return $toencode; } sub save_request { @@ -851,8 +852,9 @@ END_OF_FUNC # with Steve Brenner's cgi-lib.pl routines 'Vars' => <<'END_OF_FUNC', sub Vars { + my $q = shift; my %in; - tie(%in,CGI); + tie(%in,CGI,$q); return %in if wantarray; return \%in; } @@ -917,7 +919,8 @@ END_OF_FUNC 'TIEHASH' => <<'END_OF_FUNC', sub TIEHASH { - return $Q || new CGI; + return $_[1] if defined $_[1]; + return $Q || new shift; } END_OF_FUNC @@ -1520,7 +1523,8 @@ END_OF_FUNC 'endform' => <<'END_OF_FUNC', sub endform { my($self,@p) = self_or_default(@_); - return ($self->get_fields,"</FORM>"); + return wantarray ? ($self->get_fields,"</FORM>") : + $self->get_fields ."\n</FORM>"; } END_OF_FUNC @@ -2126,7 +2130,7 @@ sub hidden { $name=$self->escapeHTML($name); foreach (@value) { - $_=$self->escapeHTML($_); + $_ = defined($_) ? $self->escapeHTML($_) : ''; push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/); } return wantarray ? @result : join('',@result); @@ -2200,7 +2204,8 @@ sub url { # strip query string substr($script_name,$index) = '' if ($index = index($script_name,'?')) >= 0; # and path - substr($script_name,$index) = '' if $path and ($index = rindex($script_name,$path)) >= 0; + substr($script_name,$index) = '' if exists($ENV{PATH_INFO}) + and ($index = rindex($script_name,$ENV{PATH_INFO})) >= 0; } else { $script_name = $self->script_name; } @@ -2854,7 +2859,7 @@ sub read_multipart { # If no filename specified, then just read the data and assign it # to our parameter list. - unless ($filename) { + if ( !defined($filename) || $filename eq '' ) { my($value) = $buffer->readBody; push(@{$self->{$param}},$value); next; @@ -2877,7 +2882,7 @@ sub read_multipart { for (my $cnt=10;$cnt>0;$cnt--) { next unless $tmpfile = new TempFile($seqno); $tmp = $tmpfile->as_string; - last if $filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES); + last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES)); $seqno += int rand(100); } die "CGI open of tmpfile: $!\n" unless $filehandle; @@ -2895,7 +2900,7 @@ sub read_multipart { # Save some information about the uploaded file where we can get # at it later. - $self->{'.tmpfiles'}->{$filename}= { + $self->{'.tmpfiles'}->{fileno($filehandle)}= { name => $tmpfile, info => {%header}, }; @@ -2918,8 +2923,8 @@ END_OF_FUNC 'tmpFileName' => <<'END_OF_FUNC', sub tmpFileName { my($self,$filename) = self_or_default(@_); - return $self->{'.tmpfiles'}->{$filename}->{name} ? - $self->{'.tmpfiles'}->{$filename}->{name}->as_string + return $self->{'.tmpfiles'}->{fileno($filename)}->{name} ? + $self->{'.tmpfiles'}->{fileno($filename)}->{name}->as_string : ''; } END_OF_FUNC @@ -2927,7 +2932,7 @@ END_OF_FUNC 'uploadInfo' => <<'END_OF_FUNC', sub uploadInfo { my($self,$filename) = self_or_default(@_); - return $self->{'.tmpfiles'}->{$filename}->{info}; + return $self->{'.tmpfiles'}->{fileno($filename)}->{info}; } END_OF_FUNC @@ -2979,7 +2984,7 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; sub asString { my $self = shift; # get rid of package name - (my $i = $$self) =~ s/^\*(\w+::)+//; + (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//; $i =~ s/\\(.)/$1/g; return $i; # BEGIN DEAD CODE @@ -3005,8 +3010,7 @@ END_OF_FUNC sub new { my($pack,$name,$file,$delete) = @_; require Fcntl unless defined &Fcntl::O_RDWR; - ++$FH; - my $ref = \*{'Fh::' . quotemeta($name)}; + my $ref = \*{'Fh::' . ++$FH . quotemeta($name)}; sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return; unlink($file) if $delete; CORE::delete $Fh::{$FH}; @@ -5075,7 +5079,7 @@ Example: $file = $query->upload('uploaded_file'); if (!$file && $query->cgi_error) { - print $query->header(-status->$query->cgi_error); + print $query->header(-status=>$query->cgi_error); exit 0; } @@ -6429,7 +6433,7 @@ for suggestions and bug fixes. -rows=>10, -columns=>50); - print "<P>",$query->Reset; + print "<P>",$query->reset; print $query->submit('Action','Shout'); print $query->submit('Action','Scream'); print $query->endform; diff --git a/lib/CGI/Apache.pm b/lib/CGI/Apache.pm index 82a3669250..dced8664b4 100644 --- a/lib/CGI/Apache.pm +++ b/lib/CGI/Apache.pm @@ -1,103 +1,23 @@ -package CGI::Apache; -use Apache (); -use vars qw(@ISA $VERSION); -require CGI; -@ISA = qw(CGI); - -$VERSION = (qw$Revision: 1.1 $)[1]; -$CGI::DefaultClass = 'CGI::Apache'; -$CGI::Apache::AutoloadClass = 'CGI'; - -sub import { - my $self = shift; - my ($callpack, $callfile, $callline) = caller; - ${"${callpack}::AutoloadClass"} = 'CGI'; -} - -sub new { - my($class) = shift; - my($r) = Apache->request; - %ENV = $r->cgi_env unless defined $ENV{GATEWAY_INTERFACE}; #PerlSetupEnv On - my $self = $class->SUPER::new(@_); - $self->{'.req'} = $r; - $self; -} - -sub header { - my ($self,@rest) = CGI::self_or_default(@_); - my $r = $self->{'.req'}; - $r->basic_http_header; - return CGI::header($self,@rest); -} - -sub print { - my($self,@rest) = CGI::self_or_default(@_); - $self->{'.req'}->print(@rest); -} - -sub read_from_client { - my($self, $fh, $buff, $len, $offset) = @_; - my $r = $self->{'.req'} || Apache->request; - return $r->read($$buff, $len, $offset); -} - -sub new_MultipartBuffer { - my $self = shift; - my $new = CGI::Apache::MultipartBuffer->new($self, @_); - $new->{'.req'} = $self->{'.req'} || Apache->request; - return $new; -} - -package CGI::Apache::MultipartBuffer; -use vars qw(@ISA); -@ISA = qw(MultipartBuffer); - -$CGI::Apache::MultipartBuffer::AutoloadClass = 'MultipartBuffer'; -*CGI::Apache::MultipartBuffer::read_from_client = - \&CGI::Apache::read_from_client; - - +use CGI; 1; - __END__ =head1 NAME -CGI::Apache - Make things work with CGI.pm against Perl-Apache API +CGI::Apache - Backward compatibility module for CGI.pm =head1 SYNOPSIS - require CGI::Apache; - - my $q = new Apache::CGI; +Do not use this module. It is deprecated. - $q->print($q->header); - - #do things just like you do with CGI.pm +=head1 ABSTRACT =head1 DESCRIPTION -When using the Perl-Apache API, your applications are faster, but the -environment is different than CGI. -This module attempts to set-up that environment as best it can. - -=head1 NOTE 1 +=head1 AUTHOR INFORMATION -This module used to be named Apache::CGI. Sorry for the confusion. - -=head1 NOTE 2 - -If you're going to inherit from this class, make sure to "use" it -after your package declaration rather than "require" it. This is -because CGI.pm does a little magic during the import() step in order -to make autoloading work correctly. +=head1 BUGS =head1 SEE ALSO -perl(1), Apache(3), CGI(3) - -=head1 AUTHOR - -Doug MacEachern E<lt>dougm@osf.orgE<gt>, hacked over by Andreas KE<ouml>nig E<lt>a.koenig@mind.deE<gt>, modified by Lincoln Stein <lt>lstein@genome.wi.mit.edu<gt> - =cut diff --git a/lib/CGI/Cookie.pm b/lib/CGI/Cookie.pm index 433df496df..aac0fb0ddc 100644 --- a/lib/CGI/Cookie.pm +++ b/lib/CGI/Cookie.pm @@ -13,9 +13,9 @@ package CGI::Cookie; # wish, but if you redistribute a modified version, please attach a note # listing the modifications you have made. -$CGI::Cookie::VERSION='1.10'; +$CGI::Cookie::VERSION='1.12'; -use CGI; +use CGI qw(-no_debug); use overload '""' => \&as_string, 'cmp' => \&compare, 'fallback'=>1; @@ -97,10 +97,12 @@ sub new { },$class; # IE requires the path and domain to be present for some reason. - $path ||= CGI::url(-absolute=>1); - $domain ||= CGI::virtual_host(); + $path = CGI::url(-absolute=>1) unless defined $path; +# however, this breaks networks which use host tables without fully qualified +# names, so we comment it out. +# $domain = CGI::virtual_host() unless defined $domain; - $self->path($path) if defined $path; + $self->path($path) if defined $path; $self->domain($domain) if defined $domain; $self->secure($secure) if defined $secure; $self->expires($expires) if defined $expires; @@ -250,8 +252,8 @@ against your script's URL before returning the cookie. For example, if you specify the path "/cgi-bin", then the cookie will be returned to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and "/cgi-bin/customer_service/complain.pl", but not to the script -"/cgi-private/site_admin.pl". By default, the path is set to the -directory that contains your script. +"/cgi-private/site_admin.pl". By default, the path is set to your +script, so that only it will receive the cookie. =item B<4. secure flag> diff --git a/lib/CGI/Pretty.pm b/lib/CGI/Pretty.pm index f8931fb16e..4f2eed4ce9 100644 --- a/lib/CGI/Pretty.pm +++ b/lib/CGI/Pretty.pm @@ -7,28 +7,63 @@ package CGI::Pretty; # documentation in manual or html file format (these utilities are part of the # Perl 5 distribution). +use strict; use CGI (); -$VERSION = '1.0'; +$CGI::Pretty::VERSION = '1.03'; $CGI::DefaultClass = __PACKAGE__; -$AutoloadClass = 'CGI'; -@ISA = 'CGI'; +$CGI::Pretty::AutoloadClass = 'CGI'; +@CGI::Pretty::ISA = qw( CGI ); -# These tags should not be prettify'd. If we did prettify them, the -# browser would output text that would have extraneous spaces -@AS_IS = qw( A PRE ); -my $NON_PRETTIFY_ENDTAGS = join "", map { "</$_>" } @AS_IS; +initialize_globals(); + +sub _prettyPrint { + my $input = shift; + + foreach my $i ( @CGI::Pretty::AS_IS ) { + if ( $$input =~ /<\/$i>/si ) { + my ( $a, $b, $c, $d, $e ) = $$input =~ /(.*)<$i(\s?)(.*?)>(.*?)<\/$i>(.*)/si; + _prettyPrint( \$a ); + _prettyPrint( \$e ); + + $$input = "$a<$i$b$c>$d</$i>$e"; + return; + } + } + $$input =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g; +} + +sub comment { + my($self,@p) = CGI::self_or_CGI(@_); + + my $s = "@p"; + $s =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g; + + return $self->SUPER::comment( "$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT$s$CGI::Pretty::LINEBREAK" ) . $CGI::Pretty::LINEBREAK; +} sub _make_tag_func { my ($self,$tagname) = @_; return $self->SUPER::_make_tag_func($tagname) if $tagname=~/^(start|end)_/; + # As Lincoln as noted, the last else clause is VERY hairy, and it + # took me a while to figure out what I was trying to do. + # What it does is look for tags that shouldn't be indented (e.g. PRE) + # and makes sure that when we nest tags, those tags don't get + # indented. + # For an example, try print td( pre( "hello\nworld" ) ); + # If we didn't care about stuff like that, the code would be + # MUCH simpler. BTW: I won't claim to be a regular expression + # guru, so if anybody wants to contribute something that would + # be quicker, easier to read, etc, I would be more than + # willing to put it in - Brian + return qq{ sub $tagname { # handle various cases in which we're called # most of this bizarre stuff is to avoid -w errors shift if \$_[0] && -# (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) || + (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) || (ref(\$_[0]) && (substr(ref(\$_[0]),0,3) eq 'CGI' || UNIVERSAL::isa(\$_[0],'CGI'))); @@ -43,58 +78,64 @@ sub _make_tag_func { return \$tag unless \@_; my \@result; - if ( "$NON_PRETTIFY_ENDTAGS" =~ /\$untag/ ) { - \@result = map { "\$tag\$_\$untag\\n" } + my \$NON_PRETTIFY_ENDTAGS = join "", map { "</\$_>" } \@CGI::Pretty::AS_IS; + + if ( \$NON_PRETTIFY_ENDTAGS =~ /\$untag/ ) { + \@result = map { "\$tag\$_\$untag\$CGI::Pretty::LINEBREAK" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_"; } else { \@result = map { chomp; if ( \$_ !~ /<\\// ) { - s/\\n/\\n /g; + s/\$CGI::Pretty::LINEBREAK/\$CGI::Pretty::LINEBREAK\$CGI::Pretty::INDENT/g; } else { - my \$text = ""; - my ( \$pretag, \$thistag, \$posttag ); - while ( /<\\/.*>/si ) { - if ( (\$pretag, \$thistag, \$posttag ) = - /(.*?)<(.*?)>(.*)/si ) { - \$pretag =~ s/\\n/\\n /g; - \$text .= "\$pretag<\$thistag>"; - - ( \$thistag ) = split ' ', \$thistag; - my \$endtag = "</" . uc(\$thistag) . ">"; - if ( "$NON_PRETTIFY_ENDTAGS" =~ /\$endtag/ ) { - if ( ( \$pretag, \$posttag ) = - \$posttag =~ /(.*?)\$endtag(.*)/si ) { - \$text .= "\$pretag\$endtag"; - } - } - - \$_ = \$posttag; - } - } - \$_ = \$text; - if ( defined \$posttag ) { - \$posttag =~ s/\\n/\\n /g; - \$_ .= \$posttag; - } + my \$tmp = \$_; + CGI::Pretty::_prettyPrint( \\\$tmp ); + \$_ = \$tmp; } - "\$tag\\n \$_\\n\$untag\\n" } + "\$tag\$CGI::Pretty::LINEBREAK\$CGI::Pretty::INDENT\$_\$CGI::Pretty::LINEBREAK\$untag\$CGI::Pretty::LINEBREAK" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_"; } + local \$" = ""; return "\@result"; } }; } +sub start_html { + return CGI::start_html( @_ ) . $CGI::Pretty::LINEBREAK; +} + +sub end_html { + return CGI::end_html( @_ ) . $CGI::Pretty::LINEBREAK; +} + sub new { my $class = shift; my $this = $class->SUPER::new( @_ ); + Apache->request->register_cleanup(\&CGI::Pretty::_reset_globals) if ($CGI::MOD_PERL); + $class->_reset_globals if $CGI::PERLEX; + return bless $this, $class; } +sub initialize_globals { + # This is the string used for indentation of tags + $CGI::Pretty::INDENT = "\t"; + + # This is the string used for seperation between tags + $CGI::Pretty::LINEBREAK = "\n"; + + # These tags are not prettify'd. + @CGI::Pretty::AS_IS = qw( A PRE CODE SCRIPT TEXTAREA ); + + 1; +} +sub _reset_globals { initialize_globals(); } + 1; =head1 NAME @@ -148,22 +189,43 @@ the list of tags that are not to be touched, push them onto the C<@AS_IS> array: push @CGI::Pretty::AS_IS,qw(CODE XMP); +=head2 Customizing the Indenting + +If you wish to have your own personal style of indenting, you can change the +C<$INDENT> variable: + + $CGI::Pretty::INDENT = "\t\t"; + +would cause the indents to be two tabs. + +Similarly, if you wish to have more space between lines, you may change the +C<$LINEBREAK> variable: + + $CGI::Pretty::LINEBREAK = "\n\n"; + +would create two carriage returns between lines. + +If you decide you want to use the regular CGI indenting, you can easily do +the following: + + $CGI::Pretty::INDENT = $CGI::Pretty::LINEBREAK = ""; + =head1 BUGS This section intentionally left blank. =head1 AUTHOR -Brian Paulsen <bpaulsen@lehman.com>, with minor modifications by +Brian Paulsen <Brian@ThePaulsens.com>, with minor modifications by Lincoln Stein <lstein@cshl.org> for incorporation into the CGI.pm distribution. -Copyright 1998, Brian Paulsen. All rights reserved. +Copyright 1999, Brian Paulsen. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -Bug reports and comments to bpaulsen@lehman.com. You can also write +Bug reports and comments to Brian@ThePaulsens.com. You can also write to lstein@cshl.org, but this code looks pretty hairy to me and I'm not sure I understand it! @@ -172,4 +234,3 @@ sure I understand it! L<CGI> =cut - diff --git a/lib/CGI/Switch.pm b/lib/CGI/Switch.pm index 8afc6a6cb3..b16b9c0658 100644 --- a/lib/CGI/Switch.pm +++ b/lib/CGI/Switch.pm @@ -1,71 +1,24 @@ -package CGI::Switch; -use Carp; -use strict; -use vars qw($VERSION @Pref); -$VERSION = '0.06'; -@Pref = qw(CGI::Apache CGI); #default - -sub import { - my($self,@arg) = @_; - @Pref = @arg if @arg; -} - -sub new { - shift; - my($file,$pack); - for $pack (@Pref) { - ($file = $pack) =~ s|::|/|g; - eval { require "$file.pm"; }; - if ($@) { -#XXX warn $@; - next; - } else { -#XXX warn "Going to try $pack\->new\n"; - my $obj; - eval {$obj = $pack->new(@_)}; - if ($@) { -#XXX warn $@; - } else { - return $obj; - } - } - } - Carp::croak "Couldn't load+construct any of @Pref\n"; -} - +use CGI; 1; + __END__ =head1 NAME -CGI::Switch - Try more than one constructors and return the first object available +CGI::Switch - Backward compatibility module for defunct CGI::Switch =head1 SYNOPSIS - - use CGISwitch; - - -or- +Do not use this module. It is deprecated. - use CGI::Switch This, That, CGI::XA, Foo, Bar, CGI; - - my $q = new CGI::Switch; +=head1 ABSTRACT =head1 DESCRIPTION -Per default the new() method tries to call new() in the three packages -Apache::CGI, CGI::XA, and CGI. It returns the first CGI object it -succeeds with. +=head1 AUTHOR INFORMATION -The import method allows you to set up the default order of the -modules to be tested. +=head1 BUGS =head1 SEE ALSO -perl(1), Apache(3), CGI(3), CGI::XA(3) - -=head1 AUTHOR - -Andreas KE<ouml>nig E<lt>a.koenig@mind.deE<gt> - =cut diff --git a/lib/CPAN.pm b/lib/CPAN.pm index 2f22b773c7..bbebf6fe81 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -6,13 +6,13 @@ use vars qw{$Try_autoload $Frontend $Defaultsite }; #}; -$VERSION = '1.50'; +$VERSION = '1.52'; -# $Id: CPAN.pm,v 1.264 1999/05/23 14:26:49 k Exp $ +# $Id: CPAN.pm,v 1.276 2000/01/08 15:29:46 k Exp $ # only used during development: $Revision = ""; -# $Revision = "[".substr(q$Revision: 1.264 $, 10)."]"; +# $Revision = "[".substr(q$Revision: 1.276 $, 10)."]"; use Carp (); use Config (); @@ -61,7 +61,7 @@ use strict qw(vars); @CPAN::ISA = qw(CPAN::Debug Exporter); @EXPORT = qw( - autobundle bundle expand force get + autobundle bundle expand force get cvs_import install make readme recompile shell test clean ); @@ -90,7 +90,7 @@ sub AUTOLOAD { #-> sub CPAN::shell ; sub shell { my($self) = @_; - $Suppress_readline ||= ! -t STDIN; + $Suppress_readline = ! -t STDIN unless defined $Suppress_readline; CPAN::Config->load unless $CPAN::Config_loaded++; my $prompt = "cpan> "; @@ -113,6 +113,12 @@ sub shell { $readline::rl_completion_function = $readline::rl_completion_function = 'CPAN::Complete::cpl'; } + # $term->OUT is autoflushed anyway + my $odef = select STDERR; + $| = 1; + select STDOUT; + $| = 1; + select $odef; } no strict; @@ -120,7 +126,8 @@ sub shell { my $getcwd; $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; my $cwd = CPAN->$getcwd(); - my $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub"; + my $try_detect_readline; + $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term; my $rl_avail = $Suppress_readline ? "suppressed" : ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : "available (try ``install Bundle::CPAN'')"; @@ -190,7 +197,8 @@ ReadLine support $rl_avail my $redef; local($SIG{__WARN__}) = CPAN::Shell::dotdot_onreload(\$redef); require Term::ReadLine; - $CPAN::Frontend->myprint("\n$redef subroutines in Term::ReadLine redefined\n"); + $CPAN::Frontend->myprint("\n$redef subroutines in ". + "Term::ReadLine redefined\n"); goto &shell; } } @@ -575,7 +583,7 @@ Please make sure the directory exists and is writable. } my $fh; unless ($fh = FileHandle->new(">$lockfile")) { - if ($! =~ /Permission/ || $!{EACCES}) { + if ($! =~ /Permission/) { my $incc = $INC{'CPAN/Config.pm'}; my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm'); $CPAN::Frontend->myprint(qq{ @@ -613,6 +621,27 @@ or print "Caught SIGINT\n"; $Signal++; }; + +# From: Larry Wall <larry@wall.org> +# Subject: Re: deprecating SIGDIE +# To: perl5-porters@perl.org +# Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT) +# +# The original intent of __DIE__ was only to allow you to substitute one +# kind of death for another on an application-wide basis without respect +# to whether you were in an eval or not. As a global backstop, it should +# not be used any more lightly (or any more heavily :-) than class +# UNIVERSAL. Any attempt to build a general exception model on it should +# be politely squashed. Any bug that causes every eval {} to have to be +# modified should be not so politely squashed. +# +# Those are my current opinions. It is also my optinion that polite +# arguments degenerate to personal arguments far too frequently, and that +# when they do, it's because both people wanted it to, or at least didn't +# sufficiently want it not to. +# +# Larry + $SIG{'__DIE__'} = \&cleanup; $self->debug("Signal handler set.") if $CPAN::DEBUG; } @@ -817,7 +846,7 @@ sub disk_usage { if ($^O eq 'MacOS') { require Mac::Files; my $cat = Mac::Files::FSpGetCatInfo($_); - $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen(); + $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat; } else { $Du += (-s _); } @@ -1136,7 +1165,8 @@ Known options: commit commit session changes to disk init go through a dialog to set all parameters -You may edit key values in the follow fashion: +You may edit key values in the follow fashion (the "o" is a literal +letter o): o conf build_cache 15 @@ -1182,29 +1212,29 @@ sub h { $CPAN::Frontend->myprint("Detailed help not yet implemented\n"); } else { $CPAN::Frontend->myprint(q{ -command arguments description -a string authors -b or display bundles -d /regex/ info distributions -m or about modules -i none anything of above - -r as reinstall recommendations -u above uninstalled distributions -See manpage for autobundle, recompile, force, look, etc. - -make make -test modules, make test (implies make) -install dists, bundles, make install (implies test) -clean "r" or "u" make clean -readme display the README file - -reload index|cpan load most recent indices/CPAN.pm -h or ? display this menu -o various set and query options -! perl-code eval a perl command -q quit the shell subroutine -}); +Display Information + a authors + b string display bundles + d or info distributions + m /regex/ about modules + i or anything of above + r none reinstall recommendations + u uninstalled distributions + +Download, Test, Make, Install... + get download + make make (implies get) + test modules, make test (implies make) + install dists, bundles make install (implies test) + clean make clean + look open subshell in these dists' directories + readme display these dists' README files + +Other + h,? display this menu ! perl-code eval a perl command + o conf [opt] set and query options q quit the cpan shell + reload cpan load CPAN.pm again reload index load newer indices + autobundle Snapshot force cmd unconditionally do cmd}); } } @@ -1326,10 +1356,13 @@ sub o { } } } else { - $CPAN::Frontend->myprint("Valid options for debug are ". - join(", ",sort(keys %CPAN::DEBUG), 'all'). - qq{ or a number. Completion works on the options. }. - qq{Case is ignored.\n\n}); + my $raw = "Valid options for debug are ". + join(", ",sort(keys %CPAN::DEBUG), 'all'). + qq{ or a number. Completion works on the options. }. + qq{Case is ignored.}; + require Text::Wrap; + $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw)); + $CPAN::Frontend->myprint("\n\n"); } if ($CPAN::DEBUG) { $CPAN::Frontend->myprint("Options set for debugging:\n"); @@ -1595,21 +1628,34 @@ sub expand { my $class = "CPAN::$type"; my $obj; if (defined $regex) { - for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all_objects($class)) { - push @m, $obj - if - $obj->id =~ /$regex/i - or + for $obj ( + sort + {$a->id cmp $b->id} + $CPAN::META->all_objects($class) + ) { + unless ($obj->id){ + # BUG, we got an empty object somewhere + CPAN->debug(sprintf( + "Empty id on obj[%s]%%[%s]", + $obj, + join(":", %$obj) + )) if $CPAN::DEBUG; + next; + } + push @m, $obj + if $obj->id =~ /$regex/i + or ( ( - $] < 5.00303 ### provide sort of compatibility with 5.003 + $] < 5.00303 ### provide sort of + ### compatibility with 5.003 || $obj->can('name') ) && $obj->name =~ /$regex/i ); - } + } } else { my($xarg) = $arg; if ( $type eq 'Bundle' ) { @@ -1703,6 +1749,15 @@ sub mydie { die "\n"; } +sub setup_output { + return if -t STDOUT; + my $odef = select STDERR; + $| = 1; + select STDOUT; + $| = 1; + select $odef; +} + #-> sub CPAN::Shell::rematein ; # RE-adme||MA-ke||TE-st||IN-stall sub rematein { @@ -1713,6 +1768,7 @@ sub rematein { $pragma = $meth; $meth = shift @some; } + setup_output(); CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG; my($s,@s); foreach $s (@some) { @@ -1789,6 +1845,8 @@ sub install { shift->rematein('install',@_); } sub clean { shift->rematein('clean',@_); } #-> sub CPAN::Shell::look ; sub look { shift->rematein('look',@_); } +#-> sub CPAN::Shell::cvs_import ; +sub cvs_import { shift->rematein('cvs_import',@_); } package CPAN::FTP; @@ -1965,6 +2023,9 @@ sub localize { my $ret = $self->$method(\@host_seq,$file,$aslocal); if ($ret) { $Themethod = $level; + my $now = time; + # utime $now, $now, $aslocal; # too bad, if we do that, we + # might alter a local mirror $self->debug("level[$level]") if $CPAN::DEBUG; return $ret; } else { @@ -2045,6 +2106,9 @@ sub hosteasy { my $res = $Ua->mirror($url, $aslocal); if ($res->is_success) { $Thesite = $i; + my $now = time; + utime $now, $now, $aslocal; # download time is more + # important than upload time return $aslocal; } elsif ($url !~ /\.gz$/) { my $gzurl = "$url.gz"; @@ -2119,8 +2183,8 @@ sub hosthard { HOSTHARD: for $i (@$host_seq) { my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite; unless ($self->is_reachable($url)) { - $CPAN::Frontend->myprint("Skipping $url (not reachable)\n"); - next; + $CPAN::Frontend->myprint("Skipping $url (not reachable)\n"); + next; } $url .= "/" unless substr($url,-1) eq "/"; $url .= $file; @@ -2130,90 +2194,107 @@ sub hosthard { # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { # to if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) { - # proto not yet used - ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4); + # proto not yet used + ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4); } else { - next HOSTHARD; # who said, we could ftp anything except ftp? + next HOSTHARD; # who said, we could ftp anything except ftp? } + $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG; my($f,$funkyftp); for $f ('lynx','ncftpget','ncftp') { - next unless exists $CPAN::Config->{$f}; - $funkyftp = $CPAN::Config->{$f}; - next unless defined $funkyftp; - next if $funkyftp =~ /^\s*$/; - my($want_compressed); - my $aslocal_uncompressed; - ($aslocal_uncompressed = $aslocal) =~ s/\.gz//; - my($source_switch) = ""; - $source_switch = " -source" if $funkyftp =~ /\blynx$/; - $source_switch = " -c" if $funkyftp =~ /\bncftp$/; - $CPAN::Frontend->myprint( - qq[ + next unless exists $CPAN::Config->{$f}; + $funkyftp = $CPAN::Config->{$f}; + next unless defined $funkyftp; + next if $funkyftp =~ /^\s*$/; + my($want_compressed); + my $aslocal_uncompressed; + ($aslocal_uncompressed = $aslocal) =~ s/\.gz//; + my($source_switch) = ""; + if ($f eq "lynx"){ + $source_switch = " -source"; + } elsif ($f eq "ncftp"){ + $source_switch = " -c"; + } + my($chdir) = ""; + my($stdout_redir) = " > $aslocal_uncompressed"; + if ($f eq "ncftpget"){ + $chdir = "cd $aslocal_dir && "; + $stdout_redir = ""; + } + $CPAN::Frontend->myprint( + qq[ Trying with "$funkyftp$source_switch" to get $url ]); - my($system) = "$funkyftp$source_switch '$url' $devnull > ". - "$aslocal_uncompressed"; + my($system) = + "$chdir$funkyftp$source_switch '$url' $devnull$stdout_redir"; + $self->debug("system[$system]") if $CPAN::DEBUG; + my($wstatus); + if (($wstatus = system($system)) == 0 + && + ($f eq "lynx" ? + -s $aslocal_uncompressed # lynx returns 0 on my + # system even if it fails + : 1 + ) + ) { + if (-s $aslocal) { + # Looks good + } elsif ($aslocal_uncompressed ne $aslocal) { + # test gzip integrity + if ( + CPAN::Tarzip->gtest($aslocal_uncompressed) + ) { + rename $aslocal_uncompressed, $aslocal; + } else { + CPAN::Tarzip->gzip($aslocal_uncompressed, + "$aslocal_uncompressed.gz"); + } + } + $Thesite = $i; + return $aslocal; + } elsif ($url !~ /\.gz$/) { + unlink $aslocal_uncompressed if + -f $aslocal_uncompressed && -s _ == 0; + my $gz = "$aslocal.gz"; + my $gzurl = "$url.gz"; + $CPAN::Frontend->myprint( + qq[ +Trying with "$funkyftp$source_switch" to get + $url.gz +]); + my($system) = "$funkyftp$source_switch '$url.gz' $devnull > ". + "$aslocal_uncompressed.gz"; $self->debug("system[$system]") if $CPAN::DEBUG; my($wstatus); if (($wstatus = system($system)) == 0 && - -s $aslocal_uncompressed # lynx returns 0 on my - # system even if it fails + -s "$aslocal_uncompressed.gz" ) { - if ($aslocal_uncompressed ne $aslocal) { - # test gzip integrity - if ( - CPAN::Tarzip->gtest($aslocal_uncompressed) - ) { - rename $aslocal_uncompressed, $aslocal; - } else { - CPAN::Tarzip->gzip($aslocal_uncompressed, - "$aslocal_uncompressed.gz"); - } - } - $Thesite = $i; - return $aslocal; - } elsif ($url !~ /\.gz$/) { - unlink $aslocal_uncompressed if - -f $aslocal_uncompressed && -s _ == 0; - my $gz = "$aslocal.gz"; - my $gzurl = "$url.gz"; - $CPAN::Frontend->myprint( - qq[ -Trying with "$funkyftp$source_switch" to get - $url.gz -]); - my($system) = "$funkyftp$source_switch '$url.gz' $devnull > ". - "$aslocal_uncompressed.gz"; - $self->debug("system[$system]") if $CPAN::DEBUG; - my($wstatus); - if (($wstatus = system($system)) == 0 - && - -s "$aslocal_uncompressed.gz" - ) { - # test gzip integrity - if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) { - CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz", - $aslocal); - } else { - rename $aslocal_uncompressed, $aslocal; - } - $Thesite = $i; - return $aslocal; + # test gzip integrity + if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) { + CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz", + $aslocal); } else { - unlink "$aslocal_uncompressed.gz" if - -f "$aslocal_uncompressed.gz"; + rename $aslocal_uncompressed, $aslocal; } + $Thesite = $i; + return $aslocal; } else { - my $estatus = $wstatus >> 8; - my $size = -f $aslocal ? ", left\n$aslocal with size ".-s _ : ""; - $CPAN::Frontend->myprint(qq{ + unlink "$aslocal_uncompressed.gz" if + -f "$aslocal_uncompressed.gz"; + } + } else { + my $estatus = $wstatus >> 8; + my $size = -f $aslocal ? + ", left\n$aslocal with size ".-s _ : + "\nWarning: expected file [$aslocal] doesn't exist"; + $CPAN::Frontend->myprint(qq{ System call "$system" returned status $estatus (wstat $wstatus)$size }); - } + } } } } @@ -2241,12 +2322,12 @@ sub hosthardest { next; } my($host,$dir,$getfile) = ($1,$2,$3); - my($netrcfile,$fh); my $timestamp = 0; my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime, $ctime,$blksize,$blocks) = stat($aslocal); $timestamp = $mtime ||= 0; my($netrc) = CPAN::FTP::netrc->new; + my($netrcfile) = $netrc->netrc; my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : ""; my $targetfile = File::Basename::basename($aslocal); my(@dialog); @@ -2259,7 +2340,7 @@ sub hosthardest { "get $getfile $targetfile", "quit" ); - if (! $netrc->netrc) { + if (! $netrcfile) { CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG; } elsif ($netrc->hasdefault || $netrc->contains($host)) { CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]", @@ -2496,10 +2577,10 @@ sub cpl { /^$word/, sort qw( ! a b d h i m o q r u autobundle clean - make test install force reload look + make test install force reload look cvs_import ) ); - } elsif ( $line !~ /^[\!abdhimorutl]/ ) { + } elsif ( $line !~ /^[\!abcdhimorutl]/ ) { @return = (); } elsif ($line =~ /^a\s/) { @return = cplx('CPAN::Author',$word); @@ -2507,7 +2588,7 @@ sub cpl { @return = cplx('CPAN::Bundle',$word); } elsif ($line =~ /^d\s/) { @return = cplx('CPAN::Distribution',$word); - } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look)\s/ ) { + } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look|cvs_import)\s/ ) { @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word)); } elsif ($line =~ /^i\s/) { @return = cpl_any($word); @@ -2589,6 +2670,11 @@ sub reload { } return if $last_time + $CPAN::Config->{index_expire}*86400 > $time and ! $force; + ## IFF we are developing, it helps to wipe out the memory between + ## reloads, otherwise it is not what a user expects. + + ## undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274) + ## $CPAN::META = CPAN->new; my($debug,$t2); $last_time = $time; @@ -2708,7 +2794,7 @@ sub rd_modpacks { my($mod,$version,$dist) = split; ### $version =~ s/^\+//; - # if it is a bundle, instatiate a bundle object + # if it is a bundle, instantiate a bundle object my($bundle,$id,$userid); if ($mod eq 'CPAN' && @@ -2721,6 +2807,7 @@ sub rd_modpacks { if ($version > $CPAN::VERSION){ $CPAN::Frontend->myprint(qq{ There\'s a new CPAN.pm version (v$version) available! + [Current version is v$CPAN::VERSION] You might want to try install Bundle::CPAN reload cpan @@ -2764,12 +2851,20 @@ sub rd_modpacks { } # instantiate a distribution object - unless ($CPAN::META->exists('CPAN::Distribution',$dist)) { - $CPAN::META->instance( - 'CPAN::Distribution' => $dist - )->set( - 'CPAN_USERID' => $userid - ); + if ($CPAN::META->exists('CPAN::Distribution',$dist)) { + # we do not need CONTAINSMODS unless we do something with + # this dist, so we better produce it on demand. + + ## my $obj = $CPAN::META->instance( + ## 'CPAN::Distribution' => $dist + ## ); + ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental + } else { + $CPAN::META->instance( + 'CPAN::Distribution' => $dist + )->set( + 'CPAN_USERID' => $userid + ); } return if $CPAN::Signal; @@ -2862,9 +2957,15 @@ sub as_string { $extra .= ")"; } if (ref($self->{$_}) eq "ARRAY") { # language interface? XXX - push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra; + push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra; + } elsif (ref($self->{$_}) eq "HASH") { + push @m, sprintf( + " %-12s %s%s\n", + $_, + join(" ",keys %{$self->{$_}}), + $extra); } else { - push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra; + push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra; } } join "", @m, "\n"; @@ -2909,6 +3010,25 @@ sub email { shift->{'EMAIL'} } package CPAN::Distribution; +#-> sub CPAN::Distribution::as_string ; +sub as_string { + my $self = shift; + $self->containsmods; + $self->SUPER::as_string(@_); +} + +#-> sub CPAN::Distribution::containsmods ; +sub containsmods { + my $self = shift; + return if exists $self->{CONTAINSMODS}; + for my $mod ($CPAN::META->all_objects("CPAN::Module")) { + my $mod_file = $mod->{CPAN_FILE} or next; + my $dist_id = $self->{ID} or next; + my $mod_id = $mod->{ID} or next; + $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id; + } +} + #-> sub CPAN::Distribution::called_for ; sub called_for { my($self,$id) = @_; @@ -3114,6 +3234,44 @@ Please define it with "o conf shell <your shell>" chdir($pwd); } +sub cvs_import { + my($self) = @_; + $self->get; + my $dir = $self->dir; + + my $package = $self->called_for; + my $module = $CPAN::META->instance('CPAN::Module', $package); + my $version = $module->cpan_version; + + my $userid = $self->{CPAN_USERID}; + + my $cvs_dir = (split '/', $dir)[-1]; + $cvs_dir =~ s/-\d+[^-]+$//; + my $cvs_root = + $CPAN::Config->{cvsroot} || $ENV{CVSROOT}; + my $cvs_site_perl = + $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL}; + if ($cvs_site_perl) { + $cvs_dir = "$cvs_site_perl/$cvs_dir"; + } + my $cvs_log = qq{"imported $package $version sources"}; + $version =~ s/\./_/g; + my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log, + "$cvs_dir", $userid, "v$version"); + + my $getcwd; + $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; + my $pwd = CPAN->$getcwd(); + chdir($dir); + + $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); + + $CPAN::Frontend->myprint(qq{@cmd\n}); + system(@cmd) == 0 or + $CPAN::Frontend->mydie("cvs import failed"); + chdir($pwd); +} + #-> sub CPAN::Distribution::readme ; sub readme { my($self) = @_; @@ -3325,8 +3483,7 @@ sub perl { $perl ||= $candidate if MM->maybe_command($candidate); unless ($perl) { my ($component,$perl_name); - DIST_PERLNAME: - foreach $perl_name ($^X, 'perl', 'perl5', "perl$Config::Config{version}") { + DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") { PATH_COMPONENT: foreach $component (MM->path(), $Config::Config{'binexp'}) { next unless defined($component) && $component; @@ -3706,13 +3863,14 @@ sub contains { my $fh = FileHandle->new; local $/ = "\n"; open($fh,$parsefile) or die "Could not open '$parsefile': $!"; - my $inpod = 0; + my $in_cont = 0; $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG; while (<$fh>) { - $inpod = m/^=(?!head1\s+CONTENTS)/ ? 0 : - m/^=head1\s+CONTENTS/ ? 1 : $inpod; - next unless $inpod; + $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 : + m/^=head1\s+CONTENTS/ ? 1 : $in_cont; + next unless $in_cont; next if /^=/; + s/\#.*//; next if /^\s+$/; chomp; push @result, (split " ", $_, 2)[0]; @@ -3758,7 +3916,7 @@ sub find_bundle_file { $what2 =~ s/:Bundle://; $what2 =~ tr|:|/|; } else { - $what2 =~ s|Bundle/||; + $what2 =~ s|Bundle[/\\]||; } my $bu; while (<$fh>) { @@ -3824,13 +3982,19 @@ explicitly a file $s. # recap with less noise if ( $meth eq "install") { if (%fail) { - $CPAN::Frontend->myprint(qq{\nBundle summary: }. - qq{The following items seem to }. - qq{have had installation problems:\n}); + require Text::Wrap; + my $raw = sprintf(qq{Bundle summary: +The following items in bundle %s had installation problems:}, + $self->id + ); + $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw)); + $CPAN::Frontend->myprint("\n"); + my $paragraph = ""; for $s ($self->contains) { - $CPAN::Frontend->myprint( "$s " ) if $fail{$s}; + $paragraph .= "$s " if $fail{$s}; } - $CPAN::Frontend->myprint(qq{\n}); + $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph)); + $CPAN::Frontend->myprint("\n"); } else { $self->{'install'} = 'YES'; } @@ -4060,6 +4224,8 @@ sub rematein { sub readme { shift->rematein('readme') } #-> sub CPAN::Module::look ; sub look { shift->rematein('look') } +#-> sub CPAN::Module::cvs_import ; +sub cvs_import { shift->rematein('cvs_import') } #-> sub CPAN::Module::get ; sub get { shift->rematein('get',@_); } #-> sub CPAN::Module::make ; @@ -4140,7 +4306,7 @@ sub inst_version { local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38; # warn "HERE"; my $have = MM->parse_version($parsefile) || "undef"; - $have =~ s/\s+//g; + $have =~ s/\s*//g; # stringify to float around floating point issues $have; } @@ -4251,7 +4417,7 @@ sub DESTROY { $gz->gzclose(); } else { my $fh = $self->{FH}; - $fh->close; + $fh->close if defined $fh; } undef $self; } @@ -4262,29 +4428,30 @@ sub untar { if (MM->maybe_command($CPAN::Config->{'gzip'}) && MM->maybe_command($CPAN::Config->{'tar'})) { - if ($^O =~ /win/i) { # irgggh - # people find the most curious tar binaries that cannot handle - # pipes - my $system = "$CPAN::Config->{'gzip'} --decompress $file"; - if (system($system)==0) { - $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n}); - } else { - $CPAN::Frontend->mydie( - qq{Couldn\'t uncompress $file\n} - ); - } - $file =~ s/\.gz$//; - $system = "$CPAN::Config->{tar} xvf $file"; - if (system($system)==0) { - $CPAN::Frontend->myprint(qq{Untarred $file successfully\n}); - } else { - $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n}); - } - return 1; + my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " . + "< $file | $CPAN::Config->{tar} xvf -"; + if (system($system) != 0) { + # people find the most curious tar binaries that cannot handle + # pipes + my $system = "$CPAN::Config->{'gzip'} --decompress $file"; + if (system($system)==0) { + $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n}); + } else { + $CPAN::Frontend->mydie( + qq{Couldn\'t uncompress $file\n} + ); + } + $file =~ s/\.gz$//; + $system = "$CPAN::Config->{tar} xvf $file"; + $CPAN::Frontend->myprint(qq{Using Tar:$system:\n}); + if (system($system)==0) { + $CPAN::Frontend->myprint(qq{Untarred $file successfully\n}); + } else { + $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n}); + } + return 1; } else { - my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " . - "< $file | $CPAN::Config->{tar} xvf -"; - return system($system) == 0; + return 1; } } elsif ($CPAN::META->has_inst("Archive::Tar") && @@ -4340,8 +4507,8 @@ Modules are fetched from one or more of the mirrored CPAN directory. The CPAN module also supports the concept of named and versioned -'bundles' of modules. Bundles simplify the handling of sets of -related modules. See BUNDLES below. +I<bundles> of modules. Bundles simplify the handling of sets of +related modules. See Bundles below. The package contains a session manager and a cache manager. There is no status retained between sessions. The session manager keeps track @@ -4392,29 +4559,14 @@ objects. The parser recognizes a regular expression only if you enclose it between two slashes. The principle is that the number of found objects influences how an -item is displayed. If the search finds one item, the result is displayed -as object-E<gt>as_string, but if we find more than one, we display -each as object-E<gt>as_glimpse. E.g. - - cpan> a ANDK - Author id = ANDK - EMAIL a.koenig@franz.ww.TU-Berlin.DE - FULLNAME Andreas König - - - cpan> a /andk/ - Author id = ANDK - EMAIL a.koenig@franz.ww.TU-Berlin.DE - FULLNAME Andreas König - - - cpan> a /and.*rt/ - Author ANDYD (Andy Dougherty) - Author MERLYN (Randal L. Schwartz) +item is displayed. If the search finds one item, the result is +displayed with the rather verbose method C<as_string>, but if we find +more than one, we display each object with the terse method +<as_glimpse>. =item make, test, install, clean modules or distributions -These commands take any number of arguments and investigates what is +These commands take any number of arguments and investigate what is necessary to perform the action. If the argument is a distribution file name (recognized by embedded slashes), it is processed. If it is a module, CPAN determines the distribution file in which this module @@ -4456,12 +4608,11 @@ A C<clean> command results in a being executed within the distribution file's working directory. -=item readme, look module or distribution +=item get, readme, look module or distribution -These two commands take only one argument, be it a module or a -distribution file. C<readme> unconditionally runs, displaying the -README of the associated distribution file. C<Look> gets and -untars (if not yet done) the distribution file, changes to the +C<get> downloads a distribution file without further action. C<readme> +displays the README file of the associated distribution. C<Look> gets +and untars (if not yet done) the distribution file, changes to the appropriate directory and opens a subshell process in that directory. =item Signals @@ -4796,24 +4947,24 @@ shell with the command set defined within the C<o conf> command: =over 2 -=item o conf E<lt>scalar optionE<gt> +=item C<o conf E<lt>scalar optionE<gt>> prints the current value of the I<scalar option> -=item o conf E<lt>scalar optionE<gt> E<lt>valueE<gt> +=item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>> Sets the value of the I<scalar option> to I<value> -=item o conf E<lt>list optionE<gt> +=item C<o conf E<lt>list optionE<gt>> prints the current value of the I<list option> in MakeMaker's neatvalue format. -=item o conf E<lt>list optionE<gt> [shift|pop] +=item C<o conf E<lt>list optionE<gt> [shift|pop]> shifts or pops the array in the I<list option> variable -=item o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt> +=item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>> works like the corresponding perl commands. @@ -4916,10 +5067,10 @@ ftp) you will need to use LWP. =item ftp firewall -This where the firewall machine runs a ftp server. This kind of firewall will -only let you access ftp serves outside the firewall. This is usually done by -connecting to the firewall with ftp, then entering a username like -"user@outside.host.com" +This where the firewall machine runs a ftp server. This kind of +firewall will only let you access ftp servers outside the firewall. +This is usually done by connecting to the firewall with ftp, then +entering a username like "user@outside.host.com" To access servers outside these type of firewalls with perl you will need to use Net::FTP. @@ -4971,7 +5122,7 @@ traditional method of building a Perl module package from a shell. =head1 AUTHOR -Andreas König E<lt>a.koenig@kulturbox.deE<gt> +Andreas Koenig E<lt>andreas.koenig@anima.deE<gt> =head1 SEE ALSO diff --git a/lib/CPAN/FirstTime.pm b/lib/CPAN/FirstTime.pm index 289984956c..0e795da4fb 100644 --- a/lib/CPAN/FirstTime.pm +++ b/lib/CPAN/FirstTime.pm @@ -16,7 +16,7 @@ use FileHandle (); use File::Basename (); use File::Path (); use vars qw($VERSION); -$VERSION = substr q$Revision: 1.37 $, 10; +$VERSION = substr q$Revision: 1.38 $, 10; =head1 NAME @@ -360,17 +360,19 @@ sub conf_sites { require File::Copy; File::Copy::copy($m,$mby) or die "Could not update $mby: $!"; } + my $loopcount = 0; while () { if ( ! -f $mby ){ print qq{You have no $mby I\'m trying to fetch one }; $mby = CPAN::FTP->localize($m,$mby,3); - } elsif (-M $mby > 30 ) { - print qq{Your $mby is older than 30 days, + } elsif (-M $mby > 60 && $loopcount == 0) { + print qq{Your $mby is older than 60 days, I\'m trying to fetch one }; $mby = CPAN::FTP->localize($m,$mby,3); + $loopcount++; } elsif (-s $mby == 0) { print qq{You have an empty $mby, I\'m trying to fetch one diff --git a/lib/CPAN/Nox.pm b/lib/CPAN/Nox.pm index e9cb189f29..8b59ca07a1 100644 --- a/lib/CPAN/Nox.pm +++ b/lib/CPAN/Nox.pm @@ -1,7 +1,12 @@ package CPAN::Nox; +use strict; +use vars qw($VERSION @EXPORT); -BEGIN{$CPAN::Suppress_readline=1 unless defined $CPAN::term;} +BEGIN{ + $CPAN::Suppress_readline=1 unless defined $CPAN::term; +} +use base 'Exporter'; use CPAN; $VERSION = "1.00"; @@ -12,6 +17,8 @@ $CPAN::META->has_inst('Compress::Zlib','no'); *AUTOLOAD = \&CPAN::AUTOLOAD; +__END__ + =head1 NAME CPAN::Nox - Wrapper around CPAN.pm without using any XS module diff --git a/lib/Carp/Heavy.pm b/lib/Carp/Heavy.pm index 161e7fbe73..553a0edfcb 100644 --- a/lib/Carp/Heavy.pm +++ b/lib/Carp/Heavy.pm @@ -87,7 +87,7 @@ sub longmess_heavy { # set args to the string "undef" if undefined $_ = "undef", next unless defined $_; if (ref $_) { - # dunno what this is for... + # force reference to string representation $_ .= ''; s/'/\\'/g; } @@ -128,6 +128,30 @@ sub longmess_heavy { } +# ancestors() returns the complete set of ancestors of a module + +sub ancestors($$); + +sub ancestors($$){ + my( $pack, $href ) = @_; + if( @{"${pack}::ISA"} ){ + my $risa = \@{"${pack}::ISA"}; + my %tree = (); + @tree{@$risa} = (); + foreach my $mod ( @$risa ){ + # visit ancestors - if not already in the gallery + if( ! defined( $$href{$mod} ) ){ + my @ancs = ancestors( $mod, $href ); + @tree{@ancs} = (); + } + } + return ( keys( %tree ) ); + } else { + return (); + } +} + + # shortmess() is called by carp() and croak() to skip all the way up to # the top-level caller's package and report the error from there. confess() # and cluck() generate a full stack trace so they call longmess() to @@ -140,6 +164,8 @@ sub shortmess_heavy { # Short-circuit &longmess if called via multiple packages my $error = join '', @_; my ($prevpack) = caller(1); my $extra = $CarpLevel; + + my @Clans = ( $prevpack ); my $i = 2; my ($pack,$file,$line); # when reporting an error, we want to report it from the context of the @@ -150,33 +176,45 @@ sub shortmess_heavy { # Short-circuit &longmess if called via multiple packages # track of all the packages to which the calling package belongs. We # do this by examining its @ISA variable. Any call from a base class # method (one of our caller's @ISA packages) can be ignored - my %isa = ($prevpack,1); + my %isa; - # merge all the caller's @ISA packages into %isa. - @isa{@{"${prevpack}::ISA"}} = () - if(@{"${prevpack}::ISA"}); + # merge all the caller's @ISA packages and ancestors into %isa. + my @pars = ancestors( $prevpack, \%isa ); + @isa{@pars} = () if @pars; + $isa{$prevpack} = 1; # now we crawl up the calling stack and look at all the packages in # there. For each package, we look to see if it has an @ISA and then # we see if our caller features in that list. That would imply that # our caller is a derived class of that package and its calls can also # be ignored +CALLER: while (($pack,$file,$line) = caller($i++)) { - if(@{$pack . "::ISA"}) { - my @i = @{$pack . "::ISA"}; - my %i; - @i{@i} = (); - # merge any relevant packages into %isa - @isa{@i,$pack} = () - if(exists $i{$prevpack} || exists $isa{$pack}); - } - # and here's where we do the ignoring... if the package in - # question is one of our caller's base or derived packages then - # we can ignore it (skip it) and go onto the next (but note that - # the continue { } block below gets called every time) - next - if(exists $isa{$pack}); + # Chances are, the caller's caller (or its caller...) is already + # in the gallery - if so, ignore this caller. + next if exists( $isa{$pack} ); + + # no: collect this module's ancestors. + my @i = ancestors( $pack, \%isa ); + my %i; + if( @i ){ + @i{@i} = (); + # check whether our representative of one of the clans is + # in this family tree. + foreach my $cl (@Clans){ + if( exists( $i{$cl} ) ){ + # yes: merge all of the family tree into %isa + @isa{@i,$pack} = (); + # and here's where we do some more ignoring... + # if the package in question is one of our caller's + # base or derived packages then we can ignore it (skip it) + # and go onto the next. + next CALLER if exists( $isa{$pack} ); + last; + } + } + } # Hey! We've found a package that isn't one of our caller's # clan....but wait, $extra refers to the number of 'extra' levels @@ -184,9 +222,8 @@ sub shortmess_heavy { # Short-circuit &longmess if called via multiple packages # We must merge the package into the %isa hash (so we can ignore it # if it pops up again), decrement $extra, and continue. if ($extra-- > 0) { - %isa = ($pack,1); - @isa{@{$pack . "::ISA"}} = () - if(@{$pack . "::ISA"}); + push( @Clans, $pack ); + @isa{@i,$pack} = (); } else { # OK! We've got a candidate package. Time to construct the @@ -204,9 +241,6 @@ sub shortmess_heavy { # Short-circuit &longmess if called via multiple packages return $msg; } } - continue { - $prevpack = $pack; - } # uh-oh! It looks like we crawled all the way up the stack and # never found a candidate package. Oh well, let's call longmess diff --git a/lib/Class/Struct.pm b/lib/Class/Struct.pm index 3e08e801d0..b4f2117557 100644 --- a/lib/Class/Struct.pm +++ b/lib/Class/Struct.pm @@ -2,10 +2,10 @@ package Class::Struct; ## See POD after __END__ -require 5.002; +use 5.005_64; use strict; -use vars qw(@ISA @EXPORT $VERSION); +our(@ISA, @EXPORT, $VERSION); use Carp; @@ -355,7 +355,7 @@ The element is an array, initialized by default to C<()>. With no argument, the accessor returns a reference to the element's whole array (whether or not the element was -specified as C<'@'> or C<'*@'). +specified as C<'@'> or C<'*@'>). With one or two arguments, the first argument is an index specifying one element of the array; the second argument, if @@ -370,7 +370,7 @@ The element is a hash, initialized by default to C<()>. With no argument, the accessor returns a reference to the element's whole hash (whether or not the element was -specified as C<'%'> or C<'*%'). +specified as C<'%'> or C<'*%'>). With one or two arguments, the first argument is a key specifying one element of the hash; the second argument, if present, is @@ -520,6 +520,7 @@ struct's constructor. print "(which was a ", $cat->breed->name, ")\n"; print "had two kittens: ", join(' and ', @{$cat->kittens}), "\n"; +=back =head1 Author and Modification History diff --git a/lib/Cwd.pm b/lib/Cwd.pm index ee1bc28367..e3c45903c3 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -20,7 +20,7 @@ getcwd - get pathname of current working directory chdir "/tmp"; print $ENV{'PWD'}; - use Cwd 'abs_path'; + use Cwd 'abs_path'; # aka realpath() print abs_path($ENV{'PWD'}); use Cwd 'fast_abs_path'; @@ -32,8 +32,11 @@ The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions in Perl. The abs_path() function takes a single argument and returns the -absolute pathname for that argument. It uses the same algorithm as -getcwd(). (actually getcwd() is abs_path(".")) +absolute pathname for that argument. It uses the same algorithm +as getcwd(). (Actually, getcwd() is abs_path(".")) Symbolic links +and relative-path components ("." and "..") are resolved to return +the canonical pathname, just like realpath(3). Also callable as +realpath(). The fastcwd() function looks the same as getcwd(), but runs faster. It's also more dangerous because it might conceivably chdir() you out @@ -67,12 +70,12 @@ kept up to date if all packages which use chdir import it from Cwd. use Carp; -$VERSION = '2.01'; +$VERSION = '2.02'; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); -@EXPORT_OK = qw(chdir abs_path fast_abs_path); +@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); # The 'natural and safe form' for UNIX (pwd may be setuid root) @@ -257,6 +260,10 @@ sub abs_path $cwd; } +# added function alias for those of us more +# used to the libc function. --tchrist 27-Jan-00 +*realpath = \&abs_path; + sub fast_abs_path { my $cwd = getcwd(); my $path = shift || '.'; @@ -266,6 +273,10 @@ sub fast_abs_path { $realpath; } +# added function alias to follow principle of least surprise +# based on previous aliasing. --tchrist 27-Jan-00 +*fast_realpath = \&fast_abs_path; + # --- PORTING SECTION --- @@ -331,7 +342,7 @@ sub _qnx_abs_path { } { - local $^W = 0; # assignments trigger 'subroutine redefined' warning + no warnings; # assignments trigger 'subroutine redefined' warning if ($^O eq 'VMS') { *cwd = \&_vms_cwd; diff --git a/lib/Dumpvalue.pm b/lib/Dumpvalue.pm index 18a40eeb1f..94b6aa6e78 100644 --- a/lib/Dumpvalue.pm +++ b/lib/Dumpvalue.pm @@ -1,7 +1,7 @@ -require 5.005; # For (defined ref) and $#$v +use 5.005_64; # for (defined ref) and $#$v and our package Dumpvalue; use strict; -use vars qw(%address *stab %subs); +our(%address, $stab, @stab, %stab, %subs); # translate control chars to ^X - Randal Schwartz # Modifications to print types by Peter Gordon v1.0 @@ -347,16 +347,30 @@ sub dumpglob { } } +sub CvGV_name { + my $self = shift; + my $in = shift; + return if $self->{skipCvGV}; # Backdoor to avoid problems if XS broken... + $in = \&$in; # Hard reference... + eval {require Devel::Peek; 1} or return; + my $gv = Devel::Peek::CvGV($in) or return; + *$gv{PACKAGE} . '::' . *$gv{NAME}; +} + sub dumpsub { my $self = shift; my ($off,$sub) = @_; + my $ini = $sub; + my $s; $sub = $1 if $sub =~ /^\{\*(.*)\}$/; - my $subref = \&$sub; - my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub}) - || ($self->{subdump} && ($sub = $self->findsubs("$subref")) - && $DB::sub{$sub}); + my $subref = defined $1 ? \&$sub : \&$ini; + my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s}) + || (($s = $self->CvGV_name($subref)) && $DB::sub{$s}) + || ($self->{subdump} && ($s = $self->findsubs("$subref")) + && $DB::sub{$s}); + $s = $sub unless defined $s; $place = '???' unless defined $place; - print( (' ' x $off) . "&$sub in $place\n" ); + print( (' ' x $off) . "&$s in $place\n" ); } sub findsubs { diff --git a/lib/English.pm b/lib/English.pm index 9f29a487dc..4e3210b12c 100644 --- a/lib/English.pm +++ b/lib/English.pm @@ -15,14 +15,6 @@ English - use nice English (or awk) names for ugly punctuation variables =head1 DESCRIPTION -You should I<not> use this module in programs intended to be portable -among Perl versions, programs that must perform regular expression -matching operations efficiently, or libraries intended for use with -such programs. In a sense, this module is deprecated. The reasons -for this have to do with implementation details of the Perl -interpreter which are too thorny to go into here. Perhaps someday -they will be fixed to make "C<use English>" more practical. - This module provides aliases for the built-in variables whose names no one seems to like to read. Variables with side-effects which get triggered just by accessing them (like $0) will still @@ -35,9 +27,15 @@ $INPUT_RECORD_SEPARATOR if you are using the English module. See L<perlvar> for a complete list of these. +=head1 BUGS + +This module provokes sizeable inefficiencies for regular expressions, +due to unfortunate implementation details. If performance matters, +consider avoiding English. + =cut -local $^W = 0; +no warnings; # Grandfather $NAME import sub import { @@ -89,6 +87,7 @@ sub import { *EGID *PROGRAM_NAME *PERL_VERSION + *PERL_VERSION_TUPLE *ACCUMULATOR *DEBUGGING *SYSTEM_FD_MAX @@ -167,6 +166,7 @@ sub import { # Internals. *PERL_VERSION = *] ; + *PERL_VERSION_TUPLE = *^V ; *ACCUMULATOR = *^A ; *COMPILING = *^C ; *DEBUGGING = *^D ; diff --git a/lib/ExtUtils/Command.pm b/lib/ExtUtils/Command.pm index e900e51ffa..bccc76cc19 100644 --- a/lib/ExtUtils/Command.pm +++ b/lib/ExtUtils/Command.pm @@ -1,4 +1,6 @@ package ExtUtils::Command; + +use 5.005_64; use strict; # use AutoLoader; use Carp; @@ -7,7 +9,7 @@ use File::Compare; use File::Basename; use File::Path qw(rmtree); require Exporter; -use vars qw(@ISA @EXPORT $VERSION); +our(@ISA, @EXPORT, $VERSION); @ISA = qw(Exporter); @EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f); $VERSION = '1.01'; diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm index d6b1375fb6..3c183a3174 100644 --- a/lib/ExtUtils/Install.pm +++ b/lib/ExtUtils/Install.pm @@ -1,12 +1,13 @@ package ExtUtils::Install; +use 5.005_64; +our(@ISA, @EXPORT, $VERSION); $VERSION = substr q$Revision: 1.28 $, 10; # $Date: 1998/01/25 07:08:24 $ use Exporter; use Carp (); use Config qw(%Config); -use vars qw(@ISA @EXPORT $VERSION); @ISA = ('Exporter'); @EXPORT = ('install','uninstall','pm_to_blib', 'install_default'); $Is_VMS = $^O eq 'VMS'; @@ -15,7 +16,7 @@ my $splitchar = $^O eq 'VMS' ? '|' : ($^O eq 'os2' || $^O eq 'dos') ? ';' : ':'; my @PERL_ENV_LIB = split $splitchar, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || ''; my $Inc_uninstall_warn_handler; -#use vars qw( @EXPORT @ISA $Is_VMS ); +#our(@EXPORT, @ISA, $Is_VMS); #use strict; sub forceunlink { diff --git a/lib/ExtUtils/Installed.pm b/lib/ExtUtils/Installed.pm index 41f3c9b3b8..da4a6536a0 100644 --- a/lib/ExtUtils/Installed.pm +++ b/lib/ExtUtils/Installed.pm @@ -1,4 +1,6 @@ package ExtUtils::Installed; + +use 5.005_64; use strict; use Carp qw(); use ExtUtils::Packlist; @@ -6,8 +8,7 @@ use ExtUtils::MakeMaker; use Config; use File::Find; use File::Basename; -use vars qw($VERSION); -$VERSION = '0.02'; +our $VERSION = '0.02'; sub _is_type($$$) { diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index b992ec0116..c858236593 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -1,8 +1,9 @@ package ExtUtils::Liblist; -use vars qw($VERSION); + +use 5.005_64; # Broken out of MakeMaker from version 4.11 -$VERSION = substr q$Revision: 1.25 $, 10; +our $VERSION = substr q$Revision: 1.25 $, 10; use Config; use Cwd 'cwd'; diff --git a/lib/ExtUtils/MM_Cygwin.pm b/lib/ExtUtils/MM_Cygwin.pm index 7a92290664..a5ba410fdc 100644 --- a/lib/ExtUtils/MM_Cygwin.pm +++ b/lib/ExtUtils/MM_Cygwin.pm @@ -24,7 +24,6 @@ sub cflags { / *= */ and $self->{$`} = $'; }; $self->{CCFLAGS} .= " -DUSEIMPORTLIB" if ($Config{useshrplib} eq 'true'); - $self->{CCFLAGS} .= " -DCYGWIN" unless ($self->{CCFLAGS} =~ /\-DCYGWIN/); return $self->{CFLAGS} = qq{ CCFLAGS = $self->{CCFLAGS} diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index f4329e13d7..c5cf7066bf 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -2766,7 +2766,7 @@ sub parse_version { $_ }; \$$2 }; - local($^W) = 0; + no warnings; $result = eval($eval); warn "Could not eval '$eval' in $parsefile: $@" if $@; $result = "undef" unless defined $result; diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index f3de323e53..5eccf78b8e 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -13,7 +13,7 @@ require Exporter; use VMS::Filespec; use File::Basename; use File::Spec; -use vars qw($Revision @ISA); +our($Revision, @ISA); $Revision = '5.56 (27-Apr-1999)'; @ISA = qw( File::Spec ); diff --git a/lib/ExtUtils/MM_Win32.pm b/lib/ExtUtils/MM_Win32.pm index 534f26d823..e08c6791ee 100644 --- a/lib/ExtUtils/MM_Win32.pm +++ b/lib/ExtUtils/MM_Win32.pm @@ -388,7 +388,6 @@ PM_TO_BLIB = }.join(" \\\n\t", %{$self->{PM}}).q{ sub path { - local $^W = 1; my($self) = @_; my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'}; my @path = split(';',$path); diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index 0426575f87..c4b75539bf 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -180,7 +180,6 @@ sub eval_in_x { sub full_setup { $Verbose ||= 0; - $^W=1; # package name for the classes into which the first object will be blessed $PACKNAME = "PACK000"; diff --git a/lib/ExtUtils/Manifest.pm b/lib/ExtUtils/Manifest.pm index 58c91bc44b..8bb3fc8ebd 100644 --- a/lib/ExtUtils/Manifest.pm +++ b/lib/ExtUtils/Manifest.pm @@ -25,7 +25,7 @@ $MANIFEST = 'MANIFEST'; # Really cool fix from Ilya :) unless (defined $Config{d_link}) { - local $^W; + no warnings; *ln = \&cp; } diff --git a/lib/ExtUtils/Mksymlists.pm b/lib/ExtUtils/Mksymlists.pm index 9dcedbf35e..a0126cc3a0 100644 --- a/lib/ExtUtils/Mksymlists.pm +++ b/lib/ExtUtils/Mksymlists.pm @@ -1,10 +1,12 @@ package ExtUtils::Mksymlists; + +use 5.005_64; use strict qw[ subs refs ]; # no strict 'vars'; # until filehandles are exempted use Carp; use Exporter; -use vars qw( @ISA @EXPORT $VERSION ); +our(@ISA, @EXPORT, $VERSION); @ISA = 'Exporter'; @EXPORT = '&Mksymlists'; $VERSION = substr q$Revision: 1.17 $, 10; diff --git a/lib/ExtUtils/Packlist.pm b/lib/ExtUtils/Packlist.pm index eeb0a5b0c1..88ea206196 100644 --- a/lib/ExtUtils/Packlist.pm +++ b/lib/ExtUtils/Packlist.pm @@ -1,8 +1,9 @@ package ExtUtils::Packlist; + +use 5.005_64; use strict; use Carp qw(); -use vars qw($VERSION); -$VERSION = '0.03'; +our $VERSION = '0.03'; # Used for generating filehandle globs. IO::File might not be available! my $fhname = "FH1"; diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index ff9b452caf..4fedd3bb41 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -995,7 +995,9 @@ while (fetch_para()) { %XsubAliases = %XsubAliasValues = %Interfaces = (); $DoSetMagic = 1; - @args = split(/\s*,\s*/, $orig_args); + my $temp_args = $orig_args; + $temp_args =~ s/\\\s*//g; + @args = split(/\s*,\s*/, $temp_args); if (defined($class)) { my $arg0 = ((defined($static) or $func_name eq 'new') ? "CLASS" : "THIS"); diff --git a/lib/Fatal.pm b/lib/Fatal.pm index d1d95af884..5b832f6427 100644 --- a/lib/Fatal.pm +++ b/lib/Fatal.pm @@ -1,8 +1,9 @@ package Fatal; +use 5.005_64; use Carp; use strict; -use vars qw( $AUTOLOAD $Debug $VERSION); +our($AUTOLOAD, $Debug, $VERSION); $VERSION = 1.02; @@ -115,7 +116,7 @@ EOS no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ... $code = eval("package $pkg; use Carp; $code"); die if $@; - local($^W) = 0; # to avoid: Subroutine foo redefined ... + no warnings; # to avoid: Subroutine foo redefined ... *{$sub} = $code; } } diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm index d1c8666bbb..da2caee849 100644 --- a/lib/File/Basename.pm +++ b/lib/File/Basename.pm @@ -135,11 +135,11 @@ BEGIN { - +use 5.005_64; +our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase); require Exporter; @ISA = qw(Exporter); @EXPORT = qw(fileparse fileparse_set_fstype basename dirname); -use vars qw($VERSION $Fileparse_fstype $Fileparse_igncase); $VERSION = "2.6"; diff --git a/lib/File/Compare.pm b/lib/File/Compare.pm index dce78e28ab..8a8afac05f 100644 --- a/lib/File/Compare.pm +++ b/lib/File/Compare.pm @@ -1,7 +1,8 @@ package File::Compare; +use 5.005_64; use strict; -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $Too_Big *FROM *TO); +our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Too_Big); require Exporter; use Carp; @@ -115,6 +116,7 @@ sub compare { return -1; } +sub cmp; *cmp = \&compare; sub compare_text { diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index 8df54e55a8..8638bee210 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -7,10 +7,14 @@ package File::Copy; +use 5.005_64; use strict; use Carp; -use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $Too_Big - © &syscopy &cp &mv $Syscopy_is_copy); +our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy); +sub copy; +sub syscopy; +sub cp; +sub mv; # Note that this module implements only *part* of the API defined by # the File/Copy.pm module of the File-Tools-2.0 package. However, that diff --git a/lib/File/Find.pm b/lib/File/Find.pm index c674b2c5f6..42905dec80 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -1,5 +1,5 @@ package File::Find; -require 5.005; +use 5.005_64; require Exporter; require Cwd; @@ -53,12 +53,12 @@ If either I<follow> or I<follow_fast> is in effect: =over 6 -=item +=item * It is guarantueed that an I<lstat> has been called before the user's I<wanted()> function is called. This enables fast file checks involving S< _>. -=item +=item * There is a variable C<$File::Find::fullname> which holds the absolute pathname of the file with all symbolic links resolved @@ -270,7 +270,7 @@ sub Follow_SymLink($) { return $AbsName; } -use vars qw/ $dir $name $fullname $prune /; +our($dir, $name, $fullname, $prune); sub _find_dir_symlnk($$$); sub _find_dir($$$); @@ -309,6 +309,8 @@ sub _find_opt { $top_item =~ s|/$|| unless $top_item eq '/'; $Is_Dir= 0; + ($topdev,$topino,$topmode,$topnlink) = stat $top_item; + if ($follow) { if (substr($top_item,0,1) eq '/') { $abs_dir = $top_item; @@ -331,7 +333,6 @@ sub _find_opt { } else { # no follow $topdir = $top_item; - ($topdev,$topino,$topmode,$topnlink) = lstat $top_item; unless (defined $topnlink) { warn "Can't stat $top_item: $!\n"; next Proc_Top_Item; diff --git a/lib/File/Path.pm b/lib/File/Path.pm index 634b2cd108..59b72baa45 100644 --- a/lib/File/Path.pm +++ b/lib/File/Path.pm @@ -91,16 +91,15 @@ Charles Bailey <F<bailey@newman.upenn.edu>> =cut +use 5.005_64; use Carp; use File::Basename (); -use DirHandle (); use Exporter (); use strict; -use vars qw( $VERSION @ISA @EXPORT ); -$VERSION = "1.0402"; -@ISA = qw( Exporter ); -@EXPORT = qw( mkpath rmtree ); +our $VERSION = "1.0403"; +our @ISA = qw( Exporter ); +our @EXPORT = qw( mkpath rmtree ); my $Is_VMS = $^O eq 'VMS'; @@ -170,10 +169,14 @@ sub rmtree { or carp "Can't make directory $root read+writeable: $!" unless $safe; - my $d = DirHandle->new($root) - or carp "Can't read $root: $!"; - @files = $d->read; - $d->close; + if (opendir my $d, $root) { + @files = readdir $d; + closedir $d; + } + else { + carp "Can't read $root: $!"; + @files = (); + } # Deleting large numbers of files from VMS Files-11 filesystems # is faster if done in reverse ASCIIbetical order diff --git a/lib/File/Spec/VMS.pm b/lib/File/Spec/VMS.pm index 00c068accb..79491463cd 100644 --- a/lib/File/Spec/VMS.pm +++ b/lib/File/Spec/VMS.pm @@ -22,6 +22,8 @@ See File::Spec::Unix for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. +=over + =item eliminate_macros Expands MM[KS]/Make macros in a text string, using the contents of @@ -111,6 +113,7 @@ sub fixpath { $fixedpath; } +=back =head2 Methods always loaded diff --git a/lib/File/Spec/Win32.pm b/lib/File/Spec/Win32.pm index 0ea4970b41..120b799cd2 100644 --- a/lib/File/Spec/Win32.pm +++ b/lib/File/Spec/Win32.pm @@ -81,7 +81,6 @@ sub catfile { } sub path { - local $^W = 1; my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'}; my @path = split(';',$path); foreach (@path) { $_ = '.' if $_ eq '' } @@ -309,14 +308,18 @@ sub abs2rel { $path_directories = CORE::join( '\\', @pathchunks ); $base_directories = CORE::join( '\\', @basechunks ); - # $base now contains the directories the resulting relative path - # must ascend out of before it can descend to $path_directory. So, + # $base_directories now contains the directories the resulting relative + # path must ascend out of before it can descend to $path_directory. So, # replace all names with $parentDir - $base_directories =~ s|[^/]+|..|g ; + + #FA Need to replace between backslashes... + $base_directories =~ s|[^\\]+|..|g ; # Glue the two together, using a separator if necessary, and preventing an # empty result. - if ( $path ne '' && $base ne '' ) { + + #FA Must check that new directories are not empty. + if ( $path_directories ne '' && $base_directories ne '' ) { $path_directories = "$base_directories\\$path_directories" ; } else { $path_directories = "$base_directories$path_directories" ; diff --git a/lib/File/stat.pm b/lib/File/stat.pm index f5d17f7da4..0cf7a0b7aa 100644 --- a/lib/File/stat.pm +++ b/lib/File/stat.pm @@ -1,9 +1,11 @@ package File::stat; use strict; +use 5.005_64; +our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); + BEGIN { use Exporter (); - use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); @EXPORT = qw(stat lstat); @EXPORT_OK = qw( $st_dev $st_ino $st_mode $st_nlink $st_uid $st_gid @@ -13,7 +15,7 @@ BEGIN { ); %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); } -use vars @EXPORT_OK; +use vars @EXPORT_OK; # Class::Struct forbids use of @ISA sub import { goto &Exporter::import } diff --git a/lib/FileHandle.pm b/lib/FileHandle.pm index eec9b61f31..34c3475d9c 100644 --- a/lib/FileHandle.pm +++ b/lib/FileHandle.pm @@ -1,8 +1,8 @@ package FileHandle; -use 5.003_11; +use 5.005_64; use strict; -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); +our($VERSION, @ISA, @EXPORT, @EXPORT_OK); $VERSION = "2.00"; diff --git a/lib/Getopt/Std.pm b/lib/Getopt/Std.pm index e027bad3d2..e5b369ceb5 100644 --- a/lib/Getopt/Std.pm +++ b/lib/Getopt/Std.pm @@ -28,21 +28,25 @@ which take an argument don't care whether there is a space between the switch and the argument. Note that, if your code is running under the recommended C<use strict -'vars'> pragma, it may be helpful to declare these package variables -via C<use vars> perhaps something like this: +'vars'> pragma, you will need to declare these package variables +with "our": - use vars qw/ $opt_foo $opt_bar /; + our($opt_foo, $opt_bar); -For those of you who don't like additional variables being created, getopt() +For those of you who don't like additional global variables being created, getopt() and getopts() will also accept a hash reference as an optional second argument. Hash keys will be x (where x is the switch name) with key values the value of the argument or 1 if no argument is specified. +To allow programs to process arguments that look like switches, but aren't, +both functions will stop processing switches when they see the argument +C<-->. The C<--> will be removed from @ARGV. + =cut @ISA = qw(Exporter); @EXPORT = qw(getopt getopts); -$VERSION = '1.01'; +$VERSION = '1.02'; # Process single-character switches with switch clustering. Pass one argument # which is a string containing all switches that take an argument. For each @@ -60,6 +64,10 @@ sub getopt ($;$) { while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { ($first,$rest) = ($1,$2); + if (/^--$/) { # early exit if -- + shift @ARGV; + last; + } if (index($argumentative,$first) >= 0) { if ($rest ne '') { shift(@ARGV); @@ -68,22 +76,22 @@ sub getopt ($;$) { shift(@ARGV); $rest = shift(@ARGV); } - if (ref $hash) { - $$hash{$first} = $rest; - } - else { - ${"opt_$first"} = $rest; - push( @EXPORT, "\$opt_$first" ); - } + if (ref $hash) { + $$hash{$first} = $rest; + } + else { + ${"opt_$first"} = $rest; + push( @EXPORT, "\$opt_$first" ); + } } else { - if (ref $hash) { - $$hash{$first} = 1; - } - else { - ${"opt_$first"} = 1; - push( @EXPORT, "\$opt_$first" ); - } + if (ref $hash) { + $$hash{$first} = 1; + } + else { + ${"opt_$first"} = 1; + push( @EXPORT, "\$opt_$first" ); + } if ($rest ne '') { $ARGV[0] = "-$rest"; } @@ -111,31 +119,35 @@ sub getopts ($;$) { @args = split( / */, $argumentative ); while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { ($first,$rest) = ($1,$2); + if (/^--$/) { # early exit if -- + shift @ARGV; + last; + } $pos = index($argumentative,$first); - if($pos >= 0) { - if(defined($args[$pos+1]) and ($args[$pos+1] eq ':')) { + if ($pos >= 0) { + if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) { shift(@ARGV); - if($rest eq '') { + if ($rest eq '') { ++$errs unless @ARGV; $rest = shift(@ARGV); } - if (ref $hash) { - $$hash{$first} = $rest; - } - else { - ${"opt_$first"} = $rest; - push( @EXPORT, "\$opt_$first" ); - } + if (ref $hash) { + $$hash{$first} = $rest; + } + else { + ${"opt_$first"} = $rest; + push( @EXPORT, "\$opt_$first" ); + } } else { - if (ref $hash) { - $$hash{$first} = 1; - } - else { - ${"opt_$first"} = 1; - push( @EXPORT, "\$opt_$first" ); - } - if($rest eq '') { + if (ref $hash) { + $$hash{$first} = 1; + } + else { + ${"opt_$first"} = 1; + push( @EXPORT, "\$opt_$first" ); + } + if ($rest eq '') { shift(@ARGV); } else { @@ -146,7 +158,7 @@ sub getopts ($;$) { else { warn "Unknown option: $first\n"; ++$errs; - if($rest ne '') { + if ($rest ne '') { $ARGV[0] = "-$rest"; } else { @@ -162,4 +174,3 @@ sub getopts ($;$) { } 1; - diff --git a/lib/Math/BigFloat.pm b/lib/Math/BigFloat.pm index 1a9195e185..d8d643ca3e 100644 --- a/lib/Math/BigFloat.pm +++ b/lib/Math/BigFloat.pm @@ -74,7 +74,7 @@ sub fnorm; sub fsqrt; sub fnorm { #(string) return fnum_str local($_) = @_; s/\s+//g; # strip white space - local $^W = 0; # $4 and $5 below might legitimately be undefined + no warnings; # $4 and $5 below might legitimately be undefined if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/ && "$2$4" ne '') { &norm(($1 ? "$1$2$4" : "+$2$4"),(($4 ne '') ? $6-length($4) : $6)); } else { diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm index b339573bc9..5b7ddb6f2c 100644 --- a/lib/Math/Complex.pm +++ b/lib/Math/Complex.pm @@ -8,9 +8,10 @@ require Exporter; package Math::Complex; +use 5.005_64; use strict; -use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS); +our($VERSION, @ISA, @EXPORT, %EXPORT_TAGS); my ( $i, $ip2, %logn ); @@ -179,21 +180,21 @@ sub cplxe { # # The number defined as pi = 180 degrees # -use constant pi => 4 * CORE::atan2(1, 1); +sub pi () { 4 * CORE::atan2(1, 1) } # # pit2 # # The full circle # -use constant pit2 => 2 * pi; +sub pit2 () { 2 * pi } # # pip2 # # The quarter circle # -use constant pip2 => pi / 2; +sub pip2 () { pi / 2 } # # deg1 @@ -201,14 +202,14 @@ use constant pip2 => pi / 2; # One degree in radians, used in stringify_polar. # -use constant deg1 => pi / 180; +sub deg1 () { pi / 180 } # # uplog10 # # Used in log10(). # -use constant uplog10 => 1 / CORE::log(10); +sub uplog10 () { 1 / CORE::log(10) } # # i diff --git a/lib/Math/Trig.pm b/lib/Math/Trig.pm index c659137eba..68dcb94822 100644 --- a/lib/Math/Trig.pm +++ b/lib/Math/Trig.pm @@ -7,13 +7,12 @@ require Exporter; package Math::Trig; +use 5.005_64; use strict; use Math::Complex qw(:trig); -use vars qw($VERSION $PACKAGE - @ISA - @EXPORT @EXPORT_OK %EXPORT_TAGS); +our($VERSION, $PACKAGE, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); @ISA = qw(Exporter); @@ -37,8 +36,8 @@ my @rdlcnv = qw(cartesian_to_cylindrical %EXPORT_TAGS = ('radial' => [ @rdlcnv ]); -use constant pi2 => 2 * pi; -use constant pip2 => pi / 2; +sub pi2 () { 2 * pi } # use constant generates warning +sub pip2 () { pi / 2 } # use constant generates warning use constant DR => pi2/360; use constant RD => 360/pi2; use constant DG => 400/360; diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm index 54540601d3..0c8622e220 100644 --- a/lib/Net/Ping.pm +++ b/lib/Net/Ping.pm @@ -10,12 +10,11 @@ package Net::Ping; # program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. -require 5.002; +use 5.005_64; require Exporter; use strict; -use vars qw(@ISA @EXPORT $VERSION - $def_timeout $def_proto $max_datasize); +our(@ISA, @EXPORT, $VERSION, $def_timeout, $def_proto, $max_datasize); use FileHandle; use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET inet_aton sockaddr_in ); diff --git a/lib/Net/hostent.pm b/lib/Net/hostent.pm index d586358f0a..6cfde7253c 100644 --- a/lib/Net/hostent.pm +++ b/lib/Net/hostent.pm @@ -1,9 +1,10 @@ package Net::hostent; use strict; +use 5.005_64; +our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); - use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); @EXPORT = qw(gethostbyname gethostbyaddr gethost); @EXPORT_OK = qw( $h_name @h_aliases diff --git a/lib/Net/netent.pm b/lib/Net/netent.pm index fbc6d987fe..d8c094ae81 100644 --- a/lib/Net/netent.pm +++ b/lib/Net/netent.pm @@ -1,9 +1,10 @@ package Net::netent; use strict; +use 5.005_64; +our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); - use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); @EXPORT = qw(getnetbyname getnetbyaddr getnet); @EXPORT_OK = qw( $n_name @n_aliases diff --git a/lib/Net/protoent.pm b/lib/Net/protoent.pm index 737ff5a33b..334af78914 100644 --- a/lib/Net/protoent.pm +++ b/lib/Net/protoent.pm @@ -1,9 +1,10 @@ package Net::protoent; use strict; +use 5.005_64; +our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); - use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); @EXPORT = qw(getprotobyname getprotobynumber getprotoent); @EXPORT_OK = qw( $p_name @p_aliases $p_proto ); %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); diff --git a/lib/Net/servent.pm b/lib/Net/servent.pm index fb85dd04bf..c892af0bbe 100644 --- a/lib/Net/servent.pm +++ b/lib/Net/servent.pm @@ -1,9 +1,10 @@ package Net::servent; use strict; +use 5.005_64; +our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); - use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); @EXPORT = qw(getservbyname getservbyport getservent getserv); @EXPORT_OK = qw( $s_name @s_aliases $s_port $s_proto ); %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); diff --git a/lib/Pod/Checker.pm b/lib/Pod/Checker.pm index aa5c5490ae..c661c7527e 100644 --- a/lib/Pod/Checker.pm +++ b/lib/Pod/Checker.pm @@ -10,9 +10,11 @@ package Pod::Checker; use vars qw($VERSION); -$VERSION = 1.090; ## Current version of this package +$VERSION = 1.096; ## Current version of this package require 5.004; ## requires this Perl version or later +use Pod::ParseUtils; ## for hyperlinks and lists + =head1 NAME Pod::Checker, podchecker() - check pod documents for syntax errors @@ -23,15 +25,19 @@ Pod::Checker, podchecker() - check pod documents for syntax errors $syntax_okay = podchecker($filepath, $outputpath, %options); + my $checker = new Pod::Checker %options; + =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. +indicating 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>. -=head2 Options +=head2 podchecker() + +This function can take a hash of options: =over 4 @@ -45,20 +51,25 @@ Turn warnings on/off. See L<"Warnings">. 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. +I<NOTE THAT THIS MODULE IS CURRENTLY IN THE BETA STAGE!> 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>. +additional features they wish to see in B<Pod::Checker> and B<podchecker> +and verify that the checks are consistent with L<perlpod>. -The following additional checks are preformed: +The following checks are preformed: =over 4 =item * -Check for proper balancing of C<=begin> and C<=end>. +Unknown '=xxxx' commands, unknown 'X<...>' interior-sequences, +and unterminated interior sequences. + +=item * + +Check for proper balancing of C<=begin> and C<=end>. The contents of such +a block are generally ignored, i.e. no syntax checks are performed. =item * @@ -66,55 +77,156 @@ Check for proper nesting and balancing of C<=over>, C<=item> and C<=back>. =item * -Check for same nested interior-sequences (e.g. C<LE<lt>...LE<lt>...E<gt>...E<gt>>). +Check for same nested interior-sequences (e.g. +C<LE<lt>...LE<lt>...E<gt>...E<gt>>). =item * -Check for malformed entities. +Check for malformed or nonexisting entities C<EE<lt>...E<gt>>. =item * -Check for correct syntax of hyperlinks C<LE<lt>E<gt>>. See L<perlpod> for -details. +Check for correct syntax of hyperlinks C<LE<lt>...E<gt>>. See L<perlpod> +for details. =item * -Check for unresolved document-internal links. +Check for unresolved document-internal links. This check may also reveal +misspelled links that seem to be internal links but should be links +to something else. =back -=head2 Warnings +=head2 Additional Features + +While checking, this module collects document properties, e.g. the nodes +for hyperlinks (C<=headX>, C<=item>). POD translators can use this feature +to syntax-check and get the nodes in a first pass before actually starting +to convert. This is expensive in terms of execution time, but allows for +very robust conversions. + +=head1 DIAGNOSTICS -The following warnings are printed. These may not necessarily cause trouble, -but indicate mediocre style. +=head2 Errors =over 4 -=item * +=item * =over on line I<N> without closing =back -Spurious characters after C<=back> and C<=end>. +The C<=over> command does not have a corresponding C<=back> before the +next heading (C<=head1> or C<=head2>) or the end of the file. -=item * +=item * =item without previous =over -Unescaped C<E<lt>> and C<E<gt>> in the text. +=item * =back without previous =over -=item * +An C<=item> or C<=back> command has been found outside a +C<=over>/C<=back> block. -Missing arguments for C<=begin> and C<=over>. +=item * No argument for =begin -=item * +A C<=begin> command was found that is not followed by the formatter +specification. -Empty C<=over> / C<=back> list. +=item * =end without =begin -=item * +A standalone C<=end> command was found. + +=item * Nested =begin's + +There were at least two concecutive C<=begin> commands without +the corresponding C<=end>. Only one C<=begin> may be active at +a time. + +=item * =for without formatter specification -Hyperlinks: leading/trailing whitespace, brackets C<()> in the page name. +There is no specification of the formatter after the C<=for> command. + +=item * unresolved internal link I<NAME> + +The given link to I<NAME> does not have a matching node in the current +POD. This also happend when a single word node name is not enclosed in +C<"">. + +=item * Unknown command "I<CMD>" + +An invalid POD command has been found. Valid are C<=head1>, C<=head2>, +C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>, C<=for>, C<=pod>, +C<=cut> + +=item * Unknown interior-sequence "I<SEQ>" + +An invalid markup command has been encountered. Valid are: +C<BE<lt>E<gt>>, C<CE<lt>E<gt>>, C<EE<lt>E<gt>>, C<FE<lt>E<gt>>, +C<IE<lt>E<gt>>, C<LE<lt>E<gt>>, C<SE<lt>E<gt>>, C<XE<lt>E<gt>>, +C<ZE<lt>E<gt>> + +=item * nested commands I<CMD>E<lt>...I<CMD>E<lt>...E<gt>...E<gt> + +Two nested identical markup commands have been found. Generally this +does not make sense. + +=item * garbled entity I<STRING> + +The I<STRING> found cannot be interpreted as an character entity. + +=item * malformed link LE<lt>E<gt> + +The link found cannot be parsed because it does not conform to the +syntax described in L<perlpod>. =back -=head1 DIAGNOSTICS +=head2 Warnings -I<[T.B.D.]> +These may not necessarily cause trouble, but indicate mediocre style. + +=over 4 + +=item * No numeric argument for =over + +The C<=over> command is supposed to have a numeric argument (the +indentation). + +=item * Spurious character(s) after =back + +The C<=back> command does not take any arguments. + +=item * I<N> unescaped C<E<lt>E<gt>> in paragraph + +Angle brackets not written as C<E<lt>ltE<gt>> and C<E<lt>gtE<gt>> +can potentially cause errors as they could be misinterpreted as +markup commands. + +=item * Non-standard entity + +A character entity was found that does not belong to the standard +ISO set. + +=item * No items in =over + +The list does not contain any items. + +=item * No argument for =item + +C<=item> without any parameters is deprecated. It should either be followed +by C<*> to indicate an unordered list, by a number (optionally followed +by a dot) to indicate an ordered (numbered) list or simple text for a +definition list. + +=item * Verbatim paragraph in NAME section + +The NAME section (C<=head1 NAME>) should consist of a single paragraph +with the script/module name, followed by a dash `-' and a very short +description of what the thing is good for. + +=item * Hyperlinks + +There are some warnings wrt. hyperlinks: +Leading/trailing whitespace, newlines in hyperlinks, +brackets C<()>. + +=back =head1 RETURN VALUE @@ -174,6 +286,117 @@ my %VALID_SEQUENCES = ( 'E' => 1, ); +# stolen from HTML::Entities +my %ENTITIES = ( + # Some normal chars that have special meaning in SGML context + amp => '&', # ampersand +'gt' => '>', # greater than +'lt' => '<', # less than + quot => '"', # double quote + + # PUBLIC ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML + AElig => 'Æ', # capital AE diphthong (ligature) + Aacute => 'Á', # capital A, acute accent + Acirc => 'Â', # capital A, circumflex accent + Agrave => 'À', # capital A, grave accent + Aring => 'Å', # capital A, ring + Atilde => 'Ã', # capital A, tilde + Auml => 'Ä', # capital A, dieresis or umlaut mark + Ccedil => 'Ç', # capital C, cedilla + ETH => 'Ð', # capital Eth, Icelandic + Eacute => 'É', # capital E, acute accent + Ecirc => 'Ê', # capital E, circumflex accent + Egrave => 'È', # capital E, grave accent + Euml => 'Ë', # capital E, dieresis or umlaut mark + Iacute => 'Í', # capital I, acute accent + Icirc => 'Î', # capital I, circumflex accent + Igrave => 'Ì', # capital I, grave accent + Iuml => 'Ï', # capital I, dieresis or umlaut mark + Ntilde => 'Ñ', # capital N, tilde + Oacute => 'Ó', # capital O, acute accent + Ocirc => 'Ô', # capital O, circumflex accent + Ograve => 'Ò', # capital O, grave accent + Oslash => 'Ø', # capital O, slash + Otilde => 'Õ', # capital O, tilde + Ouml => 'Ö', # capital O, dieresis or umlaut mark + THORN => 'Þ', # capital THORN, Icelandic + Uacute => 'Ú', # capital U, acute accent + Ucirc => 'Û', # capital U, circumflex accent + Ugrave => 'Ù', # capital U, grave accent + Uuml => 'Ü', # capital U, dieresis or umlaut mark + Yacute => 'Ý', # capital Y, acute accent + aacute => 'á', # small a, acute accent + acirc => 'â', # small a, circumflex accent + aelig => 'æ', # small ae diphthong (ligature) + agrave => 'à', # small a, grave accent + aring => 'å', # small a, ring + atilde => 'ã', # small a, tilde + auml => 'ä', # small a, dieresis or umlaut mark + ccedil => 'ç', # small c, cedilla + eacute => 'é', # small e, acute accent + ecirc => 'ê', # small e, circumflex accent + egrave => 'è', # small e, grave accent + eth => 'ð', # small eth, Icelandic + euml => 'ë', # small e, dieresis or umlaut mark + iacute => 'í', # small i, acute accent + icirc => 'î', # small i, circumflex accent + igrave => 'ì', # small i, grave accent + iuml => 'ï', # small i, dieresis or umlaut mark + ntilde => 'ñ', # small n, tilde + oacute => 'ó', # small o, acute accent + ocirc => 'ô', # small o, circumflex accent + ograve => 'ò', # small o, grave accent + oslash => 'ø', # small o, slash + otilde => 'õ', # small o, tilde + ouml => 'ö', # small o, dieresis or umlaut mark + szlig => 'ß', # small sharp s, German (sz ligature) + thorn => 'þ', # small thorn, Icelandic + uacute => 'ú', # small u, acute accent + ucirc => 'û', # small u, circumflex accent + ugrave => 'ù', # small u, grave accent + uuml => 'ü', # small u, dieresis or umlaut mark + yacute => 'ý', # small y, acute accent + yuml => 'ÿ', # small y, dieresis or umlaut mark + + # Some extra Latin 1 chars that are listed in the HTML3.2 draft (21-May-96) + copy => '©', # copyright sign + reg => '®', # registered sign + nbsp => "\240", # non breaking space + + # Additional ISO-8859/1 entities listed in rfc1866 (section 14) + iexcl => '¡', + cent => '¢', + pound => '£', + curren => '¤', + yen => '¥', + brvbar => '¦', + sect => '§', + uml => '¨', + ordf => 'ª', + laquo => '«', +'not' => '¬', # not is a keyword in perl + shy => '', + macr => '¯', + deg => '°', + plusmn => '±', + sup1 => '¹', + sup2 => '²', + sup3 => '³', + acute => '´', + micro => 'µ', + para => '¶', + middot => '·', + cedil => '¸', + ordm => 'º', + raquo => '»', + frac14 => '¼', + frac12 => '½', + frac34 => '¾', + iquest => '¿', +'times' => '×', # times is a keyword in perl + divide => '÷', +); + ##--------------------------------------------------------------------------- ##--------------------------------- @@ -219,16 +442,18 @@ sub initialize { ## Initialize number of errors, and setup an error function to ## increment this number and then print to the designated output. $self->{_NUM_ERRORS} = 0; - $self->errorsub('poderror'); + $self->errorsub('poderror'); # set the error handling subroutine $self->{_commands} = 0; # total number of POD commands encountered $self->{_list_stack} = []; # stack for nested lists $self->{_have_begin} = ''; # stores =begin $self->{_links} = []; # stack for internal hyperlinks $self->{_nodes} = []; # stack for =head/=item nodes + # print warnings? $self->{-warnings} = 1 unless(defined $self->{-warnings}); + $self->{_current_head1} = ''; # the current =head1 block } -## Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args ) +# Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args ) sub poderror { my $self = shift; my %opts = (ref $_[0]) ? %{shift()} : (); @@ -243,13 +468,43 @@ sub poderror { ++($self->{_NUM_ERRORS}) if(!%opts || ($opts{-severity} && $opts{-severity} eq 'ERROR')); my $out_fh = $self->output_handle(); - print $out_fh ($severity, $msg, $line, $file, "\n"); + print $out_fh ($severity, $msg, $line, $file, "\n") + if($self->{-warnings} || !%opts || $opts{-severity} ne 'WARNING'); } +# set/retrieve the number of errors found sub num_errors { return (@_ > 1) ? ($_[0]->{_NUM_ERRORS} = $_[1]) : $_[0]->{_NUM_ERRORS}; } +# set and/or retrieve canonical name of POD +sub name { + return (@_ > 1 && $_[1]) ? + ($_[0]->{-name} = $_[1]) : $_[0]->{-name}; +} + +# set/return nodes of the current POD +sub node { + my ($self,$text) = @_; + if(defined $text) { + $text =~ s/[\s\n]+$//; # strip trailing whitespace + # add node + push(@{$self->{_nodes}}, $text); + return $text; + } + @{$self->{_nodes}}; +} + +# set/return hyperlinks of the current POD +sub hyperlink { + my $self = shift; + if($_[0]) { + push(@{$self->{_links}}, $_[0]); + return $_[0]; + } + @{$self->{_links}}; +} + ## overrides for Pod::Parser sub end_pod { @@ -273,7 +528,6 @@ sub end_pod { # first build the node names from the paragraph text my %nodes; foreach($self->node()) { - #print "Have node: +$_+\n"; $nodes{$_} = 1; if(/^(\S+)\s+/) { # we have more than one word. Use the first as a node, too. @@ -282,7 +536,6 @@ sub end_pod { } } foreach($self->hyperlink()) { - #print "Seek node: +$_+\n"; my $line = ''; s/^(\d+):// && ($line = $1); if($_ && !$nodes{$_}) { @@ -307,6 +560,7 @@ sub end_pod { } } +# check a POD command directive sub command { my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_; my ($file, $line) = $pod_para->file_line; @@ -320,32 +574,47 @@ sub command { $self->{_commands}++; # found a valid command ## check syntax of particular command if($cmd eq 'over') { + # check for argument + $arg = $self->interpolate_and_check($paragraph, $line,$file); + my $indent = 4; # default + if($arg && $arg =~ /^\s*(\d+)\s*$/) { + $indent = $1; + } else { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "No numeric argument for =over"}); + } # start a new list - unshift(@{$self->{_list_stack}}, - Pod::List->new( - -indent => $paragraph, + unshift(@{$self->{_list_stack}}, Pod::List->new( + -indent => $indent, -start => $line, -file => $file)); } elsif($cmd eq 'item') { + # are we in a list? unless(@{$self->{_list_stack}}) { $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR', -msg => "=item without previous =over" }); + # auto-open in case we encounter many more + unshift(@{$self->{_list_stack}}, + Pod::List->new( + -indent => 'auto', + -start => $line, + -file => $file)); } - else { - # check for argument - $arg = $self->_interpolate_and_check($paragraph, $line, $file); - unless($arg && $arg =~ /(\S+)/) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => "No argument for =item" }); - } - # add this item - $self->{_list_stack}[0]->item($arg || ''); - # remember this node - $self->node($arg) if($arg); + # check for argument + $arg = $self->interpolate_and_check($paragraph, $line, $file); + unless($arg && $arg =~ /(\S+)/) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "No argument for =item" }); + $arg = ' '; # empty } + # add this item + $self->{_list_stack}[0]->item($arg); + # remember this node + $self->node($arg); } elsif($cmd eq 'back') { # check if we have an open list @@ -356,7 +625,7 @@ sub command { } else { # check for spurious characters - $arg = $self->_interpolate_and_check($paragraph, $line,$file); + $arg = $self->interpolate_and_check($paragraph, $line,$file); if($arg && $arg =~ /\S/) { $self->poderror({ -line => $line, -file => $file, -severity => 'WARNING', @@ -380,13 +649,19 @@ sub command { while($list = shift(@{$self->{_list_stack}})) { $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR', - -msg => "unclosed =over (line ". $list->start() . - ") at $cmd" }); + -msg => "=over on line ". $list->start() . + " without closing =back (at $cmd)" }); } } # remember this node - $arg = $self->_interpolate_and_check($paragraph, $line,$file); + $arg = $self->interpolate_and_check($paragraph, $line,$file); $self->node($arg) if($arg); + if($cmd eq 'head1') { + $arg =~ s/[\s\n]+$//; + $self->{_current_head1} = $arg; + } else { + $self->{_current_head1} = ''; + } } elsif($cmd eq 'begin') { if($self->{_have_begin}) { @@ -398,10 +673,10 @@ sub command { } else { # check for argument - $arg = $self->_interpolate_and_check($paragraph, $line,$file); + $arg = $self->interpolate_and_check($paragraph, $line,$file); unless($arg && $arg =~ /(\S+)/) { $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', + -severity => 'ERROR', -msg => "No argument for =begin"}); } # remember the =begin @@ -413,27 +688,37 @@ sub command { # close the existing =begin $self->{_have_begin} = ''; # check for spurious characters - $arg = $self->_interpolate_and_check($paragraph, $line,$file); - if($arg && $arg =~ /\S/) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => "Spurious character(s) after =end" }); - } + $arg = $self->interpolate_and_check($paragraph, $line,$file); + # the closing argument is optional + #if($arg && $arg =~ /\S/) { + # $self->poderror({ -line => $line, -file => $file, + # -severity => 'WARNING', + # -msg => "Spurious character(s) after =end" }); + #} } else { # don't have a matching =begin $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', + -severity => 'ERROR', -msg => "=end without =begin" }); } } - } + elsif($cmd eq 'for') { + unless($paragraph =~ /\s*(\S+)\s*/) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "=for without formatter specification" }); + } + $arg = ''; # do not expand paragraph below + } ## Check the interior sequences in the command-text - $self->_interpolate_and_check($paragraph, $line,$file) + $self->interpolate_and_check($paragraph, $line,$file) unless(defined $arg); + } } -sub _interpolate_and_check { +# process a block of some text +sub interpolate_and_check { my ($self, $paragraph, $line, $file) = @_; ## Check the interior sequences in the command-text # and return the text @@ -452,10 +737,11 @@ sub _check_ptree { my $count; # count the unescaped angle brackets my $i = $_; - if($count = $i =~ s/[<>]/$self->expand_unescaped_bracket($&)/ge) { + if($count = $i =~ tr/<>/<>/) { $self->poderror({ -line => $line, -file => $file, -severity => 'WARNING', - -msg => "$count unescaped <>" }); + -msg => "$count unescaped <> in paragraph" }) + if($self->{-warnings}); } $text .= $i; next; @@ -488,7 +774,21 @@ sub _check_ptree { -msg => "garbled entity " . $_->raw_text()}); next; } - $text .= $self->expand_entity($$contents[0]); + my $ent = $$contents[0]; + if($ent =~ /^\d+$/) { + # numeric entity + $text .= chr($ent); + } + elsif($ENTITIES{$ent}) { + # known ISO entity + $text .= $ENTITIES{$ent}; + } + else { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "Non-standard entity " . $_->raw_text()}); + $text .= "E<$ent>"; + } } elsif($cmd eq 'L') { # try to parse the hyperlink @@ -496,7 +796,7 @@ sub _check_ptree { unless(defined $link) { $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR', - -msg => "malformed link L<>: $@"}); + -msg => "malformed link " . $_->raw_text() ." : $@"}); next; } $link->line($line); # remember line @@ -511,13 +811,14 @@ sub _check_ptree { $text .= $self->_check_ptree($self->parse_text($link->text(), $line), $line, $file, "$nestlist$cmd"); my $node = ''; - $node = $self->_check_ptree($self->parse_text($link->node(), - $line), $line, $file, "$nestlist$cmd") - if($link->node()); - # store internal link + # remember internal link # _TODO_ what if there is a link to the page itself by the name, - # e.g. Tk::Pod : L<Tk::Pod/"DESCRIPTION"> - $self->hyperlink("$line:$node") if($node && !$link->page()); + # e.g. in Tk::Pod : L<Tk::Pod/"DESCRIPTION"> + if($link->node() && !$link->page() && $link->type() ne 'hyperlink') { + $node = $self->_check_ptree($self->parse_text($link->node(), + $line), $line, $file, "$nestlist$cmd"); + $self->hyperlink("$line:$node") if($node); + } } elsif($cmd =~ /[BCFIS]/) { # add the guts @@ -531,397 +832,35 @@ sub _check_ptree { $text; } -# default method - just return it -sub expand_unescaped_bracket { - my ($self,$bracket) = @_; - $bracket; -} - -# keep the entities -sub expand_entity { - my ($self,$entity) = @_; - "E<$entity>"; -} - -# _TODO_ overloadable methods for BC..Z<...> expansion +# _TODO_ overloadable methods for BC..Z<...> expansion? +# process a block of verbatim text sub verbatim { ## Nothing to check - ## my ($self, $paragraph, $line_num, $pod_para) = @_; + my ($self, $paragraph, $line_num, $pod_para) = @_; + if($self->{_current_head1} eq 'NAME') { + my ($file, $line) = $pod_para->file_line; + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => 'Verbatim paragraph in NAME section' }); + } } +# process a block of regular text sub textblock { my ($self, $paragraph, $line_num, $pod_para) = @_; my ($file, $line) = $pod_para->file_line; - $self->_interpolate_and_check($paragraph, $line,$file); -} - -# set/return nodes of the current POD -sub node { - my ($self,$text) = @_; - if(defined $text) { - $text =~ s/[\s\n]+$//; # strip trailing whitespace - # add node - push(@{$self->{_nodes}}, $text); - return $text; - } - @{$self->{_nodes}}; -} - -# set/return hyperlinks of the current POD -sub hyperlink { - my $self = shift; - if($_[0]) { - push(@{$self->{_links}}, $_[0]); - return $_[0]; - } - @{$self->{_links}}; -} - -#----------------------------------------------------------------------------- -# Pod::List -# -# class to hold POD list info (=over, =item, =back) -#----------------------------------------------------------------------------- - -package Pod::List; - -use Carp; - -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->{-file} ||= 'unknown'; - $self->{-start} ||= 'unknown'; - $self->{-indent} ||= 4; # perlpod: "should be the default" - $self->{_items} = []; -} - -# The POD file name the list appears in -sub file { - return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; -} - -# The line in the file the node appears -sub start { - return (@_ > 1) ? ($_[0]->{-start} = $_[1]) : $_[0]->{-start}; -} - -# indent level -sub indent { - return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent}; -} - -# The individual =items of this list -sub item { - my ($self,$item) = @_; - if(defined $item) { - push(@{$self->{_items}}, $item); - return $item; - } - else { - return @{$self->{_items}}; - } -} - -#----------------------------------------------------------------------------- -# Pod::Hyperlink -# -# class to hold hyperlinks (L<>) -#----------------------------------------------------------------------------- - -package Pod::Hyperlink; - -=head1 NAME - -Pod::Hyperlink - class for manipulation of POD hyperlinks - -=head1 SYNOPSIS - - my $link = Pod::Hyperlink->new('alternative text|page/"section in page"'); - -=head1 DESCRIPTION - -The B<Pod::Hyperlink> class is mainly designed to parse the contents of the -C<LE<lt>...E<gt>> sequence, providing a simple interface for accessing the -different parts of a POD hyperlink. - -=head1 METHODS - -=over 4 - -=item new() - -The B<new()> method can either be passed a set of key/value pairs or a single -scalar value, namely the contents of a C<LE<lt>...E<gt>> sequence. An object -of the class C<Pod::Hyperlink> is returned. The value C<undef> indicates a -failure, the error message is stored in C<$@>. - -=item parse() - -This method can be used to (re)parse a (new) hyperlink. The result is stored -in the current object. - -=item markup($on,$off,$pageon,$pageoff) - -The result of this method is a string the represents the textual value of the -link, but with included arbitrary markers that highlight the active portion -of the link. This will mainly be used by POD translators and saves the -effort of determining which words have to be highlighted. Examples: Depending -on the type of link, the following text will be returned, the C<*> represent -the places where the section/item specific on/off markers will be placed -(link to a specific node) and C<+> for the pageon/pageoff markers (link to the -top of the page). - - the +perl+ manpage - the *$|* entry in the +perlvar+ manpage - the section on *OPTIONS* in the +perldoc+ manpage - the section on *DESCRIPTION* elsewhere in this document - -This method is read-only. - -=item text() - -This method returns the textual representation of the hyperlink as above, -but without markers (read only). - -=item warning() - -After parsing, this method returns any warnings ecountered during the -parsing process. - -=item page() - -This method sets or returns the POD page this link points to. - -=item node() - -As above, but the destination node text of the link. - -=item type() - -The node type, either C<section> or C<item>. - -=item alttext() - -Sets or returns an alternative text specified in the link. -=item line(), file() - -Just simple slots for storing information about the line and the file -the link was incountered in. Has to be filled in manually. - -=back - -=head1 AUTHOR - -Marek Rouchal E<lt>marek@saftsack.fs.uni-bayreuth.deE<gt>, borrowing -a lot of things from L<pod2man> and L<pod2roff>. - -=cut - -use Carp; - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my $self = +{}; - bless $self, $class; - $self->initialize(); - if(defined $_[0]) { - if(ref($_[0])) { - # called with a list of parameters - %$self = %{$_[0]}; - } - else { - # called with L<> contents - return undef unless($self->parse($_[0])); - } - } - return $self; -} - -sub initialize { - my $self = shift; - $self->{-line} ||= 'undef'; - $self->{-file} ||= 'undef'; - $self->{-page} ||= ''; - $self->{-node} ||= ''; - $self->{-alttext} ||= ''; - $self->{-type} ||= 'undef'; - $self->{_warnings} = []; - $self->_construct_text(); -} - -sub parse { - my $self = shift; - local($_) = $_[0]; - # syntax check the link and extract destination - my ($alttext,$page,$section,$item) = ('','','',''); - - # strip leading/trailing whitespace - if(s/^[\s\n]+//) { - $self->warning("ignoring leading whitespace in link"); - } - if(s/[\s\n]+$//) { - $self->warning("ignoring trailing whitespace in link"); - } - - # collapse newlines with whitespace - s/\s*\n\s*/ /g; - - # extract alternative text - if(s!^([^|/"\n]*)[|]!!) { - $alttext = $1; - } - # extract page - if(s!^([^|/"\s]*)(?=/|$)!!) { - $page = $1; - } - # extract section - if(s!^/?"([^"\n]+)"$!!) { # e.g. L</"blah blah"> - $section = $1; - } - # extact item - if(s!^/(.*)$!!) { - $item = $1; - } - # last chance here - if(s!^([^|"\s\n/][^"\n/]*)$!!) { # e.g. L<lah di dah> - $section = $1; - } - # now there should be nothing left - if(length) { - _invalid_link("garbled entry (spurious characters `$_')"); - return undef; - } - elsif(!(length($page) || length($section) || length($item))) { - _invalid_link("empty link"); - return undef; - } - elsif($alttext =~ /[<>]/) { - _invalid_link("alternative text contains < or >"); - return undef; - } - else { # no errors so far - if($page =~ /[(]\d\w*[)]$/) { - $self->warning("brackets in `$page'"); - $page = $`; # strip that extension - } - if($page =~ /^(\s*)(\S+)(\s*)/ && (length($1) || length($3))) { - $self->warning("whitespace in `$page'"); - $page = $2; # strip that extension + # skip this paragraph if in a =begin block + unless($self->{_have_begin}) { + my $block = $self->interpolate_and_check($paragraph, $line,$file); + if($self->{_current_head1} eq 'NAME') { + if($block =~ /^\s*(\S+?)\s*[,-]/) { + # this is the canonical name + $self->{-name} = $1 unless(defined $self->{-name}); + } } } - $self->page($page); - $self->node($section || $item); # _TODO_ do not distinguish for now - $self->alttext($alttext); - $self->type($item ? 'item' : 'section'); - 1; -} - -sub _construct_text { - my $self = shift; - my $alttext = $self->alttext(); - my $type = $self->type(); - my $section = $self->node(); - my $page = $self->page(); - $self->{_text} = - $alttext ? $alttext : ( - !$section ? '' : - $type eq 'item' ? 'the ' . $section . ' entry' : - 'the section on ' . $section ) . - ($page ? ($section ? ' in ':''). 'the ' . $page . ' manpage' : - 'elsewhere in this document'); - # for being marked up later - $self->{_markup} = - $alttext ? '<SECTON>' . $alttext . '<SECTOFF>' : ( - !$section ? '' : - $type eq 'item' ? 'the <SECTON>' . $section . '<SECTOFF> entry' : - 'the section on <SECTON>' . $section . '<SECTOFF>' ) . - ($page ? ($section ? ' in ':'') . 'the <PAGEON>' . - $page . '<PAGEOFF> manpage' : - ' elsewhere in this document'); -} - -# include markup -sub markup { - my ($self,$on,$off,$pageon,$pageoff) = @_; - $on ||= ''; - $off ||= ''; - $pageon ||= ''; - $pageoff ||= ''; - $_[0]->_construct_text; - my $str = $self->{_markup}; - $str =~ s/<SECTON>/$on/; - $str =~ s/<SECTOFF>/$off/; - $str =~ s/<PAGEON>/$pageon/; - $str =~ s/<PAGEOFF>/$pageoff/; - return $str; -} - -# The complete link's text -sub text { - $_[0]->_construct_text(); - $_[0]->{_text}; -} - -# The POD page the link appears on -sub warning { - my $self = shift; - if(@_) { - push(@{$self->{_warnings}}, @_); - return @_; - } - return @{$self->{_warnings}}; -} - -# The POD file name the link appears in -sub file { - return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; -} - -# The line in the file the link appears -sub line { - return (@_ > 1) ? ($_[0]->{-line} = $_[1]) : $_[0]->{-line}; -} - -# The POD page the link appears on -sub page { - return (@_ > 1) ? ($_[0]->{-page} = $_[1]) : $_[0]->{-page}; -} - -# The link destination -sub node { - return (@_ > 1) ? ($_[0]->{-node} = $_[1]) : $_[0]->{-node}; -} - -# Potential alternative text -sub alttext { - return (@_ > 1) ? ($_[0]->{-alttext} = $_[1]) : $_[0]->{-alttext}; -} - -# The type -sub type { - return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; -} - -sub _invalid_link { - my ($msg) = @_; - # this sets @_ - #eval { die "$msg\n" }; - #chomp $@; - $@ = $msg; # this seems to work, too! - undef; } 1; diff --git a/lib/Pod/Find.pm b/lib/Pod/Find.pm new file mode 100644 index 0000000000..399bbba252 --- /dev/null +++ b/lib/Pod/Find.pm @@ -0,0 +1,259 @@ +############################################################################# +# Pod/Find.pm -- finds files containing POD documentation +# +# Author: Marek Rouchal <marek@saftsack.fs.uni-bayreuth.de> +# +# borrowing code from Nick Ing-Simmon's PodToHtml +# This file is part of "PodParser". Pod::Find is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::Find; + +use vars qw($VERSION); +$VERSION = 0.10; ## Current version of this package +require 5.005; ## requires this Perl version or later + +############################################################################# + +=head1 NAME + +Pod::Find - find POD documents in directory trees + +=head1 SYNOPSIS + + use Pod::Find qw(pod_find simplify_name); + my %pods = pod_find({ -verbose => 1, -inc => 1 }); + foreach(keys %pods) { + print "found library POD `$pods{$_}' in $_\n"; + } + + print "podname=",simplify_name('a/b/c/mymodule.pod'),"\n"; + +=head1 DESCRIPTION + +B<Pod::Find> provides a function B<pod_find> that searches for POD +documents in a given set of files and directories. It returns a hash +with the file names as keys and the POD name as value. The POD name +is derived from the file name and its position in the directory tree. + +E.g. when searching in F<$HOME/perl5lib>, the file +F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>, +whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be +I<Myclass::Subclass>. The name information can be used for POD +translators. + +Only text files containing at least one valid POD command are found. + +A warning is printed if more than one POD file with the same POD name +is found, e.g. F<CPAN.pm> in different directories. This usually +indicates duplicate occurences of modules in the I<@INC> search path. + +The function B<simplify_name> is equivalent to B<basename>, but also +strips Perl-like extensions (.pm, .pl, .pod). + +Note that neither B<pod_find> nor B<simplify_name> are exported by +default so be sure to specify them in the B<use> statement if you need them: + + use Pod::Find qw(pod_find simplify_name); + +=head1 OPTIONS + +The first argument for B<pod_find> may be a hash reference with options. +The rest are either directories that are searched recursively or files. +The POD names of files are the plain basenames with any Perl-like extension +(.pm, .pl, .pod) stripped. + +=over 4 + +=item B<-verbose> + +Print progress information while scanning. + +=item B<-perl> + +Apply Perl-specific heuristics to find the correct PODs. This includes +stripping Perl-like extensions, omitting subdirectories that are numeric +but do I<not> match the current Perl interpreter's version id, suppressing +F<site_perl> as a module hierarchy name etc. + +=item B<-script> + +Search for PODs in the current Perl interpreter's installation +B<scriptdir>. This is taken from the local L<Config|Config> module. + +=item B<-inc> + +Search for PODs in the current Perl interpreter's I<@INC> paths. + +=back + +=head1 AUTHOR + +Marek Rouchal E<lt>marek@saftsack.fs.uni-bayreuth.deE<gt>, +heavily borrowing code from Nick Ing-Simmons' PodToHtml. + +=head1 SEE ALSO + +L<Pod::Parser>, L<Pod::Checker> + +=cut + +use strict; +#use diagnostics; +use Exporter; +use File::Find; +use Cwd; + +use vars qw(@ISA @EXPORT_OK $VERSION); +@ISA = qw(Exporter); +@EXPORT_OK = qw(&pod_find &simplify_name); + +# package global variables +my $SIMPLIFY_RX; + +# return a hash of the +sub pod_find +{ + my %opts; + if(ref $_[0]) { + %opts = %{shift()}; + } + + $opts{-verbose} ||= 0; + $opts{-perl} ||= 0; + + my (@search) = @_; + + if($opts{-script}) { + require Config; + push(@search, $Config::Config{scriptdir}); + $opts{-perl} = 1; + } + + if($opts{-inc}) { + push(@search, grep($_ ne '.',@INC)); + $opts{-perl} = 1; + } + + if($opts{-perl}) { + require Config; + # this code simplifies the POD name for Perl modules: + # * remove "site_perl" + # * remove e.g. "i586-linux" + # * remove e.g. 5.00503 + # * remove pod/ if followed by *.pod (e.g. in pod/perlfunc.pod) + $SIMPLIFY_RX = + qr!^(?i:site_perl/|$Config::Config{archname}/|\d+\.\d+([_.]?\d+)?/|pod/(?=.*?\.pod$))*!o; + } + + my %dirs_visited; + my %pods; + my %names; + my $pwd = cwd(); + + foreach my $try (@search) { + unless($try =~ m:^/:) { + # make path absolute + $try = join('/',$pwd,$try); + } + $try =~ s:/\.?(?=/|$)::; # simplify path + my $name; + if(-f $try) { + if($name = _check_and_extract_name($try, $opts{-verbose})) { + _check_for_duplicates($try, $name, \%names, \%pods); + } + next; + } + my $root_rx = qr!^\Q$try\E/!; + File::Find::find( sub { + my $item = $File::Find::name; + if(-d) { + if($dirs_visited{$item}) { + warn "Directory '$item' already seen, skipping.\n" + if($opts{-verbose}); + $File::Find::prune = 1; + return; + } + else { + $dirs_visited{$item} = 1; + } + if($opts{-perl} && /^(\d+\.[\d_]+)$/ && eval "$1" != $]) { + $File::Find::prune = 1; + warn "Perl $] version mismatch on $_, skipping.\n" + if($opts{-verbose}); + } + return; + } + if($name = _check_and_extract_name($item, $opts{-verbose}, $root_rx)) { + _check_for_duplicates($item, $name, \%names, \%pods); + } + }, $try); # end of File::Find::find + } + chdir $pwd; + %pods; +} + +sub _check_for_duplicates { + my ($file, $name, $names_ref, $pods_ref) = @_; + if($$names_ref{$name}) { + warn "Duplicate POD found (shadowing?): $name ($file)\n"; + warn " Already seen in ", + join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n"; + } + else { + $$names_ref{$name} = 1; + } + $$pods_ref{$file} = $name; +} + +sub _check_and_extract_name { + my ($file, $verbose, $root_rx) = @_; + + # check extension or executable + unless($file =~ /\.(pod|pm|pl)$/i || (-f $file && -x _ && -T _)) { + return undef; + } + + # check for one line of POD + unless(open(POD,"<$file")) { + warn "Error: $file is unreadable: $!\n"; + return undef; + } + local $/ = undef; + my $pod = <POD>; + close(POD); + unless($pod =~ /\n=(head\d|pod|over|item)\b/) { + warn "No POD in $file, skipping.\n" + if($verbose); + return; + } + undef $pod; + + # strip non-significant path components + # _TODO_ what happens on e.g. Win32? + my $name = $file; + if(defined $root_rx) { + $name =~ s!$root_rx!!; + $name =~ s!$SIMPLIFY_RX!!o if(defined $SIMPLIFY_RX); + } + else { + $name =~ s:^.*/::; + } + $name =~ s/\.(pod|pm|pl)$//i; + $name =~ s!/+!::!g; + $name; +} + +# basic simplification of the POD name: +# basename & strip extension +sub simplify_name { + my ($str) = @_; + $str =~ s:^.*/::; + $str =~ s:\.p([lm]|od)$::i; + $str; +} + +1; + diff --git a/lib/Pod/Html.pm b/lib/Pod/Html.pm index 15757ec80d..4d77bc0a11 100644 --- a/lib/Pod/Html.pm +++ b/lib/Pod/Html.pm @@ -5,7 +5,7 @@ use Getopt::Long; # package for handling command-line parameters use File::Spec::Unix; require Exporter; use vars qw($VERSION); -$VERSION = 1.02; +$VERSION = 1.03; @ISA = Exporter; @EXPORT = qw(pod2html htmlify); use Cwd; @@ -176,10 +176,6 @@ Uses $Config{pod2html} to setup default options. Tom Christiansen, E<lt>tchrist@perl.comE<gt>. -=head1 BUGS - -Has trouble with C<> etc in = commands. - =head1 SEE ALSO L<perlpod> @@ -216,13 +212,8 @@ my $quiet = 0; # not quiet by default my $verbose = 0; # not verbose by default my $doindex = 1; # non-zero if we should generate an index my $listlevel = 0; # current list depth -my @listitem = (); # stack of HTML commands to use when a =item is - # encountered. the top of the stack is the - # current list. -my @listdata = (); # similar to @listitem, but for the text after - # an =item -my @listend = (); # similar to @listitem, but the text to use to - # end the list. +my @listend = (); # the text to use to end the list. +my $after_lpar = 0; # set to true after a par in an =item my $ignore = 1; # whether or not to format text. we don't # format text until we hit our first pod # directive. @@ -236,11 +227,13 @@ my $top = 1; # true if we are at the top of the doc. used # to prevent the first <HR> directive. my $paragraph; # which paragraph we're processing (used # for error messages) +my $ptQuote = 0; # status of double-quote conversion my %pages = (); # associative array used to find the location # of pages referenced by L<> links. my %sections = (); # sections within this page my %items = (); # associative array used to find the location # of =item directives referenced by C<> links +my %local_items = (); # local items - avoid destruction of %items my $Is83; # is dos with short filenames (8.3) sub init_globals { @@ -263,13 +256,8 @@ $quiet = 0; # not quiet by default $verbose = 0; # not verbose by default $doindex = 1; # non-zero if we should generate an index $listlevel = 0; # current list depth -@listitem = (); # stack of HTML commands to use when a =item is - # encountered. the top of the stack is the - # current list. -@listdata = (); # similar to @listitem, but for the text after - # an =item -@listend = (); # similar to @listitem, but the text to use to - # end the list. +@listend = (); # the text to use to end the list. +$after_lpar = 0; # set to true after a par in an =item $ignore = 1; # whether or not to format text. we don't # format text until we hit our first pod # directive. @@ -291,9 +279,28 @@ $paragraph = ''; # which paragraph we're processing (used # of pages referenced by L<> links. #%items = (); # associative array used to find the location # of =item directives referenced by C<> links +%local_items = (); $Is83=$^O eq 'dos'; } +# +# clean_data: global clean-up of pod data +# +sub clean_data($){ + my( $dataref ) = @_; + my $i; + for( $i = 0; $i <= $#$dataref; $i++ ){ + ${$dataref}[$i] =~ s/\s+\Z//; + + # have a look for all-space lines + if( ${$dataref}[$i] =~ /^\s+$/m ){ + my @chunks = split( /^\s+$/m, ${$dataref}[$i] ); + splice( @$dataref, $i, 1, @chunks ); + } + } +} + + sub pod2html { local(@ARGV) = @_; local($/); @@ -341,6 +348,7 @@ sub pod2html { $/ = ""; my @poddata = <POD>; close(POD); + clean_data( \@poddata ); # scan the pod for =head[1-6] directives and build an index my $index = scan_headings(\%sections, @poddata); @@ -410,12 +418,13 @@ END_OF_HEAD get_cache($dircache, $itemcache, \@podpath, $podroot, $recurse); # scan the pod for =item directives - scan_items("", \%items, @poddata); + scan_items( \%local_items, "", @poddata); # put an index at the top of the file. note, if $doindex is 0 we # still generate an index, but surround it with an html comment. # that way some other program can extract it if desired. $index =~ s/--+/-/g; + print HTML "<A NAME=\"__index__\"></A>\n"; print HTML "<!-- INDEX BEGIN -->\n"; print HTML "<!--\n" unless $doindex; print HTML $index; @@ -424,12 +433,16 @@ END_OF_HEAD print HTML "<HR>\n" if $doindex and $index; # now convert this file - warn "Converting input file\n" if $verbose; - foreach my $i (0..$#poddata) { + my $after_item; # set to true after an =item + warn "Converting input file $podfile\n" if $verbose; + foreach my $i (0..$#poddata){ + $ptQuote = 0; # status of quote conversion + $_ = $poddata[$i]; $paragraph = $i+1; if (/^(=.*)/s) { # is it a pod directive? $ignore = 0; + $after_item = 0; $_ = $1; if (/^=begin\s+(\S+)\s*(.*)/si) {# =begin process_begin($1, $2); @@ -443,14 +456,17 @@ END_OF_HEAD next if @begin_stack && $begin_stack[-1] ne 'html'; if (/^=(head[1-6])\s+(.*\S)/s) { # =head[1-6] heading - process_head($1, $2); - } elsif (/^=item\s*(.*\S)/sm) { # =item text - process_item($1); + process_head( $1, $2, $doindex && $index ); + } elsif (/^=item\s*(.*\S)?/sm) { # =item text + warn "$0: $podfile: =item without bullet, number or text" + . " in paragraph $paragraph.\n" if !defined($1) or $1 eq ''; + process_item( $1 ); + $after_item = 1; } elsif (/^=over\s*(.*)/) { # =over N process_over(); } elsif (/^=back/) { # =back process_back(); - } elsif (/^=for\s+(\S+)\s+(.*)/si) {# =for + } elsif (/^=for\s+(\S+)\s*(.*)/si) {# =for process_for($1,$2); } else { /^=(\S*)\s*/; @@ -464,13 +480,53 @@ END_OF_HEAD next if $ignore; next if @begin_stack && $begin_stack[-1] ne 'html'; my $text = $_; - process_text(\$text, 1); - print HTML "<P>\n$text</P>\n"; + if( $text =~ /\A\s+/ ){ + process_pre( \$text ); + print HTML "<PRE>\n$text</PRE>\n"; + + } else { + process_text( \$text ); + + # experimental: check for a paragraph where all lines + # have some ...\t...\t...\n pattern + if( $text =~ /\t/ ){ + my @lines = split( "\n", $text ); + if( @lines > 1 ){ + my $all = 2; + foreach my $line ( @lines ){ + if( $line =~ /\S/ && $line !~ /\t/ ){ + $all--; + last if $all == 0; + } + } + if( $all > 0 ){ + $text =~ s/\t+/<TD>/g; + $text =~ s/^/<TR><TD>/gm; + $text = '<TABLE CELLSPACING=0 CELLPADDING=0>' . + $text . '</TABLE>'; + } + } + } + ## end of experimental + + if( $after_item ){ + print HTML "$text\n"; + $after_lpar = 1; + } else { + print HTML "<P>$text</P>\n"; + } + } + $after_item = 0; } } # finish off any pending directives finish_list(); + + # link to page index + print HTML "<P><A HREF=\"#__index__\"><SMALL>page index</SMALL></A></P>\n" + if $doindex and $index; + print HTML <<END_OF_TAIL; $block </BODY> @@ -532,7 +588,7 @@ Usage: $0 --help --htmlroot=<name> --infile=<name> --outfile=<name> END_OF_USAGE sub parse_command_line { - my ($opt_flush,$opt_help,$opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,$opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_norecurse,$opt_recurse,$opt_title,$opt_verbose,$opt_css,$opt_header,$opt_quiet); + my ($opt_flush,$opt_help,$opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,$opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_recurse,$opt_title,$opt_verbose,$opt_css,$opt_header,$opt_quiet); unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html}; my $result = GetOptions( 'flush' => \$opt_flush, @@ -546,7 +602,6 @@ sub parse_command_line { 'outfile=s' => \$opt_outfile, 'podpath=s' => \$opt_podpath, 'podroot=s' => \$opt_podroot, - 'norecurse' => \$opt_norecurse, 'recurse!' => \$opt_recurse, 'title=s' => \$opt_title, 'header' => \$opt_header, @@ -626,7 +681,6 @@ sub cache_key { # are valid caches of %pages and %items. if they are valid then it loads # them and returns a non-zero value. # - sub load_cache { my($dircache, $itemcache, $podpath, $podroot) = @_; my($tests); @@ -740,15 +794,17 @@ sub scan_podpath { die "$0: error opening $dirname/$pod for input: $!\n"; @poddata = <POD>; close(POD); + clean_data( \@poddata ); - scan_items("$dirname/$pod", @poddata); + scan_items( \%items, "$dirname/$pod", @poddata); } # use the names of files as =item directives too. - foreach $pod (@files) { - $pod =~ /^(.*)(\.pod|\.pm)$/; - $items{$1} = "$dirname/$1.html" if $1; - } +### Don't think this should be done this way - confuses issues.(WL) +### foreach $pod (@files) { +### $pod =~ /^(.*)(\.pod|\.pm)$/; +### $items{$1} = "$dirname/$1.html" if $1; +### } } elsif ($pages{$libpod} =~ /([^:]*\.pod):/ || $pages{$libpod} =~ /([^:]*\.pm):/) { # scan the .pod or .pm file for =item directives @@ -757,8 +813,9 @@ sub scan_podpath { die "$0: error opening $pod for input: $!\n"; @poddata = <POD>; close(POD); + clean_data( \@poddata ); - scan_items("$pod", @poddata); + scan_items( \%items, "$pod", @poddata); } else { warn "$0: shouldn't be here (line ".__LINE__."\n"; } @@ -842,7 +899,7 @@ sub scan_dir { # sub scan_headings { my($sections, @data) = @_; - my($tag, $which_head, $title, $listdepth, $index); + my($tag, $which_head, $otitle, $listdepth, $index); # here we need local $ignore = 0; # unfortunately, we can't have it, because $ignore is lexical @@ -855,9 +912,12 @@ sub scan_headings { # pointing to each of them. foreach my $line (@data) { if ($line =~ /^=(head)([1-6])\s+(.*)/) { - ($tag,$which_head, $title) = ($1,$2,$3); - chomp($title); - $$sections{htmlify(0,$title)} = 1; + ($tag, $which_head, $otitle) = ($1,$2,$3); + + my $title = depod( $otitle ); + my $name = htmlify( $title ); + $$sections{$name} = 1; + $title = process_text( \$otitle ); while ($which_head != $listdepth) { if ($which_head > $listdepth) { @@ -870,8 +930,8 @@ sub scan_headings { } $index .= "\n" . ("\t" x $listdepth) . "<LI>" . - "<A HREF=\"#" . htmlify(0,$title) . "\">" . - html_escape(process_text(\$title, 0)) . "</A></LI>"; + "<A HREF=\"#" . $name . "\">" . + $title . "</A></LI>"; } } @@ -893,7 +953,7 @@ sub scan_headings { # will use this information later on in resolving C<> links. # sub scan_items { - my($pod, @poddata) = @_; + my( $itemref, $pod, @poddata ) = @_; my($i, $item); local $_; @@ -901,28 +961,22 @@ sub scan_items { $pod .= ".html" if $pod; foreach $i (0..$#poddata) { - $_ = $poddata[$i]; - - # remove any formatting instructions - s,[A-Z]<([^<>]*)>,$1,g; - - # figure out what kind of item it is and get the first word of - # it's name. - if (/^=item\s+(\w*)\s*.*$/s) { - if ($1 eq "*") { # bullet list - /\A=item\s+\*\s*(.*?)\s*\Z/s; - $item = $1; - } elsif ($1 =~ /^\d+/) { # numbered list - /\A=item\s+\d+\.?(.*?)\s*\Z/s; - $item = $1; - } else { -# /\A=item\s+(.*?)\s*\Z/s; - /\A=item\s+(\w*)/s; - $item = $1; - } - - $items{$item} = "$pod" if $item; + my $txt = depod( $poddata[$i] ); + + # figure out what kind of item it is. + # Build string for referencing this item. + if ( $txt =~ /\A=item\s+\*\s*(.*)\Z/s ) { # bullet + next unless $1; + $item = $1; + } elsif( $txt =~ /\A=item\s+(?>\d+\.?)\s*(.*)\Z/s ) { # numbered list + $item = $1; + } elsif( $txt =~ /\A=item\s+(.*)\Z/s ) { # plain item + $item = $1; + } else { + next; } + my $fid = fragment_id( $item ); + $$itemref{$fid} = "$pod" if $fid; } } @@ -930,168 +984,167 @@ sub scan_items { # process_head - convert a pod head[1-6] tag and convert it to HTML format. # sub process_head { - my($tag, $heading) = @_; - my $firstword; + my($tag, $heading, $hasindex) = @_; # figure out the level of the =head $tag =~ /head([1-6])/; my $level = $1; - # can't have a heading full of spaces and speechmarks and so on - $firstword = $heading; $firstword =~ s/\s*(\w+)\s.*/$1/; - - print HTML "<P>\n" unless $listlevel; - print HTML "<HR>\n" unless $listlevel || $top; - print HTML "<H$level>"; # unless $listlevel; - #print HTML "<H$level>" unless $listlevel; - my $convert = $heading; process_text(\$convert, 0); - $convert = html_escape($convert); - print HTML '<A NAME="' . htmlify(0,$heading) . "\">$convert</A>"; - print HTML "</H$level>"; # unless $listlevel; - print HTML "\n"; + if( $listlevel ){ + warn "$0: $podfile: unterminated list at =head in paragraph $paragraph. ignoring.\n"; + while( $listlevel ){ + process_back(); + } + } + + print HTML "<P>\n"; + if( $level == 1 && ! $top ){ + print HTML "<A HREF=\"#__index__\"><SMALL>page index</SMALL></A>\n" + if $hasindex; + print HTML "<HR>\n" + } + + my $name = htmlify( depod( $heading ) ); + my $convert = process_text( \$heading ); + print HTML "<H$level><A NAME=\"$name\">$convert</A></H$level>\n"; } + # -# process_item - convert a pod item tag and convert it to HTML format. +# emit_item_tag - print an =item's text +# Note: The global $EmittedItem is used for inhibiting self-references. # -sub process_item { - my $text = $_[0]; - my($i, $quote, $name); +my $EmittedItem; - my $need_preamble = 0; - my $this_entry; +sub emit_item_tag($$$){ + my( $otext, $text, $compact ) = @_; + my $item = fragment_id( $text ); + + $EmittedItem = $item; + ### print STDERR "emit_item_tag=$item ($text)\n"; + + print HTML '<STRONG>'; + if ($items_named{$item}++) { + print HTML process_text( \$otext ); + } else { + my $name = 'item_' . $item; + print HTML qq{<A NAME="$name">}, process_text( \$otext ), '</A>'; + } + print HTML "</STRONG><BR>\n"; + undef( $EmittedItem ); +} + +sub emit_li { + my( $tag ) = @_; + if( $items_seen[$listlevel]++ == 0 ){ + push( @listend, "</$tag>" ); + print HTML "<$tag>\n"; + } + print HTML $tag eq 'DL' ? '<DT>' : '<LI>'; +} +# +# process_item - convert a pod item tag and convert it to HTML format. +# +sub process_item { + my( $otext ) = @_; # lots of documents start a list without doing an =over. this is # bad! but, the proper thing to do seems to be to just assume # they did do an =over. so warn them once and then continue. - warn "$0: $podfile: unexpected =item directive in paragraph $paragraph. ignoring.\n" - unless $listlevel; - process_over() unless $listlevel; + if( $listlevel == 0 ){ + warn "$0: $podfile: unexpected =item directive in paragraph $paragraph. ignoring.\n"; + process_over(); + } - return unless $listlevel; + # formatting: insert a paragraph if preceding item has >1 paragraph + if( $after_lpar ){ + print HTML "<P></P>\n"; + $after_lpar = 0; + } # remove formatting instructions from the text - 1 while $text =~ s/[A-Z]<([^<>]*)>/$1/g; - pre_escape(\$text); - - $need_preamble = $items_seen[$listlevel]++ == 0; - - # check if this is the first =item after an =over - $i = $listlevel - 1; - my $need_new = $listlevel >= @listitem; - - if ($text =~ /\A\*/) { # bullet - - if ($need_preamble) { - push(@listend, "</UL>"); - print HTML "<UL>\n"; + my $text = depod( $otext ); + + # all the list variants: + if( $text =~ /\A\*/ ){ # bullet + emit_li( 'UL' ); + if ($text =~ /\A\*\s+(.+)\Z/s ) { # with additional text + my $tag = $1; + $otext =~ s/\A\*\s+//; + emit_item_tag( $otext, $tag, 1 ); } - print HTML '<LI>'; - if ($text =~ /\A\*\s*(.+)\Z/s) { - print HTML '<STRONG>'; - if ($items_named{$1}++) { - print HTML html_escape($1); - } else { - my $name = 'item_' . htmlify(1,$1); - print HTML qq(<A NAME="$name">), html_escape($1), '</A>'; - } - print HTML '</STRONG>'; + } elsif( $text =~ /\A\d+/ ){ # numbered list + emit_li( 'OL' ); + if ($text =~ /\A(?>\d+\.?)\s*(.+)\Z/s ) { # with additional text + my $tag = $1; + $otext =~ s/\A\d+\.?\s*//; + emit_item_tag( $otext, $tag, 1 ); } - } elsif ($text =~ /\A[\d#]+/) { # numbered list - - if ($need_preamble) { - push(@listend, "</OL>"); - print HTML "<OL>\n"; - } - - print HTML '<LI>'; - if ($text =~ /\A\d+\.?\s*(.+)\Z/s) { - print HTML '<STRONG>'; - if ($items_named{$1}++) { - print HTML html_escape($1); - } else { - my $name = 'item_' . htmlify(0,$1); - print HTML qq(<A NAME="$name">), html_escape($1), '</A>'; - } - print HTML '</STRONG>'; - } - - } else { # all others - - if ($need_preamble) { - push(@listend, '</DL>'); - print HTML "<DL>\n"; - } - - print HTML '<DT>'; - if ($text =~ /(\S+)/) { - print HTML '<STRONG>'; - if ($items_named{$1}++) { - print HTML html_escape($text); - } else { - my $name = 'item_' . htmlify(1,$text); - print HTML qq(<A NAME="$name">), html_escape($text), '</A>'; - } - print HTML '</STRONG>'; + } else { # definition list + emit_li( 'DL' ); + if ($text =~ /\A(.+)\Z/s ){ # should have text + emit_item_tag( $otext, $text, 1 ); } print HTML '<DD>'; } - print HTML "\n"; } # -# process_over - process a pod over tag and start a corresponding HTML -# list. +# process_over - process a pod over tag and start a corresponding HTML list. # sub process_over { # start a new list $listlevel++; + push( @items_seen, 0 ); + $after_lpar = 0; } # # process_back - process a pod back tag and convert it to HTML format. # sub process_back { - warn "$0: $podfile: unexpected =back directive in paragraph $paragraph. ignoring.\n" - unless $listlevel; - return unless $listlevel; + if( $listlevel == 0 ){ + warn "$0: $podfile: unexpected =back directive in paragraph $paragraph. ignoring.\n"; + return; + } # close off the list. note, I check to see if $listend[$listlevel] is # defined because an =item directive may have never appeared and thus # $listend[$listlevel] may have never been initialized. $listlevel--; - print HTML $listend[$listlevel] if defined $listend[$listlevel]; - print HTML "\n"; - - # don't need the corresponding perl code anymore - pop(@listitem); - pop(@listdata); - pop(@listend); + if( defined $listend[$listlevel] ){ + print HTML '<P></P>' if $after_lpar; + print HTML $listend[$listlevel]; + print HTML "\n"; + pop( @listend ); + } + $after_lpar = 0; - pop(@items_seen); + # clean up item count + pop( @items_seen ); } # -# process_cut - process a pod cut tag, thus stop ignoring pod directives. +# process_cut - process a pod cut tag, thus start ignoring pod directives. # sub process_cut { $ignore = 1; } # -# process_pod - process a pod pod tag, thus ignore pod directives until we see a -# corresponding cut. +# process_pod - process a pod pod tag, thus stop ignoring pod directives +# until we see a corresponding cut. # sub process_pod { # no need to set $ignore to 0 cause the main loop did it } # -# process_for - process a =for pod tag. if it's for html, split +# process_for - process a =for pod tag. if it's for html, spit # it out verbatim, if illustration, center it, otherwise ignore it. # sub process_for { @@ -1131,78 +1184,69 @@ sub process_end { if ($begin_stack[-1] ne $whom ) { die "Unmatched begin/end at chunk $paragraph\n" } - pop @begin_stack; + pop( @begin_stack ); } # -# process_text - handles plaintext that appears in the input pod file. -# there may be pod commands embedded within the text so those must be -# converted to html commands. +# process_pre - indented paragraph, made into <PRE></PRE> # -sub process_text { - my($text, $escapeQuotes) = @_; - my($result, $rest, $s1, $s2, $s3, $s4, $match, $bf); - my($podcommand, $params, $tag, $quote); - +sub process_pre { + my( $text ) = @_; + my( $rest ); return if $ignore; - $quote = 0; # status of double-quote conversion - $result = ""; $rest = $$text; - if ($rest =~ /^\s+/) { # preformatted text, no pod directives - $rest =~ s/\n+\Z//; - $rest =~ s#.*# + # insert spaces in place of tabs + $rest =~ s#.*# my $line = $&; 1 while $line =~ s/\t+/' ' x (length($&) * 8 - length($`) % 8)/e; $line; #eg; - $rest =~ s/&/&/g; - $rest =~ s/</</g; - $rest =~ s/>/>/g; - $rest =~ s/"/"/g; - - # try and create links for all occurrences of perl.* within - # the preformatted text. - $rest =~ s{ - (\s*)(perl\w+) - }{ - if (defined $pages{$2}) { # is a link - qq($1<A HREF="$htmlroot/$pages{$2}">$2</A>); - } elsif (defined $pages{dosify($2)}) { # is a link - qq($1<A HREF="$htmlroot/$pages{dosify($2)}">$2</A>); - } else { - "$1$2"; - } - }xeg; -# $rest =~ s/(<A HREF=)([^>:]*:)?([^>:]*)\.pod:([^>:]*:)?/$1$3.html/g; - $rest =~ s{ - (<A\ HREF="?) ([^>:]*:)? ([^>:]*) \.pod: ([^>:]*:)? - }{ - my $url ; - if ( $htmlfileurl ne '' ) { - # Here, we take advantage of the knowledge - # that $htmlfileurl ne '' implies $htmlroot eq ''. - # Since $htmlroot eq '', we need to prepend $htmldir - # on the fron of the link to get the absolute path - # of the link's target. We check for a leading '/' - # to avoid corrupting links that are #, file:, etc. - my $old_url = $3 ; - $old_url = "$htmldir$old_url" - if ( $old_url =~ m{^\/} ) ; - $url = relativize_url( "$old_url.html", $htmlfileurl ); -# print( " a: [$old_url.html,$htmlfileurl,$url]\n" ) ; - } - else { - $url = "$3.html" ; - } - "$1$url" ; - }xeg; - - # Look for embedded URLs and make them in to links. We don't - # relativize them since they are best left as the author intended. - my $urls = '(' . join ('|', qw{ + # convert some special chars to HTML escapes + $rest =~ s/&/&/g; + $rest =~ s/</</g; + $rest =~ s/>/>/g; + $rest =~ s/"/"/g; + + # try and create links for all occurrences of perl.* within + # the preformatted text. + $rest =~ s{ + (\s*)(perl\w+) + }{ + if ( defined $pages{$2} ){ # is a link + qq($1<A HREF="$htmlroot/$pages{$2}">$2</A>); + } elsif (defined $pages{dosify($2)}) { # is a link + qq($1<A HREF="$htmlroot/$pages{dosify($2)}">$2</A>); + } else { + "$1$2"; + } + }xeg; + $rest =~ s{ + (<A\ HREF="?) ([^>:]*:)? ([^>:]*) \.pod: ([^>:]*:)? + }{ + my $url ; + if ( $htmlfileurl ne '' ){ + # Here, we take advantage of the knowledge + # that $htmlfileurl ne '' implies $htmlroot eq ''. + # Since $htmlroot eq '', we need to prepend $htmldir + # on the fron of the link to get the absolute path + # of the link's target. We check for a leading '/' + # to avoid corrupting links that are #, file:, etc. + my $old_url = $3 ; + $old_url = "$htmldir$old_url" if $old_url =~ m{^\/}; + $url = relativize_url( "$old_url.html", $htmlfileurl ); + } else { + $url = "$3.html" ; + } + "$1$url" ; + }xeg; + + # Look for embedded URLs and make them into links. We don't + # relativize them since they are best left as the author intended. + + my $urls = '(' . join ('|', qw{ http telnet mailto @@ -1214,12 +1258,12 @@ sub process_text { } ) . ')'; - my $ltrs = '\w'; - my $gunk = '/#~:.?+=&%@!\-'; - my $punc = '.:?\-'; - my $any = "${ltrs}${gunk}${punc}"; + my $ltrs = '\w'; + my $gunk = '/#~:.?+=&%@!\-'; + my $punc = '.:?\-'; + my $any = "${ltrs}${gunk}${punc}"; - $rest =~ s{ + $rest =~ s{ \b # start at word boundary ( # begin $1 { $urls : # need resource and a colon @@ -1237,166 +1281,76 @@ sub process_text { ) }{<A HREF="$1">$1</A>}igox; - $result = "<PRE>" # text should be as it is (verbatim) - . "$rest\n" - . "</PRE>\n"; - } else { # formatted text - # parse through the string, stopping each time we find a - # pod-escape. once the string has been throughly processed - # we can output it. - while (length $rest) { - # check to see if there are any possible pod directives in - # the remaining part of the text. - if ($rest =~ m/[BCEIFLSZ]</) { - warn "\$rest\t= $rest\n" unless - $rest =~ /\A - ([^<]*?) - ([BCEIFLSZ]?) - < - (.*)\Z/xs; - - $s1 = $1; # pure text - $s2 = $2; # the type of pod-escape that follows - $s3 = '<'; # '<' - $s4 = $3; # the rest of the string - } else { - $s1 = $rest; - $s2 = ""; - $s3 = ""; - $s4 = ""; - } - - if ($s3 eq '<' && $s2) { # a pod-escape - $result .= ($escapeQuotes ? process_puretext($s1, \$quote) : $s1); - $podcommand = "$s2<"; - $rest = $s4; - - # find the matching '>' - $match = 1; - $bf = 0; - while ($match && !$bf) { - $bf = 1; - if ($rest =~ /\A([^<>]*[BCEIFLSZ]<)(.*)\Z/s) { - $bf = 0; - $match++; - $podcommand .= $1; - $rest = $2; - } elsif ($rest =~ /\A([^>]*>)(.*)\Z/s) { - $bf = 0; - $match--; - $podcommand .= $1; - $rest = $2; - } - } - - if ($match != 0) { - warn <<WARN; -$0: $podfile: cannot find matching > for $s2 in paragraph $paragraph. -WARN - $result .= substr $podcommand, 0, 2; - $rest = substr($podcommand, 2) . $rest; - next; - } + # text should be as it is (verbatim) + $$text = $rest; +} - # pull out the parameters to the pod-escape - $podcommand =~ /^([BCFEILSZ]?)<(.*)>$/s; - $tag = $1; - $params = $2; - - # process the text within the pod-escape so that any escapes - # which must occur do. - process_text(\$params, 0) unless $tag eq 'L'; - - $s1 = $params; - if (!$tag || $tag eq " ") { # <> : no tag - $s1 = "<$params>"; - } elsif ($tag eq "L") { # L<> : link - $s1 = process_L($params); - } elsif ($tag eq "I" || # I<> : italicize text - $tag eq "B" || # B<> : bold text - $tag eq "F") { # F<> : file specification - $s1 = process_BFI($tag, $params); - } elsif ($tag eq "C") { # C<> : literal code - $s1 = process_C($params, 1); - } elsif ($tag eq "E") { # E<> : escape - $s1 = process_E($params); - } elsif ($tag eq "Z") { # Z<> : zero-width character - $s1 = process_Z($params); - } elsif ($tag eq "S") { # S<> : non-breaking space - $s1 = process_S($params); - } elsif ($tag eq "X") { # S<> : non-breaking space - $s1 = process_X($params); - } else { - warn "$0: $podfile: unhandled tag '$tag' in paragraph $paragraph\n"; - } - $result .= "$s1"; - } else { - # for pure text we must deal with implicit links and - # double-quotes among other things. - $result .= ($escapeQuotes ? process_puretext("$s1$s2$s3", \$quote) : "$s1$s2$s3"); - $rest = $s4; - } - } - } - $$text = $result; +# +# pure text processing +# +# pure_text/inIS_text: differ with respect to automatic C<> recognition. +# we don't want this to happen within IS +# +sub pure_text($){ + my $text = shift(); + process_puretext( $text, \$ptQuote, 1 ); } -sub html_escape { - my $rest = $_[0]; - $rest =~ s/&(?!\w+;|#)/&/g; # XXX not bulletproof - $rest =~ s/</</g; - $rest =~ s/>/>/g; - $rest =~ s/"/"/g; - return $rest; -} +sub inIS_text($){ + my $text = shift(); + process_puretext( $text, \$ptQuote, 0 ); +} # # process_puretext - process pure text (without pod-escapes) converting # double-quotes and handling implicit C<> links. # sub process_puretext { - my($text, $quote) = @_; - my(@words, $result, $rest, $lead, $trail); + my($text, $quote, $notinIS) = @_; - # convert double-quotes to single-quotes - $text =~ s/\A([^"]*)"/$1''/s if $$quote; - while ($text =~ s/\A([^"]*)["]([^"]*)["]/$1``$2''/sg) {} + ## Guessing at func() or [$@%&]*var references in plain text is destined + ## to produce some strange looking ref's. uncomment to disable: + ## $notinIS = 0; + + my(@words, $lead, $trail); - $$quote = ($text =~ m/"/ ? 1 : 0); - $text =~ s/\A([^"]*)"/$1``/s if $$quote; + # convert double-quotes to single-quotes + if( $$quote && $text =~ s/"/''/s ){ + $$quote = 0; + } + while ($text =~ s/"([^"]*)"/``$1''/sg) {}; + $$quote = 1 if $text =~ s/"/``/s; # keep track of leading and trailing white-space - $lead = ($text =~ /\A(\s*)/s ? $1 : ""); - $trail = ($text =~ /(\s*)\Z/s ? $1 : ""); + $lead = ($text =~ s/\A(\s+)//s ? $1 : ""); + $trail = ($text =~ s/(\s+)\Z//s ? $1 : ""); - # collapse all white space into a single space - $text =~ s/\s+/ /g; - @words = split(" ", $text); + # split at space/non-space boundaries + @words = split( /(?<=\s)(?=\S)|(?<=\S)(?=\s)/, $text ); # process each word individually foreach my $word (@words) { + # skip space runs + next if $word =~ /^\s*$/; # see if we can infer a link - if ($word =~ /^\w+\(/) { + if( $notinIS && $word =~ s/^(\w+)\((.*)\)\W*$/$1/ ) { # has parenthesis so should have been a C<> ref - $word = process_C($word); -# $word =~ /^[^()]*]\(/; -# if (defined $items{$1} && $items{$1}) { -# $word = "\n<CODE><A HREF=\"$htmlroot/$items{$1}#item_" -# . htmlify(0,$word) -# . "\">$word</A></CODE>"; -# } elsif (defined $items{$word} && $items{$word}) { -# $word = "\n<CODE><A HREF=\"$htmlroot/$items{$word}#item_" -# . htmlify(0,$word) -# . "\">$word</A></CODE>"; -# } else { -# $word = "\n<CODE><A HREF=\"#item_" -# . htmlify(0,$word) -# . "\">$word</A></CODE>"; -# } - } elsif ($word =~ /^[\$\@%&*]+\w+$/) { - # perl variables, should be a C<> ref - $word = process_C($word, 1); + ## try for a pagename (perlXXX(1))? + if( $2 =~ /^\d+$/ ){ + my $url = page_sect( $word, '' ); + if( defined $url ){ + $word = "<A HREF=\"$url\">the $word manpage</A>"; + next; + } + } + $word = emit_C( $word ); + +#### disabled. either all (including $\W, $\w+{.*} etc.) or nothing. +## } elsif( $notinIS && $word =~ /^[\$\@%&*]+\w+$/) { +## # perl variables, should be a C<> ref +## $word = emit_C( $word ); + } elsif ($word =~ m,^\w+://\w,) { # looks like a URL # Don't relativize it: leave it as the author intended @@ -1415,37 +1369,270 @@ sub process_puretext { } } - # build a new string based upon our conversion - $result = ""; - $rest = join(" ", @words); - while (length($rest) > 75) { - if ( $rest =~ m/^(.{0,75})\s(.*?)$/o || - $rest =~ m/^(\S*)\s(.*?)$/o) { + # put everything back together + return $lead . join( '', @words ) . $trail; +} + - $result .= "$1\n"; - $rest = $2; +# +# process_text - handles plaintext that appears in the input pod file. +# there may be pod commands embedded within the text so those must be +# converted to html commands. +# + +sub process_text1($$;$); + +sub process_text { + return if $ignore; + my( $tref ) = @_; + my $res = process_text1( 0, $tref ); + $$tref = $res; +} + +sub process_text1($$;$){ + my( $lev, $rstr, $func ) = @_; + $lev++ unless defined $func; + my $res = ''; + + $func ||= ''; + if( $func eq 'B' ){ + # B<text> - boldface + $res = '<STRONG>' . process_text1( $lev, $rstr ) . '</STRONG>'; + + } elsif( $func eq 'C' ){ + # C<code> - can be a ref or <CODE></CODE> + # need to extract text + my $par = go_ahead( $rstr, 'C' ); + + ## clean-up of the link target + my $text = depod( $par ); + + ### my $x = $par =~ /[BI]</ ? 'yes' : 'no' ; + ### print STDERR "-->call emit_C($par) lev=$lev, par with BI=$x\n"; + + $res = emit_C( $text, $lev > 1 || ($par =~ /[BI]</) ); + + } elsif( $func eq 'E' ){ + # E<x> - convert to character + $$rstr =~ s/^(\w+)>//; + $res = "&$1;"; + + } elsif( $func eq 'F' ){ + # F<filename> - italizice + $res = '<EM>' . process_text1( $lev, $rstr ) . '</EM>'; + + } elsif( $func eq 'I' ){ + # I<text> - italizice + $res = '<EM>' . process_text1( $lev, $rstr ) . '</EM>'; + + } elsif( $func eq 'L' ){ + # L<link> - link + ## L<text|cross-ref> => produce text, use cross-ref for linking + ## L<cross-ref> => make text from cross-ref + ## need to extract text + my $par = go_ahead( $rstr, 'L' ); + + # some L<>'s that shouldn't be: + # a) full-blown URL's are emitted as-is + if( $par =~ m{^\w+://}s ){ + return make_URL_href( $par ); + } + # b) C<...> is stripped and treated as C<> + if( $par =~ /^C<(.*)>$/ ){ + my $text = depod( $1 ); + return emit_C( $text, $lev > 1 || ($par =~ /[BI]</) ); + } + + # analyze the contents + $par =~ s/\n/ /g; # undo word-wrapped tags + my $opar = $par; + my $linktext; + if( $par =~ s{^([^|]+)\|}{} ){ + $linktext = $1; + } + + # make sure sections start with a / + $par =~ s{^"}{/"}; + + my( $page, $section, $ident ); + + # check for link patterns + if( $par =~ m{^([^/]+?)/(?!")(.*?)$} ){ # name/ident + # we've got a name/ident (no quotes) + ( $page, $ident ) = ( $1, $2 ); + ### print STDERR "--> L<$par> to page $page, ident $ident\n"; + + } elsif( $par =~ m{^(.*?)/"?(.*?)"?$} ){ # [name]/"section" + # even though this should be a "section", we go for ident first + ( $page, $ident ) = ( $1, $2 ); + ### print STDERR "--> L<$par> to page $page, section $section\n"; + + } elsif( $par =~ /\s/ ){ # this must be a section with missing quotes + ( $page, $section ) = ( '', $par ); + ### print STDERR "--> L<$par> to void page, section $section\n"; + + } else { + ( $page, $section ) = ( $par, '' ); + ### print STDERR "--> L<$par> to page $par, void section\n"; + } + + # now, either $section or $ident is defined. the convoluted logic + # below tries to resolve L<> according to what the user specified. + # failing this, we try to find the next best thing... + my( $url, $ltext, $fid ); + + RESOLVE: { + if( defined $ident ){ + ## try to resolve $ident as an item + ( $url, $fid ) = coderef( $page, $ident ); + if( $url ){ + if( ! defined( $linktext ) ){ + $linktext = $ident; + $linktext .= " in " if $ident && $page; + $linktext .= "the $page manpage" if $page; + } + ### print STDERR "got coderef url=$url\n"; + last RESOLVE; + } + ## no luck: go for a section (auto-quoting!) + $section = $ident; + } + ## now go for a section + my $htmlsection = htmlify( $section ); + $url = page_sect( $page, $htmlsection ); + if( $url ){ + if( ! defined( $linktext ) ){ + $linktext = $section; + $linktext .= " in " if $section && $page; + $linktext .= "the $page manpage" if $page; + } + ### print STDERR "got page/section url=$url\n"; + last RESOLVE; + } + ## no luck: go for an ident + if( $section ){ + $ident = $section; + } else { + $ident = $page; + $page = undef(); + } + ( $url, $fid ) = coderef( $page, $ident ); + if( $url ){ + if( ! defined( $linktext ) ){ + $linktext = $ident; + $linktext .= " in " if $ident && $page; + $linktext .= "the $page manpage" if $page; + } + ### print STDERR "got section=>coderef url=$url\n"; + last RESOLVE; + } + + # warning; show some text. + $linktext = $opar unless defined $linktext; + warn "$0: $podfile: cannot resolve L<$opar> in paragraph $paragraph."; + } + + # now we have an URL or just plain code + $$rstr = $linktext . '>' . $$rstr; + if( defined( $url ) ){ + $res = "<A HREF=\"$url\">" . process_text1( $lev, $rstr ) . '</A>'; + } else { + $res = '<EM>' . process_text1( $lev, $rstr ) . '</EM>'; + } + + } elsif( $func eq 'S' ){ + # S<text> - non-breaking spaces + $res = process_text1( $lev, $rstr ); + $res =~ s/ / /g; + + } elsif( $func eq 'X' ){ + # X<> - ignore + $$rstr =~ s/^[^>]*>//; + + } elsif( $func eq 'Z' ){ + # Z<> - empty + warn "$0: $podfile: invalid X<> in paragraph $paragraph." + unless $$rstr =~ s/^>//; + + } else { + while( $$rstr =~ s/\A(.*?)([BCEFILSXZ]<|>)//s ){ + # all others: either recurse into new function or + # terminate at closing angle bracket + my $pt = $1; + $pt .= '>' if $2 eq '>' && $lev == 1; + $res .= $lev == 1 ? pure_text( $pt ) : inIS_text( $pt ); + return $res if $2 eq '>' && $lev > 1; + if( $2 ne '>' ){ + $res .= process_text1( $lev, $rstr, substr($2,0,1) ); + } + + } + if( $lev == 1 ){ + $res .= pure_text( $$rstr ); } else { - $result .= "$rest\n"; - $rest = ""; + warn "$0: $podfile: undelimited $func<> in paragraph $paragraph."; } } - $result .= $rest if $rest; - - # restore the leading and trailing white-space - $result = "$lead$result$trail"; + return $res; +} - return $result; +# +# go_ahead: extract text of an IS (can be nested) +# +sub go_ahead($$){ + my( $rstr, $func ) = @_; + my $res = ''; + my $level = 1; + while( $$rstr =~ s/\A(.*?)([BCEFILSXZ]<|>)//s ){ + $res .= $1; + if( $2 eq '>' ){ + return $res if --$level == 0; + } else { + ++$level; + } + $res .= $2; + } + warn "$0: $podfile: undelimited $func<> in paragraph $paragraph."; + return $res; } # -# pre_escape - convert & in text to $amp; +# emit_C - output result of C<text> +# $text is the depod-ed text # -sub pre_escape { - my($str) = @_; - $$str =~ s/&(?!\w+;|#)/&/g; # XXX not bulletproof +sub emit_C($;$){ + my( $text, $nocode ) = @_; + my $res; + my( $url, $fid ) = coderef( undef(), $text ); + + # need HTML-safe text + my $linktext = html_escape( $text ); + + if( defined( $url ) && + (!defined( $EmittedItem ) || $EmittedItem ne $fid ) ){ + $res = "<A HREF=\"$url\"><CODE>$linktext</CODE></A>"; + } elsif( 0 && $nocode ){ + $res = $linktext; + } else { + $res = "<CODE>$linktext</CODE>"; + } + return $res; } # +# html_escape: make text safe for HTML +# +sub html_escape { + my $rest = $_[0]; + $rest =~ s/&/&/g; + $rest =~ s/</</g; + $rest =~ s/>/>/g; + $rest =~ s/"/"/g; + return $rest; +} + + +# # dosify - convert filenames to 8.3 # sub dosify { @@ -1460,54 +1647,24 @@ sub dosify { } # -# process_L - convert a pod L<> directive to a corresponding HTML link. -# most of the links made are inferred rather than known about directly -# (i.e it's not known whether the =head\d section exists in the target file, -# or whether a .pod file exists in the case of split files). however, the -# guessing usually works. +# page_sect - make an URL from the text of a L<> # -# Unlike the other directives, this should be called with an unprocessed -# string, else tags in the link won't be matched. -# -sub process_L { - my($str) = @_; - my($s1, $s2, $linktext, $page, $page83, $section, $link); # work strings - - $str =~ s/\n/ /g; # undo word-wrapped tags - $s1 = $str; - for ($s1) { - # LREF: a la HREF L<show this text|man/section> - $linktext = $1 if s:^([^|]+)\|::; - - # make sure sections start with a / - s,^",/",g; - s,^,/,g if (!m,/, && / /); - - # check if there's a section specified - if (m,^(.*?)/"?(.*?)"?$,) { # yes - ($page, $section) = ($1, $2); - } else { # no - ($page, $section) = ($_, ""); - } - - # check if we know that this is a section in this page - if (!defined $pages{$page} && defined $sections{$page}) { - $section = $page; - $page = ""; - } - - # remove trailing punctuation, like () - $section =~ s/\W*$// ; +sub page_sect($$) { + my( $page, $section ) = @_; + my( $linktext, $page83, $link); # work strings + + # check if we know that this is a section in this page + if (!defined $pages{$page} && defined $sections{$page}) { + $section = $page; + $page = ""; + ### print STDERR "reset page='', section=$section\n"; } $page83=dosify($page); $page=$page83 if (defined $pages{$page83}); if ($page eq "") { - $link = "#" . htmlify(0,$section); - $linktext = $section unless defined($linktext); + $link = "#" . htmlify( $section ); } elsif ( $page =~ /::/ ) { - $linktext = ($section ? "$section" : "$page") - unless defined($linktext); $page =~ s,::,/,g; # Search page cache for an entry keyed under the html page name, # then look to see what directory that page might be in. NOTE: @@ -1529,45 +1686,42 @@ sub process_L { # but A::C is found in lib/A/C.pm, then A::B is assumed to be in # lib/A/B.pm. This is also limited, but it's an improvement. # Maybe a hints file so that the links point to the correct places - # non-theless? - # Also, maybe put a warn "$0: cannot resolve..." here. + # nonetheless? + } $link = "$htmlroot/$page.html"; - $link .= "#" . htmlify(0,$section) if ($section); + $link .= "#" . htmlify( $section ) if ($section); } elsif (!defined $pages{$page}) { - warn "$0: $podfile: cannot resolve L<$str> in paragraph $paragraph: no such page '$page'\n" unless $quiet; $link = ""; - $linktext = $page unless defined($linktext); } else { - $linktext = ($section ? "$section" : "the $page manpage") unless defined($linktext); - $section = htmlify(0,$section) if $section ne ""; + $section = htmlify( $section ) if $section ne ""; + ### print STDERR "...section=$section\n"; # if there is a directory by the name of the page, then assume that an # appropriate section will exist in the subdirectory # if ($section ne "" && $pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) { if ($section ne "" && $pages{$page} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) { $link = "$htmlroot/$1/$section.html"; + ### print STDERR "...link=$link\n"; # since there is no directory by the name of the page, the section will # have to exist within a .html of the same name. thus, make sure there # is a .pod or .pm that might become that .html } else { - $section = "#$section"; + $section = "#$section" if $section; + ### print STDERR "...section=$section\n"; + # check if there is a .pod with the page name if ($pages{$page} =~ /([^:]*)\.pod:/) { $link = "$htmlroot/$1.html$section"; } elsif ($pages{$page} =~ /([^:]*)\.pm:/) { $link = "$htmlroot/$1.html$section"; } else { - warn "$0: $podfile: cannot resolve L$str in paragraph $paragraph: ". - "no .pod or .pm found\n"; $link = ""; - $linktext = $section unless defined($linktext); } } } - process_text(\$linktext, 0); if ($link) { # Here, we take advantage of the knowledge that $htmlfileurl ne '' # implies $htmlroot eq ''. This means that the link in question @@ -1576,21 +1730,18 @@ sub process_L { # for other kinds of links, like file:, ftp:, etc. my $url ; if ( $htmlfileurl ne '' ) { - $link = "$htmldir$link" - if ( $link =~ m{^/} ) ; - - $url = relativize_url( $link, $htmlfileurl ) ; -# print( " b: [$link,$htmlfileurl,$url]\n" ) ; + $link = "$htmldir$link" if $link =~ m{^/}; + $url = relativize_url( $link, $htmlfileurl ); +# print( " b: [$link,$htmlfileurl,$url]\n" ); } else { $url = $link ; } + return $url; - $s1 = "<A HREF=\"$url\">$linktext</A>"; } else { - $s1 = "<EM>$linktext</EM>"; + return undef(); } - return $s1; } # @@ -1626,110 +1777,63 @@ sub relativize_url { return $rel_path ; } -# -# process_BFI - process any of the B<>, F<>, or I<> pod-escapes and -# convert them to corresponding HTML directives. -# -sub process_BFI { - my($tag, $str) = @_; - my($s1); # work string - my(%repltext) = ( 'B' => 'STRONG', - 'F' => 'EM', - 'I' => 'EM'); - - # extract the modified text and convert to HTML - $s1 = "<$repltext{$tag}>$str</$repltext{$tag}>"; - return $s1; -} # -# process_C - process the C<> pod-escape. +# coderef - make URL from the text of a C<> # -sub process_C { - my($str, $doref) = @_; - my($s1, $s2); +sub coderef($$){ + my( $page, $item ) = @_; + my( $url ); + + my $fid = fragment_id( $item ); + return( $url, $fid ); + if( defined( $page ) ){ + # we have been given a $page... + $page =~ s{::}{/}g; + + # Do we take it? Item could be a section! + my $base = $items{$fid} || ""; + $base =~ s{[^/]*/}{}; + if( $base ne "$page.html" ){ + ### print STDERR "coderef( $page, $item ): items{$fid} = $items{$fid} = $base => discard page!\n"; + $page = undef(); + } - $s1 = $str; - $s1 =~ s/\([^()]*\)//g; # delete parentheses - $s2 = $s1; - $s1 =~ s/\W//g; # delete bogus characters - $str = html_escape($str); + } else { + # no page - local items precede cached items + if( exists $local_items{$fid} ){ + $page = $local_items{$fid}; + } else { + $page = $items{$fid}; + } + } # if there was a pod file that we found earlier with an appropriate # =item directive, then create a link to that page. - if ($doref && defined $items{$s1}) { - if ( $items{$s1} ) { - my $link = "$htmlroot/$items{$s1}#item_" . htmlify(0,$s2) ; - # Here, we take advantage of the knowledge that $htmlfileurl ne '' - # implies $htmlroot eq ''. - my $url ; - if ( $htmlfileurl ne '' ) { - $link = "$htmldir$link" ; - $url = relativize_url( $link, $htmlfileurl ) ; - } - else { - $url = $link ; + if( defined $page ){ + if( $page ){ + if( exists $pages{$page} and $pages{$page} =~ /([^:.]*)\.[^:]*:/){ + $page = $1 . '.html'; } - $s1 = "<A HREF=\"$url\">$str</A>" ; - } - else { - $s1 = "<A HREF=\"#item_" . htmlify(0,$s2) . "\">$str</A>" ; - } - $s1 =~ s,(perl\w+/(\S+)\.html)#item_\2\b,$1,; - confess "s1 has space: $s1" if $s1 =~ /HREF="[^"]*\s[^"]*"/; - } else { - $s1 = "<CODE>$str</CODE>"; - # warn "$0: $podfile: cannot resolve C<$str> in paragraph $paragraph\n" if $verbose - } - - - return $s1; -} - -# -# process_E - process the E<> pod directive which seems to escape a character. -# -sub process_E { - my($str) = @_; - - for ($str) { - s,([^/].*),\&$1\;,g; - } - - return $str; -} - -# -# process_Z - process the Z<> pod directive which really just amounts to -# ignoring it. this allows someone to start a paragraph with an = -# -sub process_Z { - my($str) = @_; - - # there is no equivalent in HTML for this so just ignore it. - $str = ""; - return $str; -} + my $link = "$htmlroot/$page#item_$fid"; -# -# process_S - process the S<> pod directive which means to convert all -# spaces in the string to non-breaking spaces (in HTML-eze). -# -sub process_S { - my($str) = @_; + # Here, we take advantage of the knowledge that $htmlfileurl + # ne '' implies $htmlroot eq ''. + if ( $htmlfileurl ne '' ) { + $link = "$htmldir$link" ; + $url = relativize_url( $link, $htmlfileurl ) ; + } else { + $url = $link ; + } + } else { + $url = "#item_" . $fid; + } - # convert all spaces in the text to non-breaking spaces in HTML. - $str =~ s/ / /g; - return $str; + confess "url has space: $url" if $url =~ /"[^"]*\s[^"]*"/; + } + return( $url, $fid ); } -# -# process_X - this is supposed to make an index entry. we'll just -# ignore it. -# -sub process_X { - return ''; -} # @@ -1757,29 +1861,129 @@ sub finish_list { # # htmlify - converts a pod section specification to a suitable section -# specification for HTML. if first arg is 1, only takes 1st word. +# specification for HTML. Note that we keep spaces and special characters +# except ", ? (Netscape problem) and the hyphen (writer's problem...). # sub htmlify { - my($compact, $heading) = @_; + my( $heading) = @_; + $heading =~ s/(\s+)/ /g; + $heading =~ s/\s+\Z//; + $heading =~ s/\A\s+//; + # The hyphen is a disgrace to the English language. + $heading =~ s/[-"?]//g; + $heading = lc( $heading ); + return $heading; +} - if ($compact) { - $heading =~ /^(\w+)/; - $heading = $1; - } +# +# depod - convert text by eliminating all interior sequences +# Note: can be called with copy or modify semantics +# +my %E2c; +$E2c{lt} = '<'; +$E2c{gt} = '>'; +$E2c{sol} = '/'; +$E2c{verbar} = '|'; + +sub depod1($;$); + +sub depod($){ + my $string; + if( ref( $_[0] ) ){ + $string = ${$_[0]}; + ${$_[0]} = depod1( \$string ); + } else { + $string = $_[0]; + depod1( \$string ); + } +} - # $heading = lc($heading); - $heading =~ s/[^\w\s]/_/g; - $heading =~ s/(\s+)/ /g; - $heading =~ s/^\s*(.*?)\s*$/$1/s; - $heading =~ s/ /_/g; - $heading =~ s/\A(.{32}).*\Z/$1/s; - $heading =~ s/\s+\Z//; - $heading =~ s/_{2,}/_/g; +sub depod1($;$){ + my( $rstr, $func ) = @_; + my $res = ''; + return $res unless defined $$rstr; + if( ! defined( $func ) ){ + # skip to next begin of an interior sequence + while( $$rstr =~ s/\A(.*?)([BCEFILSXZ])<// ){ + # recurse into its text + $res .= $1 . depod1( $rstr, $2 ); + } + $res .= $$rstr; + } elsif( $func eq 'E' ){ + # E<x> - convert to character + $$rstr =~ s/^(\w+)>//; + $res .= $E2c{$1} || ""; + } elsif( $func eq 'X' ){ + # X<> - ignore + $$rstr =~ s/^[^>]*>//; + } elsif( $func eq 'Z' ){ + # Z<> - empty + $$rstr =~ s/^>//; + } else { + # all others: either recurse into new function or + # terminate at closing angle bracket + while( $$rstr =~ s/\A(.*?)([BCEFILSXZ]<|>)// ){ + $res .= $1; + last if $2 eq '>'; + $res .= depod1( $rstr, substr($2,0,1) ); + } + ## If we're here and $2 ne '>': undelimited interior sequence. + ## Ignored, as this is called without proper indication of where we are. + ## Rely on process_text to produce diagnostics. + } + return $res; +} - return $heading; +# +# fragment_id - construct a fragment identifier from: +# a) =item text +# b) contents of C<...> +# +my @hc; +sub fragment_id { + my $text = shift(); + $text =~ s/\s+\Z//s; + if( $text ){ + # a method or function? + return $1 if $text =~ /(\w+)\s*\(/; + return $1 if $text =~ /->\s*(\w+)\s*\(?/; + + # a variable name? + return $1 if $text =~ /^([$@%*]\S+)/; + + # some pattern matching operator? + return $1 if $text =~ m|^(\w+/).*/\w*$|; + + # fancy stuff... like "do { }" + return $1 if $text =~ m|^(\w+)\s*{.*}$|; + + # honour the perlfunc manpage: func [PAR[,[ ]PAR]...] + # and some funnies with ... Module ... + return $1 if $text =~ m{^([a-z\d]+)(\s+[A-Z\d,/& ]+)?$}; + return $1 if $text =~ m{^([a-z\d]+)\s+Module(\s+[A-Z\d,/& ]+)?$}; + + # text? normalize! + $text =~ s/\s+/_/sg; + $text =~ s{(\W)}{ + defined( $hc[ord($1)] ) ? $hc[ord($1)] + : ( $hc[ord($1)] = sprintf( "%%%02X", ord($1) ) ) }gxe; + $text = substr( $text, 0, 50 ); + } else { + return undef(); + } } -BEGIN { +# +# make_URL_href - generate HTML href from URL +# Special treatment for CGI queries. +# +sub make_URL_href($){ + my( $url ) = @_; + if( $url !~ + s{^(http:[-\w/#~:.+=&%@!]+)(\?.*)$}{<A HREF="$1$2">$1</A>}i ){ + $url = "<A HREF=\"$url\">$url</A>"; + } + return $url; } 1; diff --git a/lib/Pod/ParseUtils.pm b/lib/Pod/ParseUtils.pm new file mode 100644 index 0000000000..a66e8f5e8b --- /dev/null +++ b/lib/Pod/ParseUtils.pm @@ -0,0 +1,792 @@ +############################################################################# +# Pod/ParseUtils.pm -- helpers for POD parsing and conversion +# +# Copyright (C) 1999 by Marek Rouchal. 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::ParseUtils; + +use vars qw($VERSION); +$VERSION = 0.2; ## Current version of this package +require 5.004; ## requires this Perl version or later + +=head1 NAME + +Pod::ParseUtils - helpers for POD parsing and conversion + +=head1 SYNOPSIS + + use Pod::ParseUtils; + + my $list = new Pod::List; + my $link = Pod::Hyperlink->new('Pod::Parser'); + +=head1 DESCRIPTION + +B<Pod::ParseUtils> contains a few object-oriented helper packages for +POD parsing and processing (i.e. in POD formatters and translators). + +=cut + +#----------------------------------------------------------------------------- +# Pod::List +# +# class to hold POD list info (=over, =item, =back) +#----------------------------------------------------------------------------- + +package Pod::List; + +use Carp; + +=head2 Pod::List + +B<Pod::List> can be used to hold information about POD lists +(written as =over ... =item ... =back) for further processing. +The following methods are available: + +=over 4 + +=item new() + +Create a new list object. Properties may be specified through a hash +reference like this: + + my $list = Pod::List->new({ -start => $., -indent => 4 }); + +See the individual methods/properties for details. + +=cut + +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->{-file} ||= 'unknown'; + $self->{-start} ||= 'unknown'; + $self->{-indent} ||= 4; # perlpod: "should be the default" + $self->{_items} = []; + $self->{-type} ||= ''; +} + +=item file() + +Without argument, retrieves the file name the list is in. This must +have been set before by either specifying B<-file> in the B<new()> +method or by calling the B<file()> method with a scalar argument. + +=cut + +# The POD file name the list appears in +sub file { + return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; +} + +=item start() + +Without argument, retrieves the line number where the list started. +This must have been set before by either specifying B<-start> in the +B<new()> method or by calling the B<start()> method with a scalar +argument. + +=cut + +# The line in the file the node appears +sub start { + return (@_ > 1) ? ($_[0]->{-start} = $_[1]) : $_[0]->{-start}; +} + +=item indent() + +Without argument, retrieves the indent level of the list as specified +in C<=over n>. This must have been set before by either specifying +B<-indent> in the B<new()> method or by calling the B<indent()> method +with a scalar argument. + +=cut + +# indent level +sub indent { + return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent}; +} + +=item type() + +Without argument, retrieves the list type, which can be an arbitrary value, +e.g. C<OL>, C<UL>, ... when thinking the HTML way. +This must have been set before by either specifying +B<-type> in the B<new()> method or by calling the B<type()> method +with a scalar argument. + +=cut + +# The type of the list (UL, OL, ...) +sub type { + return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; +} + +=item rx() + +Without argument, retrieves a regular expression for simplifying the +individual item strings once the list type has been determined. Usage: +E.g. when converting to HTML, one might strip the leading number in +an ordered list as C<E<lt>OLE<gt>> already prints numbers itself. +This must have been set before by either specifying +B<-rx> in the B<new()> method or by calling the B<rx()> method +with a scalar argument. + +=cut + +# The regular expression to simplify the items +sub rx { + return (@_ > 1) ? ($_[0]->{-rx} = $_[1]) : $_[0]->{-rx}; +} + +=item item() + +Without argument, retrieves the array of the items in this list. +The items may be represented by any scalar. +If an argument has been given, it is pushed on the list of items. + +=cut + +# The individual =items of this list +sub item { + my ($self,$item) = @_; + if(defined $item) { + push(@{$self->{_items}}, $item); + return $item; + } + else { + return @{$self->{_items}}; + } +} + +=item parent() + +Without argument, retrieves information about the parent holding this +list, which is represented as an arbitrary scalar. +This must have been set before by either specifying +B<-parent> in the B<new()> method or by calling the B<parent()> method +with a scalar argument. + +=cut + +# possibility for parsers/translators to store information about the +# lists's parent object +sub parent { + return (@_ > 1) ? ($_[0]->{-parent} = $_[1]) : $_[0]->{-parent}; +} + +=item tag() + +Without argument, retrieves information about the list tag, which can be +any scalar. +This must have been set before by either specifying +B<-tag> in the B<new()> method or by calling the B<tag()> method +with a scalar argument. + +=back + +=cut + +# possibility for parsers/translators to store information about the +# list's object +sub tag { + return (@_ > 1) ? ($_[0]->{-tag} = $_[1]) : $_[0]->{-tag}; +} + +#----------------------------------------------------------------------------- +# Pod::Hyperlink +# +# class to manipulate POD hyperlinks (L<>) +#----------------------------------------------------------------------------- + +package Pod::Hyperlink; + +=head2 Pod::Hyperlink + +B<Pod::Hyperlink> is a class for manipulation of POD hyperlinks. Usage: + + my $link = Pod::Hyperlink->new('alternative text|page/"section in page"'); + +The B<Pod::Hyperlink> class is mainly designed to parse the contents of the +C<LE<lt>...E<gt>> sequence, providing a simple interface for accessing the +different parts of a POD hyperlink for further processing. It can also be +used to construct hyperlinks. + +=over 4 + +=item new() + +The B<new()> method can either be passed a set of key/value pairs or a single +scalar value, namely the contents of a C<LE<lt>...E<gt>> sequence. An object +of the class C<Pod::Hyperlink> is returned. The value C<undef> indicates a +failure, the error message is stored in C<$@>. + +=cut + +use Carp; + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = +{}; + bless $self, $class; + $self->initialize(); + if(defined $_[0]) { + if(ref($_[0])) { + # called with a list of parameters + %$self = %{$_[0]}; + $self->_construct_text(); + } + else { + # called with L<> contents + return undef unless($self->parse($_[0])); + } + } + return $self; +} + +sub initialize { + my $self = shift; + $self->{-line} ||= 'undef'; + $self->{-file} ||= 'undef'; + $self->{-page} ||= ''; + $self->{-node} ||= ''; + $self->{-alttext} ||= ''; + $self->{-type} ||= 'undef'; + $self->{_warnings} = []; +} + +=item parse($string) + +This method can be used to (re)parse a (new) hyperlink, i.e. the contents +of a C<LE<lt>...E<gt>> sequence. The result is stored in the current object. + +=cut + +sub parse { + my $self = shift; + local($_) = $_[0]; + # syntax check the link and extract destination + my ($alttext,$page,$node,$type) = ('','','',''); + + $self->{_warnings} = []; + + # collapse newlines with whitespace + if(s/\s*\n+\s*/ /g) { + $self->warning("collapsing newlines to blanks"); + } + # strip leading/trailing whitespace + if(s/^[\s\n]+//) { + $self->warning("ignoring leading whitespace in link"); + } + if(s/[\s\n]+$//) { + $self->warning("ignoring trailing whitespace in link"); + } + unless(length($_)) { + _invalid_link("empty link"); + return undef; + } + + ## Check for different possibilities. This is tedious and error-prone + # we match all possibilities (alttext, page, section/item) + #warn "DEBUG: link=$_\n"; + + # only page + if(m!^(\w+(?:::\w+)*)\s*(\(\w*\)|)$!) { + $page = $1 . $2; + $type = 'page'; + } + # alttext, page and section + elsif(m!^(.+?)\s*[|]\s*(\w+(?:::\w+)*)\s*(\(\w*\)|)\s*/\s*"(.+)"$!) { + ($alttext, $page, $node) = ($1, $2 . $3, $4); + $type = 'section'; + } + # page and section + elsif(m!^(\w+(?:::\w+)*)\s*(\(\w*\)|)\s*/\s*"(.+)"$!) { + ($page, $node) = ($1 . $2, $3); + $type = 'section'; + } + # page and item + elsif(m!^(\w+(?:::\w+)*)\s*(\(\w*\)|)\s*/\s*(.+)$!) { + ($page, $node) = ($1 . $2, $3); + $type = 'item'; + } + # only section + elsif(m!^(?:/\s*|)"(.+)"$!) { + $node = $1; + $type = 'section'; + } + # only item + elsif(m!^/(.+)$!) { + $node = $1; + $type = 'item'; + } + # non-standard: Hyperlink + elsif(m!^((?:http|ftp|mailto|news):.+)$!i) { + $node = $1; + $type = 'hyperlink'; + } + # alttext, page and item + elsif(m!^(.+?)\s*[|]\s*(\w+(?:::\w+)*)\s*(\(\w*\)|)\s*/\s*(.+)$!) { + ($alttext, $page, $node) = ($1, $2 . $3, $4); + $type = 'item'; + } + # alttext and page + elsif(m!^(.+?)\s*[|]\s*(\w+(?:::\w+)*)\s*(\(\w*\)|)$!) { + ($alttext, $page) = ($1, $2 . $3); + $type = 'page'; + } + # alttext and section + elsif(m!^(.+?)\s*[|]\s*(?:/\s*|)"(.+)"$!) { + ($alttext, $node) = ($1,$2); + $type = 'section'; + } + # alttext and item + elsif(m!^(.+?)\s*[|]\s*/(.+)$!) { + ($alttext, $node) = ($1,$2); + } + # nonstandard: alttext and hyperlink + elsif(m!^(.+?)\s*[|]\s*((?:http|ftp|mailto|news):.+)$!) { + ($alttext, $node) = ($1,$2); + $type = 'hyperlink'; + } + # must be an item or a "malformed" section (without "") + else { + $node = $_; + $type = 'item'; + } + + if($page =~ /[(]\w*[)]$/) { + $self->warning("section in `$page' deprecated"); + } + $self->{-page} = $page; + $self->{-node} = $node; + $self->{-alttext} = $alttext; + #warn "DEBUG: page=$page section=$section item=$item alttext=$alttext\n"; + $self->{-type} = $type; + $self->_construct_text(); + 1; +} + +sub _construct_text { + my $self = shift; + my $alttext = $self->alttext(); + my $type = $self->type(); + my $section = $self->node(); + my $page = $self->page(); + my $page_ext = ''; + $page =~ s/([(]\w*[)])$// && ($page_ext = $1); + if($alttext) { + $self->{_text} = $alttext; + } + elsif($type eq 'hyperlink') { + $self->{_text} = $section; + } + else { + $self->{_text} = (!$section ? '' : + $type eq 'item' ? "the $section entry" : + "the section on $section" ) . + ($page ? ($section ? ' in ':'') . "the $page$page_ext manpage" : + ' elsewhere in this document'); + } + # for being marked up later + # use the non-standard markers P<> and Q<>, so that the resulting + # text can be parsed by the translators. It's their job to put + # the correct hypertext around the linktext + if($alttext) { + $self->{_markup} = "Q<$alttext>"; + } + elsif($type eq 'hyperlink') { + $self->{_markup} = "Q<$section>"; + } + else { + $self->{_markup} = (!$section ? '' : + $type eq 'item' ? "the Q<$section> entry" : + "the section on Q<$section>" ) . + ($page ? ($section ? ' in ':'') . "the P<$page>$page_ext manpage" : + ' elsewhere in this document'); + } +} + +=item markup($string) + +Set/retrieve the textual value of the link. This string contains special +markers C<PE<lt>E<gt>> and C<QE<lt>E<gt>> that should be expanded by the +translator's interior sequence expansion engine to the +formatter-specific code to highlight/activate the hyperlink. The details +have to be implemented in the translator. + +=cut + +#' retrieve/set markuped text +sub markup { + return (@_ > 1) ? ($_[0]->{_markup} = $_[1]) : $_[0]->{_markup}; +} + +=item text() + +This method returns the textual representation of the hyperlink as above, +but without markers (read only). Depending on the link type this is one of +the following alternatives (the + and * denote the portions of the text +that are marked up): + + the +perl+ manpage + the *$|* entry in the +perlvar+ manpage + the section on *OPTIONS* in the +perldoc+ manpage + the section on *DESCRIPTION* elsewhere in this document + +=cut + +# The complete link's text +sub text { + $_[0]->{_text}; +} + +=item warning() + +After parsing, this method returns any warnings encountered during the +parsing process. + +=cut + +# Set/retrieve warnings +sub warning { + my $self = shift; + if(@_) { + push(@{$self->{_warnings}}, @_); + return @_; + } + return @{$self->{_warnings}}; +} + +=item line(), file() + +Just simple slots for storing information about the line and the file +the link was encountered in. Has to be filled in manually. + +=cut + +# The line in the file the link appears +sub line { + return (@_ > 1) ? ($_[0]->{-line} = $_[1]) : $_[0]->{-line}; +} + +# The POD file name the link appears in +sub file { + return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; +} + +=item page() + +This method sets or returns the POD page this link points to. + +=cut + +# The POD page the link appears on +sub page { + if (@_ > 1) { + $_[0]->{-page} = $_[1]; + $_[0]->_construct_text(); + } + $_[0]->{-page}; +} + +=item node() + +As above, but the destination node text of the link. + +=cut + +# The link destination +sub node { + if (@_ > 1) { + $_[0]->{-node} = $_[1]; + $_[0]->_construct_text(); + } + $_[0]->{-node}; +} + +=item alttext() + +Sets or returns an alternative text specified in the link. + +=cut + +# Potential alternative text +sub alttext { + if (@_ > 1) { + $_[0]->{-alttext} = $_[1]; + $_[0]->_construct_text(); + } + $_[0]->{-alttext}; +} + +=item type() + +The node type, either C<section> or C<item>. As an unofficial type, +there is also C<hyperlink>, derived from e.g. C<LE<lt>http://perl.comE<gt>> + +=cut + +# The type: item or headn +sub type { + return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; +} + +=item link() + +Returns the link as contents of C<LE<lt>E<gt>>. Reciprocal to B<parse()>. + +=back + +=cut + +# The link itself +sub link { + my $self = shift; + my $link = $self->page() || ''; + if($self->node()) { + if($self->type() eq 'section') { + $link .= ($link ? '/' : '') . '"' . $self->node() . '"'; + } + elsif($self->type() eq 'hyperlink') { + $link = $self->node(); + } + else { # item + $link .= '/' . $self->node(); + } + } + if($self->alttext()) { + $link = $self->alttext() . '|' . $link; + } + $link; +} + +sub _invalid_link { + my ($msg) = @_; + # this sets @_ + #eval { die "$msg\n" }; + #chomp $@; + $@ = $msg; # this seems to work, too! + undef; +} + +#----------------------------------------------------------------------------- +# Pod::Cache +# +# class to hold POD page details +#----------------------------------------------------------------------------- + +package Pod::Cache; + +=head2 Pod::Cache + +B<Pod::Cache> holds information about a set of POD documents, +especially the nodes for hyperlinks. +The following methods are available: + +=over 4 + +=item new() + +Create a new cache object. This object can hold an arbitrary number of +POD documents of class Pod::Cache::Item. + +=cut + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = []; + bless $self, $class; + return $self; +} + +=item item() + +Add a new item to the cache. Without arguments, this method returns a +list of all cache elements. + +=cut + +sub item { + my ($self,%param) = @_; + if(%param) { + my $item = Pod::Cache::Item->new(%param); + push(@$self, $item); + return $item; + } + else { + return @{$self}; + } +} + +=item find_page($name) + +Look for a POD document named C<$name> in the cache. Returns the +reference to the corresponding Pod::Cache::Item object or undef if +not found. + +=back + +=cut + +sub find_page { + my ($self,$page) = @_; + foreach(@$self) { + if($_->page() eq $page) { + return $_; + } + } + undef; +} + +package Pod::Cache::Item; + +=head2 Pod::Cache::Item + +B<Pod::Cache::Item> holds information about individual POD documents, +that can be grouped in a Pod::Cache object. +It is intended to hold information about the hyperlink nodes of POD +documents. +The following methods are available: + +=over 4 + +=item new() + +Create a new object. + +=cut + +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->{-nodes} = [] unless(defined $self->{-nodes}); +} + +=item page() + +Set/retrieve the POD document name (e.g. "Pod::Parser"). + +=cut + +# The POD page +sub page { + return (@_ > 1) ? ($_[0]->{-page} = $_[1]) : $_[0]->{-page}; +} + +=item description() + +Set/retrieve the POD short description as found in the C<=head1 NAME> +section. + +=cut + +# The POD description, taken out of NAME if present +sub description { + return (@_ > 1) ? ($_[0]->{-description} = $_[1]) : $_[0]->{-description}; +} + +=item path() + +Set/retrieve the POD file storage path. + +=cut + +# The file path +sub path { + return (@_ > 1) ? ($_[0]->{-path} = $_[1]) : $_[0]->{-path}; +} + +=item file() + +Set/retrieve the POD file name. + +=cut + +# The POD file name +sub file { + return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; +} + +=item nodes() + +Add a node (or a list of nodes) to the document's node list. Note that +the order is kept, i.e. start with the first node and end with the last. +If no argument is given, the current list of nodes is returned in the +same order the nodes have been added. +A node can be any scalar, but usually is a pair of node string and +unique id for the C<find_node> method to work correctly. + +=cut + +# The POD nodes +sub nodes { + my ($self,@nodes) = @_; + if(@nodes) { + push(@{$self->{-nodes}}, @nodes); + return @nodes; + } + else { + return @{$self->{-nodes}}; + } +} + +=item find_node($name) + +Look for a node named C<$name> in the object's node list. Returns the +unique id of the node (i.e. the second element of the array stored in +the node arry) or undef if not found. + +=back + +=cut + +sub find_node { + my ($self,$node) = @_; + foreach(@{$self->{-nodes}}) { + if($_->[0] eq $node) { + return $_->[1]; # id + } + } + undef; +} + + +=head1 AUTHOR + +Marek Rouchal E<lt>marek@saftsack.fs.uni-bayreuth.deE<gt>, borrowing +a lot of things from L<pod2man> and L<pod2roff> as well as other POD +processing tools by Tom Christiansen, Brad Appleton and Russ Allbery. + +=head1 SEE ALSO + +L<pod2man>, L<pod2roff>, L<Pod::Parser>, L<Pod::Checker>, +L<pod2html> + +=cut + +1; diff --git a/lib/Pod/Parser.pm b/lib/Pod/Parser.pm index c9c67bd8e2..c727142506 100644 --- a/lib/Pod/Parser.pm +++ b/lib/Pod/Parser.pm @@ -142,8 +142,8 @@ 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. -Note that all we have described here in this quick overview overview is -the simplest most striaghtforward use of B<Pod::Parser> to do stream-based +Note that all we have described here in this quick overview is +the simplest most straightforward use of B<Pod::Parser> to do stream-based parsing. It is also possible to use the B<Pod::Parser::parse_text> function to do more sophisticated tree-based parsing. See L<"TREE-BASED PARSING">. diff --git a/lib/Pod/Usage.pm b/lib/Pod/Usage.pm index 6e6fb7bb80..aa3a009dcf 100644 --- a/lib/Pod/Usage.pm +++ b/lib/Pod/Usage.pm @@ -311,22 +311,58 @@ 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 +(perhaps by allowing a C<-man> option). The following complete example +uses B<Pod::Usage> in combination with B<Getopt::Long> to do all of these things: use Getopt::Long; use Pod::Usage; + my $man = 0; + my $help = 0; ## 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); + GetOptions('help|?' => \$help, man => \$man) or pod2usage(2); + pod2usage(1) if $help; + pod2usage(-verbose => 2) if $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)); + __END__ + + =head1 NAME + + sample - Using GetOpt::Long and Pod::Usage + + =head1 SYNOPSIS + + sample [options] [file ...] + + Options: + -help brief help message + -man full documentation + + =head1 OPTIONS + + =over 8 + + =item B<-help> + + Print a brief help message and exits. + + =item B<-man> + + Prints the manual page and exits. + + =back + + =head1 DESCRIPTION + + B<This program> will read the given input file(s) and do something + useful with the contents thereof. + + =cut =head1 CAVEATS diff --git a/lib/SelfLoader.pm b/lib/SelfLoader.pm index 4672ac49da..2aa29303fd 100644 --- a/lib/SelfLoader.pm +++ b/lib/SelfLoader.pm @@ -3,7 +3,7 @@ package SelfLoader; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(AUTOLOAD); -$VERSION = "1.09"; +$VERSION = "1.0901"; sub Version {$VERSION} $DEBUG = 0; @@ -12,7 +12,7 @@ my %Cache; # private cache for all SelfLoader's client packages # allow checking for valid ': attrlist' attachments my $nested; $nested = qr{ \( (?: (?> [^()]+ ) | (?p{ $nested }) )* \) }x; -my $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) [\s,]* }x; +my $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) (?:\s*\:\s*|\s+(?!\:)) }x; my $attr_list = qr{ \s* : \s* (?: $one_attr )* }x; sub croak { require Carp; goto &Carp::croak } diff --git a/lib/Shell.pm b/lib/Shell.pm index 0177479de5..62aa82964c 100644 --- a/lib/Shell.pm +++ b/lib/Shell.pm @@ -1,5 +1,6 @@ package Shell; -use vars qw($capture_stderr $VERSION); +use 5.005_64; +our($capture_stderr, $VERSION); $VERSION = '0.2'; @@ -71,7 +72,7 @@ AUTOLOAD { for (\@arr) { s/"/\\\\"/g; s/\\\\\\\\"/\\\\\\\\"""/g; - \$_ = qq["\$_"] if /\s/; + \$_ = qq["\$_"] if /\\s/; } } else { diff --git a/lib/Sys/Hostname.pm b/lib/Sys/Hostname.pm index 4d93f91f9e..63415a6bfe 100644 --- a/lib/Sys/Hostname.pm +++ b/lib/Sys/Hostname.pm @@ -74,25 +74,19 @@ sub hostname { # method 2 - syscall is preferred since it avoids tainting problems eval { local $SIG{__DIE__}; - { - package main; - require "syscall.ph"; - } + require "syscall.ph"; $host = "\0" x 65; ## preload scalar - syscall(&main::SYS_gethostname, $host, 65) == 0; + syscall(&SYS_gethostname, $host, 65) == 0; } # method 2a - syscall using systeminfo instead of gethostname # -- needed on systems like Solaris || eval { local $SIG{__DIE__}; - { - package main; - require "sys/syscall.ph"; - require "sys/systeminfo.ph"; - } + require "sys/syscall.ph"; + require "sys/systeminfo.ph"; $host = "\0" x 65; ## preload scalar - syscall(&main::SYS_systeminfo, &main::SI_HOSTNAME, $host, 65) != -1; + syscall(&SYS_systeminfo, &SI_HOSTNAME, $host, 65) != -1; } # method 3 - trusty old hostname command @@ -102,13 +96,21 @@ sub hostname { $host = `(hostname) 2>/dev/null`; # bsdish } - # method 4 - sysV uname command (may truncate) + # method 4 - use POSIX::uname(), which strictly can't be expected to be + # correct + || eval { + local $SIG{__DIE__}; + require POSIX; + $host = (POSIX::uname())[1]; + } + + # method 5 - sysV uname command (may truncate) || eval { local $SIG{__DIE__}; $host = `uname -n 2>/dev/null`; ## sysVish } - # method 5 - Apollo pre-SR10 + # method 6 - Apollo pre-SR10 || eval { local $SIG{__DIE__}; ($host,$a,$b,$c,$d)=split(/[:\. ]/,`/com/host`,6); diff --git a/lib/Sys/Syslog.pm b/lib/Sys/Syslog.pm deleted file mode 100644 index f0cbb71924..0000000000 --- a/lib/Sys/Syslog.pm +++ /dev/null @@ -1,277 +0,0 @@ -package Sys::Syslog; -require 5.000; -require Exporter; -use Carp; - -@ISA = qw(Exporter); -@EXPORT = qw(openlog closelog setlogmask syslog); -@EXPORT_OK = qw(setlogsock); - -use Socket; -use Sys::Hostname; - -# adapted from syslog.pl -# -# Tom Christiansen <tchrist@convex.com> -# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov> -# NOTE: openlog now takes three arguments, just like openlog(3) -# Modified to add UNIX domain sockets by Sean Robinson <robinson_s@sc.maricopa.edu> -# with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list - -# Todo: enable connect to try all three types before failing (auto setlogsock)? - -=head1 NAME - -Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls - -=head1 SYNOPSIS - - use Sys::Syslog; # all except setlogsock, or: - use Sys::Syslog qw(:DEFAULT setlogsock); # default set, plus setlogsock - - setlogsock $sock_type; - openlog $ident, $logopt, $facility; - syslog $priority, $format, @args; - $oldmask = setlogmask $mask_priority; - closelog; - -=head1 DESCRIPTION - -Sys::Syslog is an interface to the UNIX C<syslog(3)> program. -Call C<syslog()> with a string priority and a list of C<printf()> args -just like C<syslog(3)>. - -Syslog provides the functions: - -=over - -=item openlog $ident, $logopt, $facility - -I<$ident> is prepended to every message. -I<$logopt> contains zero or more of the words I<pid>, I<ndelay>, I<cons>, I<nowait>. -I<$facility> specifies the part of the system - -=item syslog $priority, $format, @args - -If I<$priority> permits, logs I<($format, @args)> -printed as by C<printf(3V)>, with the addition that I<%m> -is replaced with C<"$!"> (the latest error message). - -=item setlogmask $mask_priority - -Sets log mask I<$mask_priority> and returns the old mask. - -=item setlogsock $sock_type (added in 5.004_02) - -Sets the socket type to be used for the next call to -C<openlog()> or C<syslog()> and returns TRUE on success, -undef on failure. - -A value of 'unix' will connect to the UNIX domain socket returned by -C<_PATH_LOG> in F<syslog.ph>. A value of 'inet' will connect to an -INET socket returned by getservbyname(). Any other value croaks. - -The default is for the INET socket to be used. - -=item closelog - -Closes the log file. - -=back - -Note that C<openlog> now takes three arguments, just like C<openlog(3)>. - -=head1 EXAMPLES - - openlog($program, 'cons,pid', 'user'); - syslog('info', 'this is another test'); - syslog('mail|warning', 'this is a better test: %d', time); - closelog(); - - syslog('debug', 'this is the last test'); - - setlogsock('unix'); - openlog("$program $$", 'ndelay', 'user'); - syslog('notice', 'fooprogram: this is really done'); - - setlogsock('inet'); - $! = 55; - syslog('info', 'problem was %m'); # %m == $! in syslog(3) - -=head1 DEPENDENCIES - -B<Sys::Syslog> needs F<syslog.ph>, which can be created with C<h2ph>. - -=head1 SEE ALSO - -L<syslog(3)> - -=head1 AUTHOR - -Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<larry@wall.org>E<gt>. -UNIX domain sockets added by Sean Robinson E<lt>F<robinson_s@sc.maricopa.edu>E<gt> -with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list. - -=cut - -require 'syslog.ph'; - -$maskpri = &LOG_UPTO(&LOG_DEBUG); - -sub openlog { - ($ident, $logopt, $facility) = @_; # package vars - $lo_pid = $logopt =~ /\bpid\b/; - $lo_ndelay = $logopt =~ /\bndelay\b/; - $lo_cons = $logopt =~ /\bcons\b/; - $lo_nowait = $logopt =~ /\bnowait\b/; - return 1 unless $lo_ndelay; - &connect; -} - -sub closelog { - $facility = $ident = ''; - &disconnect; -} - -sub setlogmask { - local($oldmask) = $maskpri; - $maskpri = shift; - $oldmask; -} - -sub setlogsock { - local($setsock) = shift; - &disconnect if $connected; - if (lc($setsock) eq 'unix') { - if (defined &_PATH_LOG) { - $sock_type = 1; - } else { - return undef; - } - } elsif (lc($setsock) eq 'inet') { - if (getservbyname('syslog','udp')) { - undef($sock_type); - } else { - return undef; - } - } else { - croak "Invalid argument passed to setlogsock; must be 'unix' or 'inet'"; - } - return 1; -} - -sub syslog { - local($priority) = shift; - local($mask) = shift; - local($message, $whoami); - local(@words, $num, $numpri, $numfac, $sum); - local($facility) = $facility; # may need to change temporarily. - - croak "syslog: expected both priority and mask" unless $mask && $priority; - - @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility". - undef $numpri; - undef $numfac; - foreach (@words) { - $num = &xlate($_); # Translate word to number. - if (/^kern$/ || $num < 0) { - croak "syslog: invalid level/facility: $_"; - } - elsif ($num <= &LOG_PRIMASK) { - croak "syslog: too many levels given: $_" if defined($numpri); - $numpri = $num; - return 0 unless &LOG_MASK($numpri) & $maskpri; - } - else { - croak "syslog: too many facilities given: $_" if defined($numfac); - $facility = $_; - $numfac = $num; - } - } - - croak "syslog: level must be given" unless defined($numpri); - - if (!defined($numfac)) { # Facility not specified in this call. - $facility = 'user' unless $facility; - $numfac = &xlate($facility); - } - - &connect unless $connected; - - $whoami = $ident; - - if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) { - $whoami = $1; - $mask = $2; - } - - unless ($whoami) { - ($whoami = getlogin) || - ($whoami = getpwuid($<)) || - ($whoami = 'syslog'); - } - - $whoami .= "[$$]" if $lo_pid; - - $mask =~ s/%m/$!/g; - $mask .= "\n" unless $mask =~ /\n$/; - $message = sprintf ($mask, @_); - - $sum = $numpri + $numfac; - unless (send(SYSLOG,"<$sum>$whoami: $message\0",0)) { - if ($lo_cons) { - if ($pid = fork) { - unless ($lo_nowait) { - $died = waitpid($pid, 0); - } - } - else { - open(CONS,">/dev/console"); - print CONS "<$facility.$priority>$whoami: $message\r"; - exit if defined $pid; # if fork failed, we're parent - close CONS; - } - } - } -} - -sub xlate { - local($name) = @_; - $name = uc $name; - $name = "LOG_$name" unless $name =~ /^LOG_/; - $name = "Sys::Syslog::$name"; - defined &$name ? &$name : -1; -} - -sub connect { - unless ($host) { - require Sys::Hostname; - my($host_uniq) = Sys::Hostname::hostname(); - ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _) - } - unless ( $sock_type ) { - my $udp = getprotobyname('udp'); - my $syslog = getservbyname('syslog','udp'); - my $this = sockaddr_in($syslog, INADDR_ANY); - my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host"); - socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!"; - connect(SYSLOG,$that) || croak "connect: $!"; - } else { - my $syslog = &_PATH_LOG || croak "_PATH_LOG not found in syslog.ph"; - my $that = sockaddr_un($syslog) || croak "Can't locate $syslog"; - socket(SYSLOG,AF_UNIX,SOCK_STREAM,0) || croak "socket: $!"; - if (!connect(SYSLOG,$that)) { - socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0) || croak "socket: $!"; - connect(SYSLOG,$that) || croak "connect: $! (SOCK_DGRAM after trying SOCK_STREAM)"; - } - } - local($old) = select(SYSLOG); $| = 1; select($old); - $connected = 1; -} - -sub disconnect { - close SYSLOG; - $connected = 0; -} - -1; diff --git a/lib/Test.pm b/lib/Test.pm index 2187e8cd85..c708f57a05 100644 --- a/lib/Test.pm +++ b/lib/Test.pm @@ -1,9 +1,10 @@ use strict; package Test; +use 5.005_64; use Test::Harness 1.1601 (); use Carp; -use vars (qw($VERSION @ISA @EXPORT @EXPORT_OK $ntest $TestLevel), #public-ish - qw($TESTOUT $ONFAIL %todo %history $planned @FAILDETAIL)); #private-ish +our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $ntest, $TestLevel); #public-ish +our($TESTOUT, $ONFAIL, %todo, %history, $planned, @FAILDETAIL); #private-ish $VERSION = '1.13'; require Exporter; @ISA=('Exporter'); diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index a469cfafa8..61a29dbaaa 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -1,14 +1,14 @@ package Test::Harness; -BEGIN {require 5.002;} +use 5.005_64; use Exporter; use Benchmark; use Config; use FileHandle; use strict; -use vars qw($VERSION $verbose $switches $have_devel_corestack $curtest - @ISA @EXPORT @EXPORT_OK); +our($VERSION, $verbose, $switches, $have_devel_corestack, $curtest, + @ISA, @EXPORT, @EXPORT_OK); $have_devel_corestack = 0; $VERSION = "1.1604"; diff --git a/lib/Text/ParseWords.pm b/lib/Text/ParseWords.pm index ada9d70d74..2a6afc3be9 100644 --- a/lib/Text/ParseWords.pm +++ b/lib/Text/ParseWords.pm @@ -49,7 +49,7 @@ sub nested_quotewords { sub parse_line { # We will be testing undef strings - local($^W) = 0; + no warnings; my($delimiter, $keep, $line) = @_; my($quote, $quoted, $unquoted, $delim, $word, @pieces); diff --git a/lib/Text/Soundex.pm b/lib/Text/Soundex.pm index ddc758c94e..3079b90612 100644 --- a/lib/Text/Soundex.pm +++ b/lib/Text/Soundex.pm @@ -5,6 +5,8 @@ require Exporter; @ISA = qw(Exporter); @EXPORT = qw(&soundex $soundex_nocode); +$VERSION = '1.0'; + # $Id: soundex.pl,v 1.2 1994/03/24 00:30:27 mike Exp $ # # Implementation of soundex algorithm as described by Knuth in volume diff --git a/lib/Text/Tabs.pm b/lib/Text/Tabs.pm index c431019908..933f917acd 100644 --- a/lib/Text/Tabs.pm +++ b/lib/Text/Tabs.pm @@ -73,11 +73,11 @@ Text::Tabs -- expand and unexpand tabs per the unix expand(1) and unexpand(1) =head1 SYNOPSIS -use Text::Tabs; + use Text::Tabs; -$tabstop = 4; -@lines_without_tabs = expand(@lines_with_tabs); -@lines_with_tabs = unexpand(@lines_without_tabs); + $tabstop = 4; + @lines_without_tabs = expand(@lines_with_tabs); + @lines_with_tabs = unexpand(@lines_without_tabs); =head1 DESCRIPTION diff --git a/lib/Tie/Array.pm b/lib/Tie/Array.pm index 5ef83c4781..32e269b330 100644 --- a/lib/Tie/Array.pm +++ b/lib/Tie/Array.pm @@ -1,8 +1,9 @@ package Tie::Array; -use vars qw($VERSION); + +use 5.005_64; use strict; use Carp; -$VERSION = '1.01'; +our $VERSION = '1.01'; # Pod documentation after __END__ below. diff --git a/lib/Tie/Handle.pm b/lib/Tie/Handle.pm index 6181eca22c..f64e4b2a5b 100644 --- a/lib/Tie/Handle.pm +++ b/lib/Tie/Handle.pm @@ -1,5 +1,8 @@ package Tie::Handle; +use 5.005_64; +our $VERSION = '1.0'; + =head1 NAME Tie::Handle, Tie::StdHandle - base class definitions for tied handles @@ -183,8 +186,7 @@ sub CLOSE { } package Tie::StdHandle; -use vars qw(@ISA); -@ISA = 'Tie::Handle'; +our @ISA = 'Tie::Handle'; use Carp; sub TIEHANDLE diff --git a/lib/Time/gmtime.pm b/lib/Time/gmtime.pm index 9b823f601e..6ff4bc84a2 100644 --- a/lib/Time/gmtime.pm +++ b/lib/Time/gmtime.pm @@ -2,9 +2,10 @@ package Time::gmtime; use strict; use Time::tm; +use 5.005_64; +our(@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION); BEGIN { use Exporter (); - use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); @ISA = qw(Exporter Time::tm); @EXPORT = qw(gmtime gmctime); @EXPORT_OK = qw( diff --git a/lib/Time/localtime.pm b/lib/Time/localtime.pm index 18a36c7fb9..0ca07af166 100644 --- a/lib/Time/localtime.pm +++ b/lib/Time/localtime.pm @@ -2,9 +2,10 @@ package Time::localtime; use strict; use Time::tm; -BEGIN { +use 5.005_64; +our(@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION); +BEGIN { use Exporter (); - use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); @ISA = qw(Exporter Time::tm); @EXPORT = qw(localtime ctime); @EXPORT_OK = qw( diff --git a/lib/UNIVERSAL.pm b/lib/UNIVERSAL.pm index dc02423029..f2f1fe9e7a 100644 --- a/lib/UNIVERSAL.pm +++ b/lib/UNIVERSAL.pm @@ -62,19 +62,23 @@ The C<isa> and C<can> methods can also be called as subroutines =item UNIVERSAL::isa ( VAL, TYPE ) -C<isa> returns I<true> if the first argument is a reference and either -of the following statements is true. +C<isa> returns I<true> if one of the following statements is true. =over 8 -=item +=item * -C<VAL> is a blessed reference and is blessed into package C<TYPE> -or inherits from package C<TYPE> +C<VAL> is a reference blessed into either package C<TYPE> or a package +which inherits from package C<TYPE>. -=item +=item * -C<VAL> is a reference to a C<TYPE> of perl variable (er 'HASH') +C<VAL> is a reference to a C<TYPE> of Perl variable (e.g. 'HASH'). + +=item * + +C<VAL> is the name of a package that inherits from (or is itself) +package C<TYPE>. =back diff --git a/lib/User/grent.pm b/lib/User/grent.pm index e4e226d119..95e4189c9e 100644 --- a/lib/User/grent.pm +++ b/lib/User/grent.pm @@ -1,9 +1,10 @@ package User::grent; use strict; +use 5.005_64; +our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); - use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); @EXPORT = qw(getgrent getgrgid getgrnam getgr); @EXPORT_OK = qw($gr_name $gr_gid $gr_passwd $gr_mem @gr_members); %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); diff --git a/lib/User/pwent.pm b/lib/User/pwent.pm index bb2dace682..39bfea4fe0 100644 --- a/lib/User/pwent.pm +++ b/lib/User/pwent.pm @@ -1,9 +1,10 @@ package User::pwent; use strict; +use 5.005_64; +our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); - use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); @EXPORT = qw(getpwent getpwuid getpwnam getpw); @EXPORT_OK = qw( $pw_name $pw_passwd $pw_uid diff --git a/lib/attributes.pm b/lib/attributes.pm index 09f355139f..bbbb8b78ee 100644 --- a/lib/attributes.pm +++ b/lib/attributes.pm @@ -1,6 +1,6 @@ package attributes; -$VERSION = 0.02; +$VERSION = 0.03; @EXPORT_OK = qw(get reftype); @EXPORT = (); @@ -54,7 +54,7 @@ sub import { my $s = ((@pkgattrs == 1) ? '' : 's'); carp "$svtype package attribute$s " . "may clash with future reserved word$s: " . - join(' , ' , @pkgattrs); + join(' : ' , @pkgattrs); } } } @@ -65,7 +65,7 @@ sub import { croak "Invalid $svtype attribute" . (( @badattrs == 1 ) ? '' : 's') . ": " . - join(' , ', @badattrs); + join(' : ', @badattrs); } } @@ -267,7 +267,8 @@ will use that package name. =head2 Syntax of Attribute Lists An attribute list is a sequence of attribute specifications, separated by -whitespace, commas, or both. Each attribute specification is a simple +whitespace or a colon (with optional whitespace). +Each attribute specification is a simple name, optionally followed by a parenthesised parameter list. If such a parameter list is present, it is scanned past as for the rules for the C<q()> operator. (See L<perlop/"Quote and Quote-like Operators">.) @@ -275,8 +276,8 @@ The parameter list is passed as it was found, however, and not as per C<q()>. Some examples of syntactically valid attribute lists: - switch(10,foo(7,3)) , , expensive - Ugly('\(") , Bad + switch(10,foo(7,3)) : expensive + Ugly('\(") :Bad _5x5 locked method @@ -286,7 +287,7 @@ Some examples of syntactically invalid attribute lists (with annotation): Ugly('(') # ()-string not balanced 5x5 # "5x5" not a valid identifier Y2::north # "Y2::north" not a simple identifier - foo + bar # "+" neither a comma nor whitespace + foo + bar # "+" neither a colon nor whitespace =head1 EXPORTS diff --git a/lib/base.pm b/lib/base.pm index 7fb3d2bcb9..3cb42f5bfa 100644 --- a/lib/base.pm +++ b/lib/base.pm @@ -43,14 +43,18 @@ L<fields> =cut package base; -use vars qw($VERSION); -$VERSION = "1.00"; + +use 5.005_64; +our $VERSION = "1.01"; sub import { my $class = shift; my $fields_base; + my $pkg = caller(0); foreach my $base (@_) { + next if $pkg->isa($base); + push @{"$pkg\::ISA"}, $base; unless (exists ${"$base\::"}{VERSION}) { eval "require $base"; # Only ignore "Can't locate" errors from our eval require. @@ -79,8 +83,6 @@ sub import { } } } - my $pkg = caller(0); - push @{"$pkg\::ISA"}, @_; if ($fields_base) { require fields; fields::inherit($pkg, $fields_base); diff --git a/lib/byte.pm b/lib/byte.pm index cc23b40f4f..0424e1778d 100644 --- a/lib/byte.pm +++ b/lib/byte.pm @@ -1,11 +1,11 @@ package byte; sub import { - $^H |= 0x00000010; + $^H |= 0x00000008; } sub unimport { - $^H &= ~0x00000010; + $^H &= ~0x00000008; } sub AUTOLOAD { @@ -20,7 +20,7 @@ __END__ =head1 NAME -byte - Perl pragma to turn force treating strings as bytes not UNICODE +byte - Perl pragma to force byte semantics rather than character semantics =head1 SYNOPSIS @@ -29,5 +29,22 @@ byte - Perl pragma to turn force treating strings as bytes not UNICODE =head1 DESCRIPTION +WARNING: The implementation of Unicode support in Perl is incomplete. +Expect sudden and unannounced changes! + +The C<use byte> pragma disables character semantics for the rest of the +lexical scope in which it appears. C<no byte> can be used to reverse +the effect of C<use byte> within the current lexical scope. + +Perl normally assumes character semantics in the presence of +character data (i.e. data that has come from a source that has +been marked as being of a particular character encoding). + +To understand the implications and differences between character +semantics and byte semantics, see L<perlunicode>. + +=head1 SEE ALSO + +L<perlunicode>, L<utf8> =cut diff --git a/lib/byte_heavy.pl b/lib/byte_heavy.pl index 07c908a689..ec0558561d 100644 --- a/lib/byte_heavy.pl +++ b/lib/byte_heavy.pl @@ -1,8 +1,8 @@ package byte; -sub length ($) -{ - return CORE::length($_[0]); +sub length ($) { + BEGIN { byte::import() } + return CORE::length($_[0]); } 1; diff --git a/lib/caller.pm b/lib/caller.pm deleted file mode 100644 index 91e67a1743..0000000000 --- a/lib/caller.pm +++ /dev/null @@ -1,59 +0,0 @@ -package caller; -use vars qw($VERSION); -$VERSION = "1.0"; - -=head1 NAME - -caller - inherit pragmatic attributes from the context of the caller - -=head1 SYNOPSIS - - use caller qw(encoding); - -=head1 DESCRIPTION - -This pragma allows a module to inherit some attributes from the -context which loaded it. - -Inheriting attributes takes place at compile time; this means -only attributes that are visible in the calling context at compile -time will be propagated. - -Currently, the only supported attribute is C<encoding>. - -=over - -=item encoding - -Indicates that the character set encoding of the caller's context -must be inherited. This can be used to inherit the C<use utf8> -setting in the calling context. - -=back - -=cut - -my %bitmask = ( - # only HINT_UTF8 supported for now - encoding => 0x8 -); - -sub bits { - my $bits = 0; - for my $s (@_) { $bits |= $bitmask{$s} || 0; }; - $bits; -} - -sub import { - shift; - my @cxt = caller(3); - if (@cxt and $cxt[7]) { # was our parent require-d? - $^H |= bits(@_) & $cxt[8]; - } -} - -sub unimport { - # noop currently -} - -1; diff --git a/lib/charnames.pm b/lib/charnames.pm index bd97983abc..817b4c559e 100644 --- a/lib/charnames.pm +++ b/lib/charnames.pm @@ -29,17 +29,15 @@ sub charnames { } die "Unknown charname '$name'" unless @off; - # use caller 'encoding'; # Does not work at compile time? - my $ord = hex substr $txt, $off[0] - 4, 4; - if ($^H & 0x8) { - use utf8; - return chr $ord; + if ($^H & 0x8) { # "use byte" in effect? + use byte; + return chr $ord if $ord <= 255; + my $hex = sprintf '%X=0%o', $ord, $ord; + my $fname = substr $txt, $off[0] + 2, $off[1] - $off[0] - 2; + die "Character 0x$hex with name '$fname' is above 0xFF"; } - return chr $ord if $ord <= 255; - my $hex = sprintf '%X=0%o', $ord, $ord; - my $fname = substr $txt, $off[0] + 2, $off[1] - $off[0] - 2; - die "Character 0x$hex with name '$fname' is above 0xFF"; + return chr $ord; } sub import { diff --git a/lib/constant.pm b/lib/constant.pm index 31f47fbf54..bbfdb78ec4 100644 --- a/lib/constant.pm +++ b/lib/constant.pm @@ -1,15 +1,15 @@ package constant; use strict; -use vars qw( $VERSION %declared ); +use 5.005_64; + +our($VERSION, %declared); $VERSION = '1.01'; #======================================================================= -require 5.005_62; - # Some names are evil choices. -my %keywords = map +($_, 1), qw{ BEGIN INIT STOP END DESTROY AUTOLOAD }; +my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD }; my %forced_into_main = map +($_, 1), qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG }; diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index e6a9127158..a2c927baca 100755 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -167,7 +167,7 @@ Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995. =cut -require 5.005_64; +use 5.005_64; use Carp; $VERSION = v1.0; diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl index f473c45bd3..c72781801b 100644 --- a/lib/dumpvar.pl +++ b/lib/dumpvar.pl @@ -312,14 +312,27 @@ sub dumpglob { } } +sub CvGV_name_or_bust { + my $in = shift; + return if $skipCvGV; # Backdoor to avoid problems if XS broken... + $in = \&$in; # Hard reference... + eval {require Devel::Peek; 1} or return; + my $gv = Devel::Peek::CvGV($in) or return; + *$gv{PACKAGE} . '::' . *$gv{NAME}; +} + sub dumpsub { my ($off,$sub) = @_; + my $ini = $sub; + my $s; $sub = $1 if $sub =~ /^\{\*(.*)\}$/; - my $subref = \&$sub; - my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub}) - || ($subdump && ($sub = findsubs("$subref")) && $DB::sub{$sub}); + my $subref = defined $1 ? \&$sub : \&$ini; + my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s}) + || (($s = CvGV_name_or_bust($subref)) && $DB::sub{$s}) + || ($subdump && ($s = findsubs("$subref")) && $DB::sub{$s}); $place = '???' unless defined $place; - print( (' ' x $off) . "&$sub in $place\n" ); + $s = $sub unless defined $s; + print( (' ' x $off) . "&$s in $place\n" ); } sub findsubs { diff --git a/lib/fields.pm b/lib/fields.pm index f54f639b07..bc9e51320f 100644 --- a/lib/fields.pm +++ b/lib/fields.pm @@ -69,63 +69,90 @@ L<perlref/Pseudo-hashes: Using an array as a hash> =cut +use 5.005_64; use strict; no strict 'refs'; -use vars qw(%attr $VERSION); +our(%attr, $VERSION); -$VERSION = "0.02"; +$VERSION = "1.01"; # some constants sub _PUBLIC () { 1 } sub _PRIVATE () { 2 } -sub _INHERITED () { 4 } # The %attr hash holds the attributes of the currently assigned fields # per class. The hash is indexed by class names and the hash value is -# an array reference. The array is indexed with the field numbers -# (minus one) and the values are integer bit masks (or undef). The -# size of the array also indicate the next field index too assign for -# additional fields in this class. +# an array reference. The first element in the array is the lowest field +# number not belonging to a base class. The remaining elements' indices +# are the field numbers. The values are integer bit masks, or undef +# in the case of base class private fields (which occupy a slot but are +# otherwise irrelevant to the class). sub import { my $class = shift; + return unless @_; my $package = caller(0); my $fields = \%{"$package\::FIELDS"}; - my $fattr = ($attr{$package} ||= []); + my $fattr = ($attr{$package} ||= [1]); + my $next = @$fattr; + if ($next > $fattr->[0] + and ($fields->{$_[0]} || 0) >= $fattr->[0]) + { + # There are already fields not belonging to base classes. + # Looks like a possible module reload... + $next = $fattr->[0]; + } foreach my $f (@_) { - if (my $fno = $fields->{$f}) { + my $fno = $fields->{$f}; + + # Allow the module to be reloaded so long as field positions + # have not changed. + if ($fno and $fno != $next) { require Carp; - if ($fattr->[$fno-1] & _INHERITED) { + if ($fno < $fattr->[0]) { Carp::carp("Hides field '$f' in base class") if $^W; } else { Carp::croak("Field name '$f' already in use"); } } - $fields->{$f} = @$fattr + 1; - push(@$fattr, ($f =~ /^_/) ? _PRIVATE : _PUBLIC); + $fields->{$f} = $next; + $fattr->[$next] = ($f =~ /^_/) ? _PRIVATE : _PUBLIC; + $next += 1; + } + if (@$fattr > $next) { + # Well, we gave them the benefit of the doubt by guessing the + # module was reloaded, but they appear to be declaring fields + # in more than one place. We can't be sure (without some extra + # bookkeeping) that the rest of the fields will be declared or + # have the same positions, so punt. + require Carp; + Carp::croak ("Reloaded module must declare all fields at once"); } } -sub inherit # called by base.pm +sub inherit # called by base.pm when $base_fields is nonempty { my($derived, $base) = @_; - - if (keys %{"$derived\::FIELDS"}) { - require Carp; - Carp::croak("Inherited %FIELDS can't override existing %FIELDS"); - } else { - my $base_fields = \%{"$base\::FIELDS"}; - my $derived_fields = \%{"$derived\::FIELDS"}; - - $attr{$derived}[@{$attr{$base}}-1] = undef; - while (my($k,$v) = each %$base_fields) { - next if $attr{$base}[$v-1] & _PRIVATE; - $attr{$derived}[$v-1] = _INHERITED; - $derived_fields->{$k} = $v; - } - } - + my $base_attr = $attr{$base}; + my $derived_attr = $attr{$derived} ||= []; + my $base_fields = \%{"$base\::FIELDS"}; + my $derived_fields = \%{"$derived\::FIELDS"}; + + $derived_attr->[0] = $base_attr ? scalar(@$base_attr) : 1; + while (my($k,$v) = each %$base_fields) { + my($fno); + if ($fno = $derived_fields->{$k} and $fno != $v) { + require Carp; + Carp::croak ("Inherited %FIELDS can't override existing %FIELDS"); + } + if ($base_attr->[$v] & _PRIVATE) { + $derived_attr->[$v] = undef; + } else { + $derived_attr->[$v] = $base_attr->[$v]; + $derived_fields->{$k} = $v; + } + } } sub _dump # sometimes useful for debugging @@ -140,12 +167,12 @@ sub _dump # sometimes useful for debugging for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) { my $no = $fields->{$f}; print " $no: $f"; - my $fattr = $attr{$pkg}[$no-1]; + my $fattr = $attr{$pkg}[$no]; if (defined $fattr) { my @a; push(@a, "public") if $fattr & _PUBLIC; push(@a, "private") if $fattr & _PRIVATE; - push(@a, "inherited") if $fattr & _INHERITED; + push(@a, "inherited") if $no < $attr{$pkg}[0]; print "\t(", join(", ", @a), ")"; } print "\n"; diff --git a/lib/lib.pm b/lib/lib.pm index afc979bb45..e46c5fefa6 100644 --- a/lib/lib.pm +++ b/lib/lib.pm @@ -1,13 +1,14 @@ package lib; -use vars qw(@ORIG_INC); +use 5.005_64; use Config; my $archname = $Config{'archname'}; my $ver = $Config{'version'}; +my @inc_version_list = reverse split / /, $Config{'inc_version_list'}; -@ORIG_INC = @INC; # take a handy copy of 'original' value - +our @ORIG_INC = @INC; # take a handy copy of 'original' value +our $VERSION = '0.5564'; sub import { shift; @@ -23,12 +24,15 @@ sub import { Carp::carp("Parameter to use lib must be directory, not file"); } unshift(@INC, $_); + # Add any previous version directories we found at configure time + foreach my $incver (@inc_version_list) + { + unshift(@INC, "$_/$incver") if -d "$_/$incver"; + } # Put a corresponding archlib directory infront of $_ if it # looks like $_ has an archlib directory below it. - if (-d "$_/$archname") { - unshift(@INC, "$_/$archname") if -d "$_/$archname/auto"; - unshift(@INC, "$_/$archname/$ver") if -d "$_/$archname/$ver/auto"; - } + unshift(@INC, "$_/$ver") if -d "$_/$ver"; + unshift(@INC, "$_/$ver/$archname") if -d "$_/$ver/$archname"; } # remove trailing duplicates diff --git a/lib/perl5db.pl b/lib/perl5db.pl index d2bd98e654..de75bd7d86 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -2,7 +2,7 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.04041; +$VERSION = 1.05; $header = "perl5db.pl version $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -597,16 +597,26 @@ EOP } }; $cmd =~ s/^l\s+-\s*$/-/; - $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do { + $cmd =~ /^([lb])\b\s*(\$.*)/s && do { + $evalarg = $2; + my ($s) = &eval; + print($OUT "Error: $@\n"), next CMD if $@; + $s = CvGV_name($s); + print($OUT "Interpreted as: $1 $s\n"); + $cmd = "$1 $s"; + }; + $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do { $subname = $1; $subname =~ s/\'/::/; $subname = $package."::".$subname unless $subname =~ /::/; $subname = "main".$subname if substr($subname,0,2) eq "::"; - @pieces = split(/:/,find_sub($subname)); + @pieces = split(/:/,find_sub($subname) || $sub{$subname}); $subrange = pop @pieces; $file = join(':', @pieces); if ($file ne $filename) { + print $OUT "Switching to file '$file'.\n" + unless $emacs; *dbline = $main::{'_<' . $file}; $max = $#dbline; $filename = $file; @@ -782,7 +792,7 @@ EOP $postponed{$subname} = $break ? "break +0 if $cond" : "compile"; next CMD; }; - $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do { + $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do { $subname = $1; $cond = $2 || '1'; $subname =~ s/\'/::/; @@ -793,8 +803,8 @@ EOP ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/); $i += 0; if ($i) { - $filename = $file; - *dbline = $main::{'_<' . $filename}; + local $filename = $file; + local *dbline = $main::{'_<' . $filename}; $had_breakpoints{$filename} = 1; $max = $#dbline; ++$i while $dbline[$i] == 0 && $i < $max; @@ -884,6 +894,10 @@ EOP $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do { end_report(), next CMD if $finished and $level <= 1; $subname = $i = $1; + # Probably not needed, since we finish an interactive + # sub-session anyway... + # local $filename = $filename; + # local *dbline = *dbline; # XXX Would this work?! if ($i =~ /\D/) { # subroutine name $subname = $package."::".$subname unless $subname =~ /::/; @@ -1254,11 +1268,11 @@ sub save { # The following takes its argument via $evalarg to preserve current @_ sub eval { - my @res; + local @res; # 'my' would make it visible from user code { - my $otrace = $trace; - my $osingle = $single; - my $od = $^D; + local $otrace = $trace; + local $osingle = $single; + local $od = $^D; @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug $trace = $otrace; $single = $osingle; @@ -1807,11 +1821,18 @@ B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>. B<l> I<min>B<->I<max> List lines I<min> through I<max>. B<l> I<line> List single I<line>. B<l> I<subname> List first window of lines from subroutine. +B<l> I<$var> List first window of lines from subroutine referenced by I<$var>. B<l> List next window of lines. B<-> List previous window of lines. B<w> [I<line>] List window around I<line>. B<.> Return to the executed line. -B<f> I<filename> Switch to viewing I<filename>. Must be loaded. +B<f> I<filename> Switch to viewing I<filename>. File must be already loaded. + I<filename> may be either the full name of the file, or a regular + expression matching the full file name: + B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file. + Evals (with saved bodies) are considered to be filenames: + B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval + (in the order of execution). B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional. B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional. B<L> List all breakpoints and actions. @@ -1823,6 +1844,7 @@ B<b> [I<line>] [I<condition>] I<condition> breaks if it evaluates to true, defaults to '1'. B<b> I<subname> [I<condition>] Set breakpoint at first line of subroutine. +B<b> I<$var> Set breakpoint at first line of subroutine referenced by I<$var>. B<b> B<load> I<filename> Set breakpoint on `require'ing the given file. B<b> B<postpone> I<subname> [I<condition>] Set breakpoint at first line of subroutine after @@ -2051,10 +2073,31 @@ sub signalLevel { $signalLevel; } +sub CvGV_name { + my $in = shift; + my $name = CvGV_name_or_bust($in); + defined $name ? $name : $in; +} + +sub CvGV_name_or_bust { + my $in = shift; + return if $skipCvGV; # Backdoor to avoid problems if XS broken... + $in = \&$in; # Hard reference... + eval {require Devel::Peek; 1} or return; + my $gv = Devel::Peek::CvGV($in) or return; + *$gv{PACKAGE} . '::' . *$gv{NAME}; +} + sub find_sub { my $subr = shift; - return unless defined &$subr; $sub{$subr} or do { + return unless defined &$subr; + my $name = CvGV_name_or_bust($subr); + my $data; + $data = $sub{$name} if defined $name; + return $data if defined $data; + + # Old stupid way... $subr = \&$subr; # Hard reference my $s; for (keys %sub) { diff --git a/lib/strict.pm b/lib/strict.pm index 99ed01d583..f9d60af154 100644 --- a/lib/strict.pm +++ b/lib/strict.pm @@ -38,8 +38,8 @@ use symbolic references (see L<perlref>). =item C<strict vars> This generates a compile-time error if you access a variable that wasn't -declared via C<use vars>, -localized via C<my()> or wasn't fully qualified. Because this is to avoid +declared via "our" or C<use vars>, +localized via C<my()>, or wasn't fully qualified. Because this is to avoid variable suicide problems and subtle dynamic scoping issues, a merely local() variable isn't good enough. See L<perlfunc/my> and L<perlfunc/local>. @@ -50,7 +50,7 @@ L<perlfunc/local>. local $foo = 9; # blows up package Cinna; - use vars qw/ $bar /; # Declares $bar in current package + our $bar; # Declares $bar in current package $bar = 'HgS'; # ok, global declared via pragma The local() generated a compile-time error because you just touched a global diff --git a/lib/unicode/Is/ASCII.pl b/lib/unicode/Is/ASCII.pl index b7843e932f..63f95ae7dd 100644 --- a/lib/unicode/Is/ASCII.pl +++ b/lib/unicode/Is/ASCII.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0000 007f END diff --git a/lib/unicode/Is/Alnum.pl b/lib/unicode/Is/Alnum.pl index 18200ffdda..d44f744e20 100644 --- a/lib/unicode/Is/Alnum.pl +++ b/lib/unicode/Is/Alnum.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0030 0039 0041 005a diff --git a/lib/unicode/Is/Alpha.pl b/lib/unicode/Is/Alpha.pl index 1be8129964..0e94688e85 100644 --- a/lib/unicode/Is/Alpha.pl +++ b/lib/unicode/Is/Alpha.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0041 005a 0061 007a diff --git a/lib/unicode/Is/BidiAN.pl b/lib/unicode/Is/BidiAN.pl index e3639ba9f9..4a71ae532d 100644 --- a/lib/unicode/Is/BidiAN.pl +++ b/lib/unicode/Is/BidiAN.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0660 0669 066b 066c diff --git a/lib/unicode/Is/BidiB.pl b/lib/unicode/Is/BidiB.pl index ae1ba37b10..e4ba16567a 100644 --- a/lib/unicode/Is/BidiB.pl +++ b/lib/unicode/Is/BidiB.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 000a 000d diff --git a/lib/unicode/Is/BidiCS.pl b/lib/unicode/Is/BidiCS.pl index 4c16fe7e87..f8d037d118 100644 --- a/lib/unicode/Is/BidiCS.pl +++ b/lib/unicode/Is/BidiCS.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 002c 002e diff --git a/lib/unicode/Is/BidiEN.pl b/lib/unicode/Is/BidiEN.pl index eb8c5e7234..d63270aecf 100644 --- a/lib/unicode/Is/BidiEN.pl +++ b/lib/unicode/Is/BidiEN.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0030 0039 00b2 00b3 diff --git a/lib/unicode/Is/BidiES.pl b/lib/unicode/Is/BidiES.pl index 50e6d27e1b..5a1a36a6d8 100644 --- a/lib/unicode/Is/BidiES.pl +++ b/lib/unicode/Is/BidiES.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 002f ff0f diff --git a/lib/unicode/Is/BidiET.pl b/lib/unicode/Is/BidiET.pl index 201892260e..5e7af2bbf4 100644 --- a/lib/unicode/Is/BidiET.pl +++ b/lib/unicode/Is/BidiET.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0023 0025 002b diff --git a/lib/unicode/Is/BidiL.pl b/lib/unicode/Is/BidiL.pl index ae19cbaa2b..8dc4ca87c0 100644 --- a/lib/unicode/Is/BidiL.pl +++ b/lib/unicode/Is/BidiL.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0041 005a 0061 007a diff --git a/lib/unicode/Is/BidiON.pl b/lib/unicode/Is/BidiON.pl index 8924a60c0d..bde00ff123 100644 --- a/lib/unicode/Is/BidiON.pl +++ b/lib/unicode/Is/BidiON.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0021 0022 0026 002a diff --git a/lib/unicode/Is/BidiR.pl b/lib/unicode/Is/BidiR.pl index 5dbdd1b809..fccc1f6d6e 100644 --- a/lib/unicode/Is/BidiR.pl +++ b/lib/unicode/Is/BidiR.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 05be 05c0 diff --git a/lib/unicode/Is/BidiS.pl b/lib/unicode/Is/BidiS.pl index 3270482f0a..b28b3310ea 100644 --- a/lib/unicode/Is/BidiS.pl +++ b/lib/unicode/Is/BidiS.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0009 000b diff --git a/lib/unicode/Is/BidiWS.pl b/lib/unicode/Is/BidiWS.pl index 8322155635..25d8b8f6aa 100644 --- a/lib/unicode/Is/BidiWS.pl +++ b/lib/unicode/Is/BidiWS.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 000c 0020 diff --git a/lib/unicode/Is/C.pl b/lib/unicode/Is/C.pl index 837115a127..0db83c4bf3 100644 --- a/lib/unicode/Is/C.pl +++ b/lib/unicode/Is/C.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0000 001f 007f 009f diff --git a/lib/unicode/Is/Cc.pl b/lib/unicode/Is/Cc.pl index 2894c68bdb..d7184e3151 100644 --- a/lib/unicode/Is/Cc.pl +++ b/lib/unicode/Is/Cc.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0000 001f 007f 009f diff --git a/lib/unicode/Is/Cn.pl b/lib/unicode/Is/Cn.pl index 3054fd6216..ec287c456a 100644 --- a/lib/unicode/Is/Cn.pl +++ b/lib/unicode/Is/Cn.pl @@ -1,2 +1,5 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; END diff --git a/lib/unicode/Is/Cntrl.pl b/lib/unicode/Is/Cntrl.pl index 837115a127..0db83c4bf3 100644 --- a/lib/unicode/Is/Cntrl.pl +++ b/lib/unicode/Is/Cntrl.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0000 001f 007f 009f diff --git a/lib/unicode/Is/Co.pl b/lib/unicode/Is/Co.pl index 39445370fc..c456d33aea 100644 --- a/lib/unicode/Is/Co.pl +++ b/lib/unicode/Is/Co.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; e000 f8ff END diff --git a/lib/unicode/Is/DCcircle.pl b/lib/unicode/Is/DCcircle.pl index a9d58a44d0..4c47b28b26 100644 --- a/lib/unicode/Is/DCcircle.pl +++ b/lib/unicode/Is/DCcircle.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 2460 2473 24b6 24ea diff --git a/lib/unicode/Is/DCcompat.pl b/lib/unicode/Is/DCcompat.pl index b6d925ba53..75d25695f3 100644 --- a/lib/unicode/Is/DCcompat.pl +++ b/lib/unicode/Is/DCcompat.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 00a8 00af diff --git a/lib/unicode/Is/DCfinal.pl b/lib/unicode/Is/DCfinal.pl index 091bd64c71..33fbf6aff8 100644 --- a/lib/unicode/Is/DCfinal.pl +++ b/lib/unicode/Is/DCfinal.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; fb51 fb53 diff --git a/lib/unicode/Is/DCfont.pl b/lib/unicode/Is/DCfont.pl index c6d24436b3..c72234b3bf 100644 --- a/lib/unicode/Is/DCfont.pl +++ b/lib/unicode/Is/DCfont.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 2102 210a 2113 diff --git a/lib/unicode/Is/DCinital.pl b/lib/unicode/Is/DCinital.pl index 4faba29494..2c9cf47e7d 100644 --- a/lib/unicode/Is/DCinital.pl +++ b/lib/unicode/Is/DCinital.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; fb55 fb59 diff --git a/lib/unicode/Is/DCinitial.pl b/lib/unicode/Is/DCinitial.pl index b4e2b33873..0145b7dd71 100644 --- a/lib/unicode/Is/DCinitial.pl +++ b/lib/unicode/Is/DCinitial.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; fb54 fb58 diff --git a/lib/unicode/Is/DCisolated.pl b/lib/unicode/Is/DCisolated.pl index de7574214b..cc8541eb7b 100644 --- a/lib/unicode/Is/DCisolated.pl +++ b/lib/unicode/Is/DCisolated.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; fb50 fb52 diff --git a/lib/unicode/Is/DCnarrow.pl b/lib/unicode/Is/DCnarrow.pl index a4f448a6ec..9417de1bbd 100644 --- a/lib/unicode/Is/DCnarrow.pl +++ b/lib/unicode/Is/DCnarrow.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; ff61 ffbe ffc2 ffc7 diff --git a/lib/unicode/Is/DCnoBreak.pl b/lib/unicode/Is/DCnoBreak.pl index 5b0e817c7d..1fd9e8735b 100644 --- a/lib/unicode/Is/DCnoBreak.pl +++ b/lib/unicode/Is/DCnoBreak.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 00a0 0f0c diff --git a/lib/unicode/Is/DCsmall.pl b/lib/unicode/Is/DCsmall.pl index 2e05334032..f6c8069163 100644 --- a/lib/unicode/Is/DCsmall.pl +++ b/lib/unicode/Is/DCsmall.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; fe50 fe52 fe54 fe66 diff --git a/lib/unicode/Is/DCsquare.pl b/lib/unicode/Is/DCsquare.pl index 76b4ad8c6f..b55fdd9c6a 100644 --- a/lib/unicode/Is/DCsquare.pl +++ b/lib/unicode/Is/DCsquare.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 3300 3357 3371 3376 diff --git a/lib/unicode/Is/DCsub.pl b/lib/unicode/Is/DCsub.pl index d446ad49f7..98c4dfa87e 100644 --- a/lib/unicode/Is/DCsub.pl +++ b/lib/unicode/Is/DCsub.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 2080 208e END diff --git a/lib/unicode/Is/DCsuper.pl b/lib/unicode/Is/DCsuper.pl index 8e1330ee51..865a26dd92 100644 --- a/lib/unicode/Is/DCsuper.pl +++ b/lib/unicode/Is/DCsuper.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 00aa 00b2 00b3 diff --git a/lib/unicode/Is/DCvertical.pl b/lib/unicode/Is/DCvertical.pl index 1c00407743..5d55483606 100644 --- a/lib/unicode/Is/DCvertical.pl +++ b/lib/unicode/Is/DCvertical.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; fe30 fe44 END diff --git a/lib/unicode/Is/DCwide.pl b/lib/unicode/Is/DCwide.pl index b693b21380..09dae19629 100644 --- a/lib/unicode/Is/DCwide.pl +++ b/lib/unicode/Is/DCwide.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 3000 ff01 ff5e diff --git a/lib/unicode/Is/DecoCanon.pl b/lib/unicode/Is/DecoCanon.pl index 35a08690b7..c5a59f6596 100644 --- a/lib/unicode/Is/DecoCanon.pl +++ b/lib/unicode/Is/DecoCanon.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 00c0 00c5 00c7 00cf diff --git a/lib/unicode/Is/DecoCompat.pl b/lib/unicode/Is/DecoCompat.pl index 944d69155d..43d34fc110 100644 --- a/lib/unicode/Is/DecoCompat.pl +++ b/lib/unicode/Is/DecoCompat.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 00a0 00a8 diff --git a/lib/unicode/Is/Digit.pl b/lib/unicode/Is/Digit.pl index 2ae9c84f02..2ab8156d77 100644 --- a/lib/unicode/Is/Digit.pl +++ b/lib/unicode/Is/Digit.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0030 0039 0660 0669 diff --git a/lib/unicode/Is/Graph.pl b/lib/unicode/Is/Graph.pl index 723c881dd6..9c94bb722c 100644 --- a/lib/unicode/Is/Graph.pl +++ b/lib/unicode/Is/Graph.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0021 007e 00a0 021f diff --git a/lib/unicode/Is/L.pl b/lib/unicode/Is/L.pl index 7ab2842a75..c32f83049c 100644 --- a/lib/unicode/Is/L.pl +++ b/lib/unicode/Is/L.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0041 005a 0061 007a diff --git a/lib/unicode/Is/Ll.pl b/lib/unicode/Is/Ll.pl index da6b7d76ac..28147943e8 100644 --- a/lib/unicode/Is/Ll.pl +++ b/lib/unicode/Is/Ll.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0061 007a 00aa diff --git a/lib/unicode/Is/Lm.pl b/lib/unicode/Is/Lm.pl index cc76e43f73..4380afe18e 100644 --- a/lib/unicode/Is/Lm.pl +++ b/lib/unicode/Is/Lm.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 02b0 02b8 02bb 02c1 diff --git a/lib/unicode/Is/Lo.pl b/lib/unicode/Is/Lo.pl index e5f4537dd9..78fab4cd0e 100644 --- a/lib/unicode/Is/Lo.pl +++ b/lib/unicode/Is/Lo.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 01bb 01c0 01c3 diff --git a/lib/unicode/Is/Lower.pl b/lib/unicode/Is/Lower.pl index da6b7d76ac..28147943e8 100644 --- a/lib/unicode/Is/Lower.pl +++ b/lib/unicode/Is/Lower.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0061 007a 00aa diff --git a/lib/unicode/Is/Lt.pl b/lib/unicode/Is/Lt.pl index 2a6771723e..809c37a1f2 100644 --- a/lib/unicode/Is/Lt.pl +++ b/lib/unicode/Is/Lt.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 01c5 01c8 diff --git a/lib/unicode/Is/Lu.pl b/lib/unicode/Is/Lu.pl index eb8052e70d..8dde2742d0 100644 --- a/lib/unicode/Is/Lu.pl +++ b/lib/unicode/Is/Lu.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0041 005a 00c0 00d6 diff --git a/lib/unicode/Is/M.pl b/lib/unicode/Is/M.pl index 0b2bf32916..9367775a82 100644 --- a/lib/unicode/Is/M.pl +++ b/lib/unicode/Is/M.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0300 034e 0360 0362 diff --git a/lib/unicode/Is/Mc.pl b/lib/unicode/Is/Mc.pl index d707c6712e..937d8d4005 100644 --- a/lib/unicode/Is/Mc.pl +++ b/lib/unicode/Is/Mc.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0903 093e 0940 diff --git a/lib/unicode/Is/Mirrored.pl b/lib/unicode/Is/Mirrored.pl index b56c8357bc..e2c55a6443 100644 --- a/lib/unicode/Is/Mirrored.pl +++ b/lib/unicode/Is/Mirrored.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0028 0029 003c diff --git a/lib/unicode/Is/Mn.pl b/lib/unicode/Is/Mn.pl index ffb56f9801..aba40afa57 100644 --- a/lib/unicode/Is/Mn.pl +++ b/lib/unicode/Is/Mn.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0300 034e 0360 0362 diff --git a/lib/unicode/Is/N.pl b/lib/unicode/Is/N.pl index 6a8072c3de..1291f2713f 100644 --- a/lib/unicode/Is/N.pl +++ b/lib/unicode/Is/N.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0030 0039 00b2 00b3 diff --git a/lib/unicode/Is/Nd.pl b/lib/unicode/Is/Nd.pl index 2ae9c84f02..2ab8156d77 100644 --- a/lib/unicode/Is/Nd.pl +++ b/lib/unicode/Is/Nd.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0030 0039 0660 0669 diff --git a/lib/unicode/Is/No.pl b/lib/unicode/Is/No.pl index 0b926a8dec..6a57dc5f89 100644 --- a/lib/unicode/Is/No.pl +++ b/lib/unicode/Is/No.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 00b2 00b3 00b9 diff --git a/lib/unicode/Is/P.pl b/lib/unicode/Is/P.pl index 57b5e24331..8fd1e8e183 100644 --- a/lib/unicode/Is/P.pl +++ b/lib/unicode/Is/P.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0021 0023 0025 002a diff --git a/lib/unicode/Is/Pd.pl b/lib/unicode/Is/Pd.pl index f1c1439939..58997ca7e9 100644 --- a/lib/unicode/Is/Pd.pl +++ b/lib/unicode/Is/Pd.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 002d 00ad diff --git a/lib/unicode/Is/Pe.pl b/lib/unicode/Is/Pe.pl index 83a22a40c2..8879191c34 100644 --- a/lib/unicode/Is/Pe.pl +++ b/lib/unicode/Is/Pe.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0029 005d diff --git a/lib/unicode/Is/Po.pl b/lib/unicode/Is/Po.pl index 0e230d8331..e6b8b02520 100644 --- a/lib/unicode/Is/Po.pl +++ b/lib/unicode/Is/Po.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0021 0023 0025 0027 diff --git a/lib/unicode/Is/Print.pl b/lib/unicode/Is/Print.pl index 8faeea6d95..9560586065 100644 --- a/lib/unicode/Is/Print.pl +++ b/lib/unicode/Is/Print.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0020 007e 00a0 021f diff --git a/lib/unicode/Is/Ps.pl b/lib/unicode/Is/Ps.pl index fad4da758c..a7dee379eb 100644 --- a/lib/unicode/Is/Ps.pl +++ b/lib/unicode/Is/Ps.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0028 005b diff --git a/lib/unicode/Is/Punct.pl b/lib/unicode/Is/Punct.pl index 57b5e24331..8fd1e8e183 100644 --- a/lib/unicode/Is/Punct.pl +++ b/lib/unicode/Is/Punct.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0021 0023 0025 002a diff --git a/lib/unicode/Is/S.pl b/lib/unicode/Is/S.pl index 9292596053..8851766e9f 100644 --- a/lib/unicode/Is/S.pl +++ b/lib/unicode/Is/S.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0024 002b diff --git a/lib/unicode/Is/Sc.pl b/lib/unicode/Is/Sc.pl index ab2b0d6a30..5776bd6a57 100644 --- a/lib/unicode/Is/Sc.pl +++ b/lib/unicode/Is/Sc.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0024 00a2 00a5 diff --git a/lib/unicode/Is/Sm.pl b/lib/unicode/Is/Sm.pl index e68877ab80..ae9424cc62 100644 --- a/lib/unicode/Is/Sm.pl +++ b/lib/unicode/Is/Sm.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 002b 003c 003e diff --git a/lib/unicode/Is/So.pl b/lib/unicode/Is/So.pl index 6e937d6b39..4e9dfc2b5e 100644 --- a/lib/unicode/Is/So.pl +++ b/lib/unicode/Is/So.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 00a6 00a7 00a9 diff --git a/lib/unicode/Is/Space.pl b/lib/unicode/Is/Space.pl index d14c3fb78b..4121ef49b8 100644 --- a/lib/unicode/Is/Space.pl +++ b/lib/unicode/Is/Space.pl @@ -1,3 +1,6 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.300. +# Any changes made here will be lost! return <<'END'; 0009 000a 000c 000d diff --git a/lib/utf8.pm b/lib/utf8.pm index 5ddd4ba21a..d9e9becdda 100644 --- a/lib/utf8.pm +++ b/lib/utf8.pm @@ -1,12 +1,12 @@ package utf8; sub import { - $^H |= 0x00000008; + $^H |= 0x00800000; $enc{caller()} = $_[1] if $_[1]; } sub unimport { - $^H &= ~0x00000008; + $^H &= ~0x00800000; } sub AUTOLOAD { @@ -19,7 +19,7 @@ __END__ =head1 NAME -utf8 - Perl pragma to turn on UTF-8 and Unicode support +utf8 - Perl pragma to enable/disable UTF-8 in source code =head1 SYNOPSIS @@ -28,154 +28,48 @@ utf8 - Perl pragma to turn on UTF-8 and Unicode support =head1 DESCRIPTION -The utf8 pragma tells Perl to use UTF-8 as its internal string -representation for the rest of the enclosing block. (The "no utf8" -pragma tells Perl to switch back to ordinary byte-oriented processing -for the rest of the enclosing block.) Under utf8, many operations that -formerly operated on bytes change to operating on characters. For -ASCII data this makes no difference, because UTF-8 stores ASCII in -single bytes, but for any character greater than C<chr(127)>, the -character is stored in a sequence of two or more bytes, all of which -have the high bit set. But by and large, the user need not worry about -this, because the utf8 pragma hides it from the user. A character -under utf8 is logically just a number ranging from 0 to 2**32 or so. -Larger characters encode to longer sequences of bytes, but again, this -is hidden. +WARNING: The implementation of Unicode support in Perl is incomplete. +Expect sudden and unannounced changes! -Use of the utf8 pragma has the following effects: +The C<use utf8> pragma tells the Perl parser to allow UTF-8 in the +program text in the current lexical scope. The C<no utf8> pragma +tells Perl to switch back to treating the source text as literal +bytes in the current lexical scope. -=over 4 +This pragma is primarily a compatibility device. Perl versions +earlier than 5.6 allowed arbitrary bytes in source code, whereas +in future we would like to standardize on the UTF-8 encoding for +source text. Until UTF-8 becomes the default format for source +text, this pragma should be used to recognize UTF-8 in the source. +When UTF-8 becomes the standard source format, this pragma will +effectively become a no-op. -=item * - -Strings and patterns may contain characters that have an ordinal value -larger than 255. Presuming you use a Unicode editor to edit your -program, these will typically occur directly within the literal strings -as UTF-8 characters, but you can also specify a particular character -with an extension of the C<\x> notation. UTF-8 characters are -specified by putting the hexadecimal code within curlies after the -C<\x>. For instance, a Unicode smiley face is C<\x{263A}>. A -character in the Latin-1 range (128..255) should be written C<\x{ab}> -rather than C<\xab>, since the former will turn into a two-byte UTF-8 -code, while the latter will continue to be interpreted as generating a -8-bit byte rather than a character. In fact, if C<-w> is turned on, it will -produce a warning that you might be generating invalid UTF-8. - -=item * - -Identifiers within the Perl script may contain Unicode alphanumeric -characters, including ideographs. (You are currently on your own when -it comes to using the canonical forms of characters--Perl doesn't (yet) -attempt to canonicalize variable names for you.) - -=item * - -Regular expressions match characters instead of bytes. For instance, -"." matches a character instead of a byte. (However, the C<\C> pattern -is provided to force a match a single byte ("C<char>" in C, hence -C<\C>).) - -=item * +Enabling the C<utf8> pragma has the following effects: -Character classes in regular expressions match characters instead of -bytes, and match against the character properties specified in the -Unicode properties database. So C<\w> can be used to match an ideograph, -for instance. +=over =item * -Named Unicode properties and block ranges make be used as character -classes via the new C<\p{}> (matches property) and C<\P{}> (doesn't -match property) constructs. For instance, C<\p{Lu}> matches any -character with the Unicode uppercase property, while C<\p{M}> matches -any mark character. Single letter properties may omit the brackets, so -that can be written C<\pM> also. Many predefined character classes are -available, such as C<\p{IsMirrored}> and C<\p{InTibetan}>. +Bytes in the source text that have their high-bit set will be treated +as being part of a literal UTF-8 character. This includes most literals +such as identifiers, string constants, constant regular expression patterns +and package names. =item * -The special pattern C<\X> match matches any extended Unicode sequence -(a "combining character sequence" in Standardese), where the first -character is a base character and subsequent characters are mark -characters that apply to the base character. It is equivalent to -C<(?:\PM\pM*)>. - -=item * +In the absence of inputs marked as UTF-8, regular expressions within the +scope of this pragma will default to using character semantics instead +of byte semantics. -The C<tr///> operator translates characters instead of bytes. It can also -be forced to translate between 8-bit codes and UTF-8 regardless of the -surrounding utf8 state. For instance, if you know your input in Latin-1, -you can say: - - use utf8; - while (<>) { - tr/\0-\xff//CU; # latin1 char to utf8 - ... + @bytes_or_chars = split //, $data; # may split to bytes if data + # $data isn't UTF-8 + { + use utf8; # force char semantics + @chars = split //, $data; # splits characters } -Similarly you could translate your output with - - tr/\0-\x{ff}//UC; # utf8 to latin1 char - -No, C<s///> doesn't take /U or /C (yet?). - -=item * - -Case translation operators use the Unicode case translation tables. -Note that C<uc()> translates to uppercase, while C<ucfirst> translates -to titlecase (for languages that make the distinction). Naturally -the corresponding backslash sequences have the same semantics. - -=item * - -Most operators that deal with positions or lengths in the string will -automatically switch to using character positions, including C<chop()>, -C<substr()>, C<pos()>, C<index()>, C<rindex()>, C<sprintf()>, -C<write()>, and C<length()>. Operators that specifically don't switch -include C<vec()>, C<pack()>, and C<unpack()>. Operators that really -don't care include C<chomp()>, as well as any other operator that -treats a string as a bucket of bits, such as C<sort()>, and the -operators dealing with filenames. - -=item * - -The C<pack()>/C<unpack()> letters "C<c>" and "C<C>" do I<not> change, -since they're often used for byte-oriented formats. (Again, think -"C<char>" in the C language.) However, there is a new "C<U>" specifier -that will convert between UTF-8 characters and integers. (It works -outside of the utf8 pragma too.) - -=item * - -The C<chr()> and C<ord()> functions work on characters. This is like -C<pack("U")> and C<unpack("U")>, not like C<pack("C")> and -C<unpack("C")>. In fact, the latter are how you now emulate -byte-oriented C<chr()> and C<ord()> under utf8. - -=item * - -And finally, C<scalar reverse()> reverses by character rather than by byte. - -=back - -=head1 CAVEATS - -As of yet, there is no method for automatically coercing input and -output to some encoding other than UTF-8. This is planned in the near -future, however. - -In any event, you'll need to keep track of whether interfaces to other -modules expect UTF-8 data or something else. The utf8 pragma does not -magically mark strings for you in order to remember their encoding, nor -will any automatic coercion happen (other than that eventually planned -for I/O). If you want such automatic coercion, you can build yourself -a set of pretty object-oriented modules. Expect it to run considerably -slower than than this low-level support. +=head1 SEE ALSO -Use of locales with utf8 may lead to odd results. Currently there is -some attempt to apply 8-bit locale info to characters in the range -0..255, but this is demonstrably incorrect for locales that use -characters above that range (when mapped into Unicode). It will also -tend to run slower. Avoidance of locales is strongly encouraged. +L<perlunicode>, L<byte> =cut diff --git a/lib/utf8_heavy.pl b/lib/utf8_heavy.pl index 0f588237eb..8649e9e07e 100644 --- a/lib/utf8_heavy.pl +++ b/lib/utf8_heavy.pl @@ -38,7 +38,7 @@ sub SWASHNEW { if ($list) { my @tmp = split(/^/m, $list); my %seen; - local $^W = 0; + no warnings; $extras = join '', grep /^[^0-9a-fA-F]/, @tmp; $list = join '', sort { hex $a <=> hex $b } diff --git a/lib/warnings.pm b/lib/warnings.pm index e15d364193..6b87d85f2b 100644 --- a/lib/warnings.pm +++ b/lib/warnings.pm @@ -115,14 +115,15 @@ sub bits { my $catmask ; my $fatal = 0 ; foreach my $word (@_) { - if ($word eq 'FATAL') - { $fatal = 1 } - elsif ($catmask = $Bits{$word}) { - $mask |= $catmask ; - $mask |= $DeadBits{$word} if $fatal ; + if ($word eq 'FATAL') { + $fatal = 1; + } + else { + if ($catmask = $Bits{$word}) { + $mask |= $catmask ; + $mask |= $DeadBits{$word} if $fatal ; + } } - else - { croak "unknown warning category '$word'" } } return $mask ; @@ -130,12 +131,12 @@ sub bits { sub import { shift; - ${^Warnings} |= bits(@_ ? @_ : 'all') ; + ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ; } sub unimport { shift; - ${^Warnings} &= ~ bits(@_ ? @_ : 'all') ; + ${^WARNING_BITS} &= ~ bits(@_ ? @_ : 'all') ; } sub enabled @@ -143,7 +144,7 @@ sub enabled my $string = shift ; return 1 - if $bits{$string} && ${^Warnings} & $bits{$string} ; + if $bits{$string} && ${^WARNING_BITS} & $bits{$string} ; return 0 ; } |