diff options
Diffstat (limited to 'utils')
| -rw-r--r-- | utils/Makefile | 13 | ||||
| -rw-r--r-- | utils/dprofpp.PL | 839 | ||||
| -rw-r--r-- | utils/h2ph.PL | 104 | ||||
| -rw-r--r-- | utils/h2xs.PL | 163 | ||||
| -rw-r--r-- | utils/perlbc.PL | 80 | ||||
| -rw-r--r-- | utils/perlbug.PL | 111 | ||||
| -rw-r--r-- | utils/perlcc.PL | 381 | ||||
| -rw-r--r-- | utils/perldoc.PL | 541 |
8 files changed, 1765 insertions, 467 deletions
diff --git a/utils/Makefile b/utils/Makefile index 2df16d8060..944cbe8711 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -5,14 +5,14 @@ REALPERL = ../perl # Files to be built with variable substitution after miniperl is # available. Dependencies handled manually below (for now). -pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL splain.PL perlcc.PL -plextract = c2ph h2ph h2xs perlbug perldoc pl2pm splain perlcc -plextractexe = c2ph.exe h2ph.exe h2xs.exe perlbug.exe perldoc.exe pl2pm.exe splain.exe perlcc.exe +pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL splain.PL perlcc.PL dprofpp.PL +plextract = c2ph h2ph h2xs perlbug perldoc pl2pm splain perlcc dprofpp +plextractexe = c2ph.exe h2ph.exe h2xs.exe perlbug.exe perldoc.exe pl2pm.exe splain.exe perlcc.exe dprofpp.exe all: $(plextract) compile: all - $(REALPERL) -I../lib perlcc -regex 's/$$/.exe/' $(plextract) -prog -verbose dcf -log ../compilelog; + $(REALPERL) -I../lib perlcc -opt -regex 's/$$/.exe/' $(plextract) -prog -verbose dcf -log ../compilelog; $(plextract): $(PERL) -I../lib $@.PL @@ -31,12 +31,15 @@ pl2pm: pl2pm.PL ../config.sh splain: splain.PL ../config.sh ../lib/diagnostics.pm -perlcc: perlcc.PL ../config.sh +perlcc: perlcc.PL ../config.sh + +dprofpp: dprofpp.PL ../config.sh clean: realclean: rm -rf $(plextract) pstruct $(plextractexe) + rm -f ../t/_h2ph_pre.ph clobber: realclean diff --git a/utils/dprofpp.PL b/utils/dprofpp.PL new file mode 100644 index 0000000000..ba099c0279 --- /dev/null +++ b/utils/dprofpp.PL @@ -0,0 +1,839 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($Config{'osname'} eq 'VMS' or + $Config{'osname'} eq 'OS2'); # "case-forgiving" + +my $dprof_pm = '../ext/Devel/DProf/DProf.pm'; +my $VERSION = 0; +open( PM, "<$dprof_pm" ) || die "Can't open $dprof_pm: $!"; +while(<PM>){ + if( /^\$Devel::DProf::VERSION\s*=\s*'(\d+)'/ ){ + $VERSION = $1; + last; + } +} +close PM; +if( $VERSION == 0 ){ + die "Did not find VERSION in $dprof_pm"; +} +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{'startperl'} + eval 'exec perl -S \$0 "\$@"' + if 0; + +require 5.003; + +my \$VERSION = $VERSION; + +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; +=head1 NAME + +dprofpp - display perl profile data + +=head1 SYNOPSIS + +dprofpp [B<-a>|B<-z>|B<-l>|B<-v>|B<-U>] [B<-s>|B<-r>|B<-u>] [B<-q>] [B<-F>] [B<-I|-E>] [B<-O cnt>] [B<-A>] [B<-R>] [B<-S>] [B<-g subroutine>] [profile] + +dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile] + +dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile] + +dprofpp B<-p script> [B<-Q>] [other opts] + +dprofpp B<-V> [profile] + +=head1 DESCRIPTION + +The I<dprofpp> command interprets profile data produced by a profiler, such +as the Devel::DProf profiler. Dprofpp will read the file F<tmon.out> and +will display the 15 subroutines which are using the most time. By default +the times for each subroutine are given exclusive of the times of their +child subroutines. + +To profile a Perl script run the perl interpreter with the B<-d> switch. So +to profile script F<test.pl> with Devel::DProf the following command should +be used. + + $ perl5 -d:DProf test.pl + +Then run dprofpp to analyze the profile. The output of dprofpp depends +on the flags to the program and the version of Perl you're using. + + $ dprofpp -u + Total Elapsed Time = 1.67 Seconds + User Time = 0.61 Seconds + Exclusive Times + %Time Seconds #Calls sec/call Name + 52.4 0.320 2 0.1600 main::foo + 45.9 0.280 200 0.0014 main::bar + 0.00 0.000 1 0.0000 DynaLoader::import + 0.00 0.000 1 0.0000 main::baz + +The dprofpp tool can also run the profiler before analyzing the profile +data. The above two commands can be executed with one dprofpp command. + + $ dprofpp -u -p test.pl + +Consult L<Devel::DProf/"PROFILE FORMAT"> for a description of the raw profile. + +=head1 OUTPUT + +Columns are: + +=over 4 + +=item %Time + +Percentage of time spent in this routine. + +=item #Calls + +Number of calls to this routine. + +=item sec/call + +Average number of seconds per call to this routine. + +=item Name + +Name of routine. + +=item CumulS + +Time (in seconds) spent in this routine and routines called from it. + +=item ExclSec + +Time (in seconds) spent in this routine (not including those called +from it). + +=item Csec/c + +Average time (in seconds) spent in each call of this routine +(including those called from it). + +=back + +=head1 OPTIONS + +=over 5 + +=item B<-a> + +Sort alphabetically by subroutine names. + +=item B<-A> + +Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>. +Otherwise the time to autoload it is counted as time of the subroutine +itself (there is no way to separate autoload time from run time). + +This is going to be irrelevant with newer Perls. They will inform +C<Devel::DProf> I<when> the C<AUTOLOAD> switches to actual subroutine, +so a separate statistics for C<AUTOLOAD> will be collected no matter +whether this option is set. + +=item B<-R> + +Count anonymous subroutines defined in the same package separately. + +=item B<-E> + +(default) Display all subroutine times exclusive of child subroutine times. + +=item B<-F> + +Force the generation of fake exit timestamps if dprofpp reports that the +profile is garbled. This is only useful if dprofpp determines that the +profile is garbled due to missing exit timestamps. You're on your own if +you do this. Consult the BUGS section. + +=item B<-I> + +Display all subroutine times inclusive of child subroutine times. + +=item B<-l> + +Sort by number of calls to the subroutines. This may help identify +candidates for inlining. + +=item B<-O cnt> + +Show only I<cnt> subroutines. The default is 15. + +=item B<-p script> + +Tells dprofpp that it should profile the given script and then interpret its +profile data. See B<-Q>. + +=item B<-Q> + +Used with B<-p> to tell dprofpp to quit after profiling the script, without +interpreting the data. + +=item B<-q> + +Do not display column headers. + +=item B<-r> + +Display elapsed real times rather than user+system times. + +=item B<-s> + +Display system times rather than user+system times. + +=item B<-T> + +Display subroutine call tree to stdout. Subroutine statistics are +not displayed. + +=item B<-t> + +Display subroutine call tree to stdout. Subroutine statistics are not +displayed. When a function is called multiple consecutive times at the same +calling level then it is displayed once with a repeat count. + +=item B<-S> + +Display I<merged> subroutine call tree to stdout. Statistics is +displayed for each branch of the tree. + +When a function is called multiple (I<not necessarily consecutive>) +times in the same branch then all these calls go into one branch of +the next level. A repeat count is output together with combined +inclusive, exclusive and kids time. + +Branches are sorted w.r.t. inclusive time. + +=item B<-U> + +Do not sort. Display in the order found in the raw profile. + +=item B<-u> + +Display user times rather than user+system times. + +=item B<-V> + +Print dprofpp's version number and exit. If a raw profile is found then its +XS_VERSION variable will be displayed, too. + +=item B<-v> + +Sort by average time spent in subroutines during each call. This may help +identify candidates for inlining. + +=item B<-z> + +(default) Sort by amount of user+system time used. The first few lines +should show you which subroutines are using the most time. + +=item B<-g> C<subroutine> + +Ignore subroutines except C<subroutine> and whatever is called from it. + +=back + +=head1 ENVIRONMENT + +The environment variable B<DPROFPP_OPTS> can be set to a string containing +options for dprofpp. You might use this if you prefer B<-I> over B<-E> or +if you want B<-F> on all the time. + +This was added fairly lazily, so there are some undesirable side effects. +Options on the commandline should override options in DPROFPP_OPTS--but +don't count on that in this version. + +=head1 BUGS + +Applications which call _exit() or exec() from within a subroutine +will leave an incomplete profile. See the B<-F> option. + +Any bugs in Devel::DProf, or any profiler generating the profile data, could +be visible here. See L<Devel::DProf/BUGS>. + +Mail bug reports and feature requests to the perl5-porters mailing list at +F<E<lt>perl5-porters@perl.orgE<gt>>. Bug reports should include the +output of the B<-V> option. + +=head1 FILES + + dprofpp - profile processor + tmon.out - raw profile + +=head1 SEE ALSO + +L<perl>, L<Devel::DProf>, times(2) + +=cut + +use Getopt::Std 'getopts'; +use Config '%Config'; + +Setup: { + my $options = 'O:g:lzaAvuTtqrRsUFEIp:QVS'; + + $Monfile = 'tmon.out'; + if( exists $ENV{DPROFPP_OPTS} ){ + my @tmpargv = @ARGV; + @ARGV = split( ' ', $ENV{DPROFPP_OPTS} ); + getopts( $options ); + if( @ARGV ){ + # there was a filename. + $Monfile = shift; + } + @ARGV = @tmpargv; + } + + getopts( $options ); + if( @ARGV ){ + # there was a filename, it overrides any earlier name. + $Monfile = shift; + } + +# -O cnt Specifies maximum number of subroutines to display. +# -a Sort by alphabetic name of subroutines. +# -z Sort by user+system time spent in subroutines. (default) +# -l Sort by number of calls to subroutines. +# -v Sort by average amount of time spent in subroutines. +# -T Show call tree. +# -t Show call tree, compressed. +# -q Do not print column headers. +# -u Use user time rather than user+system time. +# -s Use system time rather than user+system time. +# -r Use real elapsed time rather than user+system time. +# -U Do not sort subroutines. +# -E Sub times are reported exclusive of child times. (default) +# -I Sub times are reported inclusive of child times. +# -V Print dprofpp's version. +# -p script Specifies name of script to be profiled. +# -Q Used with -p to indicate the dprofpp should quit after +# profiling the script, without interpreting the data. +# -A count autoloaded to *AUTOLOAD +# -R count anonyms separately even if from the same package +# -g subr count only those who are SUBR or called from SUBR +# -S Create statistics for all the depths + + if( defined $opt_V ){ + my $fh = 'main::fh'; + print "$0 version: $VERSION\n"; + open( $fh, "<$Monfile" ) && do { + local $XS_VERSION = 'early'; + header($fh); + close( $fh ); + print "XS_VERSION: $XS_VERSION\n"; + }; + exit(0); + } + $cnt = $opt_O || 15; + $sort = 'by_time'; + $sort = 'by_ctime' if defined $opt_I; + $sort = 'by_calls' if defined $opt_l; + $sort = 'by_alpha' if defined $opt_a; + $sort = 'by_avgcpu' if defined $opt_v; + $incl_excl = 'Exclusive'; + $incl_excl = 'Inclusive' if defined $opt_I; + $whichtime = 'User+System'; + $whichtime = 'System' if defined $opt_s; + $whichtime = 'Real' if defined $opt_r; + $whichtime = 'User' if defined $opt_u; + + if( defined $opt_p ){ + my $prof = 'DProf'; + my $startperl = $Config{'startperl'}; + + $startperl =~ s/^#!//; # remove shebang + run_profiler( $opt_p, $prof, $startperl ); + $Monfile = 'tmon.out'; # because that's where it is + exit(0) if defined $opt_Q; + } + elsif( defined $opt_Q ){ + die "-Q is meaningful only when used with -p\n"; + } +} + +Main: { + my $monout = $Monfile; + my $fh = 'main::fh'; + local $names = {}; + local $times = {}; # times in hz + local $ctimes = {}; # Cumulative times in hz + local $calls = {}; + local $persecs = {}; # times in seconds + local $idkeys = []; + local $runtime; # runtime in seconds + my @a = (); + my $a; + local $rrun_utime = 0; # user time in hz + local $rrun_stime = 0; # system time in hz + local $rrun_rtime = 0; # elapsed run time in hz + local $rrun_ustime = 0; # user+system time in hz + local $hz = 0; + local $deep_times = {count => 0 , kids => {}, incl_time => 0}; + local $time_precision = 2; + local $overhead = 0; + + open( $fh, "<$monout" ) || die "Unable to open $monout\n"; + + header($fh); + + $rrun_ustime = $rrun_utime + $rrun_stime; + + $~ = 'STAT'; + if( ! $opt_q ){ + $^ = 'CSTAT_top'; + } + + parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys ); + + settime( \$runtime, $hz ) unless $opt_g; + + exit(0) if $opt_T || $opt_t; + + if( $opt_v ){ + percalc( $calls, ($opt_I ? $ctimes : $times), $persecs, $idkeys ); + } + if( ! $opt_U ){ + @a = sort $sort @$idkeys; + $a = \@a; + } + else { + $a = $idkeys; + } + display( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, $a, + $deep_times); +} + + +# Sets $runtime to user, system, real, or user+system time. The +# result is given in seconds. +# +sub settime { + my( $runtime, $hz ) = @_; + + $hz ||= 1; + + if( $opt_r ){ + $$runtime = ($rrun_rtime - $overhead - $over_rtime * $total_marks/$over_tests/2)/$hz; + } + elsif( $opt_s ){ + $$runtime = ($rrun_stime - $overhead - $over_stime * $total_marks/$over_tests/2)/$hz; + } + elsif( $opt_u ){ + $$runtime = ($rrun_utime - $overhead - $over_utime * $total_marks/$over_tests/2)/$hz; + } + else{ + $$runtime = ($rrun_ustime - $overhead - ($over_utime + $over_stime) * $total_marks/$over_tests/2)/$hz; + } + $$runtime = 0 unless $$runtime > 0; +} + +sub exclusives_in_tree { + my( $deep_times ) = @_; + my $kids_time = 0; + my $kid; + # When summing, take into account non-rounded-up kids time. + for $kid (keys %{$deep_times->{kids}}) { + $kids_time += $deep_times->{kids}{$kid}{incl_time}; + } + $kids_time = 0 unless $kids_time >= 0; + $deep_times->{excl_time} = $deep_times->{incl_time} - $kids_time; + $deep_times->{excl_time} = 0 unless $deep_times->{excl_time} >= 0; + for $kid (keys %{$deep_times->{kids}}) { + exclusives_in_tree($deep_times->{kids}{$kid}); + } + $deep_times->{incl_time} = 0 unless $deep_times->{incl_time} >= 0; + $deep_times->{kids_time} = $kids_time; +} + +sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time} + or $a cmp $b } + +sub display_tree { + my( $deep_times, $name, $level ) = @_; + exclusives_in_tree($deep_times); + + my $kid; + local *kids = $deep_times->{kids}; # %kids + + my $time; + if (%kids) { + $time = sprintf '%.*fs = (%.*f + %.*f)', + $time_precision, $deep_times->{incl_time}/$hz, + $time_precision, $deep_times->{excl_time}/$hz, + $time_precision, $deep_times->{kids_time}/$hz; + } else { + $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz; + } + print ' ' x (2*$level), "$name x $deep_times->{count} \t${time}s\n" + if $deep_times->{count}; + + for $kid (sort kids_by_incl keys %kids) { + display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 ); + } +} + +# Report the times in seconds. +sub display { + my( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, + $idkeys, $deep_times ) = @_; + my( $x, $key, $s, $cs ); + #format: $ncalls, $name, $secs, $percall, $pcnt + + if ($opt_S) { + display_tree( $deep_times, 'toplevel', -1 ) + } else { + for( $x = 0; $x < @$idkeys; ++$x ){ + $key = $idkeys->[$x]; + $ncalls = $calls->{$key}; + $name = $names->{$key}; + $s = $times->{$key}/$hz; + $secs = sprintf("%.3f", $s ); + $cs = $ctimes->{$key}/$hz; + $csecs = sprintf("%.3f", $cs ); + $percall = sprintf("%.4f", $s/$ncalls ); + $cpercall = sprintf("%.4f", $cs/$ncalls ); + $pcnt = sprintf("%.2f", + $runtime? ((($opt_I ? $csecs : $secs) / $runtime) * 100.0): 0 ); + write; + $pcnt = $secs = $ncalls = $percall = ""; + write while( length $name ); + last unless --$cnt; + } + } +} + +sub move_keys { + my ($source, $dest) = @_; + my $kid; + + for $kid (keys %$source) { + if (exists $dest->{$kid}) { + $dest->{count} += $source->{count}; + $dest->{incl_time} += $source->{incl_time}; + move_keys($source->{kids},$dest->{kids}); + } else { + $dest->{$kid} = delete $source->{$kid}; + } + } +} + +sub add_to_tree { + my ($curdeep_times, $name, $t) = @_; + if ($name ne $curdeep_times->[-1]{name} and $opt_A) { + $name = $curdeep_times->[-1]{name}; + } + die "Shorted?!" unless @$curdeep_times >= 2; + $curdeep_times->[-2]{kids}{$name} = { count => 0 , kids => {}, + incl_time => 0, + } + unless exists $curdeep_times->[-2]{kids}{$name}; + my $entry = $curdeep_times->[-2]{kids}{$name}; + # Now transfer to the new node (could not do earlier, since name can change) + $entry->{count}++; + $entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp}; + # Merge the kids? + move_keys($curdeep_times->[-1]->{kids},$entry->{kids}); + pop @$curdeep_times; +} + +sub parsestack { + my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_; + my( $dir, $name ); + my( $t, $syst, $realt, $usert ); + my( $x, $z, $c, $id, $pack ); + my @stack = (); + my @tstack = (); + my $tab = 3; + my $in = 0; + + # remember last call depth and function name + my $l_in = $in; + my $l_name = ''; + my $repcnt = 0; + my $repstr = ''; + my $dprof_t = 0; + my $dprof_stamp; + my %cv_hash; + my $in_level = not defined $opt_g; # Level deep in report grouping + my $curdeep_times = [$deep_times]; + + my $over_per_call; + if ( $opt_u ) { $over_per_call = $over_utime } + elsif( $opt_s ) { $over_per_call = $over_stime } + elsif( $opt_r ) { $over_per_call = $over_rtime } + else { $over_per_call = $over_utime + $over_stime } + $over_per_call /= 2*$over_tests; # distribute over entry and exit + + while(<$fh>){ + next if /^#/; + last if /^PART/; + + chop; + if (/^&/) { + ($dir, $id, $pack, $name) = split; + if ($opt_R and ($name =~ /::(__ANON_|END)$/)) { + $name .= "($id)"; + } + $cv_hash{$id} = "$pack\::$name"; + next; + } + ($dir, $usert, $syst, $realt, $name) = split; + + my $ot = $t; + if ( $dir eq '/' ) { + $syst = $stack[-1][0]; + $usert = '&'; + $dir = '-'; + #warn("Inserted exit for $stack[-1][0].\n") + } + if (defined $realt) { # '+ times nam' '- times nam' or '@ incr' + if ( $opt_u ) { $t = $usert } + elsif( $opt_s ) { $t = $syst } + elsif( $opt_r ) { $t = $realt } + else { $t = $usert + $syst } + $t += $ot, next if $dir eq '@'; # Increments there + } else { + # "- id" or "- & name" + $name = defined $syst ? $syst : $cv_hash{$usert}; + } + + next unless $in_level or $name eq $opt_g or $dir eq '*'; + if ( $dir eq '-' or $dir eq '*' ) { + my $ename = $dir eq '*' ? $stack[-1][0] : $name; + $overhead += $over_per_call; + if ($name eq "Devel::DProf::write") { + $dprof_t += $t - $dprof_stamp; + next; + } elsif (defined $opt_g and $ename eq $opt_g) { + $in_level--; + } + add_to_tree($curdeep_times, $ename, + $t - $dprof_t - $overhead) if $opt_S; + exitstamp( \@stack, \@tstack, + $t - $dprof_t - $overhead, + $times, $ctimes, $ename, \$in, $tab, + $curdeep_times ); + } + next unless $in_level or $name eq $opt_g; + if( $dir eq '+' or $dir eq '*' ){ + if ($name eq "Devel::DProf::write") { + $dprof_stamp = $t; + next; + } elsif (defined $opt_g and $name eq $opt_g) { + $in_level++; + } + $overhead += $over_per_call; + if( $opt_T ){ + print ' ' x $in, "$name\n"; + $in += $tab; + } + elsif( $opt_t ){ + # suppress output on same function if the + # same calling level is called. + if ($l_in == $in and $l_name eq $name) { + $repcnt++; + } else { + $repstr = ' ('.++$repcnt.'x)' + if $repcnt; + print ' ' x $l_in, "$l_name$repstr\n" + if $l_name ne ''; + $repstr = ''; + $repcnt = 0; + $l_in = $in; + $l_name = $name; + } + $in += $tab; + } + if( ! defined $names->{$name} ){ + $names->{$name} = $name; + $times->{$name} = 0; + $ctimes->{$name} = 0; + push( @$idkeys, $name ); + } + $calls->{$name}++; + push @$curdeep_times, { kids => {}, + name => $name, + enter_stamp => $t - $dprof_t - $overhead, + } if $opt_S; + $x = [ $name, $t - $dprof_t - $overhead ]; + push( @stack, $x ); + + # my children will put their time here + push( @tstack, 0 ); + } elsif ($dir ne '-'){ + die "Bad profile: $_"; + } + } + if( $opt_t ){ + $repstr = ' ('.++$repcnt.'x)' if $repcnt; + print ' ' x $l_in, "$l_name$repstr\n"; + } + + if( @stack ){ + if( ! $opt_F ){ + warn "Garbled profile is missing some exit time stamps:\n"; + foreach $x (@stack) { + print $x->[0],"\n"; + } + die "Try rerunning dprofpp with -F.\n"; + # I don't want -F to be default behavior--yet + # 9/18/95 dmr + } + else{ + warn( "Faking " . scalar( @stack ) . " exit timestamp(s).\n"); + foreach $x ( reverse @stack ){ + $name = $x->[0]; + exitstamp( \@stack, \@tstack, + $t - $dprof_t - $overhead, $times, + $ctimes, $name, \$in, $tab, + $curdeep_times ); + add_to_tree($curdeep_times, $name, + $t - $dprof_t - $overhead) + if $opt_S; + } + } + } + if (defined $opt_g) { + $runtime = $ctimes->{$opt_g}/$hz; + $runtime = 0 unless $runtime > 0; + } +} + +sub exitstamp { + my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep) = @_; + my( $x, $c, $z ); + + $x = pop( @$stack ); + if( ! defined $x ){ + die "Garbled profile, missing an enter time stamp"; + } + if( $x->[0] ne $name ){ + if ($x->[0] =~ /::AUTOLOAD$/) { + if ($opt_A) { + $name = $x->[0]; + } + } elsif ( $opt_F ) { + warn( "Garbled profile, faking exit timestamp:\n\t$name => $x->[0].\n"); + $name = $x->[0]; + } else { + foreach $z (@stack, $x) { + print $z->[0],"\n"; + } + die "Garbled profile, unexpected exit time stamp"; + } + } + if( $opt_T || $opt_t ){ + $$in -= $tab; + } + # collect childtime + $c = pop( @$tstack ); + # total time this func has been active + $z = $t - $x->[1]; + $ctimes->{$name} += $z; + $times->{$name} += ($z > $c)? $z - $c: 0; + # pass my time to my parent + if( @$tstack ){ + $c = pop( @$tstack ); + push( @$tstack, $c + $z ); + } +} + + +sub header { + my $fh = shift; + chop($_ = <$fh>); + if( ! /^#fOrTyTwO$/ ){ + die "Not a perl profile"; + } + while(<$fh>){ + next if /^#/; + last if /^PART/; + eval; + } + $over_tests = 1 unless $over_tests; + $time_precision = length int ($hz - 1); # log ;-) +} + + +# Report avg time-per-function in seconds +sub percalc { + my( $calls, $times, $persecs, $idkeys ) = @_; + my( $x, $t, $n, $key ); + + for( $x = 0; $x < @$idkeys; ++$x ){ + $key = $idkeys->[$x]; + $n = $calls->{$key}; + $t = $times->{$key} / $hz; + $persecs->{$key} = $t ? $t / $n : 0; + } +} + + +# Runs the given script with the given profiler and the given perl. +sub run_profiler { + my $script = shift; + my $profiler = shift; + my $startperl = shift; + + system $startperl, "-d:$profiler", $script; + if( $? / 256 > 0 ){ + die "Failed: $startperl -d:$profiler $script: $!"; + } +} + + +sub by_time { $times->{$b} <=> $times->{$a} } +sub by_ctime { $ctimes->{$b} <=> $ctimes->{$a} } +sub by_calls { $calls->{$b} <=> $calls->{$a} } +sub by_alpha { $names->{$a} cmp $names->{$b} } +sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} } + + +format CSTAT_top = +Total Elapsed Time = @>>>>>>> Seconds +(($rrun_rtime - $overhead - $over_rtime * $total_marks/$over_tests/2) / $hz) + @>>>>>>>>>> Time = @>>>>>>> Seconds +$whichtime, $runtime +@<<<<<<<< Times +$incl_excl +%Time ExclSec CumulS #Calls sec/call Csec/c Name +. + +format STAT = + ^>>> ^>>>> ^>>>>> ^>>>>> ^>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +$pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name +. + +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/utils/h2ph.PL b/utils/h2ph.PL index 066f2c9c3f..0b0208b0ca 100644 --- a/utils/h2ph.PL +++ b/utils/h2ph.PL @@ -63,6 +63,8 @@ $inif = 0; @ARGV = ('-') unless @ARGV; +build_preamble_if_necessary(); + while (defined ($file = next_file())) { if (-l $file and -d $file) { link_if_possible($file) if ($opt_l); @@ -97,6 +99,8 @@ while (defined ($file = next_file())) { open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next); open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n"; } + + print OUT "require '_h2ph_pre.ph';\n\n"; while (<IN>) { chop; while (/\\$/) { @@ -105,6 +109,7 @@ while (defined ($file = next_file())) { chop; } print OUT "# $_\n" if $opt_D; + if (s:/\*:\200:g) { s:\*/:\201:g; s/\200[^\201]*\201//g; # delete single line comments @@ -158,6 +163,7 @@ while (defined ($file = next_file())) { $args = reindent($args); if ($t ne '') { $new =~ s/(['\\])/\\$1/g; #']); + if ($opt_h) { print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n"; $eval_index++; @@ -165,6 +171,9 @@ while (defined ($file = next_file())) { print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n"; } } else { + # Shunt around such directives as `#define FOO FOO': + next if " \&$name" eq $new; + print OUT $t,"unless(defined(\&$name)) {\n sub $name () {\t",$new,";}\n}\n"; } } @@ -230,10 +239,12 @@ while (defined ($file = next_file())) { print OUT $t,"}\n"; } elsif(/^undef\s+(\w+)/) { print OUT $t, "undef(&$1) if defined(&$1);\n"; + } elsif(/^error\s+(".*")/) { + print OUT $t, "die($1);\n"; } elsif(/^error\s+(.*)/) { - print OUT $t, "die(\"$1\");\n"; + print OUT $t, "die(\"", quotemeta($1), "\");\n"; } elsif(/^warning\s+(.*)/) { - print OUT $t, "warn(\"$1\");\n"; + print OUT $t, "warn(\"", quotemeta($1), "\");\n"; } elsif(/^ident\s+(.*)/) { print OUT $t, "# $1\n"; } @@ -512,6 +523,73 @@ sub inc_dirs } +# Create "_h2ph_pre.ph", if it doesn't exist or was built by a different +# version of h2ph. +sub build_preamble_if_necessary +{ + # Increment $VERSION every time this function is modified: + my $VERSION = 2; + my $preamble = "$Dest_dir/_h2ph_pre.ph"; + + # Can we skip building the preamble file? + if (-r $preamble) { + # Extract version number from first line of preamble: + open PREAMBLE, $preamble or die "Cannot open $preamble: $!"; + my $line = <PREAMBLE>; + $line =~ /(\b\d+\b)/; + close PREAMBLE or die "Cannot close $preamble: $!"; + + # Don't build preamble if a compatible preamble exists: + return if $1 == $VERSION; + } + + my (%define) = _extract_cc_defines(); + + open PREAMBLE, ">$preamble" or die "Cannot open $preamble: $!"; + print PREAMBLE "# This file was created by h2ph version $VERSION\n"; + + foreach (sort keys %define) { + if ($opt_D) { + print PREAMBLE "# $_=$define{$_}\n"; + } + + if ($define{$_} =~ /^\d+$/) { + print PREAMBLE + "unless (defined &$_) { sub $_() { $define{$_} } }\n\n"; + } elsif ($define{$_} =~ /^\w+$/) { + print PREAMBLE + "unless (defined &$_) { sub $_() { &$define{$_} } }\n\n"; + } else { + print PREAMBLE + "unless (defined &$_) { sub $_() { \"", + quotemeta($define{$_}), "\" } }\n\n"; + } + } + close PREAMBLE or die "Cannot close $preamble: $!"; +} + + +# %Config contains information on macros that are pre-defined by the +# system's compiler. We need this information to make the .ph files +# function with perl as the .h files do with cc. +sub _extract_cc_defines +{ + my %define; + my $allsymbols = join " ", @Config{ccsymbols, cppsymbols, cppccsymbols}; + + # Split compiler pre-definitions into `key=value' pairs: + foreach (split /\s+/, $allsymbols) { + /(.+?)=(.+)/ and $define{$1} = $2; + + if ($opt_D) { + print STDERR "$_: $1 -> $2\n"; + } + } + + return %define; +} + + 1; ############################################################################## @@ -590,6 +668,10 @@ However, the B<.ph> files almost double in size when built using B<-h>. Include the code from the B<.h> file as a comment in the B<.ph> file. This is primarily used for debugging I<h2ph>. +=item -Q + +``Quiet'' mode; don't print out the names of the files being converted. + =back =head1 ENVIRONMENT @@ -626,6 +708,24 @@ that it can translate. It's only intended as a rough tool. You may need to dicker with the files produced. +Doesn't run with C<use strict> + +You have to run this program by hand; it's not run as part of the Perl +installation. + +Doesn't handle complicated expressions built piecemeal, a la: + + enum { + FIRST_VALUE, + SECOND_VALUE, + #ifdef ABC + THIRD_VALUE + #endif + }; + +Doesn't necessarily locate all of your C compiler's internally-defined +symbols. + =cut !NO!SUBS! diff --git a/utils/h2xs.PL b/utils/h2xs.PL index 52f590b776..bd0ba16f46 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -41,7 +41,7 @@ h2xs - convert .h C header files to Perl extensions =head1 SYNOPSIS -B<h2xs> [B<-AOPXcdf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [headerfile ... [extra_libraries]] +B<h2xs> [B<-ACOPXcdf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [headerfile ... [extra_libraries]] B<h2xs> B<-h> @@ -71,7 +71,12 @@ in the extra-libraries argument. =item B<-A> Omit all autoload facilities. This is the same as B<-c> but also removes the -S<C<require AutoLoader>> statement from the .pm file. +S<C<use AutoLoader>> statement from the .pm file. + +=item B<-C> + +Omits creation of the F<Changes> file, and adds a HISTORY section to +the POD template. =item B<-F> @@ -89,7 +94,7 @@ Omit the autogenerated stub POD section. =item B<-X> Omit the XS portion. Used to generate templates for a module which is not -XS-based. +XS-based. C<-c> and C<-f> are implicitly enabled. =item B<-c> @@ -117,7 +122,7 @@ Specifies a name to be used for the extension, e.g., S<-n RPC::DCE> Specify a prefix which should be removed from the Perl function names, e.g., S<-p sec_rgy_> This sets up the XS B<PREFIX> keyword and removes the prefix from functions that are -autoloaded via the C<constant()> mechansim. +autoloaded via the C<constant()> mechanism. =item B<-s> I<sub1,sub2> @@ -211,20 +216,21 @@ The usual warnings if it cannot read or write the files involved. =cut -my( $H2XS_VERSION ) = ' $Revision: 1.18 $ ' =~ /\$Revision:\s+([^\s]+)/; +my( $H2XS_VERSION ) = ' $Revision: 1.19 $ ' =~ /\$Revision:\s+([^\s]+)/; my $TEMPLATE_VERSION = '0.01'; use Getopt::Std; sub usage{ warn "@_\n" if @_; - die "h2xs [-AOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [headerfile [extra_libraries]] + die "h2xs [-ACOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [headerfile [extra_libraries]] version: $H2XS_VERSION -A Omit all autoloading facilities (implies -c). + -C Omit creating the Changes file, add HISTORY heading to stub POD. -F Additional flags for C preprocessor (used with -x). -O Allow overwriting of a pre-existing extension directory. -P Omit the stub POD section. - -X Omit the XS portion. + -X Omit the XS portion (implies both -c and -f). -c Omit the constant() function and specialised AUTOLOAD from the XS file. -d Turn on debugging messages. -f Force creation of the extension even if the C header does not exist. @@ -241,14 +247,20 @@ extra_libraries } -getopts("AF:OPXcdfhn:p:s:v:x") || usage; +getopts("ACF:OPXcdfhn:p:s:v:x") || usage; usage if $opt_h; if( $opt_v ){ $TEMPLATE_VERSION = $opt_v; } + +# -A implies -c. $opt_c = 1 if $opt_A; + +# -X implies -c and -f +$opt_c = $opt_f = 1 if $opt_X; + %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s; while (my $arg = shift) { @@ -362,8 +374,8 @@ chdir($modpname) || die "Can't chdir $ext$modpname: $!\n"; my %types_seen; my %std_types; -my $fdecls; -my $fdecls_parsed; +my $fdecls = []; +my $fdecls_parsed = []; if( ! $opt_X ){ # use XS, unless it was disabled open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n"; @@ -374,22 +386,20 @@ if( ! $opt_X ){ # use XS, unless it was disabled get_typemap(); my $c; my $filter; - my @fdecls; - foreach my $filename (@path_h) { - my $addflags = $opt_F || ''; - if ($fullpath =~ /,/) { - $filename = $`; - $filter = $'; + foreach my $filename (@path_h) { + my $addflags = $opt_F || ''; + if ($fullpath =~ /,/) { + $filename = $`; + $filter = $'; + } + warn "Scanning $filename for functions...\n"; + $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter, + 'add_cppflags' => $addflags; + $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]); + + push @$fdecls_parsed, @{ $c->get('parsed_fdecls') }; + push(@$fdecls, @{$c->get('fdecls')}); } - warn "Scanning $filename for functions...\n"; - $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter, - 'add_cppflags' => $addflags; - $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]); - - $fdecls_parsed = $c->get('parsed_fdecls'); - push(@fdecls, @{$c->get('fdecls')}); - } - $fdecls = [ @fdecls ]; } } @@ -428,46 +438,22 @@ print PM <<"END" if ! $opt_X; # use DynaLoader, unless XS was disabled require DynaLoader; END -# require autoloader if XS is disabled. -# if XS is enabled, require autoloader unless autoloading is disabled. -if( ($opt_X && (! $opt_A)) || (!$opt_X) ) { - print PM <<"END"; -require AutoLoader; -END -} - -if( $opt_X || ($opt_c && ! $opt_A) ){ - # we won't have our own AUTOLOAD(), so we'll inherit it. - if( ! $opt_X ) { # use DynaLoader, unless XS was disabled - print PM <<"END"; -\@ISA = qw(Exporter AutoLoader DynaLoader); -END +# Are we using AutoLoader or not? +unless ($opt_A) { # no autoloader whatsoever. + unless ($opt_c) { # we're doing the AUTOLOAD + print PM "use AutoLoader;\n"; } - else{ - print PM <<"END"; - -\@ISA = qw(Exporter AutoLoader); -END + else { + print PM "use AutoLoader qw(AUTOLOAD);\n" } } -else{ - # 1) we have our own AUTOLOAD(), so don't need to inherit it. - # or - # 2) we don't want autoloading mentioned. - if( ! $opt_X ){ # use DynaLoader, unless XS was disabled - print PM <<"END"; -\@ISA = qw(Exporter DynaLoader); -END - } - else{ - print PM <<"END"; - -\@ISA = qw(Exporter); -END - } -} +# Determine @ISA. +my $myISA = '@ISA = qw(Exporter'; # We seem to always want this. +$myISA .= ' DynaLoader' unless $opt_X; # no XS +$myISA .= ');'; +print PM "\n$myISA\n\n"; print PM<<"END"; # Items to export into callers namespace by default. Note: do not export @@ -491,7 +477,7 @@ sub AUTOLOAD { croak "&$module::constant not defined" if \$constname eq 'constant'; my \$val = constant(\$constname, \@_ ? \$_[0] : 0); if (\$! != 0) { - if (\$! =~ /Invalid/) { + if (\$! =~ /Invalid/ || \$!{EINVAL}) { \$AutoLoader::AUTOLOAD = \$AUTOLOAD; goto &AutoLoader::AUTOLOAD; } @@ -499,6 +485,7 @@ sub AUTOLOAD { croak "Your vendor has not defined $module macro \$constname"; } } + no strict 'refs'; *\$AUTOLOAD = sub () { \$val }; goto &\$AUTOLOAD; } @@ -521,8 +508,14 @@ else { print PM <<"END"; # Preloaded methods go here. +END + +print PM <<"END" unless $opt_A; # Autoload methods go after $after, and are processed by the autosplit program. +END + +print PM <<"END"; 1; __END__ @@ -531,11 +524,26 @@ END $author = "A. U. Thor"; $email = 'a.u.thor@a.galaxy.far.far.away'; +my $revhist = ''; +$revhist = <<EOT if $opt_C; + +=head1 HISTORY + +=over 8 + +=item $TEMPLATE_VERSION + +Original version; created by h2xs $H2XS_VERSION + +=back + +EOT + my $const_doc = ''; my $fdecl_doc = ''; if (@const_names and not $opt_P) { $const_doc = <<EOD; -\n=head1 Exported constants +\n=head2 Exported constants @{[join "\n ", @const_names]} @@ -543,7 +551,7 @@ EOD } if (defined $fdecls and @$fdecls and not $opt_P) { $fdecl_doc = <<EOD; -\n=head1 Exported functions +\n=head2 Exported functions @{[join "\n ", @$fdecls]} @@ -569,7 +577,7 @@ $pod = <<"END" unless $opt_P; #unedited. # #Blah blah blah. -#$const_doc$fdecl_doc +#$const_doc$fdecl_doc$revhist #=head1 AUTHOR # #$author, $email @@ -591,15 +599,9 @@ if( ! $opt_X ){ # print XS, unless it is disabled warn "Writing $ext$modpname/$modfname.xs\n"; print XS <<"END"; -#ifdef __cplusplus -extern "C" { -#endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" -#ifdef __cplusplus -} -#endif END if( @path_h ){ @@ -615,17 +617,14 @@ if( @path_h ){ if( ! $opt_c ){ print XS <<"END"; static int -not_here(s) -char *s; +not_here(char *s) { croak("$module::%s not implemented on this architecture", s); return -1; } static double -constant(name, arg) -char *name; -int arg; +constant(char *name, int arg) { errno = 0; switch (*name) { @@ -870,12 +869,14 @@ print "ok 1\n"; _END_ close(EX) || die "Can't close $ext$modpname/test.pl: $!\n"; -warn "Writing $ext$modpname/Changes\n"; -open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n"; -print EX "Revision history for Perl extension $module.\n\n"; -print EX "$TEMPLATE_VERSION ",scalar localtime,"\n"; -print EX "\t- original version; created by h2xs $H2XS_VERSION\n\n"; -close(EX) || die "Can't close $ext$modpname/Changes: $!\n"; +unless ($opt_C) { + warn "Writing $ext$modpname/Changes\n"; + open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n"; + print EX "Revision history for Perl extension $module.\n\n"; + print EX "$TEMPLATE_VERSION ",scalar localtime,"\n"; + print EX "\t- original version; created by h2xs $H2XS_VERSION\n\n"; + close(EX) || die "Can't close $ext$modpname/Changes: $!\n"; +} warn "Writing $ext$modpname/MANIFEST\n"; open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!"; diff --git a/utils/perlbc.PL b/utils/perlbc.PL new file mode 100644 index 0000000000..51d074be66 --- /dev/null +++ b/utils/perlbc.PL @@ -0,0 +1,80 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); +use Cwd; + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. +# Wanted: $archlibexp + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +$origdir = cwd; +chdir dirname($0); +$file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; + +use strict; +use warning; +no warning qw(once); + +use Config; + +require ByteLoader; + +foreach my $infile (@ARGV) +{ + if ($infile =~ /\.p[ml]$/) + { + my $outfile = $infile . "c"; + + open(OUT,"> $outfile") || die "Can't open $outfile: $!"; + + if ($infile =~ /\.pl$/) + { + print OUT "$Config{startperl}\n"; + print OUT " eval 'exec $Config{perlpath} -S \$0 \${1+\"\$@\"}'\n"; + print OUT " if \$running_under_some_shell;\n\n"; + } + + print OUT "use ByteLoader $ByteLoader::VERSION;\n"; + + close(OUT); + + print "$^X -MO=Bytecode $infile >> $outfile\n"; + + system("$^X -MO=Bytecode $infile >> $outfile"); + } + else + { + warn "Don't know how to byte compile $infile"; + } +} +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; +chdir $origdir; diff --git a/utils/perlbug.PL b/utils/perlbug.PL index 589e7e69b4..3404d2b95e 100644 --- a/utils/perlbug.PL +++ b/utils/perlbug.PL @@ -3,6 +3,7 @@ use Config; use File::Basename qw(&basename &dirname); use Cwd; +use File::Spec::Functions; # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you @@ -23,7 +24,8 @@ open OUT, ">$file" or die "Can't create $file: $!"; # extract patchlevel.h information -open PATCH_LEVEL, "<../patchlevel.h" or die "Can't open patchlevel.h: $!"; +open PATCH_LEVEL, "<" . catfile(updir, "patchlevel.h") + or die "Can't open patchlevel.h: $!"; my $patchlevel_date = (stat PATCH_LEVEL)[9]; @@ -74,6 +76,7 @@ my \@patches = ( print OUT <<'!NO!SUBS!'; use Config; +use File::Spec::Functions; use Getopt::Std; use strict; @@ -86,7 +89,7 @@ BEGIN { $::HaveUtil = ($@ eq ""); }; -my $Version = "1.26"; +my $Version = "1.27"; # 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. @@ -117,6 +120,7 @@ my $Version = "1.26"; # Changed in 1.24 Added '-F<file>' to save report HVDS 98-07-01 # Changed in 1.25 Warn on failure to open save file. HVDS 98-07-12 # Changed in 1.26 Don't require -t STDIN for -ok. HVDS 98-07-15 +# Changed in 1.27 Added Mac OS and File::Spec support CNANDOR 99-07-27 # TODO: - Allow the user to re-name the file on mail failure, and # make sure failure (transmission-wise) of Mail::Send is @@ -124,7 +128,7 @@ my $Version = "1.26"; # - Test -b option my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename, - $subject, $from, $verbose, $ed, $outfile, + $subject, $from, $verbose, $ed, $outfile, $Is_MacOS, $fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP, $ok); my $config_tag2 = "$] - $Config{cf_time}"; @@ -154,6 +158,11 @@ sub Init { $Is_MSWin32 = $^O eq 'MSWin32'; $Is_VMS = $^O eq 'VMS'; + $Is_MacOS = $^O eq 'MacOS'; + + @ARGV = split m/\s+/, + MacPerl::Ask('Provide command-line args here (-h for help):') + if $Is_MacOS && $MacPerl::Version =~ /App/; if (!getopts("dhva:s:b:f:F:r:e:SCc:to:n:")) { Help(); exit; }; @@ -196,6 +205,7 @@ sub Init { $ed = $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT} || ($Is_VMS && "edit/tpu") || ($Is_MSWin32 && "notepad") + || ($Is_MacOS && '') || "vi"; # Not OK - provide build failure template by finessing OK report @@ -255,6 +265,7 @@ EOF # My username $me = $Is_MSWin32 ? $ENV{'USERNAME'} : $^O eq 'os2' ? $ENV{'USER'} || $ENV{'LOGNAME'} + : $Is_MacOS ? $ENV{'USER'} : eval { getpwuid($<) }; # May be missing $from = $::Config{'cf_email'} @@ -307,6 +318,13 @@ EOF my $guess; $guess = $ENV{'REPLY-TO'} || $ENV{'REPLYTO'} || ''; + if ($Is_MacOS) { + require Mac::InternetConfig; + $guess = $Mac::InternetConfig::InternetConfig{ + Mac::InternetConfig::kICEmail() + }; + } + unless ($guess) { my $domain; if ($::HaveUtil) { @@ -495,8 +513,8 @@ sub Dump { local(*OUT) = @_; 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" + print REP "This perlbug was built using Perl $config_tag2\n", + "It is being executed now by Perl $config_tag1.\n\n" if $config_tag2 ne $config_tag1; print OUT <<EOF; @@ -527,10 +545,13 @@ EOF --- Environment for perl $]: EOF - for my $env (sort - (qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR), - grep /^(?:PERL|LC_)/, keys %ENV) - ) { + my @env = + qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR LANGUAGE); + push @env, $Config{ldlibpthname} if $Config{ldlibpthname} ne ''; + push @env, grep /^(?:PERL|LC_|LANG)/, keys %ENV; + my %env; + @env{@env} = @env; + for my $env (sort keys %env) { print OUT " $env", exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)', "\n"; @@ -559,7 +580,15 @@ EOF } tryagain: - my $sts = system("$ed $filename"); + my $sts = system("$ed $filename") unless $Is_MacOS; + if ($Is_MacOS) { + require ExtUtils::MakeMaker; + ExtUtils::MM_MacOS::launch_file($filename); + paraprint <<EOF; +Press Enter when done. +EOF + scalar <>; + } if ($sts) { paraprint <<EOF; The editor you chose (`$ed') could apparently not be run! @@ -783,7 +812,7 @@ Options: -v Include Verbose configuration data in the report -f File containing the body of the report. Use this to quickly send a prepared message. - -F File to output the resulting mail message to, instead of mailing. + -F File to output the resulting mail message to, instead of mailing. -S Send without asking for confirmation. -a Address to send the report to. Defaults to `$address'. -c Address to send copy of report to. Defaults to `$cc'. @@ -796,7 +825,7 @@ Options: this if you don't give it here. -e Editor to use. -t Test mode. The target address defaults to `$testaddress'. - -d Data mode (the default if you redirect or pipe output.) + -d Data mode (the default if you redirect or pipe output.) 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 @@ -815,11 +844,12 @@ EOF sub filename { my $dir = $Is_VMS ? 'sys$scratch:' : ($Is_MSWin32 && $ENV{'TEMP'}) ? $ENV{'TEMP'} - : '/tmp/'; + : $Is_MacOS ? $ENV{'TMPDIR'} + : '/tmp'; $filename = "bugrep0$$"; - $dir .= "\\" if $Is_MSWin32 and $dir !~ m|[\\/]$|; - $filename++ while -e "$dir$filename"; - $filename = "$dir$filename"; +# $dir .= "\\" if $Is_MSWin32 and $dir !~ m|[\\/]$|; + $filename++ while -e catfile($dir, $filename); + $filename = catfile($dir, $filename); } sub paraprint { @@ -878,7 +908,7 @@ this checklist: =over 4 -=item What version of perl you are running? +=item What version of Perl you are running? Type C<perl -v> at the command line to find out. @@ -886,22 +916,29 @@ Type C<perl -v> at the command line to find out. Look at http://www.perl.com/ to find out. If it is not the latest released version, get that one and see whether your bug has been -fixed. Note that bug reports about old versions of perl, especially +fixed. Note that bug reports about old versions of Perl, especially those prior to the 5.0 release, are likely to fall upon deaf ears. You are on your own if you continue to use perl1 .. perl4. =item Are you sure what you have is a bug? A significant number of the bug reports we get turn out to be documented -features in perl. Make sure the behavior you are witnessing doesn't fall +features in Perl. Make sure the behavior you are witnessing doesn't fall under that category, by glancing through the documentation that comes -with perl (we'll admit this is no mean task, given the sheer volume of +with Perl (we'll admit this is no mean task, given the sheer volume of it all, but at least have a look at the sections that I<seem> relevant). Be aware of the familiar traps that perl programmers of various hues fall into. See L<perltrap>. -Try to study the problem under the perl debugger, if necessary. +Check in L<perldiag> to see what any Perl error message(s) mean. +If message isn't in perldiag, it probably isn't generated by Perl. +Consult your operating system documentation instead. + +If you are on a non-UNIX platform check also L<perlport>, as some +features may be unimplemented or work differently. + +Try to study the problem under the Perl debugger, if necessary. See L<perldebug>. =item Do you have a proper test case? @@ -916,12 +953,23 @@ A good test case is almost always a good candidate to be on the perl test suite. If you have the time, consider making your test case so that it will readily fit into the standard test suite. +Remember also to include the B<exact> error messages, if any. +"Perl complained something" is not an exact error message. + +If you get a core dump (or equivalent), you may use a debugger +(B<dbx>, B<gdb>, etc) to produce a stack trace to include in the bug +report. NOTE: unless your Perl has been compiled with debug info +(often B<-g>), the stack trace is likely to be somewhat hard to use +because it will most probably contain only the function names and not +their arguments. If possible, recompile your Perl with debug info and +reproduce the dump and the stack trace. + =item Can you describe the bug in plain English? The easier it is to understand a reproducible bug, the more likely it will be fixed. Anything you can provide by way of insight into the -problem helps a great deal. In other words, try to analyse the -problem to the extent you feel qualified and report your discoveries. +problem helps a great deal. In other words, try to analyze the +problem (to the extent you can) and report your discoveries. =item Can you fix the bug yourself? @@ -954,10 +1002,15 @@ it to B<perlbug@perl.com>. If, for some reason, you cannot run C<perlbug> at all on your system, be sure to include the entire output produced by running C<perl -V> (note the uppercase V). +Whether you use C<perlbug> or send the email manually, please make +your Subject line informative. "a bug" not informative. Neither is +"perl crashes" nor "HELP!!!". These don't help. +A compact description of what's wrong is fine. + =back Having done your bit, please be prepared to wait, to be told the bug -is in your code, or even to get no reply at all. The perl maintainers +is in your code, or even to get no reply at all. The Perl maintainers are busy folks, so if your problem is a small one or if it is difficult to understand or already known, they may not respond with a personal reply. If it is important to you that your bug be fixed, do monitor the @@ -1071,12 +1124,15 @@ Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently I<doc>tored by Gurusamy Sarathy (E<lt>gsar@umich.eduE<gt>), Tom Christiansen (E<lt>tchrist@perl.comE<gt>), Nathan Torkington (E<lt>gnat@frii.comE<gt>), Charles F. Randall (E<lt>cfr@pobox.comE<gt>), Mike Guy -(E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop (E<lt>domo@computer.orgE<gt>) -and Hugo van der Sanden (E<lt>hv@crypt0.demon.co.ukE<gt>). +(E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop (E<lt>domo@computer.orgE<gt>), +Hugo van der Sanden (E<lt>hv@crypt0.demon.co.ukE<gt>), +Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>), hris Nandor +(E<lt>pudge@pobox.comE<gt>), and Jon Orwant (E<lt>orwant@media.mit.eduE<gt>). =head1 SEE ALSO -perl(1), perldebug(1), perltrap(1), diff(1), patch(1) +perl(1), perldebug(1), perldiag(1), perlport(1), perltrap(1), +diff(1), patch(1), dbx(1), gdb(1) =head1 BUGS @@ -1090,4 +1146,3 @@ close OUT or die "Can't close $file: $!"; chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; chdir $origdir; - diff --git a/utils/perlcc.PL b/utils/perlcc.PL index b214645ad9..99e9b51851 100644 --- a/utils/perlcc.PL +++ b/utils/perlcc.PL @@ -48,8 +48,12 @@ $Getopt::Long::bundling_override = 1; $Getopt::Long::passthrough = 0; $Getopt::Long::ignore_case = 0; +my $pathsep = ($Config{'osname'} eq 'MSWin32')? "\\" : "/"; # MAJOR HACK. SHOULD + # BE IN Config.pm + my $options = {}; my $_fh; +unshift @ARGV, split ' ', $ENV{PERLCC_OPTS} if $ENV{PERLCC_OPTS}; main(); @@ -66,7 +70,9 @@ sub main "regex:s", "verbose:s", "log:s", - "argv:s", + "argv:s", + "b", + "opt", "gen", "sav", "run", @@ -101,33 +107,53 @@ sub _doit my ($file) = @_; my ($program_ext, $module_ext) = _getRegexps(); - my ($obj, $objfile, $so, $type); + my ($obj, $objfile, $so, $type, $backend, $gentype); + + $backend = $options->{'b'} ? 'Bytecode' : $options->{'opt'} ? 'CC' : 'C'; + + $gentype = $options->{'b'} ? 'Bytecode' : 'C'; if ( (($file =~ m"@$program_ext") && ($file !~ m"@$module_ext")) || (defined($options->{'prog'}) || defined($options->{'run'})) ) { - $objfile = ($options->{'C'}) ? $options->{'C'} : "$file.c"; $type = 'program'; - $obj = ($options->{'o'})? $options->{'o'} : - _getExecutable( $file,$program_ext); + if ($options->{'b'}) + { + $obj = $objfile = $options->{'o'} ? $options->{'o'} : "${file}c"; + } + else + { + $objfile = $options->{'C'} ? $options->{'C'} : "$file.c"; + $obj = $options->{'o'} ? $options->{'o'} + : _getExecutable( $file,$program_ext); + } return() if (!$obj); } elsif (($file =~ m"@$module_ext") || ($options->{'mod'})) { - die "Shared objects are not supported on Win32 yet!!!!\n" - if ($Config{'osname'} eq 'MSWin32'); + $type = 'module'; + + if ($options->{'b'}) + { + $obj = $objfile = $options->{'o'} ? $options->{'o'} : "${file}c"; + } + else + { + die "Shared objects are not supported on Win32 yet!!!!\n" + if ($Config{'osname'} eq 'MSWin32'); + + $objfile = $options->{'C'} ? $options->{'C'} : "$file.c"; + $obj = $options->{'o'} ? $options->{'o'} + : _getExecutable($file, $module_ext); + $so = "$obj.$Config{so}"; + } - $obj = ($options->{'o'})? $options->{'o'} : - _getExecutable($file, $module_ext); - $so = "$obj.$Config{so}"; - $type = 'sharedlib'; return() if (!$obj); - $objfile = ($options->{'C'}) ? $options->{'C'} : "$file.c"; } else { @@ -137,15 +163,17 @@ sub _doit if ($type eq 'program') { - _print("Making C($objfile) for $file!\n", 36 ); + _print("Making $gentype($objfile) for $file!\n", 36 ); - my $errcode = _createCode($objfile, $file); + my $errcode = _createCode($backend, $objfile, $file); (_print( "ERROR: In generating code for $file!\n", -1), return()) if ($errcode); - _print("Compiling C($obj) for $file!\n", 36 ) if (!$options->{'gen'}); + _print("Compiling C($obj) for $file!\n", 36 ) if (!$options->{'gen'} && + !$options->{'b'}); $errcode = _compileCode($file, $objfile, $obj) - if (!$options->{'gen'}); + if (!$options->{'gen'} && + !$options->{'b'}); if ($errcode) { @@ -157,29 +185,35 @@ sub _doit return() } - _runCode($obj) if ($options->{'run'}); + _runCode($objfile) if ($options->{'run'} && $options->{'b'}); + _runCode($obj) if ($options->{'run'} && !$options->{'b'}); - _removeCode($objfile) if (!$options->{'sav'} || - ($options->{'e'} && !$options->{'C'})); + _removeCode($objfile) if (($options->{'b'} && + ($options->{'e'} && !$options->{'o'})) || + (!$options->{'b'} && + (!$options->{'sav'} || + ($options->{'e'} && !$options->{'C'})))); _removeCode($file) if ($options->{'e'}); - _removeCode($obj) if (($options->{'e'} - && !$options->{'sav'} - && !$options->{'o'}) - || ($options->{'run'} && !$options->{'sav'})); + _removeCode($obj) if (!$options->{'b'} && + (($options->{'e'} && + !$options->{'sav'} && !$options->{'o'}) || + ($options->{'run'} && !$options->{'sav'}))); } else { - _print( "Making C($objfile) for $file!\n", 36 ); - my $errcode = _createCode($objfile, $file, $obj); + _print( "Making $gentype($objfile) for $file!\n", 36 ); + my $errcode = _createCode($backend, $objfile, $file, $obj); (_print( "ERROR: In generating code for $file!\n", -1), return()) if ($errcode); - _print( "Compiling C($so) for $file!\n", 36 ) if (!$options->{'gen'}); + _print( "Compiling C($so) for $file!\n", 36 ) if (!$options->{'gen'} && + !$options->{'b'}); - my $errorcode = - _compileCode($file, $objfile, $obj, $so ) if (!$options->{'gen'}); + $errcode = + _compileCode($file, $objfile, $obj, $so ) if (!$options->{'gen'} && + !$options->{'b'}); (_print( "ERROR: In compiling code for $objfile!\n", -1), return()) if ($errcode); @@ -202,10 +236,10 @@ sub _getExecutable ($obj = $sourceprog) =~ s"@$ext"$options->{ext}"g; return(0) if (_error('equal', $obj, $sourceprog)); } - elsif (defined ($options->{'run'})) - { - $obj = "perlc$$"; - } + elsif (defined ($options->{'run'})) + { + $obj = "perlc$$"; + } else { ($obj = $sourceprog) =~ s"@$ext""g; @@ -216,23 +250,41 @@ sub _getExecutable sub _createCode { - my ( $generated_cfile, $file, $final_output ) = @_; + my ( $backend, $generated_file, $file, $final_output ) = @_; my $return; local($") = " -I"; - if (@_ == 2) # compiling a program + open(GENFILE, "> $generated_file") || die "Can't open $generated_file: $!"; + + if ($backend eq "Bytecode") { - _print( "$^X -I@INC -MO=CC,-o$generated_cfile $file\n", 36); - $return = _run("$ -I@INC -MO=CC,-o$generated_cfile $file", 9); + require ByteLoader; + + print GENFILE "#!$^X\n" if @_ == 3; + print GENFILE "use ByteLoader $ByteLoader::VERSION;\n"; + } + + close(GENFILE); + + if (@_ == 3) # compiling a program + { + chmod $generated_file, 0777 & ~umask if $backend eq "Bytecode"; + + _print( "$^X -I@INC -MB::Stash -c $file\n", 36); + my $stash=`$^X -I@INC -MB::Stash -c $file 2>/dev/null|tail -1`; + chomp $stash; + + _print( "$^X -I@INC -MO=$backend,$stash $file\n", 36); + $return = _run("$^X -I@INC -MO=$backend,$stash $file >> $generated_file", 9); $return; } else # compiling a shared object { _print( - "$ -I@INC -MO=CC,-m$final_output,-o$generated_cfile $file\n", 36); + "$^X -I@INC -MO=$backend,-m$final_output $file\n", 36); $return = - _run("$ -I@INC -MO=CC,-m$final_output,-o$generated_cfile $file", 9); + _run("$^X -I@INC -MO=$backend,-m$final_output $file >> $generated_file", 9); $return; } } @@ -245,7 +297,8 @@ sub _compileCode if (@_ == 3) # just compiling a program { $return[0] = - _ccharness('static', $sourceprog, "-o", $output_executable, $generated_cfile); + _ccharness('static', $sourceprog, "-o", $output_executable, + $generated_cfile); $return[0]; } else @@ -256,7 +309,7 @@ sub _compileCode $return[0] = _ccharness('compile', $sourceprog, "-c", $generated_cfile); $return[1] = _ccharness ( - 'dynamic', + 'dynamic', $sourceprog, "-o", $shared_object, $object_file ); @@ -302,19 +355,26 @@ sub _ccharness $incdir .= " -I$options->{L}" if (defined($options->{L})); my $linkargs = ''; + my $dynaloader = ''; + my $optimize = ''; + my $flags = ''; if (!grep(/^-[cS]$/, @args)) { - my $lperl = $^O eq 'os2' ? '-llibperl' : '-lperl'; - my $flags = $type eq 'dynamic' ? $Config{lddlflags} : $Config{ldflags}; - $linkargs = "$flags $libdir $lperl @Config{libs}"; - } + my $lperl = $^O eq 'os2' ? '-llibperl' + : $^O eq 'MSWin32' ? "$Config{archlibexp}\\CORE\\perl.lib" + : '-lperl'; - my @sharedobjects = _getSharedObjects($sourceprog); + $optimize = $Config{'optimize'} =~ /-O\d/ ? '' : $Config{'optimize'}; - my $cccmd = - "$Config{cc} @Config{qw(ccflags optimize)} $incdir @sharedobjects @args $linkargs"; + $flags = $type eq 'dynamic' ? $Config{lddlflags} : $Config{ldflags}; + $linkargs = "$flags $libdir $lperl @Config{libs}"; + } + + my $libs = _getSharedObjects($sourceprog); + my $cccmd = "$Config{cc} $Config{ccflags} $optimize $incdir " + ."@args $dynaloader $linkargs @$libs"; _print ("$cccmd\n", 36); _run("$cccmd", 18 ); @@ -324,29 +384,31 @@ sub _getSharedObjects { my ($sourceprog) = @_; my ($tmpfile, $incfile); - my (@return); + my (@sharedobjects, @libraries); local($") = " -I"; + my ($tmpprog); + ($tmpprog = $sourceprog) =~ s"(.*)[\\/](.*)"$2"; + + my $tempdir; + if ($Config{'osname'} eq 'MSWin32') { - # _addstuff; + $tempdir = $ENV{TEMP}; + $tempdir =~ s[\\][/]g; } else { - my ($tmpprog); - ($tmpprog = $sourceprog) =~ s"(.*)[\/\\](.*)"$2"; - $tmpfile = "/tmp/$tmpprog.tst"; - $incfile = "/tmp/$tmpprog.val"; + $tempdir = "/tmp"; } + $tmpfile = "$tempdir/$tmpprog.tst"; + $incfile = "$tempdir/$tmpprog.val"; my $fd = new FileHandle("> $tmpfile") || die "Couldn't open $tmpfile!\n"; my $fd2 = new FileHandle("$sourceprog") || die "Couldn't open $sourceprog!\n"; - my $perl = <$fd2>; # strip off header; - - print $fd -<<"EOF"; + print $fd <<"EOF"; use FileHandle; my \$fh3 = new FileHandle("> $incfile") || die "Couldn't open $incfile\\n"; @@ -360,8 +422,8 @@ EOF print $fd ( <$fd2> ); close($fd); - _print("$ -I@INC $tmpfile\n", 36); - _run("$ -I@INC $tmpfile", 9 ); + _print("$^X -I@INC $tmpfile\n", 36); + _run("$^X -I@INC $tmpfile", 9 ); $fd = new FileHandle ("$incfile"); my @lines = <$fd>; @@ -372,19 +434,18 @@ EOF my $line; my $autolib; + my @return; + foreach $line (@lines) { chomp($line); + my ($modname, $modpath) = split(':', $line); my ($dir, $file) = ($modpath=~ m"(.*)[\\/]($modname)"); - - if ($autolib = _lookforAuto($dir, $file)) - { - push(@return, $autolib); - } - } - return(@return); + if ($autolib = _lookforAuto($dir, $file)) { push(@return, $autolib); } + } + return(\@return); } sub _maketempfile @@ -410,34 +471,28 @@ sub _lookforAuto { my ($dir, $file) = @_; - my $relshared; + my ($relabs, $relshared); + my ($prefix); my $return; - ($relshared = $file) =~ s"(.*)\.pm"$1"; + ($prefix = $file) =~ s"(.*)\.pm"$1"; - my ($tmp, $modname) = ($relshared =~ m"(?:(.*)[\\/]){0,1}(.*)"s); + my ($tmp, $modname) = ($prefix =~ m"(?:(.*)[\\/]){0,1}(.*)"s); - $relshared .= - ($Config{'osname'} eq 'MSWin32')? "\\$modname.dll" : "/$modname.so"; - + $relshared = "$pathsep$prefix$pathsep$modname.$Config{so}"; + $relabs = "$pathsep$prefix$pathsep$modname$Config{_a}"; + # HACK . WHY DOES _a HAVE A '.' + # AND so HAVE NONE?? - - if (-e ($return = "$Config{'installarchlib'}/auto/$relshared") ) - { - return($return); - } - elsif (-e ($return = "$Config{'installsitearch'}/auto/$relshared")) - { - return($return); - } - elsif (-e ($return = "$dir/arch/auto/$relshared")) - { - return($return); - } - else + my @searchpaths = map("$_${pathsep}auto", @INC); + + my $path; + foreach $path (@searchpaths) { - return(undef); + if (-e ($return = "$path$relshared")) { return($return); } + if (-e ($return = "$path$relabs")) { return($return); } } + return(undef); } sub _getRegexps # make the appropriate regexps for making executables, @@ -453,7 +508,6 @@ sub _getRegexps # make the appropriate regexps for making executables, @$module_ext = ($ENV{PERL_MODULE_EXT})? split(':', $ENV{PERL_MODULE_EXT}) : ('.pm$'); - _mungeRegexp( $program_ext ); _mungeRegexp( $module_ext ); @@ -469,7 +523,6 @@ sub _mungeRegexp grep(s:\x00::g, @$regexp); } - sub _error { my ($type, @args) = @_; @@ -530,6 +583,21 @@ sub _checkopts $_fh = new FileHandle(">> $options->{'log'}") || push(@errors, "ERROR: Couldn't open $options->{'log'}\n"); } + if ($options->{'b'} && $options->{'c'}) + { + push(@errors, +"ERROR: The '-b' and '-c' options are incompatible. The '-c' option specifies + a name for the intermediate C code but '-b' generates byte code + directly.\n"); + } + if ($options->{'b'} && ($options->{'sav'} || $options->{'gen'})) + { + push(@errors, +"ERROR: The '-sav' and '-gen' options are incompatible with the '-b' option. + They ask for intermediate C code to be saved by '-b' generates byte + code directly.\n"); + } + if (($options->{'c'}) && (@ARGV > 1) && ($options->{'sav'} )) { push(@errors, @@ -541,17 +609,17 @@ sub _checkopts if (($options->{'o'}) && (@ARGV > 1)) { push(@errors, -"ERROR: The '-o' option is incompatible when you have more than one input file! - (-o explicitly names the resulting executable, hence, with more than +"ERROR: The '-o' option is incompatible when you have more than one input + file! (-o explicitly names the resulting file, hence, with more than one file the names clash)\n"); } - if ($options->{'e'} && $options->{'sav'} && !$options->{'o'} && + if ($options->{'e'} && ($options->{'sav'} || $options->{'gen'}) && ò0 !$options->{'C'}) { push(@errors, "ERROR: You need to specify where you are going to save the resulting - executable or C code, when using '-sav' and '-e'. Use '-o' or '-C'.\n"); + C code when using '-sav' and '-e'. Use '-C'.\n"); } if (($options->{'regex'} || $options->{'run'} || $options->{'o'}) @@ -673,20 +741,74 @@ sub _run my $doreg = (($regflag & $options->{'verbose'}) || $flag == -1); if ($doreg && !$dolog) - { system("$command"); } - + { + print _interruptrun("$command"); + } elsif ($doreg && $dolog) - { my $text = `$command 2>&1`; print $_fh $text; print STDERR $text;} + { + my $text = _interruptrun($command); + print $_fh $text; + print STDERR $text; + } else - { my $text = `$command 2>&1`; print $_fh $text; } + { + my $text = _interruptrun($command); + print $_fh $text; + } } else { - `$command 2>&1`; + _interruptrun($command); } return($?); } +sub _interruptrun +{ + my ($command) = @_; + my $pid = open (FD, "$command 2|"); + + local($SIG{HUP}) = sub { +# kill 9, $pid + 1; +# HACK... 2>&1 doesn't propogate +# kill, comment out for quick and dirty +# process killing of child. + + kill 9, $pid; + exit(); + }; + local($SIG{INT}) = sub { +# kill 9, $pid + 1; +# HACK... 2>&1 doesn't propogate +# kill, comment out for quick and dirty +# process killing of child. + kill 9, $pid; + exit(); + }; + + my $needalarm = + ($ENV{'PERLCC_TIMEOUT'} && + $Config{'osname'} ne 'MSWin32' && $command =~ m"^perlc"); + my $text; + + eval + { + local($SIG{ALRM}) = sub { die "INFINITE LOOP"; }; + alarm($ENV{'PERLCC_TIMEOUT'}) if ($needalarm); + $text = join('', <FD>); + alarm(0) if ($needalarm); + }; + + if ($@) + { + eval { kill 'HUP', $pid; }; + _print("SYSTEM TIMEOUT (infinite loop?)\n", 36); + } + + close(FD); + return($text); +} + sub _usage { _print @@ -695,6 +817,9 @@ sub _usage Usage: $0 <file_list> +WARNING: The whole compiler suite ('perlcc' included) is considered VERY +experimental. Use for production purposes is strongly discouraged. + Flags with arguments -L < extra library dirs for installation (form of 'dir1:dir2') > -I < extra include dirs for installation (form of 'dir1:dir2') > @@ -702,12 +827,14 @@ Usage: $0 <file_list> -o < explicit name of resulting executable > -e < to compile 'one liners'. Need executable name (-o) or '-run'> -regex < rename regex, -regex 's/\.p/\.exe/' compiles a.p to a.exe > - -verbose < verbose level (1-63, or following letters 'gatfcd' > + -verbose < verbose level < 1-63, or following letters 'gatfcd' > -argv < arguments for the executables to be run via '-run' or '-e' > Boolean flags - -gen ( to just generate the c code. Implies '-sav' ) - -sav ( to save intermediate c code, (and executables with '-run')) + -b ( to generate byte code ) + -opt ( to generated optimised C code. May not work in some cases. ) + -gen ( to just generate the C code. Implies '-sav' ) + -sav ( to save intermediate C code, (and executables with '-run')) -run ( to run the compiled program on the fly, as were interpreted.) -prog ( to indicate that the files on command line are programs ) -mod ( to indicate that the files on command line are modules ) @@ -785,8 +912,9 @@ Adds directories inside B<include_directories> to the compilation command. =item -C < c_code_name > -Explicitly gives the name B<c_code_name> to the generated c code which is to -be compiled. Can only be used if compiling one file on the command line. +Explicitly gives the name B<c_code_name> to the generated file containing +the C code which is to be compiled. Can only be used if compiling one file +on the command line. =item -o < executable_name > @@ -801,6 +929,20 @@ in one go (see B<-run>); giving the B<-o> flag saves the resultant executable, rather than throwing it away. Use '-argv' to pass arguments to the executable created. +=item -b + +Generates bytecode instead of C code. + +=item -opt + +Uses the optimized C backend (C<B::CC>)rather than the simple C backend +(C<B::C>). Beware that the optimized C backend creates very large +switch structures and structure initializations. Many C compilers +find it a challenge to compile the resulting output in finite amounts +of time. Many Perl features such as C<goto LABEL> are also not +supported by the optimized C backend. The simple C backend should +work in more instances, but can only offer modest speed increases. + =item -regex <rename_regex> Gives a rule B<rename_regex> - which is a legal perl regular expression - to @@ -808,11 +950,12 @@ create executable file names. =item -verbose <verbose_level> -Show exactly what steps perlcc is taking to compile your code. You can change -the verbosity level B<verbose_level> much in the same way that the '-D' switch -changes perl's debugging level, by giving either a number which is the sum of -bits you want or a list of letters representing what you wish to see. Here are -the verbosity levels so far : +Show exactly what steps perlcc is taking to compile your code. You can +change the verbosity level B<verbose_level> much in the same way that +the C<-D> switch changes perl's debugging level, by giving either a +number which is the sum of bits you want or a list of letters +representing what you wish to see. Here are the verbosity levels so +far : Bit 1(g): Code Generation Errors to STDERR Bit 2(a): Compilation Errors to STDERR @@ -839,14 +982,14 @@ manually. =item -argv <arguments> -In combination with '-run' or '-e', tells perlcc to run the resulting +In combination with C<-run> or C<-e>, tells perlcc to run the resulting executable with the string B<arguments> as @ARGV. =item -sav Tells perl to save the intermediate C code. Usually, this C code is the name of the perl code, plus '.c'; 'perlcode.p' gets generated in 'perlcode.p.c', -for example. If used with the '-e' operator, you need to tell perlcc where to +for example. If used with the C<-e> operator, you need to tell perlcc where to save resulting executables. =item -gen @@ -887,7 +1030,7 @@ indicate a perl program, and: .pm$ indicate a library, for the purposes of creating executables. And furthermore, -by default, these extensions will be replaced (and dropped ) in the process of +by default, these extensions will be replaced (and dropped) in the process of creating an executable. To change the extensions which are programs, and which are modules, set the @@ -921,6 +1064,14 @@ setenv PERL_SCRIPT_EXT '\.\.\.\.\.' which would have the effect of compiling ANYTHING (except what is in PERL_MODULE_EXT) into an executable with 5 less characters in its name. +The PERLCC_OPTS environment variable can be set to the default flags +that must be used by the compiler. + +The PERLCC_TIMEOUT environment variable can be set to the number of +seconds to wait for the backends before giving up. This is sometimes +necessary to avoid some compilers taking forever to compile the +generated output. May not work on Windows and similar platforms. + =head1 FILES 'perlcc' uses a temporary file when you use the B<-e> option to evaluate @@ -932,8 +1083,14 @@ perlc$$ =head1 BUGS +The whole compiler suite (C<perlcc> included) should be considered very +experimental. Use for production purposes is strongly discouraged. + perlcc currently cannot compile shared objects on Win32. This should be fixed -by perl5.005. +in future. + +Bugs in the various compiler backends still exist, and are perhaps too +numerous to list here. =cut diff --git a/utils/perldoc.PL b/utils/perldoc.PL index 875cd25144..7dc478b4e7 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -47,7 +47,7 @@ print OUT <<'!NO!SUBS!'; # man replacement, written in perl. This perldoc is strictly for reading # the perl manuals, though it too is written in perl. -if(@ARGV<1) { +if (@ARGV<1) { my $me = $0; # Editing $0 is unportable $me =~ s,.*/,,; die <<EOF; @@ -82,7 +82,7 @@ perldoc [options] -q FAQRegex Options: -h Display this help message -r Recursive search (slow) - -i Ignore case + -i Ignore case -t Display pod using pod2text instead of pod2man and nroff (-t is the default on win32) -u Display unformatted pod text @@ -91,13 +91,13 @@ Options: -F Arguments are file names, not modules -v Verbosely describe what's going on -X use index if present (looks for pod.idx at $Config{archlib}) - + -q Search the text of questions (not answers) in perlfaq[1-9] PageName|ModuleName... - is the name of a piece of documentation that you want to look at. You + is the name of a piece of documentation that you want to look at. You may either give a descriptive name of the page (as in the case of - `perlfunc') the name of a module, either like `Term::Info', - `Term/Info', the partial name of a module, like `info', or + `perlfunc') the name of a module, either like `Term::Info', + `Term/Info', the partial name of a module, like `info', or `makemaker', or the name of a program, like `perldoc'. BuiltinFunction @@ -108,14 +108,14 @@ FAQRegex is a regex. Will search perlfaq[1-9] for and extract any questions that match. -Any switches in the PERLDOC environment variable will be used before the +Any switches in the PERLDOC environment variable will be used before the command line arguments. The optional pod index file contains a list of filenames, one per line. EOF } -if( defined $ENV{"PERLDOC"} ) { +if (defined $ENV{"PERLDOC"}) { require Text::ParseWords; unshift(@ARGV, Text::ParseWords::shellwords($ENV{"PERLDOC"})); } @@ -134,14 +134,18 @@ print OUT <<'!NO!SUBS!'; usage if $opt_h; my $podidx; -if( $opt_X ) { +if ($opt_X) { $podidx = "$Config{'archlib'}/pod.idx"; $podidx = "" unless -f $podidx && -r _ && -M _ <= 7; } -if( (my $opts = do{ local $^W; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) { +if ((my $opts = do{ local $^W; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) { usage("only one of -t, -u, -m or -l") -} elsif ($Is_MSWin32 || $Is_Dos) { +} +elsif ($Is_MSWin32 + || $Is_Dos + || !(exists $ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i)) +{ $opt_t = 1 unless $opts } @@ -149,11 +153,13 @@ if ($opt_t) { require Pod::Text; import Pod::Text; } my @pages; if ($opt_f) { - @pages = ("perlfunc"); -} elsif ($opt_q) { - @pages = ("perlfaq1" .. "perlfaq9"); -} else { - @pages = @ARGV; + @pages = ("perlfunc"); +} +elsif ($opt_q) { + @pages = ("perlfaq1" .. "perlfaq9"); +} +else { + @pages = @ARGV; } # Does this look like a module or extension directory? @@ -164,15 +170,13 @@ if (-f "Makefile.PL") { require ExtUtils::testlib; } - - sub containspod { my($file, $readit) = @_; return 1 if !$readit && $file =~ /\.pod$/i; local($_); open(TEST,"<$file"); - while(<TEST>) { - if(/^=head/) { + while (<TEST>) { + if (/^=head/) { close(TEST); return 1; } @@ -186,9 +190,9 @@ sub minus_f_nocase { my $path = join('/',$dir,$file); return $path if -f $path and -r _; if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') { - # on a case-forgiving file system or if case is important + # on a case-forgiving file system or if case is important # that is it all we can do - warn "Ignored $file: unreadable\n" if -f _; + warn "Ignored $path: unreadable\n" if -f _; return ''; } local *DIR; @@ -198,7 +202,7 @@ sub minus_f_nocase { foreach $p (split(/\//, $file)){ my $try = "@p/$p"; stat $try; - if (-d _){ + if (-d _) { push @p, $p; if ( $p eq $global_target) { my $tmp_path = join ('/', @p); @@ -209,11 +213,14 @@ sub minus_f_nocase { push (@global_found, $tmp_path) unless $path_f; print STDERR "Found as @p but directory\n" if $opt_v; } - } elsif (-f _ && -r _) { + } + elsif (-f _ && -r _) { return $try; - } elsif (-f _) { + } + elsif (-f _) { warn "Ignored $try: unreadable\n"; - } else { + } + else { my $found=0; my $lcp = lc $p; opendir DIR, "@p"; @@ -227,18 +234,19 @@ sub minus_f_nocase { return "" unless $found; push @p, $cip; return "@p" if -f "@p" and -r _; - warn "Ignored $file: unreadable\n" if -f _; + warn "Ignored @p: unreadable\n" if -f _; } } return ""; } - + sub check_file { my($dir,$file) = @_; if ($opt_m) { return minus_f_nocase($dir,$file); - } else { + } + else { my $path = minus_f_nocase($dir,$file); return $path if length $path and containspod($path); } @@ -264,7 +272,7 @@ sub searchfor { or ( $ret = check_file $dir,$s) or ( $Is_VMS and $ret = check_file $dir,"$s.com") - or ( $^O eq 'os2' and + or ( $^O eq 'os2' and $ret = check_file $dir,"$s.cmd") or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and $ret = check_file $dir,"$s.bat") @@ -273,7 +281,7 @@ sub searchfor { ) { return $ret; } - + if ($recurse) { opendir(D,$dir); my @newdirs = map "$dir/$_", grep { @@ -291,73 +299,150 @@ sub searchfor { return (); } +sub filter_nroff { + my @data = split /\n{2,}/, shift; + shift @data while @data and $data[0] !~ /\S/; # Go to header + shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header + pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like + # 28/Jan/99 perl 5.005, patch 53 1 + join "\n\n", @data; +} + +sub printout { + my ($file, $tmp, $filter) = @_; + my $err; + + if ($opt_t) { + open(OUT,">>$tmp") or warn("Can't open $tmp: $!"), return; + Pod::Text->new()->parse_from_file($file,\*OUT); + close OUT; + } + elsif (not $opt_u) { + my $cmd = "pod2man --lax $file | nroff -man"; + $cmd .= " | col -x" if $^O =~ /hpux/; + my $rslt = `$cmd`; + $rslt = filter_nroff($rslt) if $filter; + unless (($err = $?)) { + open(TMP,">>$tmp") or warn("Can't open $tmp: $!"), return; + print TMP $rslt; + close TMP; + } + } + if ($opt_u or $err or -z $tmp) { + open(OUT,">>$tmp") or warn("Can't open $tmp: $!"), return; + open(IN,"<$file") or warn("Can't open $file: $!"), return; + my $cut = 1; + while (<IN>) { + $cut = $1 eq 'cut' if /^=(\w+)/; + next if $cut; + print OUT; + } + close IN; + close OUT; + } +} + +sub page { + my ($tmp, $no_tty, @pagers) = @_; + if ($no_tty) { + open(TMP,"<$tmp") or warn("Can't open $tmp: $!"), return; + print while <TMP>; + close TMP; + } + else { + foreach my $pager (@pagers) { + system("$pager $tmp") or last; + } + } +} + +sub cleanup { + my @files = @_; + for (@files) { + 1 while unlink($_); #Possibly pointless VMSism + } +} + +sub safe_exit { + my ($val, @files) = @_; + cleanup(@files); + exit $val; +} + +sub safe_die { + my ($msg, @files) = @_; + cleanup(@files); + die $msg; +} + my @found; foreach (@pages) { - if ($podidx && open(PODIDX, $podidx)) { - my $searchfor = $_; - local($_); - $searchfor =~ s,::,/,g; - print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v; - while (<PODIDX>) { - chomp; - push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?$,i; - } - close(PODIDX); - next; - } - print STDERR "Searching for $_\n" if $opt_v; - # We must look both in @INC for library modules and in PATH - # for executables, like h2xs or perldoc itself. - my @searchdirs = @INC; - if ($opt_F) { - next unless -r; - push @found, $_ if $opt_m or containspod($_); - next; + if ($podidx && open(PODIDX, $podidx)) { + my $searchfor = $_; + local($_); + $searchfor =~ s,::,/,g; + print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v; + while (<PODIDX>) { + chomp; + push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?$,i; } - unless ($opt_m) { - if ($Is_VMS) { - my($i,$trn); - for ($i = 0; $trn = $ENV{'DCL$PATH'.$i}; $i++) { - push(@searchdirs,$trn); - } - push(@searchdirs,'perl_root:[lib.pod]') # installed pods - } else { - push(@searchdirs, grep(-d, split($Config{path_sep}, - $ENV{'PATH'}))); + close(PODIDX); + next; + } + print STDERR "Searching for $_\n" if $opt_v; + # We must look both in @INC for library modules and in PATH + # for executables, like h2xs or perldoc itself. + my @searchdirs = @INC; + if ($opt_F) { + next unless -r; + push @found, $_ if $opt_m or containspod($_); + next; + } + unless ($opt_m) { + if ($Is_VMS) { + my($i,$trn); + for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) { + push(@searchdirs,$trn); } + push(@searchdirs,'perl_root:[lib.pod]') # installed pods + } + else { + push(@searchdirs, grep(-d, split($Config{path_sep}, + $ENV{'PATH'}))); + } + } + my @files = searchfor(0,$_,@searchdirs); + if (@files) { + print STDERR "Found as @files\n" if $opt_v; + } + else { + # no match, try recursive search + @searchdirs = grep(!/^\.$/,@INC); + @files= searchfor(1,$_,@searchdirs) if $opt_r; + if (@files) { + print STDERR "Loosely found as @files\n" if $opt_v; } - my @files = searchfor(0,$_,@searchdirs); - if( @files ) { - print STDERR "Found as @files\n" if $opt_v; - } else { - # no match, try recursive search - - @searchdirs = grep(!/^\.$/,@INC); - - @files= searchfor(1,$_,@searchdirs) if $opt_r; - if( @files ) { - print STDERR "Loosely found as @files\n" if $opt_v; - } else { - print STDERR "No documentation found for \"$_\".\n"; - if (@global_found) { - print STDERR "However, try\n"; - for my $dir (@global_found) { - opendir(DIR, $dir) or die "$!"; - while (my $file = readdir(DIR)) { - next if ($file =~ /^\./); - $file =~ s/\.(pm|pod)$//; - print STDERR "\tperldoc $_\::$file\n"; - } - closedir DIR; - } - } + else { + print STDERR "No documentation found for \"$_\".\n"; + if (@global_found) { + print STDERR "However, try\n"; + for my $dir (@global_found) { + opendir(DIR, $dir) or die "$!"; + while (my $file = readdir(DIR)) { + next if ($file =~ /^\./); + $file =~ s/\.(pm|pod)$//; + print STDERR "\tperldoc $_\::$file\n"; + } + closedir DIR; } + } } - push(@found,@files); + } + push(@found,@files); } -if(!@found) { - exit ($Is_VMS ? 98962 : 1); +if (!@found) { + exit ($Is_VMS ? 98962 : 1); } if ($opt_l) { @@ -368,172 +453,143 @@ if ($opt_l) { my $lines = $ENV{LINES} || 24; my $no_tty; -if( ! -t STDOUT ) { $no_tty = 1 } +if (! -t STDOUT) { $no_tty = 1 } + +# until here we could simply exit or die +# now we create temporary files that we have to clean up +# namely $tmp, $buffer my $tmp; +my $buffer; if ($Is_MSWin32) { - $tmp = "$ENV{TEMP}\\perldoc1.$$"; - push @pagers, qw( more< less notepad ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; -} elsif ($Is_VMS) { - $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$; - push @pagers, qw( most more less type/page ); -} elsif ($Is_Dos) { - $tmp = "$ENV{TEMP}/perldoc1.$$"; - $tmp =~ tr!\\/!//!s; - push @pagers, qw( less.exe more.com< ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; -} else { - if ($^O eq 'os2') { - require POSIX; - $tmp = POSIX::tmpnam(); - unshift @pagers, 'less', 'cmd /c more <'; - } else { - $tmp = "/tmp/perldoc1.$$"; - } - push @pagers, qw( more less pg view cat ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + $tmp = "$ENV{TEMP}\\perldoc1.$$"; + $buffer = "$ENV{TEMP}\\perldoc1.b$$"; + push @pagers, qw( more< less notepad ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + for (@found) { s,/,\\,g } +} +elsif ($Is_VMS) { + $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$; + $buffer = 'Sys$Scratch:perldoc.tmp1_b'.$$; + push @pagers, qw( most more less type/page ); +} +elsif ($Is_Dos) { + $tmp = "$ENV{TEMP}/perldoc1.$$"; + $buffer = "$ENV{TEMP}/perldoc1.b$$"; + $tmp =~ tr!\\/!//!s; + $buffer =~ tr!\\/!//!s; + push @pagers, qw( less.exe more.com< ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; +} +else { + if ($^O eq 'os2') { + require POSIX; + $tmp = POSIX::tmpnam(); + $buffer = POSIX::tmpnam(); + unshift @pagers, 'less', 'cmd /c more <'; + } + else { + $tmp = "/tmp/perldoc1.$$"; + $buffer = "/tmp/perldoc1.b$$"; + } + push @pagers, qw( more less pg view cat ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; } unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER}; +# all exit calls from here on have to be safe_exit calls (see above) +# and all die calls safe_die calls to guarantee removal of files and +# dir as needed + if ($opt_m) { - foreach my $pager (@pagers) { - system("$pager @found") or exit; - } - if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' } - exit 1; -} + foreach my $pager (@pagers) { + system("$pager @found") or safe_exit(0, $tmp, $buffer); + } + if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' } + # I don't get the line above. Please patch yourself as needed. + safe_exit(1, $tmp, $buffer); +} +my @pod; if ($opt_f) { - my $perlfunc = shift @found; - open(PFUNC, $perlfunc) or die "Can't open $perlfunc: $!"; - - # Skip introduction - while (<PFUNC>) { - last if /^=head2 Alphabetical Listing of Perl Functions/; - } - - # Look for our function - my $found = 0; - my @pod; - while (<PFUNC>) { - if (/^=item\s+\Q$opt_f\E\b/o) { - $found = 1; - } elsif (/^=item/) { - last if $found > 1; - } - next unless $found; - push @pod, $_; - ++$found if /^\w/; # found descriptive text - } - if (@pod) { - if ($opt_t) { - open(FORMATTER, "| pod2text") || die "Can't start filter"; - print FORMATTER "=over 8\n\n"; - print FORMATTER @pod; - print FORMATTER "=back\n"; - close(FORMATTER); - } elsif (@pod < $lines-2) { - print @pod; - } else { - foreach my $pager (@pagers) { - open (PAGER, "| $pager") or next; - print PAGER @pod ; - close(PAGER) or next; - last; - } - } - } else { - die "No documentation for perl function `$opt_f' found\n"; - } - exit; -} + my $perlfunc = shift @found; + open(PFUNC, $perlfunc) + or safe_die("Can't open $perlfunc: $!", $tmp, $buffer); -if ($opt_q) { - local @ARGV = @found; # I'm lazy, sue me. - my $found = 0; - my %found_in; - my @pod; - - while (<>) { - if (/^=head2\s+.*$opt_q/oi) { - $found = 1; - push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++; - } elsif (/^=head2/) { - $found = 0; - } - next unless $found; - push @pod, $_; - } - - if (@pod) { - if ($opt_t) { - open(FORMATTER, "| pod2text") || die "Can't start filter"; - print FORMATTER "=over 8\n\n"; - print FORMATTER @pod; - print FORMATTER "=back\n"; - close(FORMATTER); - } elsif (@pod < $lines-2) { - print @pod; - } else { - foreach my $pager (@pagers) { - open (PAGER, "| $pager") or next; - print PAGER @pod ; - close(PAGER) or next; - last; - } - } - } else { - die "No documentation for perl FAQ keyword `$opt_q' found\n"; - } - exit; -} + # Functions like -r, -e, etc. are listed under `-X'. + my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) + ? 'I<-X' : $opt_f ; -foreach (@found) { + # Skip introduction + while (<PFUNC>) { + last if /^=head2 Alphabetical Listing of Perl Functions/; + } - my $err; - if($opt_t) { - open(TMP,">>$tmp"); - Pod::Text::pod2text($_,*TMP); - close(TMP); - } elsif(not $opt_u) { - my $cmd = "pod2man --lax $_ | nroff -man"; - $cmd .= " | col -x" if $^O =~ /hpux/; - my $rslt = `$cmd`; - unless(($err = $?)) { - open(TMP,">>$tmp"); - print TMP $rslt; - close TMP; - } + # Look for our function + my $found = 0; + my $inlist = 0; + while (<PFUNC>) { + if (/^=item\s+\Q$search_string\E\b/o) { + $found = 1; } - - if( $opt_u or $err or -z $tmp) { - open(OUT,">>$tmp"); - open(IN,"<$_"); - my $cut = 1; - while (<IN>) { - $cut = $1 eq 'cut' if /^=(\w+)/; - next if $cut; - print OUT; - } - close(IN); - close(OUT); + elsif (/^=item/) { + last if $found > 1 and not $inlist; + } + next unless $found; + if (/^=over/) { + ++$inlist; } + elsif (/^=back/) { + --$inlist; + } + push @pod, $_; + ++$found if /^\w/; # found descriptive text + } + if (!@pod) { + die "No documentation for perl function `$opt_f' found\n"; + } } -if( $no_tty ) { - open(TMP,"<$tmp"); - print while <TMP>; - close(TMP); -} else { - foreach my $pager (@pagers) { - system("$pager $tmp") or last; +if ($opt_q) { + local @ARGV = @found; # I'm lazy, sue me. + my $found = 0; + my %found_in; + + while (<>) { + if (/^=head2\s+.*(?:$opt_q)/oi) { + $found = 1; + push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++; } + elsif (/^=head2/) { + $found = 0; + } + next unless $found; + push @pod, $_; + } + if (!@pod) { + safe_die("No documentation for perl FAQ keyword `$opt_q' found\n", + $tmp, $buffer); + } } -1 while unlink($tmp); #Possibly pointless VMSism +my $filter; + +if (@pod) { + open(TMP,">$buffer") or safe_die("Can't open '$buffer': $!", $tmp, $buffer); + print TMP "=over 8\n\n"; + print TMP @pod; + print TMP "=back\n"; + close TMP; + @found = $buffer; + $filter = 1; +} + +foreach (@found) { + printout($_, $tmp, $filter); +} +page($tmp, $no_tty, @pagers); -exit 0; +safe_exit(0, $tmp, $buffer); __END__ @@ -617,7 +673,7 @@ contain fully qualified filenames, one per line. The item you want to look up. Nested modules (such as C<File::Basename>) are specified either as C<File::Basename> or C<File/Basename>. You may also -give a descriptive name of a page, such as C<perlfunc>. You make also give a +give a descriptive name of a page, such as C<perlfunc>. You may also give a partial or wrong-case name, such as "basename" for "File::Basename", but this will be slower, if there is more then one page with the same partial name, you will only get the first one. @@ -626,7 +682,7 @@ name, you will only get the first one. =head1 ENVIRONMENT -Any switches in the C<PERLDOC> environment variable will be used before the +Any switches in the C<PERLDOC> environment variable will be used before the command line arguments. C<perldoc> also searches directories specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not defined) and C<PATH> environment variables. @@ -636,11 +692,18 @@ preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or C<PAGER> before trying to find a pager on its own. (C<MANPAGER> is not used if C<perldoc> was told to display plain text or unformatted pod.) +One useful value for C<PERLDOC_PAGER> is C<less -+C -E>. + +=head1 VERSION + +This is perldoc v2.0. + =head1 AUTHOR Kenneth Albanowski <kjahds@kjahds.com> -Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu> +Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>, +and others. =cut @@ -658,7 +721,7 @@ Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu> # Kenneth Albanowski <kjahds@kjahds.com> # -added Charles Bailey's further VMS patches, and -u switch # -added -t switch, with pod2text support -# +# # Version 1.10: Thu Nov 9 07:23:47 EST 1995 # Kenneth Albanowski <kjahds@kjahds.com> # -added VMS support |