Suresh Govindachar wrote:
> =head
>
> Hello,
>
> I have been trying to not die when calling perldoc,
> but the code below keeps dying inside perldoc.
>
> The code below does show that eval is happening
> at runtime, and that the syntax used for shutting
> off __DIE__ does work when perldoc is not involved.
>
> So how can one avoid dying inside perldoc?
I played with the orig script a bit - try this one:
#!perl --
use strict;
use warnings;
use Pod::Perldoc;
$| = 1; binmode STDOUT; select ((select (STDERR), $| = 1)[0]); binmode STDERR;
our %A; # get commandline switches into %A
for (my $ii = 0; $ii < @ARGV; ) {
last if $ARGV[$ii] =~ /^--$/;
if ($ARGV[$ii] !~ /^-{1,2}(.*)$/) { $ii++; next; }
my $arg = $1; splice @ARGV, $ii, 1;
if ($arg =~ /^([\w]+)=(.*)$/) { exists ($A{$1}) ? ($A{$1} .= "|$2") :
($A{$1} = $2); } else { $A{$1}++; }
}
my $all = $A{a} || 0;
my $debug = $A{d} || 0;
my $functions = $A{f} || 0;
my $questions = $A{q} || 0;
my $shell = $A{s} || 0;
(my $prog = $0) =~ s/^.*[\\\/]//;
my $usage = <<EOD;
Usage: $prog [-d] [-a] [-f] [-q] [-s] [<args>]
-d debug (-d=2 for perldoc debug)
-a if present perform the following logic, else call perldoc
with <arglist> and return result of first successful :
"perldoc -f <args>" (args=builtin function names)
"perldoc -q <args>" (args=FAQ question words)
"perldoc <args>" (args=PageName | ModuleName |
ProgramName ...)
or return failure message
-f Do a "perldoc <options> -f arg" (search functions)
-q Do a "perldoc <options> -q arg" (search FAQ questions)
-s Shell out to perldoc.bat instead of using Pod::Perldoc->run()
<args> Normal perldoc args (see -a)
EOD
die $usage if $A{h} or $A{help};
$ENV{'PERLDOCDEBUG'} = 3 if $debug > 1; # -d=2
open my $oldout, ">&STDOUT" or die "Can't dup STDOUT: $!";
open my $olderr, ">&STDERR" or die "Can't dup STDERR: $!";
my $out = '';
my $err = '';
close STDOUT; # you have to close stdout/err first
close STDERR; # you have to close stdout/err first
open STDOUT, '>', \$out;
open STDERR, '>', \$err;
my %types = ('-f' => 'Function', '-q' => 'Question', '' => 'Page/Mod/Prog');
my @types;
my $tmp = '';
print "\n";
if ($functions) {
@types = ('-f');
} elsif ($questions) {
@types = ('-q');
} else {
@types = ('');
}
@types = ('-f', '-q', '') if $all;
# do "perldoc -f <args>" and "perldoc -q <args>" and "perldoc <args>"
for my $type (@types) {
if ($shell) {
print $olderr "-a perldoc.bat $type @ARGV\n" if $debug;
$tmp = `perldoc.bat $type @ARGV`;
print $olderr "'$type':tmp=$tmp\n" if $debug;
if (defined $tmp and $tmp !~ /^no doc/i) {
print $oldout "\nDoing $types{$type} @ARGV:\n\n";
print $oldout "$tmp\n";
}
} else {
print $olderr "-a perlrun $type @ARGV\n" if $debug;
our @argv = @ARGV;
@ARGV = ($type, @argv) if $type ne '';
print $olderr "ARGV='@ARGV'\n" if $debug;
eval "Pod::Perldoc->run();";
$tmp = $out . $err;
print $olderr "'$type':tmp=$tmp\n" if $debug;
print $oldout "\nDoing $types{$type} '@argv':\n";
print $oldout "\n" if not /-[f]/;
print $oldout "$tmp\n";
@ARGV = @argv;
}
open STDOUT, '>', \$out; open STDERR, '>', \$err;
$tmp = ''; $err = ''; $out = '';
}
exit;
__END__
#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
_______________________________________________
Perl-Win32-Users mailing list
[email protected]
To unsubscribe: http://listserv.ActiveState.com/mailman/mysubs
