dslinux/user/perl/utils Makefile c2ph.PL cpan.PL dprofpp.PL enc2xs.PL h2ph.PL h2xs.PL instmodsh.PL libnetcfg.PL perlbug.PL perlcc.PL perldoc.PL perlivp.PL piconv.PL pl2pm.PL prove.PL splain.PL xsubpp.PL
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:02:14 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/utils
In directory antilope:/tmp/cvs-serv17422/utils
Added Files:
Makefile c2ph.PL cpan.PL dprofpp.PL enc2xs.PL h2ph.PL h2xs.PL
instmodsh.PL libnetcfg.PL perlbug.PL perlcc.PL perldoc.PL
perlivp.PL piconv.PL pl2pm.PL prove.PL splain.PL xsubpp.PL
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: splain.PL ---
#!/usr/local/bin/perl
use Config;
use File::Basename qw(&basename &dirname);
use File::Spec;
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:
# $startperl
# $perlpath
# $eunicefix
# 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 input file before creating output file.
$IN = File::Spec->catfile(File::Spec->updir, 'lib', 'diagnostics.pm');
open IN or die "Can't open $IN: $!\n";
# Create output file.
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!
while (<IN>) {
print OUT unless /^package diagnostics/;
}
close IN;
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;
--- NEW FILE: xsubpp.PL ---
#!/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}.
# 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.
my $origdir = cwd;
chdir dirname($0);
my $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!
use File::Spec;
my $xsubpp = File::Spec->catfile(File::Spec->catdir(File::Spec->updir, "lib", "ExtUtils"), "xsubpp");
if (open(XSUBPP, $xsubpp)) {
print OUT <XSUBPP>;
close XSUBPP;
} else {
die "$0: cannot find '$xsubpp'\n";
}
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;
--- NEW FILE: piconv.PL ---
#!/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}.
# 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.
my $origdir = cwd;
chdir dirname($0);
my $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!
use File::Spec;
my $piconv = File::Spec->catfile(File::Spec->catdir(File::Spec->updir, "ext", "Encode", "bin"), "piconv");
if (open(PICONV, $piconv)) {
print OUT <PICONV>;
close PICONV;
} else {
die "$0: cannot find '$piconv'\n";
}
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;
--- NEW FILE: libnetcfg.PL ---
#!/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}.
# 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.
my $origdir = cwd;
chdir dirname($0);
my $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!';
=head1 NAME
libnetcfg - configure libnet
=head1 DESCRIPTION
The libnetcfg utility can be used to configure the libnet.
Starting from perl 5.8 libnet is part of the standard Perl
distribution, but the libnetcfg can be used for any libnet
installation.
=head1 USAGE
Without arguments libnetcfg displays the current configuration.
$ libnetcfg
# old config ./libnet.cfg
daytime_hosts ntp1.none.such
ftp_int_passive 0
ftp_testhost ftp.funet.fi
inet_domain none.such
nntp_hosts nntp.none.such
ph_hosts
pop3_hosts pop.none.such
smtp_hosts smtp.none.such
snpp_hosts
test_exist 1
test_hosts 1
time_hosts ntp.none.such
# libnetcfg -h for help
$
It tells where the old configuration file was found (if found).
The C<-h> option will show a usage message.
To change the configuration you will need to use either the C<-c> or
the C<-d> options.
The default name of the old configuration file is by default
"libnet.cfg", unless otherwise specified using the -i option,
C<-i oldfile>, and it is searched first from the current directory,
and then from your module path.
The default name of the new configuration file is "libnet.cfg", and by
default it is written to the current directory, unless otherwise
specified using the -o option, C<-o newfile>.
=head1 SEE ALSO
L<Net::Config>, L<Net::libnetFAQ>
=head1 AUTHORS
Graham Barr, the original Configure script of libnet.
Jarkko Hietaniemi, conversion into libnetcfg for inclusion into Perl 5.8.
=cut
# $Id: libnetcfg.PL,v 1.1 2006-12-04 17:02:12 dslinux_cayenne Exp $
use strict;
use IO::File;
use Getopt::Std;
use ExtUtils::MakeMaker qw(prompt);
use File::Spec;
use vars qw($opt_d $opt_c $opt_h $opt_o $opt_i);
##
##
##
my %cfg = ();
my @cfg = ();
my($libnet_cfg_in,$libnet_cfg_out,$msg,$ans,$def,$have_old);
##
##
##
sub valid_host
{
my $h = shift;
defined($h) && (($cfg{'test_exist'} == 0) || gethostbyname($h));
}
##
##
##
sub test_hostnames (\@)
{
my $hlist = shift;
my @h = ();
my $host;
my $err = 0;
foreach $host (@$hlist)
{
if(valid_host($host))
{
push(@h, $host);
next;
}
warn "Bad hostname: '$host'\n";
$err++;
}
@$hlist = @h;
$err ? join(" ", at h) : undef;
}
##
##
##
sub Prompt
{
my($prompt,$def) = @_;
$def = "" unless defined $def;
chomp($prompt);
if($opt_d)
{
print $prompt,," [",$def,"]\n";
return $def;
}
prompt($prompt,$def);
}
##
##
##
sub get_host_list
{
my($prompt,$def) = @_;
$def = join(" ",@$def) if ref($def);
my @hosts;
do
{
my $ans = Prompt($prompt,$def);
$ans =~ s/(\A\s+|\s+\Z)//g;
@hosts = split(/\s+/, $ans);
}
while(@hosts && defined($def = test_hostnames(@hosts)));
\@hosts;
}
##
##
##
sub get_hostname
{
my($prompt,$def) = @_;
my $host;
while(1)
{
my $ans = Prompt($prompt,$def);
$host = ($ans =~ /(\S*)/)[0];
last
if(!length($host) || valid_host($host));
$def =""
if $def eq $host;
print <<"EDQ";
*** ERROR:
Hostname `$host' does not seem to exist, please enter again
or a single space to clear any default
EDQ
}
length $host
? $host
: undef;
}
##
##
##
sub get_bool ($$)
{
my($prompt,$def) = @_;
chomp($prompt);
my $val = Prompt($prompt,$def ? "yes" : "no");
$val =~ /^y/i ? 1 : 0;
}
##
##
##
sub get_netmask ($$)
{
my($prompt,$def) = @_;
chomp($prompt);
my %list;
@list{@$def} = ();
MASK:
while(1) {
my $bad = 0;
my $ans = Prompt($prompt) or last;
if($ans eq '*') {
%list = ();
next;
}
if($ans eq '=') {
print "\n",( %list ? join("\n", sort keys %list) : 'none'),"\n\n";
next;
}
unless ($ans =~ m{^\s*(?:(-?\s*)(\d+(?:\.\d+){0,3})/(\d+))}) {
warn "Bad netmask '$ans'\n";
next;
}
my($remove,$bits, at ip) = ($1,$3,split(/\./, $2),0,0,0);
if ( $ip[0] < 1 || $bits < 1 || $bits > 32) {
warn "Bad netmask '$ans'\n";
next MASK;
}
foreach my $byte (@ip) {
if ( $byte > 255 ) {
warn "Bad netmask '$ans'\n";
next MASK;
}
}
my $mask = sprintf("%d.%d.%d.%d/%d", at ip[0..3],$bits);
if ($remove) {
delete $list{$mask};
}
else {
$list{$mask} = 1;
}
}
[ keys %list ];
}
##
##
##
sub default_hostname
{
my $host;
my @host;
foreach $host (@_)
{
if(defined($host) && valid_host($host))
{
return $host
unless wantarray;
push(@host,$host);
}
}
return wantarray ? @host : undef;
}
##
##
##
getopts('dcho:i:');
$libnet_cfg_in = "libnet.cfg"
unless(defined($libnet_cfg_in = $opt_i));
$libnet_cfg_out = "libnet.cfg"
unless(defined($libnet_cfg_out = $opt_o));
my %oldcfg = ();
$Net::Config::CONFIGURE = 1; # Suppress load of user overrides
if( -f $libnet_cfg_in )
{
%oldcfg = ( %{ do $libnet_cfg_in } );
}
elsif (eval { require Net::Config })
{
$have_old = 1;
%oldcfg = %Net::Config::NetConfig;
}
map { $cfg{lc $_} = $cfg{$_}; delete $cfg{$_} if /[A-Z]/ } keys %cfg;
#---------------------------------------------------------------------------
if ($opt_h) {
print <<EOU;
$0: Usage: $0 [-c] [-d] [-i oldconfigile] [-o newconfigfile] [-h]
Without options, the old configuration is shown.
-c change the configuration
-d use defaults from the old config (implies -c, non-interactive)
-i use a specific file as the old config file
-o use a specific file as the new config file
-h show this help
The default name of the old configuration file is by default
"libnet.cfg", unless otherwise specified using the -i option,
C<-i oldfile>, and it is searched first from the current directory,
and then from your module path.
The default name of the new configuration file is "libnet.cfg", and by
default it is written to the current directory, unless otherwise
specified using the -o option.
EOU
exit(0);
}
#---------------------------------------------------------------------------
{
my $oldcfgfile;
my @inc;
push @inc, $ENV{PERL5LIB} if exists $ENV{PERL5LIB};
push @inc, $ENV{PERLLIB} if exists $ENV{PERLLIB};
push @inc, @INC;
for (@inc) {
my $trycfgfile = File::Spec->catfile($_, $libnet_cfg_in);
if (-f $trycfgfile && -r $trycfgfile) {
$oldcfgfile = $trycfgfile;
last;
}
}
print "# old config $oldcfgfile\n" if defined $oldcfgfile;
for (sort keys %oldcfg) {
printf "%-20s %s\n", $_,
ref $oldcfg{$_} ? @{$oldcfg{$_}} : $oldcfg{$_};
}
unless ($opt_c || $opt_d) {
print "# $0 -h for help\n";
exit(0);
}
}
#---------------------------------------------------------------------------
$oldcfg{'test_exist'} = 1 unless exists $oldcfg{'test_exist'};
$oldcfg{'test_hosts'} = 1 unless exists $oldcfg{'test_hosts'};
#---------------------------------------------------------------------------
if($have_old && !$opt_d)
{
$msg = <<EDQ;
Ah, I see you already have installed libnet before.
Do you want to modify/update your configuration (y|n) ?
EDQ
$opt_d = 1
unless get_bool($msg,0);
}
#---------------------------------------------------------------------------
$msg = <<EDQ;
This script will prompt you to enter hostnames that can be used as
defaults for some of the modules in the libnet distribution.
To ensure that you do not enter an invalid hostname, I can perform a
lookup on each hostname you enter. If your internet connection is via
a dialup line then you may not want me to perform these lookups, as
it will require you to be on-line.
Do you want me to perform hostname lookups (y|n) ?
EDQ
$cfg{'test_exist'} = get_bool($msg, $oldcfg{'test_exist'});
print <<EDQ unless $cfg{'test_exist'};
*** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
OK I will not check if the hostnames you give are valid
so be very cafeful
*** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
EDQ
#---------------------------------------------------------------------------
print <<EDQ;
The following questions all require a list of host names, separated
with spaces. If you do not have a host available for any of the
services, then enter a single space, followed by <CR>. To accept the
default, hit <CR>
EDQ
$msg = 'Enter a list of available NNTP hosts :';
$def = $oldcfg{'nntp_hosts'} ||
[ default_hostname($ENV{NNTPSERVER},$ENV{NEWSHOST},'news') ];
$cfg{'nntp_hosts'} = get_host_list($msg,$def);
#---------------------------------------------------------------------------
$msg = 'Enter a list of available SMTP hosts :';
$def = $oldcfg{'smtp_hosts'} ||
[ default_hostname(split(/:/,$ENV{SMTPHOSTS} || ""), 'mailhost') ];
$cfg{'smtp_hosts'} = get_host_list($msg,$def);
#---------------------------------------------------------------------------
$msg = 'Enter a list of available POP3 hosts :';
$def = $oldcfg{'pop3_hosts'} || [];
$cfg{'pop3_hosts'} = get_host_list($msg,$def);
#---------------------------------------------------------------------------
$msg = 'Enter a list of available SNPP hosts :';
$def = $oldcfg{'snpp_hosts'} || [];
$cfg{'snpp_hosts'} = get_host_list($msg,$def);
#---------------------------------------------------------------------------
$msg = 'Enter a list of available PH Hosts :' ;
$def = $oldcfg{'ph_hosts'} ||
[ default_hostname('dirserv') ];
$cfg{'ph_hosts'} = get_host_list($msg,$def);
#---------------------------------------------------------------------------
$msg = 'Enter a list of available TIME Hosts :' ;
$def = $oldcfg{'time_hosts'} || [];
$cfg{'time_hosts'} = get_host_list($msg,$def);
#---------------------------------------------------------------------------
$msg = 'Enter a list of available DAYTIME Hosts :' ;
$def = $oldcfg{'daytime_hosts'} || $oldcfg{'time_hosts'};
$cfg{'daytime_hosts'} = get_host_list($msg,$def);
#---------------------------------------------------------------------------
$msg = <<EDQ;
Do you have a firewall/ftp proxy between your machine and the internet
If you use a SOCKS firewall answer no
(y|n) ?
EDQ
if(get_bool($msg,0)) {
$msg = <<'EDQ';
What series of FTP commands do you need to send to your
firewall to connect to an external host.
user/pass => external user & password
fwuser/fwpass => firewall user & password
0) None
1) -----------------------
USER user at remote.host
PASS pass
2) -----------------------
USER fwuser
PASS fwpass
USER user at remote.host
PASS pass
3) -----------------------
USER fwuser
PASS fwpass
SITE remote.site
USER user
PASS pass
4) -----------------------
USER fwuser
PASS fwpass
OPEN remote.site
USER user
PASS pass
5) -----------------------
USER user at fwuser@remote.site
PASS pass at fwpass
6) -----------------------
USER fwuser at remote.site
PASS fwpass
USER user
PASS pass
7) -----------------------
USER user at remote.host
PASS pass
AUTH fwuser
RESP fwpass
Choice:
EDQ
$def = exists $oldcfg{'ftp_firewall_type'} ? $oldcfg{'ftp_firewall_type'} : 1;
$ans = Prompt($msg,$def);
$cfg{'ftp_firewall_type'} = 0+$ans;
$def = $oldcfg{'ftp_firewall'} || $ENV{FTP_FIREWALL};
$cfg{'ftp_firewall'} = get_hostname("FTP proxy hostname :", $def);
}
else {
delete $cfg{'ftp_firewall'};
}
#---------------------------------------------------------------------------
if (defined $cfg{'ftp_firewall'})
{
print <<EDQ;
By default Net::FTP assumes that it only needs to use a firewall if it
cannot resolve the name of the host given. This only works if your DNS
system is setup to only resolve internal hostnames. If this is not the
case and your DNS will resolve external hostnames, then another method
is needed. Net::Config can do this if you provide the netmasks that
describe your internal network. Each netmask should be entered in the
form x.x.x.x/y, for example 127.0.0.0/8 or 214.8.16.32/24
EDQ
$def = [];
if(ref($oldcfg{'local_netmask'}))
{
$def = $oldcfg{'local_netmask'};
print "Your current netmasks are :\n\n\t",
join("\n\t",@{$def}),"\n\n";
}
print "
Enter one netmask at each prompt, prefix with a - to remove a netmask
from the list, enter a '*' to clear the whole list, an '=' to show the
current list and an empty line to continue with Configure.
";
my $mask = get_netmask("netmask :",$def);
$cfg{'local_netmask'} = $mask if ref($mask) && @$mask;
}
#---------------------------------------------------------------------------
###$msg =<<EDQ;
###
###SOCKS is a commonly used firewall protocol. If you use SOCKS firewalls
###then enter a list of hostames
###
###Enter a list of available SOCKS hosts :
###EDQ
###
###$def = $cfg{'socks_hosts'} ||
### [ default_hostname($ENV{SOCKS5_SERVER},
### $ENV{SOCKS_SERVER},
### $ENV{SOCKS4_SERVER}) ];
###
###$cfg{'socks_hosts'} = get_host_list($msg,$def);
#---------------------------------------------------------------------------
print <<EDQ;
Normally when FTP needs a data connection the client tells the server
a port to connect to, and the server initiates a connection to the client.
Some setups, in particular firewall setups, can/do not work using this
protocol. In these situations the client must make the connection to the
server, this is called a passive transfer.
EDQ
if (defined $cfg{'ftp_firewall'}) {
$msg = "\nShould all FTP connections via a firewall/proxy be passive (y|n) ?";
$def = $oldcfg{'ftp_ext_passive'} || 0;
$cfg{'ftp_ext_passive'} = get_bool($msg,$def);
$msg = "\nShould all other FTP connections be passive (y|n) ?";
}
else {
$msg = "\nShould all FTP connections be passive (y|n) ?";
}
$def = $oldcfg{'ftp_int_passive'} || 0;
$cfg{'ftp_int_passive'} = get_bool($msg,$def);
#---------------------------------------------------------------------------
$def = $oldcfg{'inet_domain'} || $ENV{LOCALDOMAIN};
$ans = Prompt("\nWhat is your local internet domain name :",$def);
$cfg{'inet_domain'} = ($ans =~ /(\S+)/)[0];
#---------------------------------------------------------------------------
$msg = <<EDQ;
If you specified some default hosts above, it is possible for me to
do some basic tests when you run `make test'
This will cause `make test' to be quite a bit slower and, if your
internet connection is via dialup, will require you to be on-line
unless the hosts are local.
Do you want me to run these tests (y|n) ?
EDQ
$cfg{'test_hosts'} = get_bool($msg,$oldcfg{'test_hosts'});
#---------------------------------------------------------------------------
$msg = <<EDQ;
To allow Net::FTP to be tested I will need a hostname. This host
should allow anonymous access and have a /pub directory
What host can I use :
EDQ
$cfg{'ftp_testhost'} = get_hostname($msg,$oldcfg{'ftp_testhost'})
if $cfg{'test_hosts'};
print "\n";
#---------------------------------------------------------------------------
my $fh = IO::File->new($libnet_cfg_out, "w") or
die "Cannot create `$libnet_cfg_out': $!";
print "Writing $libnet_cfg_out\n";
print $fh "{\n";
my $key;
foreach $key (keys %cfg) {
my $val = $cfg{$key};
if(!defined($val)) {
$val = "undef";
}
elsif(ref($val)) {
$val = '[' . join(",",
map {
my $v = "undef";
if(defined $_) {
($v = $_) =~ s/'/\'/sog;
$v = "'" . $v . "'";
}
$v;
} @$val ) . ']';
}
else {
$val =~ s/'/\'/sog;
$val = "'" . $val . "'" if $val =~ /\D/;
}
print $fh "\t'",$key,"' => ",$val,",\n";
}
print $fh "}\n";
$fh->close;
############################################################################
############################################################################
exit 0;
!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;
--- NEW FILE: instmodsh.PL ---
#!/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}.
# 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.
my $origdir = cwd;
chdir dirname($0);
my $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!
use File::Spec;
my $instmodsh = File::Spec->catfile(File::Spec->catdir(File::Spec->updir, "lib", "ExtUtils"), "instmodsh");
if (open(INSTMODSH, $instmodsh)) {
print OUT <INSTMODSH>;
close INSTMODSH;
} else {
die "$0: cannot find '$instmodsh'\n";
}
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;
--- NEW FILE: perldoc.PL ---
#!/usr/local/bin/perl
# This is for generating the perldoc executable.
# It may eventually be expanded to generate many executables, as
# explained in the preface of /Programming Perl/ 3e.
require 5;
use strict;
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}.
# 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.
my $origdir = cwd;
chdir dirname($0);
my $file = basename($0, '.PL');
my $file_shortname = $file; # should be like "perldoc", maybe "perlsyn", etc.
warn "How odd, I'm going to generate $file_shortname?!"
unless $file_shortname =~ m/^\w+$/;
$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 0;
# This "$file" file was generated by "$0"
require 5;
BEGIN { \$^W = 1 if \$ENV{'PERLDOCDEBUG'} }
use Pod::Perldoc;
exit( Pod::Perldoc->run() );
!GROK!THIS!
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;
--- NEW FILE: c2ph.PL ---
#!/usr/local/bin/perl
use Config;
use File::Basename qw(&basename &dirname);
use Cwd;
use subs qw(link);
sub link { # This is a cut-down version of installperl:link().
my($from,$to) = @_;
my($success) = 0;
eval {
CORE::link($from, $to)
? $success++
: ($from =~ m#^/afs/# || $to =~ m#^/afs/#)
? die "AFS" # okay inside eval {}
: die "Couldn't link $from to $to: $!\n";
};
if ($@) {
[...1408 lines suppressed...]
} else {
$_[0] = $template x $ncount;
}
}
}
!NO!SUBS!
close OUT or die "Can't close $file: $!";
chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
unlink 'pstruct';
print "Linking c2ph to pstruct.\n";
if (defined $Config{d_link}) {
link 'c2ph', 'pstruct';
} else {
unshift @INC, '../lib';
require File::Copy;
File::Copy::syscopy('c2ph', 'pstruct');
}
exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
chdir $origdir;
--- NEW FILE: Makefile ---
PERL = ../miniperl
REALPERL = ../perl
# Files to be built with variable substitution after miniperl is
# available. Dependencies handled manually below (for now).
pl = c2ph.PL cpan.PL h2ph.PL h2xs.PL instmodsh.PL perlbug.PL perldoc.PL perlivp.PL pl2pm.PL prove.PL splain.PL perlcc.PL dprofpp.PL libnetcfg.PL piconv.PL enc2xs.PL xsubpp.PL
plextract = c2ph cpan h2ph h2xs instmodsh perlbug perldoc perlivp pl2pm prove splain perlcc dprofpp libnetcfg piconv enc2xs xsubpp
plextractexe = ./c2ph ./cpan ./h2ph ./h2xs ./instmodsh ./perlbug ./perldoc ./perlivp ./pl2pm ./prove ./splain ./perlcc ./dprofpp ./libnetcfg ./piconv ./enc2xs ./xsubpp
all: $(plextract)
compile: all $(plextract)
$(REALPERL) -I../lib perlcc -I .. -L .. c2ph -o c2ph.exe -v 10 -log ../compilelog;
$(REALPERL) -I../lib perlcc -I .. -L .. h2ph -o h2ph.exe -v 10 -log ../compilelog;
$(REALPERL) -I../lib perlcc -I .. -L .. h2xs -o h2xs.exe -v 10 -log ../compilelog;
$(REALPERL) -I../lib perlcc -I .. -L .. perlbug -o perlbug.exe -v 10 -log ../compilelog;
$(REALPERL) -I../lib perlcc -I .. -L .. perldoc -o perldoc.exe -v 10 -log ../compilelog;
$(REALPERL) -I../lib perlcc -I .. -L .. perlivp -o perlivp.exe -v 10 -log ../compilelog;
$(REALPERL) -I../lib perlcc -I .. -L .. pl2pm -o pl2pm.exe -v 10 -log ../compilelog;
$(REALPERL) -I../lib perlcc -I .. -L .. splain -o splain.exe -v 10 -log ../compilelog;
$(REALPERL) -I../lib perlcc -I .. -L .. perlcc -I .. -L .. -o perlcc.exe -v 10 -log ../compilelog;
$(REALPERL) -I../lib perlcc -I .. -L .. dprofpp -o dprofpp.exe -v 10 -log ../compilelog;
$(REALPERL) -I../lib perlcc -I .. -L .. libnetcfg -o libnetcfg.exe -v 10 -log ../compilelog;
$(plextract):
$(PERL) -I../lib $@.PL
c2ph: c2ph.PL ../config.sh
cpan: cpan.PL ../config.sh
h2ph: h2ph.PL ../config.sh
h2xs: h2xs.PL ../config.sh
instmodsh: instmodsh.PL ../config.sh
perlbug: perlbug.PL ../config.sh ../patchlevel.h
perldoc: perldoc.PL ../config.sh
perlivp: perlivp.PL ../config.sh
prove: prove.PL ../config.sh
pl2pm: pl2pm.PL ../config.sh
splain: splain.PL ../config.sh ../lib/diagnostics.pm
perlcc: perlcc.PL ../config.sh
dprofpp: dprofpp.PL ../config.sh
libnetcfg: libnetcfg.PL ../config.sh
piconv: piconv.PL ../config.sh
enc2xs: enc2xs.PL ../config.sh
xsubpp: xsubpp.PL ../config.sh
clean:
realclean:
rm -rf $(plextract) pstruct $(plextractexe)
rm -f ../t/_h2ph_pre.ph
clobber: realclean
distclean: clobber
veryclean: distclean
-rm -f *~ *.org
--- NEW FILE: h2xs.PL ---
#!/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}.
# 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.
my $origdir = cwd;
chdir dirname($0);
my $file = basename($0, '.PL');
$file .= '.com' if $^O eq 'VMS';
[...2174 lines suppressed...]
}
if (!@files) { @files = map {chomp && $_} `ls`; }
if ($^O eq 'VMS') {
foreach (@files) {
# Clip trailing '.' for portability -- non-VMS OSs don't expect it
s%\.$%%;
# Fix up for case-sensitive file systems
s/$modfname/$modfname/i && next;
$_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
$_ = 'Makefile.PL' if $_ eq 'makefile.pl';
}
}
print MANI join("\n", at files), "\n";
close MANI;
!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;
--- NEW FILE: perlcc.PL ---
#!/usr/local/bin/perl
use Config;
use File::Basename qw(&basename &dirname);
use File::Spec;
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;
--\$running_under_some_shell;
!GROK!THIS!
# In the following, perl variables are not expanded during extraction.
print OUT <<'!NO!SUBS!';
# Version 2.0, Simon Cozens, Thu Mar 30 17:52:45 JST 2000
# Version 2.01, Tom Christiansen, Thu Mar 30 08:25:14 MST 2000
# Version 2.02, Simon Cozens, Sun Apr 16 01:53:36 JST 2000
# Version 2.03, Edward Peschko, Mon Feb 26 12:04:17 PST 2001
# Version 2.04, Enache Adrian,Fri, 18 Jul 2003 23:15:37 +0300
use strict;
use warnings;
use 5.006_000;
use FileHandle;
use Config;
use Fcntl qw(:DEFAULT :flock);
use File::Temp qw(tempfile);
use Cwd;
our $VERSION = 2.04;
$| = 1;
$SIG{INT} = sub { exit(); }; # exit gracefully and clean up after ourselves.
use subs qw{
cc_harness check_read check_write checkopts_byte choose_backend
compile_byte compile_cstyle compile_module generate_code
grab_stash parse_argv sanity_check vprint yclept spawnit
};
sub opt(*); # imal quoting
sub is_win32();
sub is_msvc();
our ($Options, $BinPerl, $Backend);
our ($Input => $Output);
our ($logfh);
our ($cfile);
our (@begin_output); # output from BEGIN {}, for testsuite
# eval { main(); 1 } or die;
main();
sub main {
parse_argv();
check_write($Output);
choose_backend();
generate_code();
run_code();
_die("XXX: Not reached?");
}
#######################################################################
sub choose_backend {
# Choose the backend.
$Backend = 'C';
if (opt(B)) {
checkopts_byte();
$Backend = 'Bytecode';
}
if (opt(S) && opt(c)) {
# die "$0: Do you want me to compile this or not?\n";
delete $Options->{S};
}
$Backend = 'CC' if opt(O);
}
sub generate_code {
vprint 0, "Compiling $Input";
$BinPerl = yclept(); # Calling convention for perl.
if (opt(shared)) {
compile_module();
} else {
if ($Backend eq 'Bytecode') {
compile_byte();
} else {
compile_cstyle();
}
}
exit(0) if (!opt('r'));
}
sub run_code {
vprint 0, "Running code";
run("$Output @ARGV");
exit(0);
}
# usage: vprint [level] msg args
sub vprint {
my $level;
if (@_ == 1) {
$level = 1;
} elsif ($_[0] =~ /^\d$/) {
$level = shift;
} else {
# well, they forgot to use a number; means >0
$level = 0;
}
my $msg = "@_";
$msg .= "\n" unless substr($msg, -1) eq "\n";
if (opt(v) > $level)
{
print "$0: $msg" if !opt('log');
print $logfh "$0: $msg" if opt('log');
}
}
sub parse_argv {
use Getopt::Long;
# disallows using long arguments
# Getopt::Long::Configure("bundling");
Getopt::Long::Configure("no_ignore_case");
# no difference in exists and defined for %ENV; also, a "0"
# argument or a "" would not help cc, so skip
unshift @ARGV, split ' ', $ENV{PERLCC_OPTS} if $ENV{PERLCC_OPTS};
$Options = {};
Getopt::Long::GetOptions( $Options,
'L:s', # lib directory
'I:s', # include directories (FOR C, NOT FOR PERL)
'o:s', # Output executable
'v:i', # Verbosity level
'e:s', # One-liner
'r', # run resulting executable
'B', # Byte compiler backend
'O', # Optimised C backend
'c', # Compile only
'h', # Help me
'S', # Dump C files
'r', # run the resulting executable
'T', # run the backend using perl -T
't', # run the backend using perl -t
'static', # Dirty hack to enable -shared/-static
'shared', # Create a shared library (--shared for compat.)
'log:s', # where to log compilation process information
'Wb:s', # pass (comma-sepearated) options to backend
'testsuite', # try to be nice to testsuite
);
$Options->{v} += 0;
if( opt(t) && opt(T) ) {
warn "Can't specify both -T and -t, -t ignored";
$Options->{t} = 0;
}
helpme() if opt(h); # And exit
$Output = opt(o) || ( is_win32 ? 'a.exe' : 'a.out' );
$Output = is_win32() ? $Output : relativize($Output);
$logfh = new FileHandle(">> " . opt('log')) if (opt('log'));
if (opt(e)) {
warn "$0: using -e 'code' as input file, ignoring @ARGV\n" if @ARGV;
# We don't use a temporary file here; why bother?
# XXX: this is not bullet proof -- spaces or quotes in name!
$Input = is_win32() ? # Quotes eaten by shell
'-e "'.opt(e).'"' :
"-e '".opt(e)."'";
} else {
$Input = shift @ARGV; # XXX: more files?
_usage_and_die("$0: No input file specified\n") unless $Input;
# DWIM modules. This is bad but necessary.
$Options->{shared}++ if $Input =~ /\.pm\z/;
warn "$0: using $Input as input file, ignoring @ARGV\n" if @ARGV;
check_read($Input);
check_perl($Input);
sanity_check();
}
}
sub opt(*) {
my $opt = shift;
return exists($Options->{$opt}) && ($Options->{$opt} || 0);
}
sub compile_module {
die "$0: Compiling to shared libraries is currently disabled\n";
}
sub compile_byte {
my $command = "$BinPerl -MO=Bytecode,-H,-o$Output $Input";
$Input =~ s/^-e.*$/-e/;
my ($output_r, $error_r) = spawnit($command);
if (@$error_r && $? != 0) {
_die("$0: $Input did not compile:\n@$error_r\n");
} else {
my @error = grep { !/^$Input syntax OK$/o } @$error_r;
warn "$0: Unexpected compiler output:\n at error" if @error;
}
chmod 0777 & ~umask, $Output or _die("can't chmod $Output: $!");
exit 0;
}
sub compile_cstyle {
my $stash = grab_stash();
my $taint = opt(T) ? '-T' :
opt(t) ? '-t' : '';
# What are we going to call our output C file?
my $lose = 0;
my ($cfh);
my $testsuite = '';
my $addoptions = opt(Wb);
if( $addoptions ) {
$addoptions .= ',' if $addoptions !~ m/,$/;
}
if (opt(testsuite)) {
my $bo = join '', @begin_output;
$bo =~ s/\\/\\\\\\\\/gs;
$bo =~ s/\n/\\n/gs;
$bo =~ s/,/\\054/gs;
# don't look at that: it hurts
$testsuite = q{-fuse-script-name,-fsave-data,-fsave-sig-hash,}.
qq[-e"print q{$bo}",] .
q{-e"open(Test::Builder::TESTOUT\054 '>&STDOUT') or die $!",} .
q{-e"open(Test::Builder::TESTERR\054 '>&STDERR') or die $!",};
}
if (opt(S) || opt(c)) {
# We need to keep it.
if (opt(e)) {
$cfile = "a.out.c";
} else {
$cfile = $Input;
# File off extension if present
# hold on: plx is executable; also, careful of ordering!
$cfile =~ s/\.(?:p(?:lx|l|h)|m)\z//i;
$cfile .= ".c";
$cfile = $Output if opt(c) && $Output =~ /\.c\z/i;
}
check_write($cfile);
} else {
# Don't need to keep it, be safe with a tempfile.
$lose = 1;
($cfh, $cfile) = tempfile("pccXXXXX", SUFFIX => ".c");
close $cfh; # See comment just below
}
vprint 1, "Writing C on $cfile";
my $max_line_len = '';
if ($^O eq 'MSWin32' && $Config{cc} =~ /^cl/i) {
$max_line_len = '-l2000,';
}
# This has to do the write itself, so we can't keep a lock. Life
# sucks.
my $command = "$BinPerl $taint -MO=$Backend,$addoptions$testsuite$max_line_len$stash,-o$cfile $Input";
vprint 1, "Compiling...";
vprint 1, "Calling $command";
my ($output_r, $error_r) = spawnit($command);
my @output = @$output_r;
my @error = @$error_r;
if (@error && $? != 0) {
_die("$0: $Input did not compile, which can't happen:\n at error\n");
}
is_msvc ?
cc_harness_msvc($cfile,$stash) :
cc_harness($cfile,$stash) unless opt(c);
if ($lose) {
vprint 2, "unlinking $cfile";
unlink $cfile or _die("can't unlink $cfile: $!");
}
}
sub cc_harness_msvc {
my ($cfile,$stash)=@_;
use ExtUtils::Embed ();
my $obj = "${Output}.obj";
my $compile = ExtUtils::Embed::ccopts." -c -Fo$obj $cfile ";
my $link = "-out:$Output $obj";
$compile .= " -I".$_ for split /\s+/, opt(I);
$link .= " -libpath:".$_ for split /\s+/, opt(L);
my @mods = split /-?u /, $stash;
$link .= " ".ExtUtils::Embed::ldopts("-std", \@mods);
$link .= " perl5$Config{PERL_VERSION}.lib kernel32.lib msvcrt.lib";
vprint 3, "running $Config{cc} $compile";
system("$Config{cc} $compile");
vprint 3, "running $Config{ld} $link";
system("$Config{ld} $link");
}
sub cc_harness {
my ($cfile,$stash)=@_;
use ExtUtils::Embed ();
my $command = ExtUtils::Embed::ccopts." -o $Output $cfile ";
$command .= " -I".$_ for split /\s+/, opt(I);
$command .= " -L".$_ for split /\s+/, opt(L);
my @mods = split /-?u /, $stash;
$command .= " ".ExtUtils::Embed::ldopts("-std", \@mods);
$command .= " -lperl";
vprint 3, "running $Config{cc} $command";
system("$Config{cc} $command");
}
# Where Perl is, and which include path to give it.
sub yclept {
my $command = "$^X ";
# DWIM the -I to be Perl, not C, include directories.
if (opt(I) && $Backend eq "Bytecode") {
for (split /\s+/, opt(I)) {
if (-d $_) {
push @INC, $_;
} else {
warn "$0: Include directory $_ not found, skipping\n";
}
}
}
$command .= "-I$_ " for @INC;
return $command;
}
# Use B::Stash to find additional modules and stuff.
{
my $_stash;
sub grab_stash {
warn "already called get_stash once" if $_stash;
my $taint = opt(T) ? '-T' :
opt(t) ? '-t' : '';
my $command = "$BinPerl $taint -MB::Stash -c $Input";
# Filename here is perfectly sanitised.
vprint 3, "Calling $command\n";
my ($stash_r, $error_r) = spawnit($command);
my @stash = @$stash_r;
my @error = @$error_r;
if (@error && $? != 0) {
_die("$0: $Input did not compile:\n at error\n");
}
# band-aid for modules with noisy BEGIN {}
foreach my $i ( @stash ) {
$i =~ m/-u(?:[\w:]+|\<none\>)$/ and $stash[0] = $i and next;
push @begin_output, $i;
}
chomp $stash[0];
$stash[0] =~ s/,-u\<none\>//;
$stash[0] =~ s/^.*?-u/-u/s;
vprint 2, "Stash: ", join " ", split /,?-u/, $stash[0];
chomp $stash[0];
return $_stash = $stash[0];
}
}
# Check the consistency of options if -B is selected.
# To wit, (-B|-O) ==> no -shared, no -S, no -c
sub checkopts_byte {
_die("$0: Please choose one of either -B and -O.\n") if opt(O);
if (opt(shared)) {
warn "$0: Will not create a shared library for bytecode\n";
delete $Options->{shared};
}
for my $o ( qw[c S] ) {
if (opt($o)) {
warn "$0: Compiling to bytecode is a one-pass process--",
"-$o ignored\n";
delete $Options->{$o};
}
}
}
# Check the input and output files make sense, are read/writeable.
sub sanity_check {
if ($Input eq $Output) {
if ($Input eq 'a.out') {
_die("$0: Compiling a.out is probably not what you want to do.\n");
# You fully deserve what you get now. No you *don't*. typos happen.
} else {
warn "$0: Will not write output on top of input file, ",
"compiling to a.out instead\n";
$Output = "a.out";
}
}
}
sub check_read {
my $file = shift;
unless (-r $file) {
_die("$0: Input file $file is a directory, not a file\n") if -d _;
unless (-e _) {
_die("$0: Input file $file was not found\n");
} else {
_die("$0: Cannot read input file $file: $!\n");
}
}
unless (-f _) {
# XXX: die? don't try this on /dev/tty
warn "$0: WARNING: input $file is not a plain file\n";
}
}
sub check_write {
my $file = shift;
if (-d $file) {
_die("$0: Cannot write on $file, is a directory\n");
}
if (-e _) {
_die("$0: Cannot write on $file: $!\n") unless -w _;
}
unless (-w cwd()) {
_die("$0: Cannot write in this directory: $!\n");
}
}
sub check_perl {
my $file = shift;
unless (-T $file) {
warn "$0: Binary `$file' sure doesn't smell like perl source!\n";
print "Checking file type... ";
system("file", $file);
_die("Please try a perlier file!\n");
}
open(my $handle, "<", $file) or _die("XXX: can't open $file: $!");
local $_ = <$handle>;
if (/^#!/ && !/perl/) {
_die("$0: $file is a ", /^#!\s*(\S+)/, " script, not perl\n");
}
}
# File spawning and error collecting
sub spawnit {
my ($command) = shift;
my (@error, at output);
my $errname;
(undef, $errname) = tempfile("pccXXXXX");
{
open (S_OUT, "$command 2>$errname |")
or _die("$0: Couldn't spawn the compiler.\n");
@output = <S_OUT>;
}
open (S_ERROR, $errname) or _die("$0: Couldn't read the error file.\n");
@error = <S_ERROR>;
close S_ERROR;
close S_OUT;
unlink $errname or _die("$0: Can't unlink error file $errname");
return (\@output, \@error);
}
sub helpme {
print "perlcc compiler frontend, version $VERSION\n\n";
{ no warnings;
exec "pod2usage $0";
exec "perldoc $0";
exec "pod2text $0";
}
}
sub relativize {
my ($args) = @_;
return() if ($args =~ m"^[/\\]");
return("./$args");
}
sub _die {
$logfh->print(@_) if opt('log');
print STDERR @_;
exit(); # should die eventually. However, needed so that a 'make compile'
# can compile all the way through to the end for standard dist.
}
sub _usage_and_die {
_die(<<EOU);
$0: Usage:
$0 [-o executable] [-r] [-O|-B|-c|-S] [-I /foo] [-L /foo] [-log log] [source[.pl] | -e oneliner]
EOU
}
sub run {
my (@commands) = @_;
print interruptrun(@commands) if (!opt('log'));
$logfh->print(interruptrun(@commands)) if (opt('log'));
}
sub interruptrun
{
my (@commands) = @_;
my $command = join('', @commands);
local(*FD);
my $pid = open(FD, "$command |");
my $text;
local($SIG{HUP}) = sub { kill 9, $pid; exit };
local($SIG{INT}) = sub { kill 9, $pid; exit };
my $needalarm =
($ENV{PERLCC_TIMEOUT} &&
$Config{'osname'} ne 'MSWin32' &&
$command =~ m"(^|\s)perlcc\s");
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 };
vprint 0, "SYSTEM TIMEOUT (infinite loop?)\n";
}
close(FD);
return($text);
}
sub is_win32() { $^O =~ m/^MSWin/ }
sub is_msvc() { is_win32 && $Config{cc} =~ m/^cl/i }
END {
unlink $cfile if ($cfile && !opt(S) && !opt(c));
}
__END__
=head1 NAME
perlcc - generate executables from Perl programs
=head1 SYNOPSIS
$ perlcc hello # Compiles into executable 'a.out'
$ perlcc -o hello hello.pl # Compiles into executable 'hello'
$ perlcc -O file # Compiles using the optimised C backend
$ perlcc -B file # Compiles using the bytecode backend
$ perlcc -c file # Creates a C file, 'file.c'
$ perlcc -S -o hello file # Creates a C file, 'file.c',
# then compiles it to executable 'hello'
$ perlcc -c out.c file # Creates a C file, 'out.c' from 'file'
$ perlcc -e 'print q//' # Compiles a one-liner into 'a.out'
$ perlcc -c -e 'print q//' # Creates a C file 'a.out.c'
$ perlcc -I /foo hello # extra headers (notice the space after -I)
$ perlcc -L /foo hello # extra libraries (notice the space after -L)
$ perlcc -r hello # compiles 'hello' into 'a.out', runs 'a.out'.
$ perlcc -r hello a b c # compiles 'hello' into 'a.out', runs 'a.out'.
# with arguments 'a b c'
$ perlcc hello -log c # compiles 'hello' into 'a.out' logs compile
# log into 'c'.
=head1 DESCRIPTION
F<perlcc> creates standalone executables from Perl programs, using the
code generators provided by the L<B> module. At present, you may
either create executable Perl bytecode, using the C<-B> option, or
generate and compile C files using the standard and 'optimised' C
backends.
The code generated in this way is not guaranteed to work. The whole
codegen suite (C<perlcc> included) should be considered B<very>
experimental. Use for production purposes is strongly discouraged.
=head1 OPTIONS
=over 4
=item -LI<library directories>
Adds the given directories to the library search path when C code is
passed to your C compiler.
=item -II<include directories>
Adds the given directories to the include file search path when C code is
passed to your C compiler; when using the Perl bytecode option, adds the
given directories to Perl's include path.
=item -o I<output file name>
Specifies the file name for the final compiled executable.
=item -c I<C file name>
Create C code only; do not compile to a standalone binary.
=item -e I<perl code>
Compile a one-liner, much the same as C<perl -e '...'>
=item -S
Do not delete generated C code after compilation.
=item -B
Use the Perl bytecode code generator.
=item -O
Use the 'optimised' C code generator. This is more experimental than
everything else put together, and the code created is not guaranteed to
compile in finite time and memory, or indeed, at all.
=item -v
Increase verbosity of output; can be repeated for more verbose output.
=item -r
Run the resulting compiled script after compiling it.
=item -log
Log the output of compiling to a file rather than to stdout.
=back
=cut
!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;
--- NEW FILE: pl2pm.PL ---
#!/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}.
# 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!';
=head1 NAME
pl2pm - Rough tool to translate Perl4 .pl files to Perl5 .pm modules.
=head1 SYNOPSIS
B<pl2pm> F<files>
=head1 DESCRIPTION
B<pl2pm> is a tool to aid in the conversion of Perl4-style .pl
library files to Perl5-style library modules. Usually, your old .pl
file will still work fine and you should only use this tool if you
plan to update your library to use some of the newer Perl 5 features,
such as AutoLoading.
=head1 LIMITATIONS
It's just a first step, but it's usually a good first step.
=head1 AUTHOR
Larry Wall <larry at wall.org>
=cut
use strict;
use warnings;
my %keyword = ();
while (<DATA>) {
chomp;
$keyword{$_} = 1;
}
local $/;
while (<>) {
my $newname = $ARGV;
$newname =~ s/\.pl$/.pm/ || next;
$newname =~ s#(.*/)?(\w+)#$1\u$2#;
if (-f $newname) {
warn "Won't overwrite existing $newname\n";
next;
}
my $oldpack = $2;
my $newpack = "\u$2";
my @export = ();
s/\bstd(in|out|err)\b/\U$&/g;
s/(sub\s+)(\w+)(\s*\{[ \t]*\n)\s*package\s+$oldpack\s*;[ \t]*\n+/${1}main'$2$3/ig;
if (/sub\s+\w+'/) {
@export = m/sub\s+\w+'(\w+)/g;
s/(sub\s+)main'(\w+)/$1$2/g;
}
else {
@export = m/sub\s+([A-Za-z]\w*)/g;
}
my @export_ok = grep($keyword{$_}, @export);
@export = grep(!$keyword{$_}, @export);
my %export = ();
@export{@export} = (1) x @export;
s/(^\s*);#/$1#/g;
s/(#.*)require ['"]$oldpack\.pl['"]/$1use $newpack/;
s/(package\s*)($oldpack)\s*;[ \t]*\n+//ig;
s/([\$\@%&*])'(\w+)/&xlate($1,"",$2,$newpack,$oldpack,\%export)/eg;
s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3,$newpack,$oldpack,\%export)/eg;
if (!/\$\[\s*\)?\s*=\s*[^0\s]/) {
s/^\s*(local\s*\()?\s*\$\[\s*\)?\s*=\s*0\s*;[ \t]*\n//g;
s/\$\[\s*\+\s*//g;
s/\s*\+\s*\$\[//g;
s/\$\[/0/g;
}
s/open\s+(\w+)/open($1)/g;
my $export_ok = '';
my $carp ='';
if (s/\bdie\b/croak/g) {
$carp = "use Carp;\n";
s/croak "([^"]*)\\n"/croak "$1"/g;
}
if (@export_ok) {
$export_ok = "\@EXPORT_OK = qw(@export_ok);\n";
}
if ( open(PM, ">$newname") ) {
print PM <<"END";
package $newpack;
use 5.006;
require Exporter;
$carp
\@ISA = qw(Exporter);
\@EXPORT = qw(@export);
$export_ok
$_
END
}
else {
warn "Can't create $newname: $!\n";
}
}
sub xlate {
my ($prefix, $pack, $ident,$newpack,$oldpack,$export) = @_;
my $xlated ;
if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) {
$xlated = "${pack}'$ident";
}
elsif ($pack eq '' || $pack eq 'main') {
if ($export->{$ident}) {
$xlated = "$prefix$ident";
}
else {
$xlated = "$prefix${pack}::$ident";
}
}
elsif ($pack eq $oldpack) {
$xlated = "$prefix${newpack}::$ident";
}
else {
$xlated = "$prefix${pack}::$ident";
}
return $xlated;
}
__END__
AUTOLOAD
BEGIN
CORE
DESTROY
END
INIT
CHECK
abs
accept
alarm
and
atan2
bind
binmode
bless
caller
chdir
chmod
chomp
chop
chown
chr
chroot
close
closedir
cmp
connect
continue
cos
crypt
dbmclose
dbmopen
defined
delete
die
do
dump
each
else
elsif
endgrent
endhostent
endnetent
endprotoent
endpwent
endservent
eof
eq
eval
exec
exists
exit
exp
fcntl
fileno
flock
for
foreach
fork
format
formline
ge
getc
getgrent
getgrgid
getgrnam
gethostbyaddr
gethostbyname
gethostent
getlogin
getnetbyaddr
getnetbyname
getnetent
getpeername
getpgrp
getppid
getpriority
getprotobyname
getprotobynumber
getprotoent
getpwent
getpwnam
getpwuid
getservbyname
getservbyport
getservent
getsockname
getsockopt
glob
gmtime
goto
grep
gt
hex
if
index
int
ioctl
join
keys
kill
last
lc
lcfirst
le
length
link
listen
local
localtime
lock
log
lstat
lt
m
map
mkdir
msgctl
msgget
msgrcv
msgsnd
my
ne
next
no
not
oct
open
opendir
or
ord
our
pack
package
pipe
pop
pos
print
printf
prototype
push
q
qq
qr
quotemeta
qw
qx
rand
read
readdir
readline
readlink
readpipe
recv
redo
ref
rename
require
reset
return
reverse
rewinddir
rindex
rmdir
s
scalar
seek
seekdir
select
semctl
semget
semop
send
setgrent
sethostent
setnetent
setpgrp
setpriority
setprotoent
setpwent
setservent
setsockopt
shift
shmctl
shmget
shmread
shmwrite
shutdown
sin
sleep
socket
socketpair
sort
splice
split
sprintf
sqrt
srand
stat
study
sub
substr
symlink
syscall
sysopen
sysread
sysseek
system
syswrite
tell
telldir
tie
tied
time
times
tr
truncate
uc
ucfirst
umask
undef
unless
unlink
unpack
unshift
untie
until
use
utime
values
vec
wait
waitpid
wantarray
warn
while
write
x
xor
y
!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;
--- NEW FILE: cpan.PL ---
#!/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}.
# 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.
my $origdir = cwd;
chdir dirname($0);
my $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!
use File::Spec;
my $cpan = File::Spec->catfile(File::Spec->catdir(File::Spec->updir, "lib", "CPAN", "bin"), "cpan");
if (open(CPAN, $cpan)) {
print OUT <CPAN>;
close CPAN;
} else {
die "$0: cannot find '$cpan'\n";
}
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;
--- NEW FILE: perlivp.PL ---
#!/usr/local/bin/perl
use Config;
use File::Basename;
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:
# $startperl
# $perlpath
# $eunicefix
# 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.
my $origdir = cwd;
chdir dirname($0);
my $file = basename($0, '.PL');
$file .= '.com' if $^O eq 'VMS';
# Create output file.
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!';
# perlivp V 0.02
sub usage {
warn "@_\n" if @_;
print << " EOUSAGE";
Usage:
$0 [-a] [-p] [-v] | [-h]
-a Run all tests (default is to skip .ph tests)
-p Print a preface before each test telling what it will test.
-v Verbose mode in which extra information about test results
is printed. Test failures always print out some extra information
regardless of whether or not this switch is set.
-h Prints this help message.
EOUSAGE
exit;
}
use vars qw(%opt); # allow testing with older versions (do not use our)
@opt{ qw/? H h P p V v/ } = qw(0 0 0 0 0 0 0);
while ($ARGV[0] =~ /^-/) {
$ARGV[0] =~ s/^-//;
for my $flag (split(//,$ARGV[0])) {
usage() if '?' =~ /\Q$flag/;
usage() if 'h' =~ /\Q$flag/;
usage() if 'H' =~ /\Q$flag/;
usage("unknown flag: `$flag'") unless 'HhPpVva' =~ /\Q$flag/;
warn "$0: `$flag' flag already set\n" if $opt{$flag}++;
}
shift;
}
$opt{p}++ if $opt{P};
$opt{v}++ if $opt{V};
my $pass__total = 0;
my $error_total = 0;
my $tests_total = 0;
!NO!SUBS!
# We cannot merely check the variable `$^X' in general since on many
# Unixes it is the basename rather than the full path to the perl binary.
my $perlpath = '';
if (defined($Config{'perlpath'})) { $perlpath = $Config{'perlpath'}; }
# The useithreads Config variable plays a role in whether or not
# threads and threads/shared work when C<use>d. They apparently always
# get installed on systems that can run Configure.
my $useithreads = '';
if (defined($Config{'useithreads'})) { $useithreads = $Config{'useithreads'}; }
print OUT <<"!GROK!THIS!";
my \$perlpath = '$perlpath';
my \$useithreads = '$useithreads';
!GROK!THIS!
print OUT <<'!NO!SUBS!';
print "## Checking Perl binary via variable `\$perlpath' = $perlpath.\n" if $opt{'p'};
if (-x $perlpath) {
print "## Perl binary `$perlpath' appears executable.\n" if $opt{'v'};
print "ok 1\n";
$pass__total++;
}
else {
print "# Perl binary `$perlpath' does not appear executable.\n";
print "not ok 1\n";
$error_total++;
}
$tests_total++;
print "## Checking Perl version via variable `\$]'.\n" if $opt{'p'};
!NO!SUBS!
print OUT <<"!GROK!THIS!";
my \$ivp_VERSION = $];
!GROK!THIS!
print OUT <<'!NO!SUBS!';
if ($ivp_VERSION eq $]) {
print "## Perl version `$]' appears installed as expected.\n" if $opt{'v'};
print "ok 2\n";
$pass__total++;
}
else {
print "# Perl version `$]' installed, expected $ivp_VERSION.\n";
print "not ok 2\n";
$error_total++;
}
$tests_total++;
print "## Checking roots of the Perl library directory tree via variable `\@INC'.\n" if $opt{'p'};
my $INC_total = 0;
my $INC_there = 0;
foreach (@INC) {
next if $_ eq '.'; # skip -d test here
if ($^O eq 'MacOS') {
next if $_ eq ':'; # skip -d test here
next if $_ eq 'Dev:Pseudo:'; # why is this in @INC?
}
if (-d $_) {
print "## Perl \@INC directory `$_' exists.\n" if $opt{'v'};
$INC_there++;
}
else {
print "# Perl \@INC directory `$_' does not appear to exist.\n";
}
$INC_total++;
}
if ($INC_total == $INC_there) {
print "ok 3\n";
$pass__total++;
}
else {
print "not ok 3\n";
$error_total++;
}
$tests_total++;
print "## Checking installations of modules necessary for ivp.\n" if $opt{'p'};
my $needed_total = 0;
my $needed_there = 0;
foreach (qw(Config.pm ExtUtils/Installed.pm)) {
$@ = undef;
$needed_total++;
eval "require \"$_\";";
if (!$@) {
print "## Module `$_' appears to be installed.\n" if $opt{'v'};
$needed_there++;
}
else {
print "# Needed module `$_' does not appear to be properly installed.\n";
}
$@ = undef;
}
if ($needed_total == $needed_there) {
print "ok 4\n";
$pass__total++;
}
else {
print "not ok 4\n";
$error_total++;
}
$tests_total++;
print "## Checking installations of extensions built with perl.\n" if $opt{'p'};
use Config;
my $extensions_total = 0;
my $extensions_there = 0;
if (defined($Config{'extensions'})) {
my @extensions = split(/\s+/,$Config{'extensions'});
foreach (@extensions) {
next if ($_ eq '');
if ( $useithreads !~ /define/i ) {
next if ($_ eq 'threads');
next if ($_ eq 'threads/shared');
}
next if ($_ eq 'Devel/DProf');
# VMS$ perl -e "eval ""require \""Devel/DProf.pm\"";"" print $@"
# \NT> perl -e "eval \"require 'Devel/DProf.pm'\"; print $@"
# DProf: run perl with -d to use DProf.
# Compilation failed in require at (eval 1) line 1.
eval " require \"$_.pm\"; ";
if (!$@) {
print "## Module `$_' appears to be installed.\n" if $opt{'v'};
$extensions_there++;
}
else {
print "# Required module `$_' does not appear to be properly installed.\n";
$@ = undef;
}
$extensions_total++;
}
# A silly name for a module (that hopefully won't ever exist).
# Note that this test serves more as a check of the validity of the
# actuall required module tests above.
my $unnecessary = 'bLuRfle';
if (!grep(/$unnecessary/, @extensions)) {
$@ = undef;
eval " require \"$unnecessary.pm\"; ";
if ($@) {
print "## Unnecessary module `$unnecessary' does not appear to be installed.\n" if $opt{'v'};
}
else {
print "# Unnecessary module `$unnecessary' appears to be installed.\n";
$extensions_there++;
}
}
$@ = undef;
}
if ($extensions_total == $extensions_there) {
print "ok 5\n";
$pass__total++;
}
else {
print "not ok 5\n";
$error_total++;
}
$tests_total++;
print "## Checking installations of later additional extensions.\n" if $opt{'p'};
use ExtUtils::Installed;
my $installed_total = 0;
my $installed_there = 0;
my $version_check = 0;
my $installed = ExtUtils::Installed -> new();
my @modules = $installed -> modules();
my @missing = ();
my $version = undef;
for (@modules) {
$installed_total++;
# Consider it there if it contains one or more files,
# and has zero missing files,
# and has a defined version
$version = undef;
$version = $installed -> version($_);
if ($version) {
print "## $_; $version\n" if $opt{'v'};
$version_check++;
}
else {
print "# $_; NO VERSION\n" if $opt{'v'};
}
$version = undef;
@missing = ();
@missing = $installed -> validate($_);
if ($#missing >= 0) {
print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n";
print '# ',join(' ', at missing),"\n";
}
elsif ($#missing == -1) {
$installed_there++;
}
@missing = ();
}
if (($installed_total == $installed_there) &&
($installed_total == $version_check)) {
print "ok 6\n";
$pass__total++;
}
else {
print "not ok 6\n";
$error_total++;
}
$tests_total++;
if ($opt{'a'}) {
print "## Checking installations of *.h -> *.ph header files.\n" if $opt{'p'};
my $ph_there = 0;
my $var = undef;
my $val = undef;
my $h_file = undef;
# Just about "any" C implementation ought to have a stdio.h (even if
# Config.pm may not list a i_stdio var).
my @ph_files = qw(stdio.ph);
# Add the ones that we know that perl thinks are there:
while (($var, $val) = each %Config) {
if ($var =~ m/i_(.+)/ && $val eq 'define') {
$h_file = $1;
# Some header and symbol names don't match for hysterical raisins.
$h_file = 'arpa/inet' if $h_file eq 'arpainet';
$h_file = 'netinet/in' if $h_file eq 'niin';
$h_file = 'netinet/tcp' if $h_file eq 'netinettcp';
$h_file = 'sys/resource' if $h_file eq 'sysresrc';
$h_file = 'sys/select' if $h_file eq 'sysselct';
$h_file = 'sys/security' if $h_file eq 'syssecrt';
$h_file = 'rpcsvc/dbm' if $h_file eq 'rpcsvcdbm';
# This ought to distinguish syslog from sys/syslog.
# (NB syslog.ph is heavily used for the DBI pre-requisites).
$h_file =~ s{^sys(\w.+)}{sys/$1} unless $h_file eq 'syslog';
push(@ph_files, "$h_file.ph");
}
}
#foreach (qw(stdio.ph syslog.ph)) {
foreach (@ph_files) {
$@ = undef;
eval "require \"$_\";";
if (!$@) {
print "## Perl header `$_' appears to be installed.\n" if $opt{'v'};
$ph_there++;
}
else {
print "# Perl header `$_' does not appear to be properly installed.\n";
}
$@ = undef;
}
if (scalar(@ph_files) == $ph_there) {
print "ok 7\n";
$pass__total++;
}
else {
print "not ok 7\n";
$error_total++;
}
$tests_total++;
}
else {
print "## Skip checking of *.ph header files.\n" if $opt{'p'};
}
# Final report (rather than feed ousrselves to Test::Harness::runtests()
# we simply format some output on our own to keep things simple and
# easier to "fix" - at least for now.
if ($error_total == 0 && $tests_total) {
print "All tests successful.\n";
} elsif ($tests_total==0){
die "FAILED--no tests were run for some reason.\n";
} else {
my $rate = 0.0;
if ($tests_total > 0) { $rate = sprintf "%.2f", 100.0 * ($pass__total / $tests_total); }
printf " %d/%d subtests failed, %.2f%% okay.\n",
$error_total, $tests_total, $rate;
}
=head1 NAME
perlivp - Perl Installation Verification Procedure
=head1 SYNOPSIS
B<perlivp> [B<-a>] [B<-p>] [B<-v>] [B<-h>]
=head1 DESCRIPTION
The B<perlivp> program is set up at Perl source code build time to test the
Perl version it was built under. It can be used after running:
make install
(or your platform's equivalent procedure) to verify that B<perl> and its
libraries have been installed correctly. A correct installation is verified
by output that looks like:
ok 1
ok 2
etc.
=head1 OPTIONS
=over 5
=item B<-h> help
Prints out a brief help message.
=item B<-a> run all tests
Normally tests for optional features are skipped. With -a all tests
are executed.
=item B<-p> print preface
Gives a description of each test prior to performing it.
=item B<-v> verbose
Gives more detailed information about each test, after it has been performed.
Note that any failed tests ought to print out some extra information whether
or not -v is thrown.
=back
=head1 DIAGNOSTICS
=over 4
=item * print "# Perl binary `$perlpath' does not appear executable.\n";
Likely to occur for a perl binary that was not properly installed.
Correct by conducting a proper installation.
=item * print "# Perl version `$]' installed, expected $ivp_VERSION.\n";
Likely to occur for a perl that was not properly installed.
Correct by conducting a proper installation.
=item * print "# Perl \@INC directory `$_' does not appear to exist.\n";
Likely to occur for a perl library tree that was not properly installed.
Correct by conducting a proper installation.
=item * print "# Needed module `$_' does not appear to be properly installed.\n";
One of the two modules that is used by perlivp was not present in the
installation. This is a serious error since it adversely affects perlivp's
ability to function. You may be able to correct this by performing a
proper perl installation.
=item * print "# Required module `$_' does not appear to be properly installed.\n";
An attempt to C<eval "require $module"> failed, even though the list of
extensions indicated that it should succeed. Correct by conducting a proper
installation.
=item * print "# Unnecessary module `bLuRfle' appears to be installed.\n";
This test not coming out ok could indicate that you have in fact installed
a bLuRfle.pm module or that the C<eval " require \"$module_name.pm\"; ">
test may give misleading results with your installation of perl. If yours
is the latter case then please let the author know.
=item * print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n";
One or more files turned up missing according to a run of
C<ExtUtils::Installed -E<gt> validate()> over your installation.
Correct by conducting a proper installation.
=item * print "# Perl header `$_' does not appear to be properly installed.\n";
Correct by running B<h2ph> over your system's C header files. If necessary,
edit the resulting *.ph files to eliminate perl syntax errors.
=back
For further information on how to conduct a proper installation consult the
INSTALL file that comes with the perl source and the README file for your
platform.
=head1 AUTHOR
Peter Prymmer
=cut
!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;
--- NEW FILE: enc2xs.PL ---
#!/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}.
# 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.
my $origdir = cwd;
chdir dirname($0);
my $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!
use File::Spec;
my $enc2xs = File::Spec->catfile(File::Spec->catdir(File::Spec->updir, "ext", "Encode", "bin"), "enc2xs");
if (open(ENC2XS, $enc2xs)) {
print OUT <ENC2XS>;
close ENC2XS;
} else {
die "$0: cannot find '$enc2xs'\n";
}
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;
--- NEW FILE: perlbug.PL ---
#!/usr/local/bin/perl
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
# 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}.
# $perlpath
# 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);
[...1248 lines suppressed...]
(E<lt>pudge at pobox.comE<gt>), Jon Orwant (E<lt>orwant at media.mit.eduE<gt>,
and Richard Foley (E<lt>richard at rfi.netE<gt>).
=head1 SEE ALSO
perl(1), perldebug(1), perldiag(1), perlport(1), perltrap(1),
diff(1), patch(1), dbx(1), gdb(1)
=head1 BUGS
None known (guess what must have been used to report them?)
=cut
!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;
--- NEW FILE: h2ph.PL ---
#!/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 Config;
use File::Path qw(mkpath);
use Getopt::Std;
# Make sure read permissions for all are set:
if (defined umask && (umask() & 0444)) {
umask (umask() & ~0444);
}
getopts('Dd:rlhaQe');
use vars qw($opt_D $opt_d $opt_r $opt_l $opt_h $opt_a $opt_Q $opt_e);
die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a);
my @inc_dirs = inc_dirs() if $opt_a;
my $Exit = 0;
my $Dest_dir = $opt_d || $Config{installsitearch};
die "Destination directory $Dest_dir doesn't exist or isn't a directory\n"
unless -d $Dest_dir;
my @isatype = qw(
char uchar u_char
short ushort u_short
int uint u_int
long ulong u_long
FILE key_t caddr_t
float double size_t
);
my %isatype;
@isatype{@isatype} = (1) x @isatype;
my $inif = 0;
my %Is_converted;
my %bad_file = ();
@ARGV = ('-') unless @ARGV;
build_preamble_if_necessary();
sub reindent($) {
my($text) = shift;
$text =~ s/\n/\n /g;
$text =~ s/ /\t/g;
$text;
}
my ($t, $tab, %curargs, $new, $eval_index, $dir, $name, $args, $outfile);
my ($incl, $incl_type, $next);
while (defined (my $file = next_file())) {
if (-l $file and -d $file) {
link_if_possible($file) if ($opt_l);
next;
}
# Recover from header files with unbalanced cpp directives
$t = '';
$tab = 0;
# $eval_index goes into ``#line'' directives, to help locate syntax errors:
$eval_index = 1;
if ($file eq '-') {
open(IN, "-");
open(OUT, ">-");
} else {
($outfile = $file) =~ s/\.h$/.ph/ || next;
print "$file -> $outfile\n" unless $opt_Q;
if ($file =~ m|^(.*)/|) {
$dir = $1;
mkpath "$Dest_dir/$dir";
}
if ($opt_a) { # automagic mode: locate header file in @inc_dirs
foreach (@inc_dirs) {
chdir $_;
last if -f $file;
}
}
open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next);
open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n";
}
print OUT
"require '_h2ph_pre.ph';\n\n",
"no warnings 'redefine';\n\n";
while (defined (local $_ = next_line($file))) {
if (s/^\s*\#\s*//) {
if (s/^define\s+(\w+)//) {
$name = $1;
$new = '';
s/\s+$//;
s/\(\w+\s*\(\*\)\s*\(\w*\)\)\s*(-?\d+)/$1/; # (int (*)(foo_t))0
if (s/^\(([\w,\s]*)\)//) {
$args = $1;
my $proto = '() ';
if ($args ne '') {
$proto = '';
foreach my $arg (split(/,\s*/,$args)) {
$arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
$curargs{$arg} = 1;
}
$args =~ s/\b(\w)/\$$1/g;
$args = "my($args) = \@_;\n$t ";
}
s/^\s+//;
expr();
$new =~ s/(["\\])/\\$1/g; #"]);
EMIT:
$new = reindent($new);
$args = reindent($args);
if ($t ne '') {
$new =~ s/(['\\])/\\$1/g; #']);
if ($opt_h) {
print OUT $t,
"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
$eval_index++;
} else {
print OUT $t,
"eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
}
} else {
print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n";
}
%curargs = ();
} else {
s/^\s+//;
expr();
$new = 1 if $new eq '';
$new = reindent($new);
$args = reindent($args);
if ($t ne '') {
$new =~ s/(['\\])/\\$1/g; #']);
if ($opt_h) {
print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n";
$eval_index++;
} else {
print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
}
} else {
# Shunt around such directives as `#define FOO FOO':
next if " \&$name" eq $new;
print OUT $t,"unless(defined(\&$name)) {\n sub $name () {\t",$new,";}\n}\n";
}
}
} elsif (/^(include|import|include_next)\s*[<\"](.*)[>\"]/) {
$incl_type = $1;
$incl = $2;
if (($incl_type eq 'include_next') ||
($opt_e && exists($bad_file{$incl}))) {
$incl =~ s/\.h$/.ph/;
print OUT ($t,
"eval {\n");
$tab += 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
print OUT ($t, "my(\@REM);\n");
if ($incl_type eq 'include_next') {
print OUT ($t,
"my(\%INCD) = map { \$INC{\$_} => 1 } ",
"(grep { \$_ eq \"$incl\" } ",
"keys(\%INC));\n");
print OUT ($t,
"\@REM = map { \"\$_/$incl\" } ",
"(grep { not exists(\$INCD{\"\$_/$incl\"})",
" and -f \"\$_/$incl\" } \@INC);\n");
} else {
print OUT ($t,
"\@REM = map { \"\$_/$incl\" } ",
"(grep {-r \"\$_/$incl\" } \@INC);\n");
}
print OUT ($t,
"require \"\$REM[0]\" if \@REM;\n");
$tab -= 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
print OUT ($t,
"};\n");
print OUT ($t,
"warn(\$\@) if \$\@;\n");
} else {
$incl =~ s/\.h$/.ph/;
print OUT $t,"require '$incl';\n";
}
} elsif (/^ifdef\s+(\w+)/) {
print OUT $t,"if(defined(&$1)) {\n";
$tab += 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
} elsif (/^ifndef\s+(\w+)/) {
print OUT $t,"unless(defined(&$1)) {\n";
$tab += 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
} elsif (s/^if\s+//) {
$new = '';
$inif = 1;
expr();
$inif = 0;
print OUT $t,"if($new) {\n";
$tab += 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
} elsif (s/^elif\s+//) {
$new = '';
$inif = 1;
expr();
$inif = 0;
$tab -= 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
print OUT $t,"}\n elsif($new) {\n";
$tab += 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
} elsif (/^else/) {
$tab -= 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
print OUT $t,"} else {\n";
$tab += 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
} elsif (/^endif/) {
$tab -= 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
print OUT $t,"}\n";
} elsif(/^undef\s+(\w+)/) {
print OUT $t, "undef(&$1) if defined(&$1);\n";
} elsif(/^error\s+(".*")/) {
print OUT $t, "die($1);\n";
} elsif(/^error\s+(.*)/) {
print OUT $t, "die(\"", quotemeta($1), "\");\n";
} elsif(/^warning\s+(.*)/) {
print OUT $t, "warn(\"", quotemeta($1), "\");\n";
} elsif(/^ident\s+(.*)/) {
print OUT $t, "# $1\n";
}
} elsif (/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?/) { # { for vi
until(/\{[^}]*\}.*;/ || /;/) {
last unless defined ($next = next_line($file));
chomp $next;
# drop "#define FOO FOO" in enums
$next =~ s/^\s*#\s*define\s+(\w+)\s+\1\s*$//;
# #defines in enums (aliases)
$next =~ s/^\s*#\s*define\s+(\w+)\s+(\w+)\s*$/$1 = $2,/;
$_ .= $next;
print OUT "# $next\n" if $opt_D;
}
s/#\s*if.*?#\s*endif//g; # drop #ifdefs
s@/\*.*?\*/@@g;
s/\s+/ /g;
next unless /^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/;
(my $enum_subs = $3) =~ s/\s//g;
my @enum_subs = split(/,/, $enum_subs);
my $enum_val = -1;
foreach my $enum (@enum_subs) {
my ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/;
$enum_name or next;
$enum_value =~ s/^=//;
$enum_val = (length($enum_value) ? $enum_value : $enum_val + 1);
if ($opt_h) {
print OUT ($t,
"eval(\"\\n#line $eval_index $outfile\\n",
"sub $enum_name () \{ $enum_val; \}\") ",
"unless defined(\&$enum_name);\n");
++ $eval_index;
} else {
print OUT ($t,
"eval(\"sub $enum_name () \{ $enum_val; \}\") ",
"unless defined(\&$enum_name);\n");
}
}
} elsif (/^(?:__extension__\s+)?(?:extern|static)\s+(?:__)?inline(?:__)?\s+/
and !/;\s*$/ and !/{\s*}\s*$/)
{ # { for vi
# This is a hack to parse the inline functions in the glibc headers.
# Warning: massive kludge ahead. We suppose inline functions
# are mainly constructed like macros.
while (1) {
last unless defined ($next = next_line($file));
chomp $next;
undef $_, last if $next =~ /__THROW\s*;/
or $next =~ /^(__extension__|extern|static)\b/;
$_ .= " $next";
print OUT "# $next\n" if $opt_D;
last if $next =~ /^}|^{.*}\s*$/;
}
next if not defined; # because it's only a prototype
s/\b(__extension__|extern|static|(?:__)?inline(?:__)?)\b//g;
# violently drop #ifdefs
s/#\s*if.*?#\s*endif//g
and print OUT "# some #ifdef were dropped here -- fill in the blanks\n";
if (s/^(?:\w|\s|\*)*\s(\w+)\s*//) {
$name = $1;
} else {
warn "name not found"; next; # shouldn't occur...
}
my @args;
if (s/^\(([^()]*)\)\s*(\w+\s*)*//) {
for my $arg (split /,/, $1) {
if ($arg =~ /(\w+)\s*$/) {
$curargs{$1} = 1;
push @args, $1;
}
}
}
$args = (
@args
? "my(" . (join ',', map "\$$_", @args) . ") = \@_;\n$t "
: ""
);
my $proto = @args ? '' : '() ';
$new = '';
s/\breturn\b//g; # "return" doesn't occur in macros usually...
expr();
# try to find and perlify local C variables
our @local_variables = (); # needs to be a our(): (?{...}) bug workaround
{
use re "eval";
my $typelist = join '|', keys %isatype;
$new =~ s['
(?:(?:__)?const(?:__)?\s+)?
(?:(?:un)?signed\s+)?
(?:long\s+)?
(?:$typelist)\s+
(\w+)
(?{ push @local_variables, $1 })
']
[my \$$1]gx;
$new =~ s['
(?:(?:__)?const(?:__)?\s+)?
(?:(?:un)?signed\s+)?
(?:long\s+)?
(?:$typelist)\s+
' \s+ &(\w+) \s* ;
(?{ push @local_variables, $1 })
]
[my \$$1;]gx;
}
$new =~ s/&$_\b/\$$_/g for @local_variables;
$new =~ s/(["\\])/\\$1/g; #"]);
# now that's almost like a macro (we hope)
goto EMIT;
}
}
$Is_converted{$file} = 1;
if ($opt_e && exists($bad_file{$file})) {
unlink($Dest_dir . '/' . $outfile);
$next = '';
} else {
print OUT "1;\n";
queue_includes_from($file) if $opt_a;
}
}
if ($opt_e && (scalar(keys %bad_file) > 0)) {
warn "Was unable to convert the following files:\n";
warn "\t" . join("\n\t",sort(keys %bad_file)) . "\n";
}
exit $Exit;
sub expr {
$new = '"(assembly code)"' and return if /\b__asm__\b/; # freak out.
my $joined_args;
if(keys(%curargs)) {
$joined_args = join('|', keys(%curargs));
}
while ($_ ne '') {
s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator
s/^\&([\(a-z\)]+)/$1/i; # hack for things that take the address of
s/^(\s+)// && do {$new .= ' '; next;};
s/^0X([0-9A-F]+)[UL]*//i
&& do {my $hex = $1;
$hex =~ s/^0+//;
if (length $hex > 8 && !$Config{use64bitint}) {
# Croak if nv_preserves_uv_bits < 64 ?
$new .= hex(substr($hex, -8)) +
2**32 * hex(substr($hex, 0, -8));
# The above will produce "errorneus" code
# if the hex constant was e.g. inside UINT64_C
# macro, but then again, h2ph is an approximation.
} else {
$new .= lc("0x$hex");
}
next;};
s/^(-?\d+\.\d+E[-+]?\d+)[FL]?//i && do {$new .= $1; next;};
s/^(\d+)\s*[LU]*//i && do {$new .= $1; next;};
s/^("(\\"|[^"])*")// && do {$new .= $1; next;};
s/^'((\\"|[^"])*)'// && do {
if ($curargs{$1}) {
$new .= "ord('\$$1')";
} else {
$new .= "ord('$1')";
}
next;
};
# replace "sizeof(foo)" with "{foo}"
# also, remove * (C dereference operator) to avoid perl syntax
# problems. Where the %sizeof array comes from is anyone's
# guess (c2ph?), but this at least avoids fatal syntax errors.
# Behavior is undefined if sizeof() delimiters are unbalanced.
# This code was modified to able to handle constructs like this:
# sizeof(*(p)), which appear in the HP-UX 10.01 header files.
s/^sizeof\s*\(// && do {
$new .= '$sizeof';
my $lvl = 1; # already saw one open paren
# tack { on the front, and skip it in the loop
$_ = "{" . "$_";
my $index = 1;
# find balanced closing paren
while ($index <= length($_) && $lvl > 0) {
$lvl++ if substr($_, $index, 1) eq "(";
$lvl-- if substr($_, $index, 1) eq ")";
$index++;
}
# tack } on the end, replacing )
substr($_, $index - 1, 1) = "}";
# remove pesky * operators within the sizeof argument
substr($_, 0, $index - 1) =~ s/\*//g;
next;
};
# Eliminate typedefs
/\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do {
my $doit = 1;
foreach (split /\s+/, $1) { # Make sure all the words are types,
unless($isatype{$_} or $_ eq 'struct' or $_ eq 'union'){
$doit = 0;
last;
}
}
if( $doit ){
s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them.
}
};
# struct/union member, including arrays:
s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do {
my $id = $1;
$id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g;
$id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args);
while($id =~ /\[\s*([^\$\&\d\]]+)\]/) {
my($index) = $1;
$index =~ s/\s//g;
if(exists($curargs{$index})) {
$index = "\$$index";
} else {
$index = "&$index";
}
$id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/;
}
$new .= " (\$$id)";
};
s/^([_a-zA-Z]\w*)// && do {
my $id = $1;
if ($id eq 'struct' || $id eq 'union') {
s/^\s+(\w+)//;
$id .= ' ' . $1;
$isatype{$id} = 1;
} elsif ($id =~ /^((un)?signed)|(long)|(short)$/) {
while (s/^\s+(\w+)//) { $id .= ' ' . $1; }
$isatype{$id} = 1;
}
if ($curargs{$id}) {
$new .= "\$$id";
$new .= '->' if /^[\[\{]/;
} elsif ($id eq 'defined') {
$new .= 'defined';
} elsif (/^\s*\(/) {
s/^\s*\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
$new .= " &$id";
} elsif ($isatype{$id}) {
if ($new =~ /{\s*$/) {
$new .= "'$id'";
} elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
$new =~ s/\(\s*$//;
s/^[\s*]*\)//;
} else {
$new .= q(').$id.q(');
}
} else {
if ($inif && $new !~ /defined\s*\($/) {
$new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
} elsif (/^\[/) {
$new .= " \$$id";
} else {
$new .= ' &' . $id;
}
}
next;
};
s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
}
}
sub next_line
{
my $file = shift;
my ($in, $out);
my $pre_sub_tri_graphs = 1;
READ: while (not eof IN) {
$in .= <IN>;
chomp $in;
next unless length $in;
while (length $in) {
if ($pre_sub_tri_graphs) {
# Preprocess all tri-graphs
# including things stuck in quoted string constants.
$in =~ s/\?\?=/#/g; # | ??=| #|
$in =~ s/\?\?\!/|/g; # | ??!| ||
$in =~ s/\?\?'/^/g; # | ??'| ^|
$in =~ s/\?\?\(/[/g; # | ??(| [|
$in =~ s/\?\?\)/]/g; # | ??)| ]|
$in =~ s/\?\?\-/~/g; # | ??-| ~|
$in =~ s/\?\?\//\\/g; # | ??/| \|
$in =~ s/\?\?</{/g; # | ??<| {|
$in =~ s/\?\?>/}/g; # | ??>| }|
}
if ($in =~ /^\#ifdef __LANGUAGE_PASCAL__/) {
# Tru64 disassembler.h evilness: mixed C and Pascal.
while (<IN>) {
last if /^\#endif/;
}
$in = "";
next READ;
}
if ($in =~ /^extern inline / && # Inlined assembler.
$^O eq 'linux' && $file =~ m!(?:^|/)asm/[^/]+\.h$!) {
while (<IN>) {
last if /^}/;
}
$in = "";
next READ;
}
if ($in =~ s/\\$//) { # \-newline
$out .= ' ';
next READ;
} elsif ($in =~ s/^([^"'\\\/]+)//) { # Passthrough
$out .= $1;
} elsif ($in =~ s/^(\\.)//) { # \...
$out .= $1;
} elsif ($in =~ /^'/) { # '...
if ($in =~ s/^('(\\.|[^'\\])*')//) {
$out .= $1;
} else {
next READ;
}
} elsif ($in =~ /^"/) { # "...
if ($in =~ s/^("(\\.|[^"\\])*")//) {
$out .= $1;
} else {
next READ;
}
} elsif ($in =~ s/^\/\/.*//) { # //...
# fall through
} elsif ($in =~ m/^\/\*/) { # /*...
# C comment removal adapted from perlfaq6:
if ($in =~ s/^\/\*[^*]*\*+([^\/*][^*]*\*+)*\///) {
$out .= ' ';
} else { # Incomplete /* */
next READ;
}
} elsif ($in =~ s/^(\/)//) { # /...
$out .= $1;
} elsif ($in =~ s/^([^\'\"\\\/]+)//) {
$out .= $1;
} elsif ($^O eq 'linux' &&
$file =~ m!(?:^|/)linux/byteorder/pdp_endian\.h$! &&
$in =~ s!\'T KNOW!!) {
$out =~ s!I DON$!I_DO_NOT_KNOW!;
} else {
if ($opt_e) {
warn "Cannot parse $file:\n$in\n";
$bad_file{$file} = 1;
$in = '';
$out = undef;
last READ;
} else {
die "Cannot parse:\n$in\n";
}
}
}
last READ if $out =~ /\S/;
}
return $out;
}
# Handle recursive subdirectories without getting a grotesquely big stack.
# Could this be implemented using File::Find?
sub next_file
{
my $file;
while (@ARGV) {
$file = shift @ARGV;
if ($file eq '-' or -f $file or -l $file) {
return $file;
} elsif (-d $file) {
if ($opt_r) {
expand_glob($file);
} else {
print STDERR "Skipping directory `$file'\n";
}
} elsif ($opt_a) {
return $file;
} else {
print STDERR "Skipping `$file': not a file or directory\n";
}
}
return undef;
}
# Put all the files in $directory into @ARGV for processing.
sub expand_glob
{
my ($directory) = @_;
$directory =~ s:/$::;
opendir DIR, $directory;
foreach (readdir DIR) {
next if ($_ eq '.' or $_ eq '..');
# expand_glob() is going to be called until $ARGV[0] isn't a
# directory; so push directories, and unshift everything else.
if (-d "$directory/$_") { push @ARGV, "$directory/$_" }
else { unshift @ARGV, "$directory/$_" }
}
closedir DIR;
}
# Given $file, a symbolic link to a directory in the C include directory,
# make an equivalent symbolic link in $Dest_dir, if we can figure out how.
# Otherwise, just duplicate the file or directory.
sub link_if_possible
{
my ($dirlink) = @_;
my $target = eval 'readlink($dirlink)';
if ($target =~ m:^\.\./: or $target =~ m:^/:) {
# The target of a parent or absolute link could leave the $Dest_dir
# hierarchy, so let's put all of the contents of $dirlink (actually,
# the contents of $target) into @ARGV; as a side effect down the
# line, $dirlink will get created as an _actual_ directory.
expand_glob($dirlink);
} else {
if (-l "$Dest_dir/$dirlink") {
unlink "$Dest_dir/$dirlink" or
print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n";
}
if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
print "Linking $target -> $Dest_dir/$dirlink\n";
# Make sure that the link _links_ to something:
if (! -e "$Dest_dir/$target") {
mkpath("$Dest_dir/$target", 0755) or
print STDERR "Could not create $Dest_dir/$target/\n";
}
} else {
print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n";
}
}
}
# Push all #included files in $file onto our stack, except for STDIN
# and files we've already processed.
sub queue_includes_from
{
my ($file) = @_;
my $line;
return if ($file eq "-");
open HEADER, $file or return;
while (defined($line = <HEADER>)) {
while (/\\$/) { # Handle continuation lines
chop $line;
$line .= <HEADER>;
}
if ($line =~ /^#\s*include\s+<(.*?)>/) {
push(@ARGV, $1) unless $Is_converted{$1};
}
}
close HEADER;
}
# Determine include directories; $Config{usrinc} should be enough for (all
# non-GCC?) C compilers, but gcc uses an additional include directory.
sub inc_dirs
{
my $from_gcc = `LC_ALL=C $Config{cc} -v 2>&1`;
if( !( $from_gcc =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s ) )
{ # gcc-4+ :
$from_gcc = `LC_ALL=C $Config{cc} -print-search-dirs 2>&1`;
if ( !($from_gcc =~ s/^install:\s*([^\s]+[^\s\/])([\s\/]*).*$/$1\/include/s) )
{
$from_gcc = '';
};
};
length($from_gcc) ? ($from_gcc, $Config{usrinc}) : ($Config{usrinc});
}
# Create "_h2ph_pre.ph", if it doesn't exist or was built by a different
# version of h2ph.
sub build_preamble_if_necessary
{
# Increment $VERSION every time this function is modified:
my $VERSION = 2;
my $preamble = "$Dest_dir/_h2ph_pre.ph";
# Can we skip building the preamble file?
if (-r $preamble) {
# Extract version number from first line of preamble:
open PREAMBLE, $preamble or die "Cannot open $preamble: $!";
my $line = <PREAMBLE>;
$line =~ /(\b\d+\b)/;
close PREAMBLE or die "Cannot close $preamble: $!";
# Don't build preamble if a compatible preamble exists:
return if $1 == $VERSION;
}
my (%define) = _extract_cc_defines();
open PREAMBLE, ">$preamble" or die "Cannot open $preamble: $!";
print PREAMBLE "# This file was created by h2ph version $VERSION\n";
foreach (sort keys %define) {
if ($opt_D) {
print PREAMBLE "# $_=$define{$_}\n";
}
if ($define{$_} =~ /^(\d+)U?L{0,2}$/i) {
print PREAMBLE
"unless (defined &$_) { sub $_() { $1 } }\n\n";
} elsif ($define{$_} =~ /^\w+$/) {
print PREAMBLE
"unless (defined &$_) { sub $_() { &$define{$_} } }\n\n";
} else {
print PREAMBLE
"unless (defined &$_) { sub $_() { \"",
quotemeta($define{$_}), "\" } }\n\n";
}
}
close PREAMBLE or die "Cannot close $preamble: $!";
}
# %Config contains information on macros that are pre-defined by the
# system's compiler. We need this information to make the .ph files
# function with perl as the .h files do with cc.
sub _extract_cc_defines
{
my %define;
my $allsymbols = join " ",
@Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'};
# Split compiler pre-definitions into `key=value' pairs:
foreach (split /\s+/, $allsymbols) {
/(.+?)=(.+)/ and $define{$1} = $2;
if ($opt_D) {
print STDERR "$_: $1 -> $2\n";
}
}
return %define;
}
1;
##############################################################################
__END__
=head1 NAME
h2ph - convert .h C header files to .ph Perl header files
=head1 SYNOPSIS
B<h2ph [-d destination directory] [-r | -a] [-l] [headerfiles]>
=head1 DESCRIPTION
I<h2ph>
converts any C header files specified to the corresponding Perl header file
format.
It is most easily run while in /usr/include:
cd /usr/include; h2ph * sys/*
or
cd /usr/include; h2ph * sys/* arpa/* netinet/*
or
cd /usr/include; h2ph -r -l .
The output files are placed in the hierarchy rooted at Perl's
architecture dependent library directory. You can specify a different
hierarchy with a B<-d> switch.
If run with no arguments, filters standard input to standard output.
=head1 OPTIONS
=over 4
=item -d destination_dir
Put the resulting B<.ph> files beneath B<destination_dir>, instead of
beneath the default Perl library location (C<$Config{'installsitsearch'}>).
=item -r
Run recursively; if any of B<headerfiles> are directories, then run I<h2ph>
on all files in those directories (and their subdirectories, etc.). B<-r>
and B<-a> are mutually exclusive.
=item -a
Run automagically; convert B<headerfiles>, as well as any B<.h> files
which they include. This option will search for B<.h> files in all
directories which your C compiler ordinarily uses. B<-a> and B<-r> are
mutually exclusive.
=item -l
Symbolic links will be replicated in the destination directory. If B<-l>
is not specified, then links are skipped over.
=item -h
Put ``hints'' in the .ph files which will help in locating problems with
I<h2ph>. In those cases when you B<require> a B<.ph> file containing syntax
errors, instead of the cryptic
[ some error condition ] at (eval mmm) line nnn
you will see the slightly more helpful
[ some error condition ] at filename.ph line nnn
However, the B<.ph> files almost double in size when built using B<-h>.
=item -D
Include the code from the B<.h> file as a comment in the B<.ph> file.
This is primarily used for debugging I<h2ph>.
=item -Q
``Quiet'' mode; don't print out the names of the files being converted.
=back
=head1 ENVIRONMENT
No environment variables are used.
=head1 FILES
/usr/include/*.h
/usr/include/sys/*.h
etc.
=head1 AUTHOR
Larry Wall
=head1 SEE ALSO
perl(1)
=head1 DIAGNOSTICS
The usual warnings if it can't read or write the files involved.
=head1 BUGS
Doesn't construct the %sizeof array for you.
It doesn't handle all C constructs, but it does attempt to isolate
definitions inside evals so that you can get at the definitions
that it can translate.
It's only intended as a rough tool.
You may need to dicker with the files produced.
You have to run this program by hand; it's not run as part of the Perl
installation.
Doesn't handle complicated expressions built piecemeal, a la:
enum {
FIRST_VALUE,
SECOND_VALUE,
#ifdef ABC
THIRD_VALUE
#endif
};
Doesn't necessarily locate all of your C compiler's internally-defined
symbols.
=cut
!NO!SUBS!
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;
--- NEW FILE: dprofpp.PL ---
#!/usr/local/bin/perl
use Config;
use File::Basename qw(&basename &dirname);
use File::Spec;
# 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$//i;
$file .= '.COM' if ($^O eq 'VMS');
my $dprof_pm = File::Spec->catfile(File::Spec->updir, '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";
}
my $stty = 'undef';
foreach my $s (qw(/bin/stty /usr/bin/stty)) {
if (-x $s) {
$stty = qq["$s"];
last;
}
}
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';
my \$stty = $stty;
!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<-d>] [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>] [B<-G> <regexp> [B<-P>]] [B<-f> <regexp>] [profile]
dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
dprofpp B<-G> <regexp> [B<-P>] [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
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 use the following:
$ 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<-d>
Reverse whatever sort is used
=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 are
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 with regard to 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.
=item B<-G> <regexp>
Aggregate "Group" all calls matching the pattern together.
For example this can be used to group all calls of a set of packages
-G "(package1::)|(package2::)|(package3::)"
or to group subroutines by name:
-G "getNum"
=item B<-P>
Used with -G to aggregate "Pull" together all calls that did not match -G.
=item B<-f> <regexp>
Filter all calls matching the pattern.
=item B<-h>
Display brief help and exit.
=item B<-H>
Display long help and exit.
=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 at 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
sub shortusage {
print <<'EOF';
dprofpp [options] [profile]
-A Count autoloaded to *AUTOLOAD
-a Sort by alphabetic name of subroutines.
-d Reverse sort
-E Sub times are reported exclusive of child times. (default)
-f Filter all calls mathcing the pattern.
-G Group all calls matching the pattern together.
-g subr Count only those who are SUBR or called from SUBR
-H Display long manual page.
-h Display this short usage message.
-I Sub times are reported inclusive of child times.
-l Sort by number of calls to subroutines.
-O cnt Specifies maximum number of subroutines to display.
-P Used with -G to pull all other calls together.
-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.
-q Do not print column headers.
-R Count anonyms separately even if from the same package
-r Use real elapsed time rather than user+system time.
-S Create statistics for all the depths
-s Use system time rather than user+system time.
-T Show call tree.
-t Show call tree, compressed.
-U Do not sort subroutines.
-u Use user time rather than user+system time.
-V Print dprofpp's version.
-v Sort by average amount of time spent in subroutines.
-z Sort by user+system time spent in subroutines. (default)
EOF
}
use Getopt::Std 'getopts';
use Config '%Config';
Setup: {
my $options = 'O:g:G:Pf:dlzaAvuTtqrRsUFEIp:QVShH';
$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 ) or die "Try 'dprofpp -h' for help.\n";
if( @ARGV ){
# there was a filename, it overrides any earlier name.
$Monfile = shift;
}
if ( defined $opt_h ) {
shortusage();
exit;
}
if ( defined $opt_H ) {
require Pod::Usage;
Pod::Usage::pod2usage( {-verbose => 2, -input => $0 } );
exit;
}
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;
if(defined $opt_d){
$sort = "r".$sort;
}
$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 );
#filter calls
if( $opt_f ){
for(my $i = 0;$i < @$idkeys - 2;){
$key = $$idkeys[$i];
if($key =~ /$opt_f/){
splice(@$idkeys, $i, 1);
$runtime -= $$times{$key};
next;
}
$i++;
}
}
if( $opt_G ){
group($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);
}
sub group{
my ($names, $calls, $times, $ctimes, $idkeys ) = @_;
print "Option G Grouping: [$opt_G]\n";
# create entries to store grouping
$$names{$opt_G} = $opt_G;
$$calls{$opt_G} = 0;
$$times{$opt_G} = 0;
$$ctimes{$opt_G} = 0;
$$idkeys[@$idkeys] = $opt_G;
# Sum calls for the grouping
my $other = "other";
if($opt_P){
$$names{$other} = $other;
$$calls{$other} = 0;
$$times{$other} = 0;
$$ctimes{$other} = 0;
$$idkeys[@$idkeys] = $other;
}
for(my $i = 0;$i < @$idkeys - 2;){
$key = $$idkeys[$i];
if($key =~ /$opt_G/){
$$calls{$opt_G} += $$calls{$key};
$$times{$opt_G} += $$times{$key};
$$ctimes{$opt_G} += $$ctimes{$key};
splice(@$idkeys, $i, 1);
next;
}else{
if($opt_P){
$$calls{$other} += $$calls{$key};
$$times{$other} += $$times{$key};
$$ctimes{$other} += $$ctimes{$key};
splice(@$idkeys, $i, 1);
next;
}
}
$i++;
}
print "Grouping [$opt_G] Calls: [$$calls{$opt_G}]\n".
"Grouping [$opt_G] Times: [$$times{$opt_G}]\n".
"Grouping [$opt_G] IncTimes: [$$ctimes{$opt_G}]\n";
}
# 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)/$hz;
}
elsif( $opt_s ){
$$runtime = ($rrun_stime - $overhead)/$hz;
}
elsif( $opt_u ){
$$runtime = ($rrun_utime - $overhead)/$hz;
}
else{
$$runtime = ($rrun_ustime - $overhead)/$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;
my $time;
if (%{$deep_times->{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 %{$deep_times->{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) = @_;
for my $kid_name (keys %$source) {
my $source_kid = delete $source->{$kid_name};
if (my $dest_kid = $dest->{$kid_name}) {
$dest_kid->{count} += $source_kid->{count};
$dest_kid->{incl_time} += $source_kid->{incl_time};
move_keys($source_kid->{kids},$dest_kid->{kids});
} else {
$dest->{$kid_name} = $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;
my $entry = $curdeep_times->[-2]{kids}{$name} ||= {
count => 0,
kids => {},
incl_time => 0,
};
# 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 %outer;
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_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] if scalar @stack;
$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;
if ( $dir eq '-' or $dir eq '*' ) {
my $ename = $dir eq '*' ? $stack[-1][0] : $name;
$overhead += $over_per_call;
if ($name eq "Devel::DProf::write") {
$overhead += $t - $dprof_stamp;
next;
} elsif (defined $opt_g and $ename eq $opt_g) {
$in_level--;
}
add_to_tree($curdeep_times, $ename,
$t - $overhead) if $opt_S;
exitstamp( \@stack, \@tstack,
$t - $overhead,
$times, $ctimes, $name, \$in, $tab,
$curdeep_times, \%outer );
}
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}++;
$outer{$name}++;
push @$curdeep_times, { kids => {},
name => $name,
enter_stamp => $t - $overhead,
} if $opt_S;
$x = [ $name, $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";
}
while (my ($key, $count) = each %outer) {
next unless $count;
warn "$key has $count unstacked calls in outer\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 - $overhead, $times,
$ctimes, $name, \$in, $tab,
$curdeep_times, \%outer );
add_to_tree($curdeep_times, $name,
$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, $outer) = @_;
my( $x, $c, $z );
$x = pop( @$stack );
if( ! defined $x ){
die "Garbled profile, missing an enter time stamp";
}
if( $x->[0] ne $name and $opt_G and ($name =~ /$opt_G/)){
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
unless --$outer->{$name};
$times->{$name} += $z - $c;
# 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;
my @script_parts = split /\s+/, $script;
system $startperl, "-d:$profiler", @script_parts;
if( $? / 256 > 0 ){
my $cmd = join ' ', @script_parts;
die "Failed: $startperl -d:$profiler $cmd: $!";
}
}
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} }
# Reversed
sub rby_time { $times->{$a} <=> $times->{$b} }
sub rby_ctime { $ctimes->{$a} <=> $ctimes->{$b} }
sub rby_calls { $calls->{$a} <=> $calls->{$b} }
sub rby_alpha { $names->{$b} cmp $names->{$a} }
sub rby_avgcpu { $persecs->{$a} <=> $persecs->{$b} }
format CSTAT_top =
Total Elapsed Time = @>>>>>>> Seconds
(($rrun_rtime - $overhead) / $hz)
@>>>>>>>>>> Time = @>>>>>>> Seconds
$whichtime, $runtime
@<<<<<<<< Times
$incl_excl
%Time ExclSec CumulS #Calls sec/call Csec/c Name
.
BEGIN {
my $fmt = ' ^>>> ^>>>> ^>>>>> ^>>>>> ^>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<';
if (-t STDOUT and defined $stty and my ($cols) = `$stty -a` =~ /\bcolumns\s+(\d+)/)
{
$fmt .= '<' x ($cols - length $fmt) if $cols > 80;
}
eval "format STAT = \n$fmt" . '
$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 ':';
--- NEW FILE: prove.PL ---
#!/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}.
# 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.
my $origdir = cwd;
chdir dirname($0);
my $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!
use File::Spec;
my $prove = File::Spec->catfile(File::Spec->catdir(File::Spec->updir,
"lib", "Test", "Harness", "bin"), "prove");
if (open(PROVE, $prove)) {
print OUT <PROVE>;
close PROVE;
} else {
die "$0: cannot find '$prove'\n";
}
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;
More information about the dslinux-commit
mailing list