diff options
Diffstat (limited to 'contrib/perl5/utils')
| -rw-r--r-- | contrib/perl5/utils/Makefile | 13 | ||||
| -rw-r--r-- | contrib/perl5/utils/dprofpp.PL | 838 | ||||
| -rw-r--r-- | contrib/perl5/utils/h2ph.PL | 8 | ||||
| -rw-r--r-- | contrib/perl5/utils/h2xs.PL | 1084 | ||||
| -rw-r--r-- | contrib/perl5/utils/perlbc.PL | 80 | ||||
| -rw-r--r-- | contrib/perl5/utils/perlbug.PL | 168 | ||||
| -rw-r--r-- | contrib/perl5/utils/perlcc.PL | 414 | ||||
| -rw-r--r-- | contrib/perl5/utils/perldoc.PL | 706 |
8 files changed, 2677 insertions, 634 deletions
diff --git a/contrib/perl5/utils/Makefile b/contrib/perl5/utils/Makefile index 2df16d8..944cbe8 100644 --- a/contrib/perl5/utils/Makefile +++ b/contrib/perl5/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/contrib/perl5/utils/dprofpp.PL b/contrib/perl5/utils/dprofpp.PL new file mode 100644 index 0000000..51e8d78 --- /dev/null +++ b/contrib/perl5/utils/dprofpp.PL @@ -0,0 +1,838 @@ +#!/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 'OS2'); # "case-forgiving" +$file =~ s/\.pl$/.com/ if ($Config{'osname'} eq 'VMS'); # "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/contrib/perl5/utils/h2ph.PL b/contrib/perl5/utils/h2ph.PL index 6011d98..0b0208b 100644 --- a/contrib/perl5/utils/h2ph.PL +++ b/contrib/perl5/utils/h2ph.PL @@ -528,7 +528,7 @@ sub inc_dirs sub build_preamble_if_necessary { # Increment $VERSION every time this function is modified: - my $VERSION = 1; + my $VERSION = 2; my $preamble = "$Dest_dir/_h2ph_pre.ph"; # Can we skip building the preamble file? @@ -556,6 +556,9 @@ sub build_preamble_if_necessary 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 $_() { \"", @@ -576,8 +579,7 @@ sub _extract_cc_defines # Split compiler pre-definitions into `key=value' pairs: foreach (split /\s+/, $allsymbols) { - /(.*?)=(.*)/; - $define{$1} = $2; + /(.+?)=(.+)/ and $define{$1} = $2; if ($opt_D) { print STDERR "$_: $1 -> $2\n"; diff --git a/contrib/perl5/utils/h2xs.PL b/contrib/perl5/utils/h2xs.PL index 129b01b..ca0e7cb 100644 --- a/contrib/perl5/utils/h2xs.PL +++ b/contrib/perl5/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,12 +71,21 @@ 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> Additional flags to specify to C preprocessor when scanning header for -function declarations. Should not be used without B<-x>. +function declarations. Should not be used without B<-x>. + +=item B<-M> I<regular expression> + +selects functions/macros to process. =item B<-O> @@ -89,7 +98,21 @@ 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<-a> + +Generate an accessor method for each element of structs and unions. The +generated methods are named after the element name; will return the current +value of the element if called without additional arguments; and will set +the element to the supplied value (and return the new value) if called with +an additional argument. Embedded structures and unions are returned as a +pointer rather than the complete structure, to facilitate chained calls. + +These methods all apply to the Ptr type for the structure; additionally +two methods are constructed for the structure type itself, C<_to_ptr> +which returns a Ptr type pointing to the same structure, and a C<new> +method to construct and return a new structure, initialised to zeroes. =item B<-c> @@ -103,21 +126,46 @@ Turn on debugging messages. =item B<-f> Allows an extension to be created for a header even if that header is -not found in /usr/include. +not found in standard include directories. =item B<-h> Print the usage, help and version for this h2xs and exit. +=item B<-k> + +For function arguments declared as C<const>, omit the const attribute in the +generated XS code. + +=item B<-m> + +B<Experimental>: for each variable declared in the header file(s), declare +a perl variable of the same name magically tied to the C variable. + =item B<-n> I<module_name> Specifies a name to be used for the extension, e.g., S<-n RPC::DCE> +=item B<-o> I<regular expression> + +Use "opaque" data type for the C types matched by the regular +expression, even if these types are C<typedef>-equivalent to types +from typemaps. Should not be used without B<-x>. + +This may be useful since, say, types which are C<typedef>-equivalent +to integers may represent OS-related handles, and one may want to work +with these handles in OO-way, as in C<$handle-E<gt>do_something()>. +Use C<-o .> if you want to handle all the C<typedef>ed types as opaque types. + +The type-to-match is whitewashed (except for commas, which have no +whitespace before them, and multiple C<*> which have no whitespace +between them). + =item B<-p> I<prefix> 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> @@ -140,7 +188,8 @@ but XSUBs are emitted only for the declarations included from file NAME2. Note that some types of arguments/return-values for functions may result in XSUB-declarations/typemap-entries which need hand-editing. Such may be objects which cannot be converted from/to a -pointer (like C<long long>), pointers to functions, or arrays. +pointer (like C<long long>), pointers to functions, or arrays. See +also the section on L<LIMITATIONS of B<-x>>. =back @@ -193,6 +242,12 @@ pointer (like C<long long>), pointers to functions, or arrays. # Same with function declaration in proto.h as visible from perl.h. h2xs -xAn perl2 perl.h,proto.h + # Same but select only functions which match /^av_/ + h2xs -M '^av_' -xAn perl2 perl.h,proto.h + + # Same but treat SV* etc as "opaque" types + h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h + =head1 ENVIRONMENT No environment variables are used. @@ -209,27 +264,97 @@ L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>. The usual warnings if it cannot read or write the files involved. +=head1 LIMITATIONS of B<-x> + +F<h2xs> would not distinguish whether an argument to a C function +which is of the form, say, C<int *>, is an input, output, or +input/output parameter. In particular, argument declarations of the +form + + int + foo(n) + int *n + +should be better rewritten as + + int + foo(n) + int &n + +if C<n> is an input parameter. + +Additionally, F<h2xs> has no facilities to intuit that a function + + int + foo(addr,l) + char *addr + int l + +takes a pair of address and length of data at this address, so it is better +to rewrite this function as + + int + foo(sv) + SV *addr + PREINIT: + STRLEN len; + char *s; + CODE: + s = SvPV(sv,len); + RETVAL = foo(s, len); + OUTPUT: + RETVAL + +or alternately + + static int + my_foo(SV *sv) + { + STRLEN len; + char *s = SvPV(sv,len); + + return foo(s, len); + } + + MODULE = foo PACKAGE = foo PREFIX = my_ + + int + foo(sv) + SV *sv + +See L<perlxs> and L<perlxstut> for additional details. + =cut -my( $H2XS_VERSION ) = ' $Revision: 1.19 $ ' =~ /\$Revision:\s+([^\s]+)/; +use strict; + + +my( $H2XS_VERSION ) = ' $Revision: 1.20 $ ' =~ /\$Revision:\s+([^\s]+)/; my $TEMPLATE_VERSION = '0.01'; +my @ARGS = @ARGV; 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). + -M Mask to select C functions/macros (default is select all). -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). + -a Generate get/set accessors for struct and union members (used with -x). -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. -h Display this help message + -k Omit 'const' attribute on function arguments (used with -x). + -m Generate tied variables for access to declared variables. -n Specify a name to use for the extension (recommended). + -o Regular expression for \"opaque\" types. -p Specify a prefix which should be removed from the Perl function names. -s Create subroutines for specified macros. -v Specify a version number for this extension. @@ -241,15 +366,25 @@ extra_libraries } -getopts("AF:OPXcdfhn:p:s:v:x") || usage; +getopts("ACF:M:OPXacdfhkmn:o:p:s:v:x") || usage; +use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_a $opt_c $opt_d + $opt_f $opt_h $opt_k $opt_m $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x); usage if $opt_h; if( $opt_v ){ $TEMPLATE_VERSION = $opt_v; } + +# -A implies -c. $opt_c = 1 if $opt_A; -%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s; + +# -X implies -c and -f +$opt_c = $opt_f = 1 if $opt_X; + +my %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s; +my $extralibs; +my @path_h; while (my $arg = shift) { if ($arg =~ /^-l/i) { @@ -262,34 +397,78 @@ while (my $arg = shift) { usage "Must supply header file or module name\n" unless (@path_h or $opt_n); +my $fmask; +my $tmask; + +$fmask = qr{$opt_M} if defined $opt_M; +$tmask = qr{$opt_o} if defined $opt_o; +my $tmask_all = $tmask && $opt_o eq '.'; + +if ($opt_x) { + eval {require C::Scan; 1} + or die <<EOD; +C::Scan required if you use -x option. +To install C::Scan, execute + perl -MCPAN -e "install C::Scan" +EOD + unless ($tmask_all) { + $C::Scan::VERSION >= 0.70 + or die <<EOD; +C::Scan v. 0.70 or later required unless you use -o . option. +You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}. +To install C::Scan, execute + perl -MCPAN -e "install C::Scan" +EOD + } + if (($opt_m || $opt_a) && $C::Scan::VERSION < 0.73) { + die <<EOD; +C::Scan v. 0.73 or later required to use -m or -a options. +You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}. +To install C::Scan, execute + perl -MCPAN -e "install C::Scan" +EOD + } +} +elsif ($opt_o or $opt_F) { + warn <<EOD; +Options -o and -F do not make sense without -x. +EOD +} + +my @path_h_ini = @path_h; +my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names); if( @path_h ){ + use Config; + use File::Spec; + my @paths; + if ($^O eq 'VMS') { # Consider overrides of default location + # XXXX This is not equivalent to what the older version did: + # it was looking at $hadsys header-file per header-file... + my($hadsys) = grep s!^sys/!!i , @path_h; + @paths = qw( Sys$Library VAXC$Include ); + push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]'); + push @paths, qw( DECC$Library_Include DECC$System_Include ); + } + else { + @paths = (File::Spec->curdir(), $Config{usrinc}, + (split ' ', $Config{locincpth}), '/usr/include'); + } foreach my $path_h (@path_h) { $name ||= $path_h; if( $path_h =~ s#::#/#g && $opt_n ){ warn "Nesting of headerfile ignored with -n\n"; } $path_h .= ".h" unless $path_h =~ /\.h$/; - $fullpath = $path_h; + my $fullpath = $path_h; $path_h =~ s/,.*$// if $opt_x; - if ($^O eq 'VMS') { # Consider overrides of default location - if ($path_h !~ m![:>\[]!) { - my($hadsys) = ($path_h =~ s!^sys/!!i); - if ($ENV{'DECC$System_Include'}) { $path_h = "DECC\$System_Include:$path_h"; } - elsif ($ENV{'DECC$Library_Include'}) { $path_h = "DECC\$Library_Include:$path_h"; } - elsif ($ENV{'GNU_CC_Include'}) { $path_h = 'GNU_CC_Include:' . - ($hadsys ? '[vms]' : '[000000]') . $path_h; } - elsif ($ENV{'VAXC$Include'}) { $path_h = "VAXC\$_Include:$path_h"; } - else { $path_h = "Sys\$Library:$path_h"; } - } - } - elsif ($^O eq 'os2') { - $path_h = "/usr/include/$path_h" - if $path_h !~ m#^([a-z]:)?[./]#i and -r "/usr/include/$path_h"; - } - else { - $path_h = "/usr/include/$path_h" - if $path_h !~ m#^[./]# and -r "/usr/include/$path_h"; + $fullpath{$path_h} = $fullpath; + + if (not -f $path_h) { + my $tmp_path_h = $path_h; + for my $dir (@paths) { + last if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h)); + } } if (!$opt_c) { @@ -298,10 +477,24 @@ if( @path_h ){ # Record the names of simple #define constants into const_names # Function prototypes are processed below. open(CH, "<$path_h") || die "Can't open $path_h: $!\n"; + defines: while (<CH>) { - if (/^#[ \t]*define\s+([\$\w]+)\b\s*[^("]/) { - print "Matched $_ ($1)\n" if $opt_d; - $_ = $1; + if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^" \t])(.*)/) { + my $def = $1; + my $rest = $2; + $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments + $rest =~ s/^\s+//; + $rest =~ s/\s+$//; + # Cannot do: (-1) and ((LHANDLE)3) are OK: + #print("Skip non-wordy $def => $rest\n"), + # next defines if $rest =~ /[^\w\$]/; + if ($rest =~ /"/) { + print("Skip stringy $def => $rest\n") if $opt_d; + next defines; + } + print "Matched $_ ($def)\n" if $opt_d; + $seen_define{$def} = $rest; + $_ = $def; next if /^_.*_h_*$/i; # special case, but for what? if (defined $opt_p) { if (!/^$opt_p(\d)/) { @@ -311,17 +504,20 @@ if( @path_h ){ warn "can't remove $opt_p prefix from '$_'!\n"; } } - $const_names{$_}++; + $prefixless{$def} = $_; + if (!$fmask or /$fmask/) { + print "... Passes mask of -M.\n" if $opt_d and $fmask; + $const_names{$_}++; + } } } close(CH); } } - @const_names = sort keys %const_names; } -$module = $opt_n || do { +my $module = $opt_n || do { $name =~ s/\.h$//; if( $name !~ /::/ ){ $name =~ s#^.*/##; @@ -330,6 +526,7 @@ $module = $opt_n || do { $name; }; +my ($ext, $nested, @modparts, $modfname, $modpname); (chdir 'ext', $ext = 'ext/') if -d 'ext'; if( $module =~ /::/ ){ @@ -347,11 +544,12 @@ else { if ($opt_O) { warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname; -} else { +} +else { die "Won't overwrite existing $ext$modpname\n" if -e $modpname; } if( $nested ){ - $modpath = ""; + my $modpath = ""; foreach (@modparts){ mkdir("$modpath$_", 0777); $modpath .= "$_/"; @@ -362,36 +560,125 @@ 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 = []; +my $typedef_rex; +my %typedefs_pre; +my %known_fnames; +my %structs; + +my @fnames; +my @fnames_no_prefix; +my %vdecl_hash; +my @vdecls; if( ! $opt_X ){ # use XS, unless it was disabled open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n"; if ($opt_x) { - require C::Scan; # Run-time directive require Config; # Run-time directive warn "Scanning typemaps...\n"; get_typemap(); - my $c; - my $filter; - my @fdecls; - foreach my $filename (@path_h) { + my @td; + my @good_td; my $addflags = $opt_F || ''; - if ($fullpath =~ /,/) { - $filename = $`; - $filter = $'; + + foreach my $filename (@path_h) { + my $c; + my $filter; + + if ($fullpath{$filename} =~ /,/) { + $filename = $`; + $filter = $'; + } + warn "Scanning $filename for functions...\n"; + $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter, + 'add_cppflags' => $addflags, 'c_styles' => [qw(C++ C9X)]; + $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]); + + push @$fdecls_parsed, @{ $c->get('parsed_fdecls') }; + push(@$fdecls, @{$c->get('fdecls')}); + + push @td, @{$c->get('typedefs_maybe')}; + if ($opt_a) { + my $structs = $c->get('typedef_structs'); + @structs{keys %$structs} = values %$structs; + } + + if ($opt_m) { + %vdecl_hash = %{ $c->get('vdecl_hash') }; + @vdecls = sort keys %vdecl_hash; + for (local $_ = 0; $_ < @vdecls; ++$_) { + my $var = $vdecls[$_]; + my($type, $post) = @{ $vdecl_hash{$var} }; + if (defined $post) { + warn "Can't handle variable '$type $var $post', skipping.\n"; + splice @vdecls, $_, 1; + redo; + } + $type = normalize_type($type); + $vdecl_hash{$var} = $type; + } + } + + unless ($tmask_all) { + warn "Scanning $filename for typedefs...\n"; + my $td = $c->get('typedef_hash'); + # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d; + my @f_good_td = grep $td->{$_}[1] eq '', keys %$td; + push @good_td, @f_good_td; + @typedefs_pre{@f_good_td} = map $_->[0], @$td{@f_good_td}; + } + } + { local $" = '|'; + $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td; + } + %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT + if ($fmask) { + my @good; + for my $i (0..$#$fdecls_parsed) { + next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME + push @good, $i; + print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n" + if $opt_d; + } + $fdecls = [@$fdecls[@good]]; + $fdecls_parsed = [@$fdecls_parsed[@good]]; + } + @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME + # Sort declarations: + { + my %h = map( ($_->[1], $_), @$fdecls_parsed); + $fdecls_parsed = [ @h{@fnames} ]; + } + @fnames_no_prefix = @fnames; + @fnames_no_prefix + = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix; + # Remove macros which expand to typedefs + print "Typedefs are @td.\n" if $opt_d; + my %td = map {($_, $_)} @td; + # Add some other possible but meaningless values for macros + for my $k (qw(char double float int long short unsigned signed void)) { + $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned '); + } + # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@; + my $n = 0; + my %bad_macs; + while (keys %td > $n) { + $n = keys %td; + my ($k, $v); + while (($k, $v) = each %seen_define) { + # print("found '$k'=>'$v'\n"), + $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v}; + } + } + # Now %bad_macs contains names of bad macros + for my $k (keys %bad_macs) { + delete $const_names{$prefixless{$k}}; + print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d; } - 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 ]; } } +my @const_names = sort keys %const_names; open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n"; @@ -401,21 +688,16 @@ warn "Writing $ext$modpname/$modfname.pm\n"; print PM <<"END"; package $module; +require 5.005_62; use strict; +use warnings; END -if( $opt_X || $opt_c || $opt_A ){ - # we won't have our own AUTOLOAD(), so won't have $AUTOLOAD - print PM <<'END'; -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); -END -} -else{ +unless( $opt_X || $opt_c || $opt_A ){ # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and # will want Carp. print PM <<'END'; use Carp; -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); END } @@ -428,58 +710,50 @@ 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"; +# Determine @ISA. +my $myISA = 'our @ISA = qw(Exporter'; # We seem to always want this. +$myISA .= ' DynaLoader' unless $opt_X; # no XS +$myISA .= ');'; +print PM "\n$myISA\n\n"; -\@ISA = qw(Exporter); -END - } -} +my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls); print PM<<"END"; # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. -\@EXPORT = qw( + +# This allows declaration use $module ':all'; +# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK +# will save memory. +our %EXPORT_TAGS = ( 'all' => [ qw( + @exported_names +) ] ); + +our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } ); + +our \@EXPORT = qw( @const_names ); -\$VERSION = '$TEMPLATE_VERSION'; +our \$VERSION = '$TEMPLATE_VERSION'; END +if (@vdecls) { + printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n"; +} + print PM <<"END" unless $opt_c or $opt_X; sub AUTOLOAD { # This AUTOLOAD is used to 'autoload' constants from the constant() @@ -487,20 +761,29 @@ sub AUTOLOAD { # to the AUTOLOAD in AutoLoader. my \$constname; + our \$AUTOLOAD; (\$constname = \$AUTOLOAD) =~ s/.*:://; 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; } else { - croak "Your vendor has not defined $module macro \$constname"; + croak "Your vendor has not defined $module macro \$constname"; + } + } + { + no strict 'refs'; + # Fixed between 5.005_53 and 5.005_61 + if (\$] >= 5.00561) { + *\$AUTOLOAD = sub () { \$val }; + } + else { + *\$AUTOLOAD = sub { \$val }; } } - no strict 'refs'; - *\$AUTOLOAD = sub () { \$val }; goto &\$AUTOLOAD; } @@ -512,6 +795,17 @@ bootstrap $module \$VERSION; END } +# tying the variables can happen only after bootstrap +if (@vdecls) { + printf PM <<END; +{ +@{[ join "\n", map " _tievar_$_(\$$_);", @vdecls ]} +} + +END +} + +my $after; if( $opt_P ){ # if POD is disabled $after = '__END__'; } @@ -522,37 +816,71 @@ 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__ END -$author = "A. U. Thor"; -$email = 'a.u.thor@a.galaxy.far.far.away'; +my $author = "A. U. Thor"; +my $email = 'a.u.thor@a.galaxy.far.far.away'; + +my $revhist = ''; +$revhist = <<EOT if $opt_C; + +=head1 HISTORY -my $const_doc = ''; -my $fdecl_doc = ''; +=over 8 + +=item $TEMPLATE_VERSION + +Original version; created by h2xs $H2XS_VERSION with options + + @ARGS + +=back + +EOT + +my $exp_doc = <<EOD; + +=head2 EXPORT + +None by default. + +EOD if (@const_names and not $opt_P) { - $const_doc = <<EOD; -\n=head1 Exported constants + $exp_doc .= <<EOD; +=head2 Exportable constants @{[join "\n ", @const_names]} EOD } if (defined $fdecls and @$fdecls and not $opt_P) { - $fdecl_doc = <<EOD; -\n=head1 Exported functions + $exp_doc .= <<EOD; +=head2 Exportable functions + +EOD + $exp_doc .= <<EOD if $opt_p; +When accessing these functions from Perl, prefix C<$opt_p> should be removed. - @{[join "\n ", @$fdecls]} +EOD + $exp_doc .= <<EOD; + @{[join "\n ", @known_fnames{@fnames}]} EOD } -$pod = <<"END" unless $opt_P; -## Below is the stub of documentation for your module. You better edit it! +my $pod = <<"END" unless $opt_P; +## Below is stub documentation for your module. You better edit it! # #=head1 NAME # @@ -565,12 +893,12 @@ $pod = <<"END" unless $opt_P; # #=head1 DESCRIPTION # -#Stub documentation for $module was created by h2xs. It looks like the +#Stub documentation for $module, created by h2xs. It looks like the #author of the extension was negligent enough to leave the stub #unedited. # #Blah blah blah. -#$const_doc$fdecl_doc +#$exp_doc$revhist #=head1 AUTHOR # #$author, $email @@ -598,7 +926,7 @@ print XS <<"END"; END if( @path_h ){ - foreach my $path_h (@path_h) { + foreach my $path_h (@path_h_ini) { my($h) = $path_h; $h =~ s#^/usr/include/##; if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; } @@ -607,54 +935,185 @@ if( @path_h ){ print XS "\n"; } -if( ! $opt_c ){ -print XS <<"END"; -static int -not_here(char *s) +my %pointer_typedefs; +my %struct_typedefs; + +sub td_is_pointer { + my $type = shift; + my $out = $pointer_typedefs{$type}; + return $out if defined $out; + my $otype = $type; + $out = ($type =~ /\*$/); + # This converts only the guys which do not have trailing part in the typedef + if (not $out + and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { + $type = normalize_type($type); + print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n" + if $opt_d; + $out = td_is_pointer($type); + } + return ($pointer_typedefs{$otype} = $out); +} + +sub td_is_struct { + my $type = shift; + my $out = $struct_typedefs{$type}; + return $out if defined $out; + my $otype = $type; + $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type); + # This converts only the guys which do not have trailing part in the typedef + if (not $out + and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { + $type = normalize_type($type); + print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n" + if $opt_d; + $out = td_is_struct($type); + } + return ($struct_typedefs{$otype} = $out); +} + +# Some macros will bomb if you try to return them from a double-returning func. +# Say, ((char *)0), or strlen (if somebody #define STRLEN strlen). +# Fortunately, we can detect both these cases... +sub protect_convert_to_double { + my $in = shift; + my $val; + return '' unless defined ($val = $seen_define{$in}); + return '(IV)' if $known_fnames{$val}; + # OUT_t of ((OUT_t)-1): + return '' unless $val =~ /^\s*(\(\s*)?\(\s*([^()]*?)\s*\)/; + td_is_pointer($2) ? '(IV)' : ''; +} + +# For each of the generated functions, length($pref) leading +# letters are already checked. Moreover, it is recommended that +# the generated functions uses switch on letter at offset at least +# $off + length($pref). +# +# The given list has length($pref) chars removed at front, it is +# guarantied that $off leading chars in the rest are the same for all +# elts of the list. +# +# Returns: how at which offset it was decided to make a switch, or -1 if none. + +sub write_const; + +sub write_const { + my ($fh, $pref, $off, $list) = (shift,shift,shift,shift); + my %leading; + my $offarg = length $pref; + + if (@$list == 0) { # Can happen on the initial iteration only + print $fh <<"END"; +static double +constant(char *name, int len, int arg) { - croak("$module::%s not implemented on this architecture", s); - return -1; + errno = EINVAL; + return 0; } +END + return -1; + } + if (@$list == 1) { # Can happen on the initial iteration only + my $protect = protect_convert_to_double("$pref$list->[0]"); + + print $fh <<"END"; static double -constant(char *name, int arg) +constant(char *name, int len, int arg) { errno = 0; - switch (*name) { + if (strEQ(name + $offarg, "$list->[0]")) { /* $pref removed */ +#ifdef $pref$list->[0] + return $protect$pref$list->[0]; +#else + errno = ENOENT; + return 0; +#endif + } + errno = EINVAL; + return 0; +} END + return -1; + } -my(@AZ, @az, @under); + for my $n (@$list) { + my $c = substr $n, $off, 1; + $leading{$c} = [] unless exists $leading{$c}; + push @{$leading{$c}}, substr $n, $off + 1; + } -foreach(@const_names){ - @AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/; - @az = 'a' .. 'z' if !@az && /^[a-z]/; - @under = '_' if !@under && /^_/; -} + if (keys(%leading) == 1) { + return 1 + write_const $fh, $pref, $off + 1, $list; + } -foreach $letter (@AZ, @az, @under) { + my $leader = substr $list->[0], 0, $off; + foreach my $letter (keys %leading) { + write_const $fh, "$pref$leader$letter", 0, $leading{$letter} + if @{$leading{$letter}} > 1; + } - last if $letter eq 'a' && !@const_names; + my $npref = "_$pref"; + $npref = '' if $pref eq ''; - print XS " case '$letter':\n"; - my($name); - while (substr($const_names[0],0,1) eq $letter) { - $name = shift(@const_names); - $macro = $prefix{$name} ? "$opt_p$name" : $name; - next if $const_xsub{$macro}; - print XS <<"END"; - if (strEQ(name, "$name")) -#ifdef $macro - return $macro; + print $fh <<"END"; +static double +constant$npref(char *name, int len, int arg) +{ +END + + print $fh <<"END" if $npref eq ''; + errno = 0; +END + + print $fh <<"END" if $off; + if ($offarg + $off >= len ) { + errno = EINVAL; + return 0; + } +END + + print $fh <<"END"; + switch (name[$offarg + $off]) { +END + + foreach my $letter (sort keys %leading) { + my $let = $letter; + $let = '\0' if $letter eq ''; + + print $fh <<EOP; + case '$let': +EOP + if (@{$leading{$letter}} > 1) { + # It makes sense to call a function + if ($off) { + print $fh <<EOP; + if (!strnEQ(name + $offarg,"$leader", $off)) + break; +EOP + } + print $fh <<EOP; + return constant_$pref$leader$letter(name, len, arg); +EOP + } + else { + # Do it ourselves + my $protect + = protect_convert_to_double("$pref$leader$letter$leading{$letter}[0]"); + + print $fh <<EOP; + if (strEQ(name + $offarg, "$leader$letter$leading{$letter}[0]")) { /* $pref removed */ +#ifdef $pref$leader$letter$leading{$letter}[0] + return $protect$pref$leader$letter$leading{$letter}[0]; #else goto not_there; #endif -END + } +EOP } - print XS <<"END"; - break; -END -} -print XS <<"END"; + } + print $fh <<"END"; } errno = EINVAL; return 0; @@ -665,9 +1124,28 @@ not_there: } END + +} + +if( ! $opt_c ) { + print XS <<"END"; +static int +not_here(char *s) +{ + croak("$module::%s not implemented on this architecture", s); + return -1; +} + +END + + write_const(\*XS, '', 0, \@const_names); } +print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls; + +my $prefix; $prefix = "PREFIX = $opt_p" if defined $opt_p; + # Now switch from C to XS by issuing the first MODULE declaration: print XS <<"END"; @@ -682,13 +1160,13 @@ $_() CODE: #ifdef $_ - RETVAL = $_; + RETVAL = $_; #else - croak("Your vendor has not defined the $module macro $_"); + croak("Your vendor has not defined the $module macro $_"); #endif OUTPUT: - RETVAL + RETVAL END } @@ -698,14 +1176,22 @@ END print XS <<"END" unless $opt_c; double -constant(name,arg) - char * name +constant(sv,arg) + PREINIT: + STRLEN len; + INPUT: + SV * sv + char * s = SvPV(sv, len); int arg + CODE: + RETVAL = constant(s,len,arg); + OUTPUT: + RETVAL END my %seen_decl; - +my %typemap; sub print_decl { my $fh = shift; @@ -714,7 +1200,10 @@ sub print_decl { return if $seen_decl{$name}++; # Need to do the same for docs as well? my @argnames = map {$_->[1]} @$args; - my @argtypes = map { normalize_type( $_->[0] ) } @$args; + my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args; + if ($opt_k) { + s/^\s*const\b\s*// for @argtypes; + } my @argarrays = map { $_->[4] || '' } @$args; my $numargs = @$args; if ($numargs and $argtypes[-1] eq '...') { @@ -722,21 +1211,152 @@ sub print_decl { $argnames[-1] = '...'; } local $" = ', '; - $type = normalize_type($type); - + $type = normalize_type($type, 1); + print $fh <<"EOP"; $type $name(@argnames) EOP - for $arg (0 .. $numargs - 1) { + for my $arg (0 .. $numargs - 1) { print $fh <<"EOP"; $argtypes[$arg] $argnames[$arg]$argarrays[$arg] EOP } } +sub print_tievar_subs { + my($fh, $name, $type) = @_; + print $fh <<END; +I32 +_get_$name(IV index, SV *sv) { + dSP; + PUSHMARK(SP); + XPUSHs(sv); + PUTBACK; + (void)call_pv("$module\::_get_$name", G_DISCARD); + return (I32)0; +} + +I32 +_set_$name(IV index, SV *sv) { + dSP; + PUSHMARK(SP); + XPUSHs(sv); + PUTBACK; + (void)call_pv("$module\::_set_$name", G_DISCARD); + return (I32)0; +} + +END +} + +sub print_tievar_xsubs { + my($fh, $name, $type) = @_; + print $fh <<END; +void +_tievar_$name(sv) + SV* sv + PREINIT: + struct ufuncs uf; + CODE: + uf.uf_val = &_get_$name; + uf.uf_set = &_set_$name; + uf.uf_index = (IV)&_get_$name; + sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf)); + +void +_get_$name(THIS) + $type THIS = NO_INIT + CODE: + THIS = $name; + OUTPUT: + SETMAGIC: DISABLE + THIS + +void +_set_$name(THIS) + $type THIS + CODE: + $name = THIS; + +END +} + +sub print_accessors { + my($fh, $name, $struct) = @_; + return unless defined $struct && $name !~ /\s|_ANON/; + $name = normalize_type($name); + my $ptrname = normalize_type("$name *"); + print $fh <<"EOF"; + +MODULE = $module PACKAGE = ${name} $prefix + +$name * +_to_ptr(THIS) + $name THIS = NO_INIT + PROTOTYPE: \$ + CODE: + if (sv_derived_from(ST(0), "$name")) { + STRLEN len; + char *s = SvPV((SV*)SvRV(ST(0)), len); + if (len != sizeof(THIS)) + croak("Size \%d of packed data != expected \%d", + len, sizeof(THIS)); + RETVAL = ($name *)s; + } + else + croak("THIS is not of type $name"); + OUTPUT: + RETVAL + +$name +new(CLASS) + char *CLASS = NO_INIT + PROTOTYPE: \$ + CODE: + Zero((void*)&RETVAL, sizeof(RETVAL), char); + OUTPUT: + RETVAL + +MODULE = $module PACKAGE = ${name}Ptr $prefix + +EOF + my @items = @$struct; + while (@items) { + my $item = shift @items; + if ($item->[0] =~ /_ANON/) { + if (defined $item->[2]) { + push @items, map [ + @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]", + ], @{ $structs{$item->[0]} }; + } else { + push @items, @{ $structs{$item->[0]} }; + } + } else { + my $type = normalize_type($item->[0]); + my $ttype = $structs{$type} ? normalize_type("$type *") : $type; + print $fh <<"EOF"; +$ttype +$item->[2](THIS, __value = NO_INIT) + $ptrname THIS + $type __value + PROTOTYPE: \$;\$ + CODE: + if (items > 1) + THIS->$item->[-1] = __value; + RETVAL = @{[ + $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])" + ]}; + OUTPUT: + RETVAL + +EOF + } + } +} + # Should be called before any actual call to normalize_type(). sub get_typemap { # We do not want to read ./typemap by obvios reasons. @@ -744,9 +1364,11 @@ sub get_typemap { my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap"; unshift @tm, $stdtypemap; my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; - my $image; - - foreach $typemap (@tm) { + + # Start with useful default values + $typemap{float} = 'T_DOUBLE'; + + foreach my $typemap (@tm) { next unless -e $typemap ; # skip directories, binary files etc. warn " Scanning $typemap\n"; @@ -762,11 +1384,12 @@ sub get_typemap { elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; } elsif ($mode eq 'Typemap') { next if /^\s*($|\#)/ ; - if ( ($type, $image) = + my ($type, $image); + if ( ($type, $image) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o # This may reference undefined functions: and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) { - normalize_type($type); + $typemap{normalize_type($type)} = $image; } } } @@ -777,24 +1400,64 @@ sub get_typemap { } -sub normalize_type { - my $ignore_mods = '(?:\b(?:__const__|static|inline|__inline__)\b\s*)*'; +sub normalize_type { # Second arg: do not strip const's before \* my $type = shift; - $type =~ s/$ignore_mods//go; - $type =~ s/([\]\[()])/ \1 /g; - $type =~ s/\s+/ /g; + my $do_keep_deep_const = shift; + # If $do_keep_deep_const this is heuristical only + my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : ''); + my $ignore_mods + = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*"; + if ($do_keep_deep_const) { # Keep different compiled /RExen/o separately! + $type =~ s/$ignore_mods//go; + } + else { + $type =~ s/$ignore_mods//go; + } + $type =~ s/([^\s\w])/ \1 /g; $type =~ s/\s+$//; $type =~ s/^\s+//; - $type =~ s/\b\*/ */g; - $type =~ s/\*\b/* /g; - $type =~ s/\*\s+(?=\*)/*/g; + $type =~ s/\s+/ /g; + $type =~ s/\* (?=\*)/*/g; + $type =~ s/\. \. \./.../g; + $type =~ s/ ,/,/g; $types_seen{$type}++ unless $type eq '...' or $type eq 'void' or $std_types{$type}; $type; } +my $need_opaque; + +sub assign_typemap_entry { + my $type = shift; + my $otype = $type; + my $entry; + if ($tmask and $type =~ /$tmask/) { + print "Type $type matches -o mask\n" if $opt_d; + $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ"); + } + elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { + $type = normalize_type $type; + print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d; + $entry = assign_typemap_entry($type); + } + $entry ||= $typemap{$otype} + || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ"); + $typemap{$otype} = $entry; + $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT"; + return $entry; +} + +for (@vdecls) { + print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_}); +} + if ($opt_x) { - for $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) } + for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) } + if ($opt_a) { + while (my($name, $struct) = each %structs) { + print_accessors(\*XS, $name, $struct); + } + } } close XS; @@ -804,10 +1467,32 @@ if (%types_seen) { warn "Writing $ext$modpname/typemap\n"; open TM, ">typemap" or die "Cannot open typemap file for write: $!"; - for $type (keys %types_seen) { - print TM $type, "\t" x (6 - int((length $type)/8)), "T_PTROBJ\n" + for $type (sort keys %types_seen) { + my $entry = assign_typemap_entry $type; + print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n" } + print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry +############################################################################# +INPUT +T_OPAQUE_STRUCT + if (sv_derived_from($arg, \"${ntype}\")) { + STRLEN len; + char *s = SvPV((SV*)SvRV($arg), len); + + if (len != sizeof($var)) + croak(\"Size %d of packed data != expected %d\", + len, sizeof($var)); + $var = *($type *)s; + } + else + croak(\"$var is not of type ${ntype}\") +############################################################################# +OUTPUT +T_OPAQUE_STRUCT + sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var)); +EOP + close TM or die "Cannot close typemap file for write: $!"; } @@ -816,18 +1501,22 @@ if (%types_seen) { warn "Writing $ext$modpname/Makefile.PL\n"; open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n"; -print PL <<'END'; +print PL <<END; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => '$module', + 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION + 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1 +END +if (!$opt_X) { # print C stuff, unless XS is disabled + $opt_F = '' unless defined $opt_F; + print PL <<END; + 'LIBS' => ['$extralibs'], # e.g., '-lm' + 'DEFINE' => '$opt_F', # e.g., '-DHAVE_SOMETHING' + 'INC' => '', # e.g., '-I/usr/include/other' END -print PL "WriteMakefile(\n"; -print PL " 'NAME' => '$module',\n"; -print PL " 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION\n"; -if( ! $opt_X ){ # print C stuff, unless XS is disabled - print PL " 'LIBS' => ['$extralibs'], # e.g., '-lm' \n"; - print PL " 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' \n"; - print PL " 'INC' => '', # e.g., '-I/usr/include/other' \n"; } print PL ");\n"; close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n"; @@ -862,16 +1551,25 @@ 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"; + @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS; + print EX <<EOP; +Revision history for Perl extension $module. + +$TEMPLATE_VERSION @{[scalar localtime]} +\t- original version; created by h2xs $H2XS_VERSION with options +\t\t@ARGS + +EOP + 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: $!"; -@files = <*>; +my @files = <*>; if (!@files) { eval {opendir(D,'.');}; unless ($@) { @files = readdir(D); closedir(D); } diff --git a/contrib/perl5/utils/perlbc.PL b/contrib/perl5/utils/perlbc.PL new file mode 100644 index 0000000..51d074b --- /dev/null +++ b/contrib/perl5/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/contrib/perl5/utils/perlbug.PL b/contrib/perl5/utils/perlbug.PL index 6f87589..208da36 100644 --- a/contrib/perl5/utils/perlbug.PL +++ b/contrib/perl5/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]; @@ -35,8 +37,8 @@ my @patches; while (<PATCH_LEVEL>) { last if /^\s*}/; chomp; - s/^\s+,?"?//; - s/"?,?$//; + s/^\s+,?\s*"?//; + s/"?\s*,?$//; s/(['\\])/\\$1/g; push @patches, $_ unless $_ eq 'NULL'; } @@ -55,12 +57,14 @@ 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. +my $extract_version = sprintf("v%vd", $^V); + print OUT <<"!GROK!THIS!"; $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' if \$running_under_some_shell; -my \$config_tag1 = '$] - $Config{cf_time}'; +my \$config_tag1 = '$extract_version - $Config{cf_time}'; my \$patchlevel_date = $patchlevel_date; my \$patch_tags = '$patch_tags'; @@ -74,6 +78,7 @@ my \@patches = ( print OUT <<'!NO!SUBS!'; use Config; +use File::Spec; # keep perlbug Perl 5.005 compatible use Getopt::Std; use strict; @@ -86,7 +91,7 @@ BEGIN { $::HaveUtil = ($@ eq ""); }; -my $Version = "1.26"; +my $Version = "1.28"; # 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 +122,8 @@ 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 +# Changed in 1.28 Additional questions for Perlbugtron RFOLEY 20.03.2000 # TODO: - Allow the user to re-name the file on mail failure, and # make sure failure (transmission-wise) of Mail::Send is @@ -124,10 +131,12 @@ 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, $category, $severity, $fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP, $ok); -my $config_tag2 = "$] - $Config{cf_time}"; +my $perl_version = $^V ? sprintf("v%vd", $^V) : $]; + +my $config_tag2 = "$perl_version - $Config{cf_time}"; Init(); @@ -149,11 +158,43 @@ Send(); exit; +sub ask_for_alternatives { + my $name = shift; + my $default = shift; + my @alts = @_; + my $alt = ""; + paraprint <<EOF; +Please pick a \u$name from the following: + + @alts + +EOF + my $err = 0; + my $joined_alts = join('|', @alts); + do { + if ($err++ > 5) { + die "Invalid $name: aborting.\n"; + } + print "Please enter a \u$name [$default]: "; + $alt = <>; + chomp $alt; + if ($alt =~ /^\s*$/) { + $alt = $default; + } + } while ($alt !~ /^($joined_alts)$/i); + lc $alt; +} + sub Init { # -------- Setup -------- $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 +237,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 @@ -232,8 +274,10 @@ EOF $::opt_C = 1; # don't send a copy to the local admin $::opt_s = 1; # we have a subject line $subject = ($::opt_n ? 'Not ' : '') - . "OK: perl $] ${patch_tags}on" + . "OK: perl $perl_version ${patch_tags}on" ." $::Config{'archname'} $::Config{'osvers'} $subject"; + $category = "install"; + $severity = "none"; $ok = 1; } else { Help(); @@ -255,6 +299,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 +352,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) { @@ -415,6 +467,16 @@ EOF } } + # Prompt for category of bug + $category ||= ask_for_alternatives("category", "core", + qw(core docs install + library utilities)); + + # Prompt for severity of bug + $severity ||= ask_for_alternatives("severity", "low", + qw(critical high medium + low wishlist none)); + # Generate scratch file to edit report in $filename = filename(); @@ -452,7 +514,7 @@ EOF print REP <<EOF; This is a $reptype report for perl from $from, -generated with the help of perlbug $Version running under perl $]. +generated with the help of perlbug $Version running under perl $perl_version. EOF @@ -494,13 +556,19 @@ EOF sub Dump { local(*OUT) = @_; - print REP "\n---\n"; - print REP "This perlbug was built using Perl $config_tag1\n", + print OUT <<EFF; +--- +Flags: + category=$category + severity=$severity +--- +EFF + print OUT "This perlbug was built using Perl $config_tag1\n", "It is being executed now by Perl $config_tag2.\n\n" if $config_tag2 ne $config_tag1; print OUT <<EOF; -Site configuration information for perl $]: +Site configuration information for perl $perl_version: EOF if ($::Config{cf_by} and $::Config{cf_time}) { @@ -516,7 +584,7 @@ EOF print OUT <<EOF; --- -\@INC for perl $]: +\@INC for perl $perl_version: EOF for my $i (@INC) { print OUT " $i\n"; @@ -525,18 +593,21 @@ EOF print OUT <<EOF; --- -Environment for perl $]: +Environment for perl $perl_version: EOF - for my $env (sort - (qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR LANGUAGE), - 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"; } if ($verbose) { - print OUT "\nComplete configuration data for perl $]:\n\n"; + print OUT "\nComplete configuration data for perl $perl_version:\n\n"; my $value; foreach (sort keys %::Config) { $value = $::Config{$_}; @@ -559,7 +630,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 +862,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 +875,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 +894,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 File::Spec->catfile($dir, $filename); + $filename = File::Spec->catfile($dir, $filename); } sub paraprint { @@ -878,7 +958,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,16 +966,16 @@ 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 @@ -905,10 +985,10 @@ 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>, some -features may not be implemented or work differently. +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. +Try to study the problem under the Perl debugger, if necessary. See L<perldebug>. =item Do you have a proper test case? @@ -930,7 +1010,7 @@ 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, not +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. @@ -938,8 +1018,8 @@ reproduce the dump and the stack trace. 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? @@ -973,14 +1053,14 @@ 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 informative. "a bug" not informative. Neither is "perl -crashes" nor "HELP!!!", these all are null information. A compact -description of what's wrong is fine. +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 @@ -1091,12 +1171,14 @@ Include verbose configuration data in the report. =head1 AUTHORS Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently I<doc>tored -by Gurusamy Sarathy (E<lt>gsar@umich.eduE<gt>), Tom Christiansen +by Gurusamy Sarathy (E<lt>gsar@activestate.comE<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>), -Hugo van der Sanden (E<lt>hv@crypt0.demon.co.ukE<gt>), and -Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>). +Hugo van der Sanden (E<lt>hv@crypt0.demon.co.ukE<gt>), +Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>), Chris Nandor +(E<lt>pudge@pobox.comE<gt>), Jon Orwant (E<lt>orwant@media.mit.eduE<gt>, +and Richard Foley (E<lt>richard@rfi.netE<gt>). =head1 SEE ALSO diff --git a/contrib/perl5/utils/perlcc.PL b/contrib/perl5/utils/perlcc.PL index b214645..f0636f6 100644 --- a/contrib/perl5/utils/perlcc.PL +++ b/contrib/perl5/utils/perlcc.PL @@ -2,6 +2,7 @@ use Config; use File::Basename qw(&basename &dirname); +use File::Spec; use Cwd; # List explicitly here the variables you want Configure to @@ -48,8 +49,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 +71,9 @@ sub main "regex:s", "verbose:s", "log:s", - "argv:s", + "argv:s", + "b", + "opt", "gen", "sav", "run", @@ -101,33 +108,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 +164,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 +186,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 +237,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 +251,49 @@ sub _getExecutable sub _createCode { - my ( $generated_cfile, $file, $final_output ) = @_; + my ( $backend, $generated_file, $file, $final_output ) = @_; my $return; + my $output_switch = "o"; + my $max_line_len = ''; local($") = " -I"; - if (@_ == 2) # compiling a program + if ($^O eq 'MSWin32' && $backend =~ /^CC?$/ && $Config{cc} =~ /^cl/i) { + $max_line_len = '-l2000,'; + } + + 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; + + open(GENFILE, "> $generated_file") || die "Can't open $generated_file: $!"; + binmode GENFILE; + print GENFILE "#!$^X\n" if @_ == 3; + print GENFILE "use ByteLoader $ByteLoader::VERSION;\n"; + close(GENFILE); + + $output_switch ="a"; + } + + if (@_ == 3) # compiling a program + { + chmod $generated_file, 0777 & ~umask if $backend eq "Bytecode"; + my $null=File::Spec->devnull; + _print( "$^X -I@INC -MB::Stash -c $file\n", 36); + my @stash=`$^X -I@INC -MB::Stash -c $file 2>$null`; + my $stash=$stash[-1]; + chomp $stash; + + _print( "$^X -I@INC -MO=$backend,$max_line_len$stash $file\n", 36); + $return = _run("$^X -I@INC -MO=$backend,$max_line_len$stash,-$output_switch$generated_file $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,$max_line_len-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,$max_line_len-m$final_output,-$output_switch$generated_file $file ", 9); $return; } } @@ -245,7 +306,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 +318,7 @@ sub _compileCode $return[0] = _ccharness('compile', $sourceprog, "-c", $generated_cfile); $return[1] = _ccharness ( - 'dynamic', + 'dynamic', $sourceprog, "-o", $shared_object, $object_file ); @@ -287,34 +349,57 @@ sub _ccharness my $sourceprog = shift(@args); my ($libdir, $incdir); + my $L = '-L'; + $L = '-libpath:' if $^O eq 'MSWin32' && $Config{cc} =~ /^cl/i; + if (-d "$Config{installarchlib}/CORE") { - $libdir = "-L$Config{installarchlib}/CORE"; + $libdir = "$L$Config{installarchlib}/CORE"; $incdir = "-I$Config{installarchlib}/CORE"; } else { - $libdir = "-L.. -L."; + $libdir = "$L.. $L."; $incdir = "-I.. -I."; } - $libdir .= " -L$options->{L}" if (defined($options->{L})); + $libdir .= " $L$options->{L}" if (defined($options->{L})); $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\\$Config{libperl}" + : '-lperl'; + ($lperl = $Config{libperl}) =~ s/lib(.*)\Q$Config{_a}\E/-l$1/ + if($^O eq 'cygwin'); + + $optimize = $Config{'optimize'} =~ /-O\d/ ? '' : $Config{'optimize'}; + + $flags = $type eq 'dynamic' ? $Config{lddlflags} : $Config{ldflags}; + $linkargs = "$flags $libdir $lperl @Config{libs}"; + $linkargs = "/link $linkargs" if $^O eq 'MSWin32' && $Config{cc} =~ /^cl/i; } - my @sharedobjects = _getSharedObjects($sourceprog); + my $libs = _getSharedObjects($sourceprog); + @$libs = grep { !(/DynaLoader\.a$/ && ($dynaloader = $_)) } @$libs + if($^O eq 'cygwin'); - my $cccmd = - "$Config{cc} @Config{qw(ccflags optimize)} $incdir @sharedobjects @args $linkargs"; + my $args = "@args"; + if ($^O eq 'MSWin32' && $Config{cc} =~ /^bcc/i) { + # BC++ cmd line syntax does not allow space between -[oexz...] and arg + $args =~ s/(^|\s+)-([oe])\s+/$1-$2/g; + } + my $ccflags = $Config{ccflags}; + $ccflags .= ' -DUSEIMPORTLIB' if $^O eq 'cygwin'; + my $cccmd = "$Config{cc} $ccflags $optimize $incdir " + ."$args $dynaloader $linkargs @$libs"; _print ("$cccmd\n", 36); _run("$cccmd", 18 ); @@ -324,29 +409,22 @@ sub _getSharedObjects { my ($sourceprog) = @_; my ($tmpfile, $incfile); - my (@return); + my (@sharedobjects, @libraries); local($") = " -I"; - if ($Config{'osname'} eq 'MSWin32') - { - # _addstuff; - } - else - { - my ($tmpprog); - ($tmpprog = $sourceprog) =~ s"(.*)[\/\\](.*)"$2"; - $tmpfile = "/tmp/$tmpprog.tst"; - $incfile = "/tmp/$tmpprog.val"; - } + my ($tmpprog); + ($tmpprog = $sourceprog) =~ s"(.*)[\\/](.*)"$2"; + + my $tempdir= File::Spec->tmpdir; + + $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 +438,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 +450,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 +487,29 @@ sub _lookforAuto { my ($dir, $file) = @_; - my $relshared; + my ($relabs, $relshared); + my ($prefix); my $return; + my $sharedextension = $^O =~ /MSWin32|cygwin|os2/i + ? $Config{_a} : ".$Config{so}"; + ($prefix = $file) =~ s"(.*)\.pm"$1"; - ($relshared = $file) =~ s"(.*)\.pm"$1"; + my ($tmp, $modname) = ($prefix =~ m"(?:(.*)[\\/]){0,1}(.*)"s); - my ($tmp, $modname) = ($relshared =~ m"(?:(.*)[\\/]){0,1}(.*)"s); + $relshared = "$pathsep$prefix$pathsep$modname$sharedextension"; + $relabs = "$pathsep$prefix$pathsep$modname$Config{_a}"; + # HACK . WHY DOES _a HAVE A '.' + # AND so HAVE NONE?? - $relshared .= - ($Config{'osname'} eq 'MSWin32')? "\\$modname.dll" : "/$modname.so"; + my @searchpaths = map("$_${pathsep}auto", @INC); - - - 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 $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 +525,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 +540,6 @@ sub _mungeRegexp grep(s:\x00::g, @$regexp); } - sub _error { my ($type, @args) = @_; @@ -530,6 +600,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 +626,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'}) && !$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 +758,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 |"); + + 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 +834,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 +844,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 +929,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 +946,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 +967,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 +999,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 +1047,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 +1081,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 +1100,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/contrib/perl5/utils/perldoc.PL b/contrib/perl5/utils/perldoc.PL index 2633510..32421d7 100644 --- a/contrib/perl5/utils/perldoc.PL +++ b/contrib/perl5/utils/perldoc.PL @@ -30,39 +30,49 @@ $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' if 0; +use warnings; use strict; + +# make sure creat()s are neither too much nor too little +INIT { eval { umask(0077) } } # doubtless someone has no mask + my \@pagers = (); push \@pagers, "$Config{'pager'}" if -x "$Config{'pager'}"; + !GROK!THIS! # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; +use Fcntl; # for sysopen +use Getopt::Std; +use Config '%Config'; + # # Perldoc revision #1 -- look up a piece of documentation in .pod format that # is embedded in the perl installation tree. # -# This is not to be confused with Tom Christianson's perlman, which is a +# This is not to be confused with Tom Christiansen's perlman, which is a # man replacement, written in perl. This perldoc is strictly for reading # the perl manuals, though it too is written in perl. +# +# Massive security and correctness patches applied to this +# noisome program by Tom Christiansen Sat Mar 11 15:22:33 MST 2000 -if(@ARGV<1) { +if (@ARGV<1) { my $me = $0; # Editing $0 is unportable $me =~ s,.*/,,; die <<EOF; -Usage: $me [-h] [-r] [-i] [-v] [-t] [-u] [-m] [-l] [-F] [-X] PageName|ModuleName|ProgramName +Usage: $me [-h] [-r] [-i] [-v] [-t] [-u] [-m] [-n program] [-l] [-F] [-X] PageName|ModuleName|ProgramName $me -f PerlFunc $me -q FAQKeywords The -h option prints more help. Also try "perldoc perldoc" to get -aquainted with the system. +acquainted with the system. EOF } -use Getopt::Std; -use Config '%Config'; - my @global_found = (); my $global_target = ""; @@ -82,22 +92,24 @@ 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 -m Display module's file in its entirety + -n Specify replacement for nroff -l Display the module's file name -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] + -U Run in insecure mode (superuser only) 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,20 +120,20 @@ 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"})); } !NO!SUBS! -my $getopts = "mhtluvriFf:Xq:"; +my $getopts = "mhtluvriFf:Xq:n:U"; print OUT <<"!GET!OPTS!"; use vars qw( @{[map "\$opt_$_", ($getopts =~ /\w/g)]} ); @@ -133,75 +145,105 @@ print OUT <<'!NO!SUBS!'; usage if $opt_h; +# refuse to run if we should be tainting and aren't +# (but regular users deserve protection too, though!) +if (!($Is_VMS || $Is_MSWin32 || $Is_Dos) && ($> == 0 || $< == 0) + && !am_taint_checking()) +{{ + if ($opt_U) { + my $id = eval { getpwnam("nobody") }; + $id = eval { getpwnam("nouser") } unless defined $id; + $id = -2 unless defined $id; + eval { + $> = $id; # must do this one first! + $< = $id; + }; + last if !$@ && $< && $>; + } + die "Superuser must not run $0 without security audit and taint checks.\n"; +}} + +$opt_n = "nroff" if !$opt_n; + 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{ no warnings; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) { usage("only one of -t, -u, -m or -l") -} elsif ($Is_MSWin32 || $Is_Dos) { - $opt_t = 1 unless $opts +} +elsif ($Is_MSWin32 + || $Is_Dos + || !($ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i)) +{ + $opt_t = 1 unless $opts; } 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? if (-f "Makefile.PL") { - # Add ., lib and blib/* libs to @INC (if they exist) - unshift(@INC, '.'); - unshift(@INC, 'lib') if -d 'lib'; - require ExtUtils::testlib; -} + # Add ., lib to @INC (if they exist) + eval q{ use lib qw(. lib); 1; } or die; + # don't add if superuser + if ($< && $>) { # don't be looking too hard now! + eval q{ use blib; 1 } or die; + } +} sub containspod { my($file, $readit) = @_; - return 1 if !$readit && $file =~ /\.pod$/i; + return 1 if !$readit && $file =~ /\.pod\z/i; local($_); - open(TEST,"<$file"); - while(<TEST>) { - if(/^=head/) { - close(TEST); + open(TEST,"<", $file) or die "Can't open $file: $!"; + while (<TEST>) { + if (/^=head/) { + close(TEST) or die "Can't close $file: $!"; return 1; } } - close(TEST); + close(TEST) or die "Can't close $file: $!"; return 0; } sub minus_f_nocase { my($dir,$file) = @_; - my $path = join('/',$dir,$file); + my $path = join('/',$dir,$file); # XXX: dirseps 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 $path: unreadable\n" if -f _; return ''; } local *DIR; + # this is completely wicked. don't mess with $", and if + # you do, don't assume / is the dirsep! local($")="/"; my @p = ($dir); my($p,$cip); - foreach $p (split(/\//, $file)){ + foreach $p (split(m!/!, $file)){ # XXX: dirseps my $try = "@p/$p"; stat $try; - if (-d _){ + if (-d _) { push @p, $p; if ( $p eq $global_target) { - my $tmp_path = join ('/', @p); + my $tmp_path = join ('/', @p); # XXX: dirseps my $path_f = 0; for (@global_found) { $path_f = 1 if $_ eq $tmp_path; @@ -209,21 +251,24 @@ 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 { + } + elsif (-d "@p") { my $found=0; my $lcp = lc $p; - opendir DIR, "@p"; + opendir DIR, "@p" or die "opendir @p: $!"; while ($cip=readdir(DIR)) { if (lc $cip eq $lcp){ $found++; last; } } - closedir DIR; + closedir DIR or die "closedir @p: $!"; return "" unless $found; push @p, $cip; return "@p" if -f "@p" and -r _; @@ -232,13 +277,15 @@ sub minus_f_nocase { } return ""; } - + sub check_file { my($dir,$file) = @_; + return "" if length $dir and not -d $dir; 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); } @@ -255,35 +302,38 @@ sub searchfor { my $ret; my $i; my $dir; - $global_target = (split('/', $s))[-1]; + $global_target = (split(m!/!, $s))[-1]; # XXX: dirseps for ($i=0; $i<@dirs; $i++) { $dir = $dirs[$i]; - ($dir = VMS::Filespec::unixpath($dir)) =~ s!/$!! if $Is_VMS; + ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if $Is_VMS; if ( ( $ret = check_file $dir,"$s.pod") or ( $ret = check_file $dir,"$s.pm") or ( $ret = check_file $dir,$s) or ( $Is_VMS and $ret = check_file $dir,"$s.com") - or ( $^O eq 'os2' and + 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") or ( $ret = check_file "$dir/pod","$s.pod") or ( $ret = check_file "$dir/pod",$s) + or ( $ret = check_file "$dir/pods","$s.pod") + or ( $ret = check_file "$dir/pods",$s) ) { return $ret; } - + if ($recurse) { - opendir(D,$dir); - my @newdirs = map "$dir/$_", grep { - not /^\.\.?$/ and - not /^auto$/ and # save time! don't search auto dirs - -d "$dir/$_" + opendir(D,$dir) or die "Can't opendir $dir: $!"; + my @newdirs = map "$dir/$_", grep { # XXX: dirseps + not /^\.\.?\z/s and + not /^auto\z/s and # save time! don't search auto dirs + -d "$dir/$_" # XXX: dirseps } readdir D; - closedir(D); + closedir(D) or die "Can't closedir $dir: $!"; next unless @newdirs; - @newdirs = map((s/.dir$//,$_)[1],@newdirs) if $Is_VMS; + # what a wicked map! + @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $Is_VMS; print STDERR "Also looking in @newdirs\n" if $opt_v; push(@dirs,@newdirs); } @@ -291,73 +341,155 @@ 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) { + # why was this append? + sysopen(OUT, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600) + or die ("Can't open $tmp: $!"); + Pod::Text->new()->parse_from_file($file,\*OUT); + close OUT or die "can't close $tmp: $!"; + } + elsif (not $opt_u) { + my $cmd = "pod2man --lax $file | $opt_n -man"; + $cmd .= " | col -x" if $^O =~ /hpux/; + my $rslt = `$cmd`; + $rslt = filter_nroff($rslt) if $filter; + unless (($err = $?)) { + # why was this append? + sysopen(TMP, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600) + or die "Can't open $tmp: $!"; + print TMP $rslt + or die "Can't print $tmp: $!"; + close TMP + or die "Can't close $tmp: $!"; + } + } + if ($opt_u or $err or -z $tmp) { # XXX: race with -z + # why was this append? + sysopen(OUT, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600) + or die "Can't open $tmp: $!"; + open(IN,"<", $file) or die("Can't open $file: $!"); + my $cut = 1; + local $_; + while (<IN>) { + $cut = $1 eq 'cut' if /^=(\w+)/; + next if $cut; + print OUT + or die "Can't print $tmp: $!"; + } + close IN or die "Can't close $file: $!"; + close OUT or die "Can't close $tmp: $!"; + } +} + +sub page { + my ($tmp, $no_tty, @pagers) = @_; + if ($no_tty) { + open(TMP,"<", $tmp) or die "Can't open $tmp: $!"; + local $_; + while (<TMP>) { + print or die "Can't print to stdout: $!"; + } + close TMP or die "Can't close while $tmp: $!"; + } + else { + foreach my $pager (@pagers) { + last if system("$pager $tmp") == 0; + } + } +} + +sub cleanup { + my @files = @_; + for (@files) { + if ($Is_VMS) { + 1 while unlink($_); # XXX: expect failure + } else { + unlink($_); # or die "Can't unlink $_: $!"; + } + } +} + 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 = $_; + $searchfor =~ s,::,/,g; # XXX: dirseps + print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v; + local $_; + while (<PODIDX>) { + chomp; + push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,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) or die "Can't 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 } - 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 { + 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(!/^\.\z/s,@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 "opendir $dir: $!"; + while (my $file = readdir(DIR)) { + next if ($file =~ /^\./s); + $file =~ s/\.(pm|pod)\z//; # XXX: badfs + print STDERR "\tperldoc $_\::$file\n"; + } + closedir DIR or die "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,175 +500,181 @@ if ($opt_l) { my $lines = $ENV{LINES} || 24; my $no_tty; -if( ! -t STDOUT ) { $no_tty = 1 } +if (! -t STDOUT) { $no_tty = 1 } +END { close(STDOUT) || die "Can't close STDOUT: $!" } + +# until here we could simply exit or die +# now we create temporary files that we have to clean up +# namely $tmp, $buffer +# that's because you did it wrong, should be descriptor based --tchrist 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 { + # XXX: this is not secure, because it doesn't open it + ($tmp, $buffer) = eval { require POSIX } + ? (POSIX::tmpnam(), POSIX::tmpnam() ) + : ("/tmp/perldoc1.$$", "/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}; +# make sure cleanup called +eval q{ + sub END { cleanup($tmp, $buffer) } + 1; +} || die; +eval q{ use sigtrap qw(die INT TERM HUP QUIT) }; + 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) { + if (system($pager, @found) == 0) { + exit; + } + } + if ($Is_VMS) { + eval q{ + use vmsish qw(status exit); + exit $?; + 1; + } or die; + } + exit(1); +} +my @pod; if ($opt_f) { - my $perlfunc = shift @found; - open(PFUNC, $perlfunc) or die "Can't open $perlfunc: $!"; - - # Functions like -r, -e, etc. are listed under `-X'. - my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) ? 'I<-X' : $opt_f ; - - # 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$search_string\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 die("Can't open $perlfunc: $!"); + + # Functions like -r, -e, etc. are listed under `-X'. + my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) + ? 'I<-X' : $opt_f ; + + # Skip introduction + local $_; + while (<PFUNC>) { + last if /^=head2 Alphabetical Listing of Perl Functions/; + } + + # Look for our function + my $found = 0; + my $inlist = 0; + while (<PFUNC>) { + if (/^=item\s+\Q$search_string\E\b/o) { + $found = 1; + } + 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"; + } + close PFUNC or die "Can't open $perlfunc: $!"; } 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; + local @ARGV = @found; # I'm lazy, sue me. + my $found = 0; + my %found_in; + my $rx = eval { qr/$opt_q/ } or die <<EOD; +Invalid regular expression '$opt_q' given as -q pattern: + $@ +Did you mean \\Q$opt_q ? + +EOD + + for (@found) { die "invalid file spec: $!" if /[<>|]/ } + local $_; + 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) { + die("No documentation for perl FAQ keyword `$opt_q' found\n"); + } } -foreach (@found) { +my $filter; + +if (@pod) { + sysopen(TMP, $buffer, O_WRONLY | O_EXCL | O_CREAT) + or die("Can't open $buffer: $!"); + print TMP "=over 8\n\n"; + print TMP @pod or die "Can't print $buffer: $!"; + print TMP "=back\n"; + close TMP or die "Can't close $buffer: $!"; + @found = $buffer; + $filter = 1; +} - 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; - } - } - - 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); - } +foreach (@found) { + printout($_, $tmp, $filter); } +page($tmp, $no_tty, @pagers); -if( $no_tty ) { - open(TMP,"<$tmp"); - print while <TMP>; - close(TMP); -} else { - foreach my $pager (@pagers) { - system("$pager $tmp") or last; - } +exit; + +sub is_tainted { + my $arg = shift; + my $nada = substr($arg, 0, 0); # zero-length + local $@; # preserve caller's version + eval { eval "# $nada" }; + return length($@) != 0; } -1 while unlink($tmp); #Possibly pointless VMSism +sub am_taint_checking { + my($k,$v) = each %ENV; + return is_tainted($v); +} -exit 0; __END__ @@ -616,11 +754,20 @@ The B<-X> option looks for a entry whose basename matches the name given on the command line in the file C<$Config{archlib}/pod.idx>. The pod.idx file should contain fully qualified filenames, one per line. +=item B<-U> run insecurely + +Because B<perldoc> does not run properly tainted, and is known to +have security issues, it will not normally execute as the superuser. +If you use the B<-U> flag, it will do so, but only after setting +the effective and real IDs to nobody's or nouser's account, or -2 +if unavailable. If it cannot relinguish its privileges, it will not +run. + =item B<PageName|ModuleName|ProgramName> 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. @@ -629,7 +776,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. @@ -639,29 +786,48 @@ 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.01. + =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 # +# Version 2.02: Mon Mar 13 18:03:04 MST 2000 +# Tom Christiansen <tchrist@perl.com> +# Added -U insecurity option +# Version 2.01: Sat Mar 11 15:22:33 MST 2000 +# Tom Christiansen <tchrist@perl.com>, querulously. +# Security and correctness patches. +# What a twisted bit of distasteful spaghetti code. +# Version 2.0: ???? +# Version 1.15: Tue Aug 24 01:50:20 EST 1999 +# Charles Wilson <cwilson@ece.gatech.edu> +# changed /pod/ directory to /pods/ for cygwin +# to support cygwin/win32 # Version 1.14: Wed Jul 15 01:50:20 EST 1998 # Robin Barker <rmb1@cise.npl.co.uk> # -strict, -w cleanups # Version 1.13: Fri Feb 27 16:20:50 EST 1997 -# Gurusamy Sarathy <gsar@umich.edu> +# Gurusamy Sarathy <gsar@activestate.com> # -doc tweaks for -F and -X options # Version 1.12: Sat Apr 12 22:41:09 EST 1997 -# Gurusamy Sarathy <gsar@umich.edu> +# Gurusamy Sarathy <gsar@activestate.com> # -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 # -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 |
