provide File::Copy::syscopy() via Win32::CopyFile() on win32

[perl5.git] / lib / diagnostics.pm

diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm
old mode 100644 (file)
new mode 100755 (executable)
index 3492bd3..1f3f30c
--- a/lib/diagnostics.pm
+++ b/lib/diagnostics.pm
@@ -27,7 +27,7 @@ Aa a program:
 =head2 The C<diagnostics> Pragma
 
 This module extends the terse diagnostics normally emitted by both the
-perl compiler and the perl interpeter, augmenting them with the more
+perl compiler and the perl interpreter, augmenting them with the more
 explicative and endearing descriptions found in L<perldiag>.  Like the
 other pragmata, it affects the compilation phase of your program rather
 than merely the execution phase.
@@ -145,7 +145,7 @@ Not being able to say "no diagnostics" is annoying, but may not be
 insurmountable.
 
 The C<-pretty> directive is called too late to affect matters.
-You have to to this instead, and I<before> you load the module.
+You have to do this instead, and I<before> you load the module.
 
     BEGIN { $diagnostics::PRETTY = 1 } 
 
@@ -158,26 +158,31 @@ a program named I<splain>, you should expect a bit of whimsy.
 
 =head1 AUTHOR
 
-Tom Christiansen F<E<lt>tchrist@mox.perl.comE<gt>>, 25 June 1995.
+Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
 
 =cut
 
 require 5.001;
-use English;
 use Carp;
 
 use Config;
+($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
 if ($^O eq 'VMS') {
-    $PODFILE = VMS::Filespec::unixify($Config{privlibexp}).'/pod/perldiag.pod';
-}
-else {
-    $PODFILE = $Config{privlibexp} . "/pod/perldiag.pod";
+    require VMS::Filespec;
+    $privlib = VMS::Filespec::unixify($privlib);
+    $archlib = VMS::Filespec::unixify($archlib);
 }
+@trypod = ("$archlib/pod/perldiag.pod",
+          "$privlib/pod/perldiag-$].pod",
+          "$privlib/pod/perldiag.pod");
+# handy for development testing of new warnings etc
+unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
+($PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
 
 $DEBUG ||= 0;
 my $WHOAMI = ref bless [];  # nobody's business, prolly not even mine
 
-$OUTPUT_AUTOFLUSH = 1;
+$| = 1;
 
 local $_;
 
@@ -189,7 +194,8 @@ CONFIG: {
     unless (caller) { 
        $standalone++;
        require Getopt::Std;
-       Getopt::Std::getopts('pdvf:') || die "Usage: $0 [-v] [-p] [-f splainpod]";
+       Getopt::Std::getopts('pdvf:')
+           or die "Usage: $0 [-v] [-p] [-f splainpod]";
        $PODFILE = $opt_f if $opt_f;
        $DEBUG = 2 if $opt_d;
        $VERBOSE = $opt_v;
@@ -268,7 +274,7 @@ if (eof(POD_DIAG)) {
 
 $transmo = <<EOFUNC;
 sub transmo {
-    local \$^W = 0;  # recursive warnings we do NOT need!
+    #local \$^W = 0;  # recursive warnings we do NOT need!
     study;
 EOFUNC
 
@@ -313,7 +319,9 @@ EOFUNC
            }
            next;
        }
-       $header = $1;
+
+       # strip formatting directives in =item line
+       ($header = $1) =~ s/[A-Z]<(.*?)>/$1/g;
 
        if ($header =~ /%[sd]/) {
            $rhs = $lhs = $header;
@@ -326,8 +334,9 @@ EOFUNC
                #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/;
                $lhs =~ s/\377([^\377]*)$/\Q$1\E/;
                $lhs =~ s/\377//g;
+               $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all
            } 
-           $transmo .= "    s{^$lhs}\n     {\Q$rhs\E}\n\t&& return 1;\n";
+           $transmo .= "    s{^$lhs}\n     {\Q$rhs\E}s\n\t&& return 1;\n";
        } else {
            $transmo .= "    m{^\Q$header\E} && return 1;\n";
        } 
@@ -352,7 +361,7 @@ EOFUNC
 
 if ($standalone) {
     if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } 
-    while ($error = <>) {
+    while (defined ($error = <>)) {
        splainthis($error) || print THITHER $error;
     } 
     exit;
@@ -362,7 +371,7 @@ if ($standalone) {
 
 sub import {
     shift;
-    $old_w = $^W;
+    #$old_w = $^W;
     $^W = 1; # yup, clobbered the global variable; tough, if you
             # want diags, you want diags.
     return if $SIG{__WARN__} eq \&warn_trap;
@@ -398,7 +407,7 @@ sub enable { &import }
 
 sub disable {
     shift;
-    $^W = $old_w;
+    #$^W = $old_w;
     return unless $SIG{__WARN__} eq \&warn_trap;
     $SIG{__WARN__} = $oldwarn;
     $SIG{__DIE__} = $olddie;
@@ -444,6 +453,7 @@ sub death_trap {
 
 sub splainthis {
     local $_ = shift;
+    local $\;
     ### &finish_compilation unless %msg;
     s/\.?\n+$//;
     my $orig = $_;
@@ -497,7 +507,7 @@ sub unescape {
              exists $HTML_Escapes{$1}
                 ? do { $HTML_Escapes{$1} }
                 : do {
-                    warn "Unknown escape: $& in $_";
+                    warn "Unknown escape: E<$1> in $_";
                     "E<$1>";
                 } 
          } 
@@ -506,7 +516,7 @@ sub unescape {
 
 sub shorten {
     my $line = $_[0];
-    if (length $line > 79) {
+    if (length($line) > 79 and index($line, "\n") == -1) {
        my $space_place = rindex($line, ' ', 79);
        if ($space_place != -1) {
            substr($line, $space_place, 1) = "\n\t";
@@ -516,7 +526,7 @@ sub shorten {
 } 
 
 
-# have to do this: RS isn't set until run time, but we're executing at compile time
+# have to do this: RS isn't set until run time, but we're executing at compiletime
 $RS = "\n";
 
 1 unless $standalone;  # or it'll complain about itself