sdbm can fail if a config.h exists in system directories

[perl5.git] / utils / perldoc.PL

diff --git a/utils/perldoc.PL b/utils/perldoc.PL
index b6f8bf9..129d985 100644 (file)
--- a/utils/perldoc.PL
+++ b/utils/perldoc.PL
@@ -57,23 +57,24 @@ EOF
 
 use Getopt::Std;
 $Is_VMS = $^O eq 'VMS';
+$Is_MSWin32 = $^O eq 'MSWin32';
 
 sub usage{
-        warn "@_\n" if @_;
-    # Make sure exit status is success under VMS, so shell doesn't
-    # display error messages left over from startup.
-    ($! = 0, $^E = 1) if $^O eq 'VMS';
+    warn "@_\n" if @_;
+    # Erase evidence of previous errors (if any), so exit status is simple.
+    $! = 0;
     die <<EOF;
 perldoc [options] PageName|ModuleName|ProgramName...
 perldoc [options] -f BuiltinFunction
 
 Options:
-    -h   Display this help message.
-    -t   Display pod using pod2text instead of pod2man and nroff.
+    -h   Display this help message
+    -t   Display pod using pod2text instead of pod2man and nroff
+             (-t is the default on win32)
     -u  Display unformatted pod text
     -m   Display modules file in its entirety
     -l   Display the modules file name
-    -v  Verbosely describe what's going on.
+    -v  Verbosely describe what's going on
 
 PageName|ModuleName...
          is the name of a piece of documentation that you want to look at. You 
@@ -101,7 +102,11 @@ getopts("mhtluvf:") || usage;
 
 usage if $opt_h || $opt_h; # avoid -w warning
 
-usage("only one of -t, -u, -m or -l") if $opt_t + $opt_u + $opt_m + $opt_l > 1;
+if ($opt_t + $opt_u + $opt_m + $opt_l > 1) {
+    usage("only one of -t, -u, -m or -l")
+} elsif ($Is_MSWin32) {
+    $opt_t = 1 unless $opt_t + $opt_u + $opt_m + $opt_l;
+}
 
 if ($opt_t) { require Pod::Text; import Pod::Text; }
 
@@ -133,7 +138,7 @@ sub containspod {
      local($")="/";
      my(@p,$p,$cip);
      foreach $p (split(/\//, $file)){
-       if (($Is_VMS or $^O eq 'os2') and not scalar @p) {
+       if (($Is_VMS or $Is_MSWin32 or $^O eq 'os2') and not scalar @p) {
            # VMSish filesystems don't begin at '/'
            push(@p,$p);
            next;
@@ -177,8 +182,10 @@ sub containspod {
            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 
+               or ( $Is_VMS and 
                     $ret = minus_f_nocase "$dir/$s.com" and containspod($ret))
+               or ( $Is_MSWin32 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; }
@@ -208,6 +215,8 @@ foreach (@pages) {
                for ($i = 0; $trn = $ENV{'DCL$PATH'.$i}; $i++) {
                    push(@searchdirs,$trn);
                }
+           } elsif ($Is_MSWin32) {
+               push(@searchdirs, grep(-d, split(';', $ENV{'PATH'})));
            } else {
                    push(@searchdirs, grep(-d, split(':', $ENV{'PATH'})));
            }
@@ -242,22 +251,26 @@ if ($opt_l) {
 
 if( ! -t STDOUT ) { $no_tty = 1 }
 
-unless($Is_VMS) {
-       $tmp = "/tmp/perldoc1.$$";
-       push @pagers, qw( more less pg view cat );
+if ($Is_MSWin32) {
+       $tmp = "$ENV{TEMP}\\perldoc1.$$";
+       push @pagers, qw( more< less notepad );
        unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
-} else {
+} elsif ($Is_VMS) {
        $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
        push @pagers, qw( most more less type/page );
+} else {
+       $tmp = "/tmp/perldoc1.$$";
+       push @pagers, qw( more less pg view cat );
+       unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
 }
 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
 
 if ($opt_m) {
-    foreach $pager (@pagers) {
-       my($sts) = system("$pager @found");
-       exit 0 if ($Is_VMS ? ($sts & 1) : !$sts);
-    }
-    exit $Is_VMS ? $sts : 1;
+       foreach $pager (@pagers) {
+               system("$pager @found") or exit;
+       }
+       if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' }
+       exit 1;
 } 
 
 if ($opt_f) {
@@ -290,7 +303,7 @@ if ($opt_f) {
           print @pod;
        }
    } else {
-       die "No documentation for perl function `$func' found\n";
+       die "No documentation for perl function `$opt_f' found\n";
    }
    exit;
 }
@@ -302,16 +315,14 @@ foreach (@found) {
                Pod::Text::pod2text($_,*TMP);
                close(TMP);
        } elsif(not $opt_u) {
-               open(TMP,">>$tmp");
-               if($^O =~ /hpux/) {
-                       $rslt = `pod2man $_ | nroff -man | col -x`;
-               } else {
-                       $rslt = `pod2man $_ | nroff -man`;
+               my $cmd = "pod2man --lax $_ | nroff -man";
+               $cmd .= " | col -x" if $^O =~ /hpux/;
+               $rslt = `$cmd`;
+               unless(($err = $?)) {
+                       open(TMP,">>$tmp");
+                       print TMP $rslt;
+                       close TMP;
                }
-               if ($Is_VMS) { $err = !($? % 2) || $rslt =~ /IVVERB/; }
-               else      { $err = $?; }
-               print TMP $rslt unless $err;
-               close TMP;
        }
                                                        
        if( $opt_u or $err or -z $tmp) {
@@ -334,9 +345,7 @@ if( $no_tty ) {
        close(TMP);
 } else {
        foreach $pager (@pagers) {
-               $sts = system("$pager $tmp");
-               last if $Is_VMS && ($sts & 1);
-               last unless $sts;
+               system("$pager $tmp") or last;
        }
 }
 
@@ -433,6 +442,9 @@ Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>
 =cut
 
 #
+# Version 1.12: Sat Apr 12 22:41:09 EST 1997
+#       Gurusamy Sarathy <gsar@umich.edu>
+#      -various fixes for win32
 # Version 1.11: Tue Dec 26 09:54:33 EST 1995
 #       Kenneth Albanowski <kjahds@kjahds.com>
 #   -added Charles Bailey's further VMS patches, and -u switch