diff options
Diffstat (limited to 'utils')
| -rw-r--r-- | utils/h2ph.PL | 7 | ||||
| -rw-r--r-- | utils/perlbug.PL | 48 | ||||
| -rw-r--r-- | utils/perldoc.PL | 176 |
3 files changed, 152 insertions, 79 deletions
diff --git a/utils/h2ph.PL b/utils/h2ph.PL index d48571f00f..1b469daab8 100644 --- a/utils/h2ph.PL +++ b/utils/h2ph.PL @@ -50,7 +50,7 @@ die "Destination directory $Dest_dir doesn't exist or isn't a directory\n" short ushort u_short int uint u_int long ulong u_long - FILE + FILE key_t caddr_t END @isatype{@isatype} = (1) x @isatype; @@ -132,7 +132,7 @@ foreach $file (@ARGV) { print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n"; } else { - print OUT $t,"unless(defined(\&$name) {\nsub $name () {",$new,";}\n}\n"; + print OUT $t,"unless(defined(\&$name)) {\nsub $name () {",$new,";}\n}\n"; } } } @@ -191,9 +191,10 @@ exit $Exit; sub expr { while ($_ ne '') { + s/^\&//; # hack for things that take the address of s/^(\s+)// && do {$new .= ' '; next;}; s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;}; - s/^(\d+)[LlUu]*// && do {$new .= $1; next;}; + s/^(\d+)\s*[LlUu]*// && do {$new .= $1; next;}; s/^("(\\"|[^"])*")// && do {$new .= $1; next;}; s/^'((\\"|[^"])*)'// && do { if ($curargs{$1}) { diff --git a/utils/perlbug.PL b/utils/perlbug.PL index 6b670fc46b..724df6b449 100644 --- a/utils/perlbug.PL +++ b/utils/perlbug.PL @@ -26,18 +26,22 @@ open PATCH_LEVEL, "<../patchlevel.h" or die "Can't open patchlevel.h: $!"; my $patchlevel_date = (stat PATCH_LEVEL)[9]; while (<PATCH_LEVEL>) { - last if index($_, "static\tchar\t*local_patches[] = {") >= 0; + last if $_ =~ /^\s*static\s+char.*?local_patches\[\]\s*=\s*{\s*$/; }; -my $patches; +my @patches; while (<PATCH_LEVEL>) { - last if /^}/; + last if /^\s*}/; chomp; s/^\s+,?"?//; s/"?,?$//; s/(['\\])/\\$1/g; - $patches .= "'$_',\n" unless $_ eq 'NULL'; + push @patches, $_ unless $_ eq 'NULL'; }; +my $patch_desc = "'" . join("',\n\t'", @patches) . "'"; +my @patch_tags = map { my $p=$_; $p=~s/\s.*//; $p } @patches; +my $patch_tags = join " ", map { "+$_" } @patch_tags; +$patch_tags .= " " if $patch_tags; close PATCH_LEVEL; @@ -56,8 +60,13 @@ $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' if \$running_under_some_shell; +my \$config_tag1 = '$] - $Config{cf_time}'; + my \$patchlevel_date = $patchlevel_date; -my \@patches = ( $patches ); +my \$patch_tags = '$patch_tags'; +my \@patches = ( + $patch_desc +); !GROK!THIS! # In the following, perl variables are not expanded during extraction. @@ -80,7 +89,7 @@ use strict; sub paraprint; -my($Version) = "1.19"; +my($Version) = "1.20"; # Changed in 1.06 to skip Mail::Send and Mail::Util if not available. # Changed in 1.07 to see more sendmail execs, and added pipe output. @@ -104,6 +113,7 @@ my($Version) = "1.19"; # Changed in 1.19 '-ok' default not '-v' # add local patch information # warn on '-ok' if this is an old system; add '-okay' +# Changed in 1.20 Added patchlevel.h reading and version/config checks # TODO: - Allow the user to re-name the file on mail failure, and # make sure failure (transmission-wise) of Mail::Send is @@ -114,6 +124,8 @@ my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename, $subject, $from, $verbose, $ed, $fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP, $ok); +my $config_tag2 = "$] - $Config{cf_time}"; + Init(); if($::opt_h) { Help(); exit; } @@ -204,8 +216,8 @@ EOF $::opt_S = 1; # don't prompt for send $::opt_C = 1; # don't send a copy to the local admin $::opt_s = 1; - $subject = "OK: perl $] on" - ." $::Config{'osname'} $::Config{'osvers'} $subject"; + $subject = "OK: perl $] ${patch_tags}on" + ." $::Config{'archname'} $::Config{'osvers'} $subject"; $::opt_b = 1; $body = "Perl reported to build OK on this system.\n"; $ok = 1; @@ -292,12 +304,9 @@ EOF $domain = Mail::Util::maildomain(); } elsif ($Is_MSWin32) { $domain = $ENV{'USERDOMAIN'}; - } elsif ($Is_VMS) { + } else { require Sys::Hostname; $domain = Sys::Hostname::hostname(); - } else { - $domain = `hostname`.".".`domainname`; - $domain =~ s/[\r\n]+//g; } my($guess); @@ -534,9 +543,13 @@ EOF sub Dump { local(*OUT) = @_; - print OUT <<EOF; + print REP "\n---\n"; ---- + print REP "This perlbug was built using Perl $config_tag1\n", + "It is being executed now by Perl $config_tag2.\n\n" + if $config_tag2 ne $config_tag1; + + print OUT <<EOF; Site configuration information for perl $]: EOF @@ -548,7 +561,7 @@ EOF print OUT Config::myconfig; if (@patches) { - print OUT join "\n\t", "\nLocally applied patches:", @patches; + print OUT join "\n\t", "Locally applied patches:", @patches; print OUT "\n"; }; @@ -878,8 +891,9 @@ Options: This prints out your configuration data, without mailing anything. You can use this with -v to get more complete data. -ok Report successful build on this system to perl porters - (use alone or with -v). - -okay As -ok but also report on older systems. + (use alone or with -v). Only use -ok if *everything* was ok. + If there were *any* problems at all then don't use -ok. + -okay As -ok but allow report from old builds. -h Print this help message. EOF diff --git a/utils/perldoc.PL b/utils/perldoc.PL index 38ea9ee5ca..d223a9aaf9 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -45,10 +45,11 @@ print OUT <<'!NO!SUBS!'; # the perl manuals, though it too is written in perl. if(@ARGV<1) { - $0 =~ s,.*/,,; + $me = $0; # Editing $0 is unportable + $me =~ s,.*/,,; die <<EOF; -Usage: $0 [-h] [-v] [-t] [-u] [-m] [-l] PageName|ModuleName|ProgramName - $0 -f PerlFunc +Usage: $me [-h] [-v] [-t] [-u] [-m] [-l] PageName|ModuleName|ProgramName + $me -f PerlFunc We suggest you use "perldoc perldoc" to get aquainted with the system. @@ -58,6 +59,9 @@ EOF use Getopt::Std; use Config '%Config'; +@global_found = (); +$global_target = ""; + $Is_VMS = $^O eq 'VMS'; $Is_MSWin32 = $^O eq 'MSWin32'; @@ -118,36 +122,60 @@ if ($opt_f) { @pages = @ARGV; } +# Does this look like a module or extension directory? +if (-f "Makefile.PL") { + # Add ., lib and blib/* libs to @INC (if they exist) + unshift(@INC, '.'); + unshift(@INC, 'lib') if -d 'lib'; + require ExtUtils::testlib; +} + sub containspod { - my($file) = @_; - local($_); - open(TEST,"<$file"); - while(<TEST>) { - if(/^=head/) { - close(TEST); - return 1; - } + my($file, $readit) = @_; + return 1 if !$readit && $file =~ /\.pod$/i; + local($_); + open(TEST,"<$file"); + while(<TEST>) { + if(/^=head/) { + close(TEST); + return 1; } - close(TEST); - return 0; + } + close(TEST); + return 0; } sub minus_f_nocase { my($file) = @_; # on a case-forgiving file system we can simply use -f $file if ($Is_VMS or $Is_MSWin32 or $^O eq 'os2') { - return ( -f $file ) ? $file : ''; + return $file if -f $file and -r _; + warn "Ignored $file: unreadable\n" unless -r _; + return ''; } local *DIR; local($")="/"; my(@p,$p,$cip); foreach $p (split(/\//, $file)){ - if (-d ("@p/$p")){ + my $try = "@p/$p"; + stat $try; + if (-d _){ push @p, $p; - } elsif (-f ("@p/$p")) { - return "@p/$p"; + if ( $p eq $global_target) { + $tmp_path = join ('/', @p); + my $path_f = 0; + for (@global_found) { + $path_f = 1 if $_ eq $tmp_path; + } + push (@global_found, $tmp_path) unless $path_f; + print STDERR "Found as @p but directory\n" if $opt_v; + } + } elsif (-f _ && -r _) { + return $try; + } elsif (-f _) { + warn "Ignored $try: unreadable\n"; } else { my $found=0; my $lcp = lc $p; @@ -161,49 +189,64 @@ sub minus_f_nocase { closedir DIR; return "" unless $found; push @p, $cip; - return "@p" if -f "@p"; + return "@p" if -f "@p" and -r _; + warn "Ignored $file: unreadable\n" if -f _; } } return; # is not a file - } +} - sub searchfor { - my($recurse,$s,@dirs) = @_; - $s =~ s!::!/!g; - $s = VMS::Filespec::unixify($s) if $Is_VMS; - return $s if -f $s && containspod($s); - printf STDERR "looking for $s in @dirs\n" if $opt_v; - my $ret; - my $i; - my $dir; - for ($i=0;$i<@dirs;$i++) { - $dir = $dirs[$i]; - ($dir = VMS::Filespec::unixpath($dir)) =~ s!/$!! if $Is_VMS; - if (( $ret = minus_f_nocase "$dir/$s.pod") - or ( $ret = minus_f_nocase "$dir/$s.pm" and containspod($ret)) - or ( $ret = minus_f_nocase "$dir/$s" and containspod($ret)) - or ( $Is_VMS and - $ret = minus_f_nocase "$dir/$s.com" and containspod($ret)) + +sub check_file { + my($file) = @_; + return minus_f_nocase($file) && containspod($file) ? $file : ""; +} + + +sub searchfor { + my($recurse,$s,@dirs) = @_; + $s =~ s!::!/!g; + $s = VMS::Filespec::unixify($s) if $Is_VMS; + return $s if -f $s && containspod($s); + printf STDERR "Looking for $s in @dirs\n" if $opt_v; + my $ret; + my $i; + my $dir; + $global_target = (split('/', $s))[-1]; + for ($i=0; $i<@dirs; $i++) { + $dir = $dirs[$i]; + ($dir = VMS::Filespec::unixpath($dir)) =~ s!/$!! if $Is_VMS; + if ( ( $ret = check_file "$dir/$s.pod") + or ( $ret = check_file "$dir/$s.pm") + or ( $ret = check_file "$dir/$s") + or ( $Is_VMS and + $ret = check_file "$dir/$s.com") or ( $^O eq 'os2' and - $ret = minus_f_nocase "$dir/$s.cmd" and containspod($ret)) + $ret = check_file "$dir/$s.cmd") or ( ($Is_MSWin32 or $^O eq 'os2') and - $ret = minus_f_nocase "$dir/$s.bat" and containspod($ret)) - or ( $ret = minus_f_nocase "$dir/pod/$s.pod") - or ( $ret = minus_f_nocase "$dir/pod/$s" and containspod($ret))) - { return $ret; } - - if($recurse) { - opendir(D,$dir); - my(@newdirs) = grep(-d,map("$dir/$_",grep(!/^\.\.?$/,readdir(D)))); - closedir(D); - @newdirs = map((s/.dir$//,$_)[1],@newdirs) if $Is_VMS; - next unless @newdirs; - print STDERR "Also looking in @newdirs\n" if $opt_v; - push(@dirs,@newdirs); - } - } - return (); - } + $ret = check_file "$dir/$s.bat") + or ( $ret = check_file "$dir/pod/$s.pod") + or ( $ret = check_file "$dir/pod/$s") + ) { + return $ret; + } + + if ($recurse) { + opendir(D,$dir); + my @newdirs = map "$dir/$_", grep { + not /^\.\.?$/ and + not /^auto$/ and # save time! don't search auto dirs + -d "$dir/$_" + } readdir D; + closedir(D); + next unless @newdirs; + @newdirs = map((s/.dir$//,$_)[1],@newdirs) if $Is_VMS; + print STDERR "Also looking in @newdirs\n" if $opt_v; + push(@dirs,@newdirs); + } + } + return (); +} foreach (@pages) { @@ -230,12 +273,24 @@ foreach (@pages) { @searchdirs = grep(!/^\.$/,@INC); - @files= searchfor(1,$_,@searchdirs); if( @files ) { print STDERR "Loosely found as @files\n" if $opt_v; } else { - print STDERR "No documentation found for '$_'\n"; + print STDERR "No documentation found for \"$_\".\n"; + if (@global_found) { + print STDERR "However, try\n"; + my $dir = $file = ""; + for $dir (@global_found) { + opendir(DIR, $dir) or die "$!"; + while ($file = readdir(DIR)) { + next if ($file =~ /^\./); + $file =~ s/\.(pm|pod)$//; + print STDERR "\tperldoc $_\::$file\n"; + } + closedir DIR; + } + } } } push(@found,@files); @@ -290,13 +345,16 @@ if ($opt_f) { # Look for our function my $found = 0; + my @pod; while (<PFUNC>) { if (/^=item\s+\Q$opt_f\E\b/o) { - $found++; + $found = 1; } elsif (/^=item/) { - last if $found; + last if $found > 1; } - push(@pod, $_) if $found; + next unless $found; + push @pod, $_; + ++$found if /^\w/; # found descriptive text } if (@pod) { if ($opt_t) { |