mirror of
https://github.com/Gator96100/ProxSpace.git
synced 2025-07-30 03:28:35 -07:00
Updated msys2 to msys2-base-x86_64-20200903
This commit is contained in:
Gator96100
parent
5bc8dbdc75
commit
2307d54cb1
18501 changed files with 1684082 additions and 720361 deletions
569
msys2/usr/bin/core_perl/corelist
Normal file
569
msys2/usr/bin/core_perl/corelist
Normal file
|
|
@ -0,0 +1,569 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!/usr/bin/perl
|
||||
|
||||
=head1 NAME
|
||||
|
||||
corelist - a commandline frontend to Module::CoreList
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
See L<Module::CoreList> for one.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
corelist -v
|
||||
corelist [-a|-d] <ModuleName> | /<ModuleRegex>/ [<ModuleVersion>] ...
|
||||
corelist [-v <PerlVersion>] [ <ModuleName> | /<ModuleRegex>/ ] ...
|
||||
corelist [-r <PerlVersion>] ...
|
||||
corelist --utils [-d] <UtilityName> [<UtilityName>] ...
|
||||
corelist --utils -v <PerlVersion>
|
||||
corelist --feature <FeatureName> [<FeatureName>] ...
|
||||
corelist --diff PerlVersion PerlVersion
|
||||
corelist --upstream <ModuleName>
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
=over
|
||||
|
||||
=item -a
|
||||
|
||||
lists all versions of the given module (or the matching modules, in case you
|
||||
used a module regexp) in the perls Module::CoreList knows about.
|
||||
|
||||
corelist -a Unicode
|
||||
|
||||
Unicode was first released with perl v5.6.2
|
||||
v5.6.2 3.0.1
|
||||
v5.8.0 3.2.0
|
||||
v5.8.1 4.0.0
|
||||
v5.8.2 4.0.0
|
||||
v5.8.3 4.0.0
|
||||
v5.8.4 4.0.1
|
||||
v5.8.5 4.0.1
|
||||
v5.8.6 4.0.1
|
||||
v5.8.7 4.1.0
|
||||
v5.8.8 4.1.0
|
||||
v5.8.9 5.1.0
|
||||
v5.9.0 4.0.0
|
||||
v5.9.1 4.0.0
|
||||
v5.9.2 4.0.1
|
||||
v5.9.3 4.1.0
|
||||
v5.9.4 4.1.0
|
||||
v5.9.5 5.0.0
|
||||
v5.10.0 5.0.0
|
||||
v5.10.1 5.1.0
|
||||
v5.11.0 5.1.0
|
||||
v5.11.1 5.1.0
|
||||
v5.11.2 5.1.0
|
||||
v5.11.3 5.2.0
|
||||
v5.11.4 5.2.0
|
||||
v5.11.5 5.2.0
|
||||
v5.12.0 5.2.0
|
||||
v5.12.1 5.2.0
|
||||
v5.12.2 5.2.0
|
||||
v5.12.3 5.2.0
|
||||
v5.12.4 5.2.0
|
||||
v5.13.0 5.2.0
|
||||
v5.13.1 5.2.0
|
||||
v5.13.2 5.2.0
|
||||
v5.13.3 5.2.0
|
||||
v5.13.4 5.2.0
|
||||
v5.13.5 5.2.0
|
||||
v5.13.6 5.2.0
|
||||
v5.13.7 6.0.0
|
||||
v5.13.8 6.0.0
|
||||
v5.13.9 6.0.0
|
||||
v5.13.10 6.0.0
|
||||
v5.13.11 6.0.0
|
||||
v5.14.0 6.0.0
|
||||
v5.14.1 6.0.0
|
||||
v5.15.0 6.0.0
|
||||
|
||||
=item -d
|
||||
|
||||
finds the first perl version where a module has been released by
|
||||
date, and not by version number (as is the default).
|
||||
|
||||
=item --diff
|
||||
|
||||
Given two versions of perl, this prints a human-readable table of all module
|
||||
changes between the two. The output format may change in the future, and is
|
||||
meant for I<humans>, not programs. For programs, use the L<Module::CoreList>
|
||||
API.
|
||||
|
||||
=item -? or -help
|
||||
|
||||
help! help! help! to see more help, try --man.
|
||||
|
||||
=item -man
|
||||
|
||||
all of the help
|
||||
|
||||
=item -v
|
||||
|
||||
lists all of the perl release versions we got the CoreList for.
|
||||
|
||||
If you pass a version argument (value of C<$]>, like C<5.00503> or C<5.008008>),
|
||||
you get a list of all the modules and their respective versions.
|
||||
(If you have the C<version> module, you can also use new-style version numbers,
|
||||
like C<5.8.8>.)
|
||||
|
||||
In module filtering context, it can be used as Perl version filter.
|
||||
|
||||
=item -r
|
||||
|
||||
lists all of the perl releases and when they were released
|
||||
|
||||
If you pass a perl version you get the release date for that version only.
|
||||
|
||||
=item --utils
|
||||
|
||||
lists the first version of perl each named utility program was released with
|
||||
|
||||
May be used with -d to modify the first release criteria.
|
||||
|
||||
If used with -v <version> then all utilities released with that version of perl
|
||||
are listed, and any utility programs named on the command line are ignored.
|
||||
|
||||
=item --feature, -f
|
||||
|
||||
lists the first version bundle of each named feature given
|
||||
|
||||
=item --upstream, -u
|
||||
|
||||
Shows if the given module is primarily maintained in perl core or on CPAN
|
||||
and bug tracker URL.
|
||||
|
||||
=back
|
||||
|
||||
As a special case, if you specify the module name C<Unicode>, you'll get
|
||||
the version number of the Unicode Character Database bundled with the
|
||||
requested perl versions.
|
||||
|
||||
=cut
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use Module::CoreList;
|
||||
use Getopt::Long qw(:config no_ignore_case);
|
||||
use Pod::Usage;
|
||||
use strict;
|
||||
use warnings;
|
||||
use List::Util qw/maxstr/;
|
||||
|
||||
my %Opts;
|
||||
|
||||
GetOptions(
|
||||
\%Opts,
|
||||
qw[ help|?! man! r|release:s v|version:s a! d diff|D utils feature|f u|upstream ]
|
||||
);
|
||||
|
||||
pod2usage(1) if $Opts{help};
|
||||
pod2usage(-verbose=>2) if $Opts{man};
|
||||
|
||||
if(exists $Opts{r} ){
|
||||
if ( !$Opts{r} ) {
|
||||
print "\nModule::CoreList has release info for the following perl versions:\n";
|
||||
my $versions = { };
|
||||
my $max_ver_len = max_mod_len(\%Module::CoreList::released);
|
||||
for my $ver ( grep !/0[01]0$/, sort keys %Module::CoreList::released ) {
|
||||
printf "%-${max_ver_len}s %s\n", format_perl_version($ver), $Module::CoreList::released{$ver};
|
||||
}
|
||||
print "\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
my $num_r = numify_version( $Opts{r} );
|
||||
my $version_hash = Module::CoreList->find_version($num_r);
|
||||
|
||||
if( !$version_hash ) {
|
||||
print "\nModule::CoreList has no info on perl $Opts{r}\n\n";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
printf "Perl %s was released on %s\n\n", format_perl_version($num_r), $Module::CoreList::released{$num_r};
|
||||
exit 0;
|
||||
}
|
||||
|
||||
if(exists $Opts{v} ){
|
||||
if( !$Opts{v} ) {
|
||||
print "\nModule::CoreList has info on the following perl versions:\n";
|
||||
print format_perl_version($_)."\n" for grep !/0[01]0$/, sort keys %Module::CoreList::version;
|
||||
print "\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
my $num_v = numify_version( $Opts{v} );
|
||||
|
||||
if ($Opts{utils}) {
|
||||
utilities_in_version($num_v);
|
||||
exit 0;
|
||||
}
|
||||
|
||||
my $version_hash = Module::CoreList->find_version($num_v);
|
||||
|
||||
if( !$version_hash ) {
|
||||
print "\nModule::CoreList has no info on perl $Opts{v}\n\n";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
if ( !@ARGV ) {
|
||||
print "\nThe following modules were in perl $Opts{v} CORE\n";
|
||||
my $max_mod_len = max_mod_len($version_hash);
|
||||
for my $mod ( sort keys %$version_hash ) {
|
||||
printf "%-${max_mod_len}s %s\n", $mod, $version_hash->{$mod} || "";
|
||||
}
|
||||
print "\n";
|
||||
exit 0;
|
||||
}
|
||||
}
|
||||
|
||||
if ($Opts{diff}) {
|
||||
if(@ARGV != 2) {
|
||||
die "\nprovide exactly two perl core versions to diff with --diff\n";
|
||||
}
|
||||
|
||||
my ($old_ver, $new_ver) = @ARGV;
|
||||
|
||||
my $old = numify_version($old_ver);
|
||||
my $new = numify_version($new_ver);
|
||||
|
||||
my %diff = Module::CoreList::changes_between($old, $new);
|
||||
|
||||
for my $lib (sort keys %diff) {
|
||||
my $diff = $diff{$lib};
|
||||
|
||||
my $was = ! exists $diff->{left} ? '(absent)'
|
||||
: ! defined $diff->{left} ? '(undef)'
|
||||
: $diff->{left};
|
||||
|
||||
my $now = ! exists $diff->{right} ? '(absent)'
|
||||
: ! defined $diff->{right} ? '(undef)'
|
||||
: $diff->{right};
|
||||
|
||||
printf "%-35s %10s %10s\n", $lib, $was, $now;
|
||||
}
|
||||
exit(0);
|
||||
}
|
||||
|
||||
if ($Opts{utils}) {
|
||||
die "\n--utils only available with perl v5.19.1 or greater\n"
|
||||
if $] < 5.019001;
|
||||
|
||||
die "\nprovide at least one utility name to --utils\n"
|
||||
unless @ARGV;
|
||||
|
||||
warn "\n-a has no effect when --utils is used\n" if $Opts{a};
|
||||
warn "\n--diff has no effect when --utils is used\n" if $Opts{diff};
|
||||
warn "\n--upstream, or -u, has no effect when --utils is used\n" if $Opts{u};
|
||||
|
||||
my $when = maxstr(values %Module::CoreList::released);
|
||||
print "\n","Data for $when\n";
|
||||
|
||||
utility_version($_) for @ARGV;
|
||||
|
||||
exit(0);
|
||||
}
|
||||
|
||||
if ($Opts{feature}) {
|
||||
die "\n--feature is only available with perl v5.16.0 or greater\n"
|
||||
if $] < 5.016;
|
||||
|
||||
die "\nprovide at least one feature name to --feature\n"
|
||||
unless @ARGV;
|
||||
|
||||
no warnings 'once';
|
||||
require feature;
|
||||
|
||||
my %feature2version;
|
||||
my @bundles = map { $_->[0] }
|
||||
sort { $b->[1] <=> $a->[1] }
|
||||
map { [$_, numify_version($_)] }
|
||||
grep { not /[^0-9.]/ }
|
||||
keys %feature::feature_bundle;
|
||||
|
||||
for my $version (@bundles) {
|
||||
$feature2version{$_} = $version =~ /^\d\.\d+$/ ? "$version.0" : $version
|
||||
for @{ $feature::feature_bundle{$version} };
|
||||
}
|
||||
|
||||
# allow internal feature names, just in case someone gives us __SUB__
|
||||
# instead of current_sub.
|
||||
while (my ($name, $internal) = each %feature::feature) {
|
||||
$internal =~ s/^feature_//;
|
||||
$feature2version{$internal} = $feature2version{$name}
|
||||
if $feature2version{$name};
|
||||
}
|
||||
|
||||
my $when = maxstr(values %Module::CoreList::released);
|
||||
print "\n","Data for $when\n";
|
||||
|
||||
for my $feature (@ARGV) {
|
||||
print "feature \"$feature\" ",
|
||||
exists $feature2version{$feature}
|
||||
? "was first released with the perl "
|
||||
. format_perl_version(numify_version($feature2version{$feature}))
|
||||
. " feature bundle\n"
|
||||
: "doesn't exist (or so I think)\n";
|
||||
}
|
||||
exit(0);
|
||||
}
|
||||
|
||||
if ( !@ARGV ) {
|
||||
pod2usage(0);
|
||||
}
|
||||
|
||||
while (@ARGV) {
|
||||
my ($mod, $ver);
|
||||
if ($ARGV[0] =~ /=/) {
|
||||
($mod, $ver) = split /=/, shift @ARGV;
|
||||
} else {
|
||||
$mod = shift @ARGV;
|
||||
$ver = (@ARGV && $ARGV[0] =~ /^\d/) ? shift @ARGV : "";
|
||||
}
|
||||
|
||||
if ($mod !~ m|^/(.*)/([imosx]*)$|) { # not a regex
|
||||
module_version($mod,$ver);
|
||||
} else {
|
||||
my $re;
|
||||
eval { $re = $2 ? qr/(?$2)($1)/ : qr/$1/; }; # trap exceptions while building regex
|
||||
if ($@) {
|
||||
# regex errors are usually like 'Quantifier follow nothing in regex; marked by ...'
|
||||
# then we drop text after ';' to shorten message
|
||||
my $errmsg = $@ =~ /(.*);/ ? $1 : $@;
|
||||
warn "\n$mod is a bad regex: $errmsg\n";
|
||||
next;
|
||||
}
|
||||
my @mod = Module::CoreList->find_modules($re);
|
||||
if (@mod) {
|
||||
module_version($_, $ver) for @mod;
|
||||
} else {
|
||||
$ver |= '';
|
||||
print "\n$mod $ver has no match in CORE (or so I think)\n";
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
exit();
|
||||
|
||||
sub module_version {
|
||||
my($mod,$ver) = @_;
|
||||
|
||||
if ( $Opts{v} ) {
|
||||
my $numeric_v = numify_version($Opts{v});
|
||||
my $version_hash = Module::CoreList->find_version($numeric_v);
|
||||
if ($version_hash) {
|
||||
print $mod, " ", $version_hash->{$mod} || 'undef', "\n";
|
||||
return;
|
||||
}
|
||||
else { die "Shouldn't happen" }
|
||||
}
|
||||
|
||||
my $ret = $Opts{d}
|
||||
? Module::CoreList->first_release_by_date(@_)
|
||||
: Module::CoreList->first_release(@_);
|
||||
my $msg = $mod;
|
||||
$msg .= " $ver" if $ver;
|
||||
|
||||
my $rem = $Opts{d}
|
||||
? Module::CoreList->removed_from_by_date($mod)
|
||||
: Module::CoreList->removed_from($mod);
|
||||
|
||||
my $when = maxstr(values %Module::CoreList::released);
|
||||
print "\n","Data for $when\n";
|
||||
|
||||
if( defined $ret ) {
|
||||
my $deprecated = Module::CoreList->deprecated_in($mod);
|
||||
$msg .= " was ";
|
||||
$msg .= "first " unless $ver;
|
||||
$msg .= "released with perl " . format_perl_version($ret);
|
||||
$msg .= ( $rem ? ',' : ' and' ) . " deprecated (will be CPAN-only) in " . format_perl_version($deprecated) if $deprecated;
|
||||
$msg .= " and removed from " . format_perl_version($rem) if $rem;
|
||||
} else {
|
||||
$msg .= " was not in CORE (or so I think)";
|
||||
}
|
||||
|
||||
print $msg,"\n";
|
||||
|
||||
if( defined $ret and exists $Opts{u} ) {
|
||||
my $upstream = $Module::CoreList::upstream{$mod};
|
||||
$upstream = 'undef' unless $upstream;
|
||||
print "upstream: $upstream\n";
|
||||
if ( $upstream ne 'blead' ) {
|
||||
my $bugtracker = $Module::CoreList::bug_tracker{$mod};
|
||||
$bugtracker = 'unknown' unless $bugtracker;
|
||||
print "bug tracker: $bugtracker\n";
|
||||
}
|
||||
}
|
||||
|
||||
if(defined $ret and exists $Opts{a} and $Opts{a}){
|
||||
display_a($mod);
|
||||
}
|
||||
}
|
||||
|
||||
sub utility_version {
|
||||
my ($utility) = @_;
|
||||
|
||||
require Module::CoreList::Utils;
|
||||
|
||||
my $released = $Opts{d}
|
||||
? Module::CoreList::Utils->first_release_by_date($utility)
|
||||
: Module::CoreList::Utils->first_release($utility);
|
||||
|
||||
my $removed = $Opts{d}
|
||||
? Module::CoreList::Utils->removed_from_by_date($utility)
|
||||
: Module::CoreList::Utils->removed_from($utility);
|
||||
|
||||
if ($released) {
|
||||
print "$utility was first released with perl ", format_perl_version($released);
|
||||
print " and later removed in ", format_perl_version($removed)
|
||||
if $removed;
|
||||
print "\n";
|
||||
} else {
|
||||
print "$utility was not in CORE (or so I think)\n";
|
||||
}
|
||||
}
|
||||
|
||||
sub utilities_in_version {
|
||||
my ($version) = @_;
|
||||
|
||||
require Module::CoreList::Utils;
|
||||
|
||||
my @utilities = Module::CoreList::Utils->utilities($version);
|
||||
|
||||
if (not @utilities) {
|
||||
print "\nModule::CoreList::Utils has no info on perl $version\n\n";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
print "\nThe following utilities were in perl ",
|
||||
format_perl_version($version), " CORE\n";
|
||||
print "$_\n" for sort { lc($a) cmp lc($b) } @utilities;
|
||||
print "\n";
|
||||
}
|
||||
|
||||
|
||||
sub max_mod_len {
|
||||
my $versions = shift;
|
||||
my $max = 0;
|
||||
for my $mod (keys %$versions) {
|
||||
$max = max($max, length $mod);
|
||||
}
|
||||
|
||||
return $max;
|
||||
}
|
||||
|
||||
sub max {
|
||||
my($this, $that) = @_;
|
||||
return $this if $this > $that;
|
||||
return $that;
|
||||
}
|
||||
|
||||
sub display_a {
|
||||
my $mod = shift;
|
||||
|
||||
for my $v (grep !/0[01]0$/, sort keys %Module::CoreList::version ) {
|
||||
next unless exists $Module::CoreList::version{$v}{$mod};
|
||||
|
||||
my $mod_v = $Module::CoreList::version{$v}{$mod} || 'undef';
|
||||
printf " %-10s %-10s\n", format_perl_version($v), $mod_v;
|
||||
}
|
||||
print "\n";
|
||||
}
|
||||
|
||||
|
||||
{
|
||||
my $have_version_pm;
|
||||
sub have_version_pm {
|
||||
return $have_version_pm if defined $have_version_pm;
|
||||
return $have_version_pm = eval { require version; 1 };
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub format_perl_version {
|
||||
my $v = shift;
|
||||
return $v if $v < 5.006 or !have_version_pm;
|
||||
return version->new($v)->normal;
|
||||
}
|
||||
|
||||
|
||||
sub numify_version {
|
||||
my $ver = shift;
|
||||
if ($ver =~ /\..+\./) {
|
||||
have_version_pm()
|
||||
or die "You need to install version.pm to use dotted version numbers\n";
|
||||
$ver = version->new($ver)->numify;
|
||||
}
|
||||
$ver += 0;
|
||||
return $ver;
|
||||
}
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
$ corelist File::Spec
|
||||
|
||||
File::Spec was first released with perl 5.005
|
||||
|
||||
$ corelist File::Spec 0.83
|
||||
|
||||
File::Spec 0.83 was released with perl 5.007003
|
||||
|
||||
$ corelist File::Spec 0.89
|
||||
|
||||
File::Spec 0.89 was not in CORE (or so I think)
|
||||
|
||||
$ corelist File::Spec::Aliens
|
||||
|
||||
File::Spec::Aliens was not in CORE (or so I think)
|
||||
|
||||
$ corelist /IPC::Open/
|
||||
|
||||
IPC::Open2 was first released with perl 5
|
||||
|
||||
IPC::Open3 was first released with perl 5
|
||||
|
||||
$ corelist /MANIFEST/i
|
||||
|
||||
ExtUtils::Manifest was first released with perl 5.001
|
||||
|
||||
$ corelist /Template/
|
||||
|
||||
/Template/ has no match in CORE (or so I think)
|
||||
|
||||
$ corelist -v 5.8.8 B
|
||||
|
||||
B 1.09_01
|
||||
|
||||
$ corelist -v 5.8.8 /^B::/
|
||||
|
||||
B::Asmdata 1.01
|
||||
B::Assembler 0.07
|
||||
B::Bblock 1.02_01
|
||||
B::Bytecode 1.01_01
|
||||
B::C 1.04_01
|
||||
B::CC 1.00_01
|
||||
B::Concise 0.66
|
||||
B::Debug 1.02_01
|
||||
B::Deparse 0.71
|
||||
B::Disassembler 1.05
|
||||
B::Lint 1.03
|
||||
B::O 1.00
|
||||
B::Showlex 1.02
|
||||
B::Stackobj 1.00
|
||||
B::Stash 1.00
|
||||
B::Terse 1.03_01
|
||||
B::Xref 1.01
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2002-2007 by D.H. aka PodMaster
|
||||
|
||||
Currently maintained by the perl 5 porters E<lt>perl5-porters@perl.orgE<gt>.
|
||||
|
||||
This program is distributed under the same terms as perl itself.
|
||||
See http://perl.org/ or http://cpan.org/ for more info on that.
|
||||
|
||||
=cut
|
||||
352
msys2/usr/bin/core_perl/cpan
Normal file
352
msys2/usr/bin/core_perl/cpan
Normal file
|
|
@ -0,0 +1,352 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!/usr/local/bin/perl
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
|
||||
use App::Cpan;
|
||||
use CPAN::Version;
|
||||
my $minver = '1.64';
|
||||
if ( CPAN::Version->vlt($App::Cpan::VERSION, $minver) ) {
|
||||
warn "WARNING: your version of App::Cpan is $App::Cpan::VERSION while we would expect at least $minver";
|
||||
}
|
||||
$VERSION = '1.64';
|
||||
|
||||
my $rc = App::Cpan->run( @ARGV );
|
||||
|
||||
# will this work under Strawberry Perl?
|
||||
exit( $rc || 0 );
|
||||
|
||||
=head1 NAME
|
||||
|
||||
cpan - easily interact with CPAN from the command line
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# with arguments and no switches, installs specified modules
|
||||
cpan module_name [ module_name ... ]
|
||||
|
||||
# with switches, installs modules with extra behavior
|
||||
cpan [-cfFimtTw] module_name [ module_name ... ]
|
||||
|
||||
# use local::lib
|
||||
cpan -I module_name [ module_name ... ]
|
||||
|
||||
# one time mirror override for faster mirrors
|
||||
cpan -p ...
|
||||
|
||||
# with just the dot, install from the distribution in the
|
||||
# current directory
|
||||
cpan .
|
||||
|
||||
# without arguments, starts CPAN.pm shell
|
||||
cpan
|
||||
|
||||
# without arguments, but some switches
|
||||
cpan [-ahpruvACDLOPX]
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This script provides a command interface (not a shell) to CPAN. At the
|
||||
moment it uses CPAN.pm to do the work, but it is not a one-shot command
|
||||
runner for CPAN.pm.
|
||||
|
||||
=head2 Options
|
||||
|
||||
=over 4
|
||||
|
||||
=item -a
|
||||
|
||||
Creates a CPAN.pm autobundle with CPAN::Shell->autobundle.
|
||||
|
||||
=item -A module [ module ... ]
|
||||
|
||||
Shows the primary maintainers for the specified modules.
|
||||
|
||||
=item -c module
|
||||
|
||||
Runs a `make clean` in the specified module's directories.
|
||||
|
||||
=item -C module [ module ... ]
|
||||
|
||||
Show the F<Changes> files for the specified modules
|
||||
|
||||
=item -D module [ module ... ]
|
||||
|
||||
Show the module details. This prints one line for each out-of-date module
|
||||
(meaning, modules locally installed but have newer versions on CPAN).
|
||||
Each line has three columns: module name, local version, and CPAN
|
||||
version.
|
||||
|
||||
=item -f
|
||||
|
||||
Force the specified action, when it normally would have failed. Use this
|
||||
to install a module even if its tests fail. When you use this option,
|
||||
-i is not optional for installing a module when you need to force it:
|
||||
|
||||
% cpan -f -i Module::Foo
|
||||
|
||||
=item -F
|
||||
|
||||
Turn off CPAN.pm's attempts to lock anything. You should be careful with
|
||||
this since you might end up with multiple scripts trying to muck in the
|
||||
same directory. This isn't so much of a concern if you're loading a special
|
||||
config with C<-j>, and that config sets up its own work directories.
|
||||
|
||||
=item -g module [ module ... ]
|
||||
|
||||
Downloads to the current directory the latest distribution of the module.
|
||||
|
||||
=item -G module [ module ... ]
|
||||
|
||||
UNIMPLEMENTED
|
||||
|
||||
Download to the current directory the latest distribution of the
|
||||
modules, unpack each distribution, and create a git repository for each
|
||||
distribution.
|
||||
|
||||
If you want this feature, check out Yanick Champoux's C<Git::CPAN::Patch>
|
||||
distribution.
|
||||
|
||||
=item -h
|
||||
|
||||
Print a help message and exit. When you specify C<-h>, it ignores all
|
||||
of the other options and arguments.
|
||||
|
||||
=item -i module [ module ... ]
|
||||
|
||||
Install the specified modules. With no other switches, this switch
|
||||
is implied.
|
||||
|
||||
=item -I
|
||||
|
||||
Load C<local::lib> (think like C<-I> for loading lib paths). Too bad
|
||||
C<-l> was already taken.
|
||||
|
||||
=item -j Config.pm
|
||||
|
||||
Load the file that has the CPAN configuration data. This should have the
|
||||
same format as the standard F<CPAN/Config.pm> file, which defines
|
||||
C<$CPAN::Config> as an anonymous hash.
|
||||
|
||||
=item -J
|
||||
|
||||
Dump the configuration in the same format that CPAN.pm uses. This is useful
|
||||
for checking the configuration as well as using the dump as a starting point
|
||||
for a new, custom configuration.
|
||||
|
||||
=item -l
|
||||
|
||||
List all installed modules with their versions
|
||||
|
||||
=item -L author [ author ... ]
|
||||
|
||||
List the modules by the specified authors.
|
||||
|
||||
=item -m
|
||||
|
||||
Make the specified modules.
|
||||
|
||||
=item -M mirror1,mirror2,...
|
||||
|
||||
A comma-separated list of mirrors to use for just this run. The C<-P>
|
||||
option can find them for you automatically.
|
||||
|
||||
=item -n
|
||||
|
||||
Do a dry run, but don't actually install anything. (unimplemented)
|
||||
|
||||
=item -O
|
||||
|
||||
Show the out-of-date modules.
|
||||
|
||||
=item -p
|
||||
|
||||
Ping the configured mirrors and print a report
|
||||
|
||||
=item -P
|
||||
|
||||
Find the best mirrors you could be using and use them for the current
|
||||
session.
|
||||
|
||||
=item -r
|
||||
|
||||
Recompiles dynamically loaded modules with CPAN::Shell->recompile.
|
||||
|
||||
=item -s
|
||||
|
||||
Drop in the CPAN.pm shell. This command does this automatically if you don't
|
||||
specify any arguments.
|
||||
|
||||
=item -t module [ module ... ]
|
||||
|
||||
Run a `make test` on the specified modules.
|
||||
|
||||
=item -T
|
||||
|
||||
Do not test modules. Simply install them.
|
||||
|
||||
=item -u
|
||||
|
||||
Upgrade all installed modules. Blindly doing this can really break things,
|
||||
so keep a backup.
|
||||
|
||||
=item -v
|
||||
|
||||
Print the script version and CPAN.pm version then exit.
|
||||
|
||||
=item -V
|
||||
|
||||
Print detailed information about the cpan client.
|
||||
|
||||
=item -w
|
||||
|
||||
UNIMPLEMENTED
|
||||
|
||||
Turn on cpan warnings. This checks various things, like directory permissions,
|
||||
and tells you about problems you might have.
|
||||
|
||||
=item -x module [ module ... ]
|
||||
|
||||
Find close matches to the named modules that you think you might have
|
||||
mistyped. This requires the optional installation of Text::Levenshtein or
|
||||
Text::Levenshtein::Damerau.
|
||||
|
||||
=item -X
|
||||
|
||||
Dump all the namespaces to standard output.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Examples
|
||||
|
||||
# print a help message
|
||||
cpan -h
|
||||
|
||||
# print the version numbers
|
||||
cpan -v
|
||||
|
||||
# create an autobundle
|
||||
cpan -a
|
||||
|
||||
# recompile modules
|
||||
cpan -r
|
||||
|
||||
# upgrade all installed modules
|
||||
cpan -u
|
||||
|
||||
# install modules ( sole -i is optional )
|
||||
cpan -i Netscape::Booksmarks Business::ISBN
|
||||
|
||||
# force install modules ( must use -i )
|
||||
cpan -fi CGI::Minimal URI
|
||||
|
||||
# install modules but without testing them
|
||||
cpan -Ti CGI::Minimal URI
|
||||
|
||||
=head2 Environment variables
|
||||
|
||||
There are several components in CPAN.pm that use environment variables.
|
||||
The build tools, L<ExtUtils::MakeMaker> and L<Module::Build> use some,
|
||||
while others matter to the levels above them. Some of these are specified
|
||||
by the Perl Toolchain Gang:
|
||||
|
||||
Lancaster Concensus: L<https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md>
|
||||
|
||||
Oslo Concensus: L<https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/oslo-consensus.md>
|
||||
|
||||
=over 4
|
||||
|
||||
=item NONINTERACTIVE_TESTING
|
||||
|
||||
Assume no one is paying attention and skips prompts for distributions
|
||||
that do that correctly. C<cpan(1)> sets this to C<1> unless it already
|
||||
has a value (even if that value is false).
|
||||
|
||||
=item PERL_MM_USE_DEFAULT
|
||||
|
||||
Use the default answer for a prompted questions. C<cpan(1)> sets this
|
||||
to C<1> unless it already has a value (even if that value is false).
|
||||
|
||||
=item CPAN_OPTS
|
||||
|
||||
As with C<PERL5OPT>, a string of additional C<cpan(1)> options to
|
||||
add to those you specify on the command line.
|
||||
|
||||
=item CPANSCRIPT_LOGLEVEL
|
||||
|
||||
The log level to use, with either the embedded, minimal logger or
|
||||
L<Log::Log4perl> if it is installed. Possible values are the same as
|
||||
the C<Log::Log4perl> levels: C<TRACE>, C<DEBUG>, C<INFO>, C<WARN>,
|
||||
C<ERROR>, and C<FATAL>. The default is C<INFO>.
|
||||
|
||||
=item GIT_COMMAND
|
||||
|
||||
The path to the C<git> binary to use for the Git features. The default
|
||||
is C</usr/local/bin/git>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXIT VALUES
|
||||
|
||||
The script exits with zero if it thinks that everything worked, or a
|
||||
positive number if it thinks that something failed. Note, however, that
|
||||
in some cases it has to divine a failure by the output of things it does
|
||||
not control. For now, the exit codes are vague:
|
||||
|
||||
1 An unknown error
|
||||
|
||||
2 The was an external problem
|
||||
|
||||
4 There was an internal problem with the script
|
||||
|
||||
8 A module failed to install
|
||||
|
||||
=head1 TO DO
|
||||
|
||||
* one shot configuration values from the command line
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
* none noted
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
Most behaviour, including environment variables and configuration,
|
||||
comes directly from CPAN.pm.
|
||||
|
||||
=head1 SOURCE AVAILABILITY
|
||||
|
||||
This code is in Github in the CPAN.pm repository:
|
||||
|
||||
https://github.com/andk/cpanpm
|
||||
|
||||
The source used to be tracked separately in another GitHub repo,
|
||||
but the canonical source is now in the above repo.
|
||||
|
||||
=head1 CREDITS
|
||||
|
||||
Japheth Cleaver added the bits to allow a forced install (-f).
|
||||
|
||||
Jim Brandt suggest and provided the initial implementation for the
|
||||
up-to-date and Changes features.
|
||||
|
||||
Adam Kennedy pointed out that exit() causes problems on Windows
|
||||
where this script ends up with a .bat extension
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
brian d foy, C<< <bdfoy@cpan.org> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2001-2015, brian d foy, All Rights Reserved.
|
||||
|
||||
You may redistribute this under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
1479
msys2/usr/bin/core_perl/enc2xs
Normal file
1479
msys2/usr/bin/core_perl/enc2xs
Normal file
File diff suppressed because it is too large
Load diff
149
msys2/usr/bin/core_perl/encguess
Normal file
149
msys2/usr/bin/core_perl/encguess
Normal file
|
|
@ -0,0 +1,149 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!./perl
|
||||
use 5.008001;
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use strict;
|
||||
use warnings;
|
||||
use Encode;
|
||||
use Getopt::Std;
|
||||
use Carp;
|
||||
use Encode::Guess;
|
||||
$Getopt::Std::STANDARD_HELP_VERSION = 1;
|
||||
|
||||
my %opt;
|
||||
getopts( "huSs:", \%opt );
|
||||
my @suspect_list;
|
||||
list_valid_suspects() and exit if $opt{S};
|
||||
@suspect_list = split /:,/, $opt{s} if $opt{s};
|
||||
HELP_MESSAGE() if $opt{h};
|
||||
HELP_MESSAGE() unless @ARGV;
|
||||
do_guess($_) for @ARGV;
|
||||
|
||||
sub read_file {
|
||||
my $filename = shift;
|
||||
local $/;
|
||||
open my $fh, '<:raw', $filename or croak "$filename:$!";
|
||||
my $content = <$fh>;
|
||||
close $fh;
|
||||
return $content;
|
||||
}
|
||||
|
||||
sub do_guess {
|
||||
my $filename = shift;
|
||||
my $data = read_file($filename);
|
||||
my $enc = guess_encoding( $data, @suspect_list );
|
||||
if ( !ref($enc) && $opt{u} ) {
|
||||
return 1;
|
||||
}
|
||||
print "$filename\t";
|
||||
if ( ref($enc) ) {
|
||||
print $enc->mime_name();
|
||||
}
|
||||
else {
|
||||
print "unknown";
|
||||
}
|
||||
print "\n";
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub list_valid_suspects {
|
||||
print join( "\n", Encode->encodings(":all") );
|
||||
print "\n";
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub HELP_MESSAGE {
|
||||
exec 'pod2usage', $0 or die "pod2usage: $!"
|
||||
}
|
||||
__END__
|
||||
=head1 NAME
|
||||
|
||||
encguess - guess character encodings of files
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
$Id: encguess,v 0.2 2016/08/04 03:15:58 dankogai Exp $
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
encguess [switches] filename...
|
||||
|
||||
=head2 SWITCHES
|
||||
|
||||
=over 2
|
||||
|
||||
=item -h
|
||||
|
||||
show this message and exit.
|
||||
|
||||
=item -s
|
||||
|
||||
specify a list of "suspect encoding types" to test,
|
||||
seperated by either C<:> or C<,>
|
||||
|
||||
=item -S
|
||||
|
||||
output a list of all acceptable encoding types that can be used with
|
||||
the -s param
|
||||
|
||||
=item -u
|
||||
|
||||
suppress display of unidentified types
|
||||
|
||||
=back
|
||||
|
||||
=head2 EXAMPLES:
|
||||
|
||||
=over 2
|
||||
|
||||
=item *
|
||||
|
||||
Guess encoding of a file named C<test.txt>, using only the default
|
||||
suspect types.
|
||||
|
||||
encguess test.txt
|
||||
|
||||
=item *
|
||||
|
||||
Guess the encoding type of a file named C<test.txt>, using the suspect
|
||||
types C<euc-jp,shiftjis,7bit-jis>.
|
||||
|
||||
encguess -s euc-jp,shiftjis,7bit-jis test.txt
|
||||
encguess -s euc-jp:shiftjis:7bit-jis test.txt
|
||||
|
||||
=item *
|
||||
|
||||
Guess the encoding type of several files, do not display results for
|
||||
unidentified files.
|
||||
|
||||
encguess -us euc-jp,shiftjis,7bit-jis test*.txt
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The encoding identification is done by checking one encoding type at a
|
||||
time until all but the right type are eliminated. The set of encoding
|
||||
types to try is defined by the -s parameter and defaults to ascii,
|
||||
utf8 and UTF-16/32 with BOM. This can be overridden by passing one or
|
||||
more encoding types via the -s parameter. If you need to pass in
|
||||
multiple suspect encoding types, use a quoted string with the a space
|
||||
separating each value.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Encode::Guess>, L<Encode::Detect>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
Copyright 2015 Michael LaGrasta and Dan Kogai.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the terms of the the Artistic License (2.0). You may obtain a
|
||||
copy of the full license at:
|
||||
|
||||
L<http://www.perlfoundation.org/artistic_license_2_0>
|
||||
|
||||
=cut
|
||||
988
msys2/usr/bin/core_perl/h2ph
Normal file
988
msys2/usr/bin/core_perl/h2ph
Normal file
|
|
@ -0,0 +1,988 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
|
||||
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, $incl_quote, $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 qw(redefine misc);\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($proto);
|
||||
} else {
|
||||
s/^\s+//;
|
||||
expr();
|
||||
|
||||
$new = 1 if $new eq '';
|
||||
|
||||
# Shunt around such directives as '#define FOO FOO':
|
||||
next if $new =~ /^\s*&\Q$name\E\s*\z/;
|
||||
|
||||
$new = reindent($new);
|
||||
$args = reindent($args);
|
||||
$new =~ s/(['\\])/\\$1/g; #']);
|
||||
|
||||
print OUT $t, 'eval ';
|
||||
if ($opt_h) {
|
||||
print OUT "\"\\n#line $eval_index $outfile\\n\" . ";
|
||||
$eval_index++;
|
||||
}
|
||||
print OUT "'sub $name () {$new;}' unless defined(&$name);\n";
|
||||
}
|
||||
} elsif (/^(include|import|include_next)\s*([<\"])(.*)[>\"]/) {
|
||||
$incl_type = $1;
|
||||
$incl_quote = $2;
|
||||
$incl = $3;
|
||||
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/;
|
||||
# copy the prefix in the quote syntax (#include "x.h") case
|
||||
if ($incl !~ m|/| && $incl_quote eq q{"} && $file =~ m|^(.*)/|) {
|
||||
$incl = "$1/$incl";
|
||||
}
|
||||
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)
|
||||
EMIT($proto);
|
||||
}
|
||||
}
|
||||
$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 EMIT {
|
||||
my $proto = shift;
|
||||
|
||||
$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 = ();
|
||||
return;
|
||||
}
|
||||
|
||||
sub expr {
|
||||
if (/\b__asm__\b/) { # freak out
|
||||
$new = '"(assembly code)"';
|
||||
return
|
||||
}
|
||||
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 "erroneous" 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) {
|
||||
if ($new =~ /defined\s*$/) {
|
||||
$new .= '(&' . $id . ')';
|
||||
} elsif ($new =~ /defined\s*\($/) {
|
||||
$new .= '&' . $id;
|
||||
} else {
|
||||
$new .= '(defined(&' . $id . ') ? &' . $id . ' : undef)';
|
||||
}
|
||||
} 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+([<"])(.*?)[>"]/) {
|
||||
my ($delimiter, $new_file) = ($1, $2);
|
||||
# copy the prefix in the quote syntax (#include "x.h") case
|
||||
if ($delimiter eq q{"} && $file =~ m|^(.*)/|) {
|
||||
$new_file = "$1/$new_file";
|
||||
}
|
||||
push(@ARGV, $new_file) unless $Is_converted{$new_file};
|
||||
}
|
||||
}
|
||||
close HEADER;
|
||||
}
|
||||
|
||||
|
||||
# Determine include directories; $Config{usrinc} should be enough for (all
|
||||
# non-GCC?) C compilers, but gcc uses additional include directories.
|
||||
sub inc_dirs
|
||||
{
|
||||
my $from_gcc = `LC_ALL=C $Config{cc} -v -E - < /dev/null 2>&1 | awk '/^#include/, /^End of search list/' | grep '^ '`;
|
||||
length($from_gcc) ? (split(' ', $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 = 4;
|
||||
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";
|
||||
# Prevent non-portable hex constants from warning.
|
||||
#
|
||||
# We still produce an overflow warning if we can't represent
|
||||
# a hex constant as an integer.
|
||||
print PREAMBLE "no warnings qw(portable);\n";
|
||||
|
||||
foreach (sort keys %define) {
|
||||
if ($opt_D) {
|
||||
print PREAMBLE "# $_=$define{$_}\n";
|
||||
}
|
||||
if ($define{$_} =~ /^\((.*)\)$/) {
|
||||
# parenthesized value: d=(v)
|
||||
$define{$_} = $1;
|
||||
}
|
||||
if (/^(\w+)\((\w)\)$/) {
|
||||
my($macro, $arg) = ($1, $2);
|
||||
my $def = $define{$_};
|
||||
$def =~ s/$arg/\$\{$arg\}/g;
|
||||
print PREAMBLE <<DEFINE;
|
||||
unless (defined &$macro) { sub $macro(\$) { my (\$$arg) = \@_; \"$def\" } }
|
||||
|
||||
DEFINE
|
||||
} elsif
|
||||
($define{$_} =~ /^([+-]?(\d+)?\.\d+([eE][+-]?\d+)?)[FL]?$/) {
|
||||
# float:
|
||||
print PREAMBLE
|
||||
"unless (defined &$_) { sub $_() { $1 } }\n\n";
|
||||
} elsif ($define{$_} =~ /^([+-]?\d+)U?L{0,2}$/i) {
|
||||
# integer:
|
||||
print PREAMBLE
|
||||
"unless (defined &$_) { sub $_() { $1 } }\n\n";
|
||||
} elsif ($define{$_} =~ /^([+-]?0x[\da-f]+)U?L{0,2}$/i) {
|
||||
# hex integer
|
||||
# Special cased, since perl warns on hex integers
|
||||
# that can't be represented in a UV.
|
||||
#
|
||||
# This way we get the warning at time of use, so the user
|
||||
# only gets the warning if they happen to use this
|
||||
# platform-specific definition.
|
||||
my $code = $1;
|
||||
$code = "hex('$code')" if length $code > 10;
|
||||
print PREAMBLE
|
||||
"unless (defined &$_) { sub $_() { $code } }\n\n";
|
||||
} elsif ($define{$_} =~ /^\w+$/) {
|
||||
my $def = $define{$_};
|
||||
if ($isatype{$def}) {
|
||||
print PREAMBLE
|
||||
"unless (defined &$_) { sub $_() { \"$def\" } }\n\n";
|
||||
} else {
|
||||
print PREAMBLE
|
||||
"unless (defined &$_) { sub $_() { &$def } }\n\n";
|
||||
}
|
||||
} else {
|
||||
print PREAMBLE
|
||||
"unless (defined &$_) { sub $_() { \"",
|
||||
quotemeta($define{$_}), "\" } }\n\n";
|
||||
}
|
||||
}
|
||||
print PREAMBLE "\n1;\n"; # avoid 'did not return a true value' when empty
|
||||
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:
|
||||
while ($allsymbols =~ /([^\s]+)=((\\\s|[^\s])+)/g) {
|
||||
$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] [-h] [-e] [-D] [-Q]
|
||||
[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{'installsitearch'}>).
|
||||
|
||||
=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 -e
|
||||
|
||||
If an error is encountered during conversion, output file will be removed and
|
||||
a warning emitted instead of terminating the conversion immediately.
|
||||
|
||||
=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
|
||||
|
||||
2207
msys2/usr/bin/core_perl/h2xs
Normal file
2207
msys2/usr/bin/core_perl/h2xs
Normal file
File diff suppressed because it is too large
Load diff
196
msys2/usr/bin/core_perl/instmodsh
Normal file
196
msys2/usr/bin/core_perl/instmodsh
Normal file
|
|
@ -0,0 +1,196 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use strict;
|
||||
use IO::File;
|
||||
use ExtUtils::Packlist;
|
||||
use ExtUtils::Installed;
|
||||
|
||||
use vars qw($Inst @Modules);
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
instmodsh - A shell to examine installed modules
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
instmodsh
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A little interface to ExtUtils::Installed to examine installed modules,
|
||||
validate your packlists and even create a tarball from an installed module.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
ExtUtils::Installed
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
my $Module_Help = <<EOF;
|
||||
Available commands are:
|
||||
f [all|prog|doc] - List installed files of a given type
|
||||
d [all|prog|doc] - List the directories used by a module
|
||||
v - Validate the .packlist - check for missing files
|
||||
t <tarfile> - Create a tar archive of the module
|
||||
h - Display module help
|
||||
q - Quit the module
|
||||
EOF
|
||||
|
||||
my %Module_Commands = (
|
||||
f => \&list_installed,
|
||||
d => \&list_directories,
|
||||
v => \&validate_packlist,
|
||||
t => \&create_archive,
|
||||
h => \&module_help,
|
||||
);
|
||||
|
||||
sub do_module($) {
|
||||
my ($module) = @_;
|
||||
|
||||
print($Module_Help);
|
||||
MODULE_CMD: while (1) {
|
||||
print("$module cmd? ");
|
||||
|
||||
my $reply = <STDIN>; chomp($reply);
|
||||
my($cmd) = $reply =~ /^(\w)\b/;
|
||||
|
||||
last if $cmd eq 'q';
|
||||
|
||||
if( $Module_Commands{$cmd} ) {
|
||||
$Module_Commands{$cmd}->($reply, $module);
|
||||
}
|
||||
elsif( $cmd eq 'q' ) {
|
||||
last MODULE_CMD;
|
||||
}
|
||||
else {
|
||||
module_help();
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub list_installed {
|
||||
my($reply, $module) = @_;
|
||||
|
||||
my $class = (split(' ', $reply))[1];
|
||||
$class = 'all' unless $class;
|
||||
|
||||
my @files;
|
||||
if (eval { @files = $Inst->files($module, $class); }) {
|
||||
print("$class files in $module are:\n ",
|
||||
join("\n ", @files), "\n");
|
||||
}
|
||||
else {
|
||||
print($@);
|
||||
}
|
||||
};
|
||||
|
||||
|
||||
sub list_directories {
|
||||
my($reply, $module) = @_;
|
||||
|
||||
my $class = (split(' ', $reply))[1];
|
||||
$class = 'all' unless $class;
|
||||
|
||||
my @dirs;
|
||||
if (eval { @dirs = $Inst->directories($module, $class); }) {
|
||||
print("$class directories in $module are:\n ",
|
||||
join("\n ", @dirs), "\n");
|
||||
}
|
||||
else {
|
||||
print($@);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub create_archive {
|
||||
my($reply, $module) = @_;
|
||||
|
||||
my $file = (split(' ', $reply))[1];
|
||||
|
||||
if( !(defined $file and length $file) ) {
|
||||
print "No tar file specified\n";
|
||||
}
|
||||
elsif( eval { require Archive::Tar } ) {
|
||||
Archive::Tar->create_archive($file, 0, $Inst->files($module));
|
||||
}
|
||||
else {
|
||||
my($first, @rest) = $Inst->files($module);
|
||||
system('tar', 'cvf', $file, $first);
|
||||
for my $f (@rest) {
|
||||
system('tar', 'rvf', $file, $f);
|
||||
}
|
||||
print "Can't use tar\n" if $?;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub validate_packlist {
|
||||
my($reply, $module) = @_;
|
||||
|
||||
if (my @missing = $Inst->validate($module)) {
|
||||
print("Files missing from $module are:\n ",
|
||||
join("\n ", @missing), "\n");
|
||||
}
|
||||
else {
|
||||
print("$module has no missing files\n");
|
||||
}
|
||||
}
|
||||
|
||||
sub module_help {
|
||||
print $Module_Help;
|
||||
}
|
||||
|
||||
|
||||
|
||||
##############################################################################
|
||||
|
||||
sub toplevel()
|
||||
{
|
||||
my $help = <<EOF;
|
||||
Available commands are:
|
||||
l - List all installed modules
|
||||
m <module> - Select a module
|
||||
q - Quit the program
|
||||
EOF
|
||||
print($help);
|
||||
while (1)
|
||||
{
|
||||
print("cmd? ");
|
||||
my $reply = <STDIN>; chomp($reply);
|
||||
CASE:
|
||||
{
|
||||
$reply eq 'l' and do
|
||||
{
|
||||
print("Installed modules are:\n ", join("\n ", @Modules), "\n");
|
||||
last CASE;
|
||||
};
|
||||
$reply =~ /^m\s+/ and do
|
||||
{
|
||||
do_module((split(' ', $reply))[1]);
|
||||
last CASE;
|
||||
};
|
||||
$reply eq 'q' and do
|
||||
{
|
||||
exit(0);
|
||||
};
|
||||
# Default
|
||||
print($help);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
###############################################################################
|
||||
|
||||
$Inst = ExtUtils::Installed->new();
|
||||
@Modules = $Inst->modules();
|
||||
toplevel();
|
||||
|
||||
###############################################################################
|
||||
240
msys2/usr/bin/core_perl/json_pp
Normal file
240
msys2/usr/bin/core_perl/json_pp
Normal file
|
|
@ -0,0 +1,240 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!/usr/bin/perl
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use strict;
|
||||
use Getopt::Long;
|
||||
use Encode ();
|
||||
|
||||
use JSON::PP ();
|
||||
|
||||
# imported from JSON-XS/bin/json_xs
|
||||
|
||||
my %allow_json_opt = map { $_ => 1 } qw(
|
||||
ascii latin1 utf8 pretty indent space_before space_after relaxed canonical allow_nonref
|
||||
allow_singlequote allow_barekey allow_bignum loose escape_slash indent_length
|
||||
);
|
||||
|
||||
|
||||
GetOptions(
|
||||
'v' => \( my $opt_verbose ),
|
||||
'f=s' => \( my $opt_from = 'json' ),
|
||||
't=s' => \( my $opt_to = 'json' ),
|
||||
'json_opt=s' => \( my $json_opt = 'pretty' ),
|
||||
'V' => \( my $version ),
|
||||
) or die "Usage: $0 [-V] [-f from_format] [-t to_format] [-json_opt options_to_json1[,options_to_json2[,...]]]\n";
|
||||
|
||||
|
||||
if ( $version ) {
|
||||
print "$JSON::PP::VERSION\n";
|
||||
exit;
|
||||
}
|
||||
|
||||
|
||||
$json_opt = '' if $json_opt eq '-';
|
||||
|
||||
my %json_opt;
|
||||
for my $opt (split /,/, $json_opt) {
|
||||
my ($key, $value) = split /=/, $opt, 2;
|
||||
$value = 1 unless defined $value;
|
||||
die "'$_' is not a valid json option" unless $allow_json_opt{$key};
|
||||
$json_opt{$key} = $value;
|
||||
}
|
||||
|
||||
my %F = (
|
||||
'json' => sub {
|
||||
my $json = JSON::PP->new;
|
||||
my $enc =
|
||||
/^\x00\x00\x00/s ? "utf-32be"
|
||||
: /^\x00.\x00/s ? "utf-16be"
|
||||
: /^.\x00\x00\x00/s ? "utf-32le"
|
||||
: /^.\x00.\x00/s ? "utf-16le"
|
||||
: "utf-8";
|
||||
for my $key (keys %json_opt) {
|
||||
next if $key eq 'utf8';
|
||||
$json->$key($json_opt{$key});
|
||||
}
|
||||
$json->decode( Encode::decode($enc, $_) );
|
||||
},
|
||||
'eval' => sub {
|
||||
my $v = eval "no strict;\n#line 1 \"input\"\n$_";
|
||||
die "$@" if $@;
|
||||
return $v;
|
||||
},
|
||||
);
|
||||
|
||||
|
||||
my %T = (
|
||||
'null' => sub { "" },
|
||||
'json' => sub {
|
||||
my $json = JSON::PP->new->utf8;
|
||||
for my $key (keys %json_opt) {
|
||||
$json->$key($json_opt{$key});
|
||||
}
|
||||
$json->canonical if $json_opt{pretty};
|
||||
$json->encode( $_ );
|
||||
},
|
||||
'dumper' => sub {
|
||||
require Data::Dumper;
|
||||
local $Data::Dumper::Terse = 1;
|
||||
local $Data::Dumper::Indent = 1;
|
||||
local $Data::Dumper::Useqq = 1;
|
||||
local $Data::Dumper::Quotekeys = 0;
|
||||
local $Data::Dumper::Sortkeys = 1;
|
||||
Data::Dumper::Dumper($_)
|
||||
},
|
||||
);
|
||||
|
||||
|
||||
|
||||
$F{$opt_from}
|
||||
or die "$opt_from: not a valid fromformat\n";
|
||||
|
||||
$T{$opt_to}
|
||||
or die "$opt_from: not a valid toformat\n";
|
||||
|
||||
{
|
||||
local $/;
|
||||
binmode STDIN;
|
||||
$_ = <STDIN>;
|
||||
}
|
||||
|
||||
$_ = $F{$opt_from}->();
|
||||
$_ = $T{$opt_to}->();
|
||||
|
||||
print $_;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
json_pp - JSON::PP command utility
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
json_pp [-v] [-f from_format] [-t to_format] [-json_opt options_to_json1[,options_to_json2[,...]]]
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
json_pp converts between some input and output formats (one of them is JSON).
|
||||
This program was copied from L<json_xs> and modified.
|
||||
|
||||
The default input format is json and the default output format is json with pretty option.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
=head2 -f
|
||||
|
||||
-f from_format
|
||||
|
||||
Reads a data in the given format from STDIN.
|
||||
|
||||
Format types:
|
||||
|
||||
=over
|
||||
|
||||
=item json
|
||||
|
||||
as JSON
|
||||
|
||||
=item eval
|
||||
|
||||
as Perl code
|
||||
|
||||
=back
|
||||
|
||||
=head2 -t
|
||||
|
||||
Writes a data in the given format to STDOUT.
|
||||
|
||||
=over
|
||||
|
||||
=item null
|
||||
|
||||
no action.
|
||||
|
||||
=item json
|
||||
|
||||
as JSON
|
||||
|
||||
=item dumper
|
||||
|
||||
as Data::Dumper
|
||||
|
||||
=back
|
||||
|
||||
=head2 -json_opt
|
||||
|
||||
options to JSON::PP
|
||||
|
||||
Acceptable options are:
|
||||
|
||||
ascii latin1 utf8 pretty indent space_before space_after relaxed canonical allow_nonref
|
||||
allow_singlequote allow_barekey allow_bignum loose escape_slash indent_length
|
||||
|
||||
Multiple options must be separated by commas:
|
||||
|
||||
Right: -json_opt pretty,canonical
|
||||
|
||||
Wrong: -json_opt pretty -json_opt canonical
|
||||
|
||||
=head2 -v
|
||||
|
||||
Verbose option, but currently no action in fact.
|
||||
|
||||
=head2 -V
|
||||
|
||||
Prints version and exits.
|
||||
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
$ perl -e'print q|{"foo":"あい","bar":1234567890000000000000000}|' |\
|
||||
json_pp -f json -t dumper -json_opt pretty,utf8,allow_bignum
|
||||
|
||||
$VAR1 = {
|
||||
'bar' => bless( {
|
||||
'value' => [
|
||||
'0000000',
|
||||
'0000000',
|
||||
'5678900',
|
||||
'1234'
|
||||
],
|
||||
'sign' => '+'
|
||||
}, 'Math::BigInt' ),
|
||||
'foo' => "\x{3042}\x{3044}"
|
||||
};
|
||||
|
||||
$ perl -e'print q|{"foo":"あい","bar":1234567890000000000000000}|' |\
|
||||
json_pp -f json -t dumper -json_opt pretty
|
||||
|
||||
$VAR1 = {
|
||||
'bar' => '1234567890000000000000000',
|
||||
'foo' => "\x{e3}\x{81}\x{82}\x{e3}\x{81}\x{84}"
|
||||
};
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<JSON::PP>, L<json_xs>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
|
||||
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 2010 by Makamaka Hannyaharamitu
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
722
msys2/usr/bin/core_perl/libnetcfg
Normal file
722
msys2/usr/bin/core_perl/libnetcfg
Normal file
|
|
@ -0,0 +1,722 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
|
||||
=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<libnetFAQ>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Graham Barr, the original Configure script of libnet.
|
||||
|
||||
Jarkko Hietaniemi, conversion into libnetcfg for inclusion into Perl 5.8.
|
||||
|
||||
=cut
|
||||
|
||||
# $Id: Configure,v 1.8 1997/03/04 09:22:32 gbarr Exp $
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
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(" ",@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,@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",@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 = ( %{ local @INC = '.'; 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@remote.host
|
||||
PASS pass
|
||||
2) -----------------------
|
||||
USER fwuser
|
||||
PASS fwpass
|
||||
USER user@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@fwuser@remote.site
|
||||
PASS pass@fwpass
|
||||
6) -----------------------
|
||||
USER fwuser@remote.site
|
||||
PASS fwpass
|
||||
USER user
|
||||
PASS pass
|
||||
7) -----------------------
|
||||
USER user@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;
|
||||
1518
msys2/usr/bin/core_perl/perlbug
Normal file
1518
msys2/usr/bin/core_perl/perlbug
Normal file
File diff suppressed because it is too large
Load diff
14
msys2/usr/bin/core_perl/perldoc
Normal file
14
msys2/usr/bin/core_perl/perldoc
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0;
|
||||
|
||||
# This "perldoc" file was generated by "perldoc.PL"
|
||||
|
||||
require 5;
|
||||
BEGIN {
|
||||
$^W = 1 if $ENV{'PERLDOCDEBUG'};
|
||||
pop @INC if $INC[-1] eq '.';
|
||||
}
|
||||
use Pod::Perldoc;
|
||||
exit( Pod::Perldoc->run() );
|
||||
|
||||
392
msys2/usr/bin/core_perl/perlivp
Normal file
392
msys2/usr/bin/core_perl/perlivp
Normal file
|
|
@ -0,0 +1,392 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
|
||||
# perlivp v5.32.0
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
|
||||
sub usage {
|
||||
warn "@_\n" if @_;
|
||||
print << " EOUSAGE";
|
||||
Usage:
|
||||
|
||||
$0 [-p] [-v] | [-h]
|
||||
|
||||
-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 'HhPpVv' =~ /\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;
|
||||
|
||||
my $perlpath = '/usr/bin/perl';
|
||||
my $useithreads = 'define';
|
||||
|
||||
print "## Checking Perl binary via variable '\$perlpath' = $perlpath.\n" if $opt{'p'};
|
||||
|
||||
my $label = 'Executable perl binary';
|
||||
|
||||
if (-x $perlpath) {
|
||||
print "## Perl binary '$perlpath' appears executable.\n" if $opt{'v'};
|
||||
print "ok 1 $label\n";
|
||||
$pass__total++;
|
||||
}
|
||||
else {
|
||||
print "# Perl binary '$perlpath' does not appear executable.\n";
|
||||
print "not ok 1 $label\n";
|
||||
$error_total++;
|
||||
}
|
||||
$tests_total++;
|
||||
|
||||
|
||||
print "## Checking Perl version via variable '\$]'.\n" if $opt{'p'};
|
||||
|
||||
my $ivp_VERSION = "5.032000";
|
||||
|
||||
|
||||
$label = 'Perl version correct';
|
||||
if ($ivp_VERSION eq $]) {
|
||||
print "## Perl version '$]' appears installed as expected.\n" if $opt{'v'};
|
||||
print "ok 2 $label\n";
|
||||
$pass__total++;
|
||||
}
|
||||
else {
|
||||
print "# Perl version '$]' installed, expected $ivp_VERSION.\n";
|
||||
print "not ok 2 $label\n";
|
||||
$error_total++;
|
||||
}
|
||||
$tests_total++;
|
||||
|
||||
# We have the right perl and version, so now reset @INC so we ignore
|
||||
# PERL5LIB and '.'
|
||||
{
|
||||
local $ENV{PERL5LIB};
|
||||
my $perl_V = qx($perlpath -V);
|
||||
$perl_V =~ s{.*\@INC:\n}{}ms;
|
||||
@INC = grep { length && $_ ne '.' } split ' ', $perl_V;
|
||||
}
|
||||
|
||||
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 (-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++;
|
||||
}
|
||||
|
||||
$label = '@INC directories exist';
|
||||
if ($INC_total == $INC_there) {
|
||||
print "ok 3 $label\n";
|
||||
$pass__total++;
|
||||
}
|
||||
else {
|
||||
print "not ok 3 $label\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;
|
||||
}
|
||||
$label = 'Modules needed for rest of perlivp exist';
|
||||
if ($needed_total == $needed_there) {
|
||||
print "ok 4 $label\n";
|
||||
$pass__total++;
|
||||
}
|
||||
else {
|
||||
print "not ok 4 $label\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');
|
||||
}
|
||||
# that's a distribution name, not a module name
|
||||
next if $_ eq 'IO/Compress';
|
||||
next if $_ eq 'Devel/DProf';
|
||||
next if $_ eq 'libnet';
|
||||
next if $_ eq 'Locale/Codes';
|
||||
next if $_ eq 'podlators';
|
||||
next if $_ eq 'perlfaq';
|
||||
# test modules
|
||||
next if $_ eq 'XS/APItest';
|
||||
next if $_ eq 'XS/Typemap';
|
||||
# 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
|
||||
# actual 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;
|
||||
}
|
||||
$label = 'All (and only) expected extensions installed';
|
||||
if ($extensions_total == $extensions_there) {
|
||||
print "ok 5 $label\n";
|
||||
$pass__total++;
|
||||
}
|
||||
else {
|
||||
print "not ok 5 $label\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($_);
|
||||
|
||||
# .bs files are optional
|
||||
@missing = grep { ! /\.bs$/ } @missing;
|
||||
# man files are often compressed
|
||||
@missing = grep { ! ( -s "$_.gz" || -s "$_.bz2" ) } @missing;
|
||||
|
||||
if ($#missing >= 0) {
|
||||
print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n";
|
||||
print '# ',join(' ',@missing),"\n";
|
||||
}
|
||||
elsif ($#missing == -1) {
|
||||
$installed_there++;
|
||||
}
|
||||
@missing = ();
|
||||
}
|
||||
$label = 'Module files correctly installed';
|
||||
if (($installed_total == $installed_there) &&
|
||||
($installed_total == $version_check)) {
|
||||
print "ok 6 $label\n";
|
||||
$pass__total++;
|
||||
}
|
||||
else {
|
||||
print "not ok 6 $label\n";
|
||||
$error_total++;
|
||||
}
|
||||
$tests_total++;
|
||||
|
||||
# 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<-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<-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.
|
||||
|
||||
=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
|
||||
|
||||
1518
msys2/usr/bin/core_perl/perlthanks
Normal file
1518
msys2/usr/bin/core_perl/perlthanks
Normal file
File diff suppressed because it is too large
Load diff
322
msys2/usr/bin/core_perl/piconv
Normal file
322
msys2/usr/bin/core_perl/piconv
Normal file
|
|
@ -0,0 +1,322 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!./perl
|
||||
# $Id: piconv,v 2.8 2016/08/04 03:15:58 dankogai Exp $
|
||||
#
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use 5.8.0;
|
||||
use strict;
|
||||
use Encode ;
|
||||
use Encode::Alias;
|
||||
my %Scheme = map {$_ => 1} qw(from_to decode_encode perlio);
|
||||
|
||||
use File::Basename;
|
||||
my $name = basename($0);
|
||||
|
||||
use Getopt::Long qw(:config no_ignore_case);
|
||||
|
||||
my %Opt;
|
||||
|
||||
help()
|
||||
unless
|
||||
GetOptions(\%Opt,
|
||||
'from|f=s',
|
||||
'to|t=s',
|
||||
'list|l',
|
||||
'string|s=s',
|
||||
'check|C=i',
|
||||
'c',
|
||||
'perlqq|p',
|
||||
'htmlcref',
|
||||
'xmlcref',
|
||||
'debug|D',
|
||||
'scheme|S=s',
|
||||
'resolve|r=s',
|
||||
'help',
|
||||
);
|
||||
|
||||
$Opt{help} and help();
|
||||
$Opt{list} and list_encodings();
|
||||
my $locale = $ENV{LC_CTYPE} || $ENV{LC_ALL} || $ENV{LANG};
|
||||
defined $Opt{resolve} and resolve_encoding($Opt{resolve});
|
||||
$Opt{from} || $Opt{to} || help();
|
||||
my $from = $Opt{from} || $locale or help("from_encoding unspecified");
|
||||
my $to = $Opt{to} || $locale or help("to_encoding unspecified");
|
||||
$Opt{string} and Encode::from_to($Opt{string}, $from, $to) and print $Opt{string} and exit;
|
||||
my $scheme = do {
|
||||
if (defined $Opt{scheme}) {
|
||||
if (!exists $Scheme{$Opt{scheme}}) {
|
||||
warn "Unknown scheme '$Opt{scheme}', fallback to 'from_to'.\n";
|
||||
'from_to';
|
||||
} else {
|
||||
$Opt{scheme};
|
||||
}
|
||||
} else {
|
||||
'from_to';
|
||||
}
|
||||
};
|
||||
|
||||
$Opt{check} ||= $Opt{c};
|
||||
$Opt{perlqq} and $Opt{check} = Encode::PERLQQ;
|
||||
$Opt{htmlcref} and $Opt{check} = Encode::HTMLCREF;
|
||||
$Opt{xmlcref} and $Opt{check} = Encode::XMLCREF;
|
||||
|
||||
my $efrom = Encode->getEncoding($from) || die "Unknown encoding '$from'";
|
||||
my $eto = Encode->getEncoding($to) || die "Unknown encoding '$to'";
|
||||
|
||||
my $cfrom = $efrom->name;
|
||||
my $cto = $eto->name;
|
||||
|
||||
if ($Opt{debug}){
|
||||
print <<"EOT";
|
||||
Scheme: $scheme
|
||||
From: $from => $cfrom
|
||||
To: $to => $cto
|
||||
EOT
|
||||
}
|
||||
|
||||
my %use_bom =
|
||||
map { $_ => 1 } qw/UTF-16 UTF-16BE UTF-16LE UTF-32 UTF-32BE UTF-32LE/;
|
||||
|
||||
# we do not use <> (or ARGV) for the sake of binmode()
|
||||
@ARGV or push @ARGV, \*STDIN;
|
||||
|
||||
unless ( $scheme eq 'perlio' ) {
|
||||
binmode STDOUT;
|
||||
my $need2slurp = $use_bom{ $eto } || $use_bom{ $efrom };
|
||||
for my $argv (@ARGV) {
|
||||
my $ifh = ref $argv ? $argv : undef;
|
||||
$ifh or open $ifh, "<", $argv or warn "Can't open $argv: $!" and next;
|
||||
$ifh or open $ifh, "<", $argv or next;
|
||||
binmode $ifh;
|
||||
if ( $scheme eq 'from_to' ) { # default
|
||||
if ($need2slurp){
|
||||
local $/;
|
||||
$_ = <$ifh>;
|
||||
Encode::from_to( $_, $from, $to, $Opt{check} );
|
||||
print;
|
||||
}else{
|
||||
while (<$ifh>) {
|
||||
Encode::from_to( $_, $from, $to, $Opt{check} );
|
||||
print;
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ( $scheme eq 'decode_encode' ) { # step-by-step
|
||||
if ($need2slurp){
|
||||
local $/;
|
||||
$_ = <$ifh>;
|
||||
my $decoded = decode( $from, $_, $Opt{check} );
|
||||
my $encoded = encode( $to, $decoded );
|
||||
print $encoded;
|
||||
}else{
|
||||
while (<$ifh>) {
|
||||
my $decoded = decode( $from, $_, $Opt{check} );
|
||||
my $encoded = encode( $to, $decoded );
|
||||
print $encoded;
|
||||
}
|
||||
}
|
||||
}
|
||||
else { # won't reach
|
||||
die "$name: unknown scheme: $scheme";
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
|
||||
# NI-S favorite
|
||||
binmode STDOUT => "raw:encoding($to)";
|
||||
for my $argv (@ARGV) {
|
||||
my $ifh = ref $argv ? $argv : undef;
|
||||
$ifh or open $ifh, "<", $argv or warn "Can't open $argv: $!" and next;
|
||||
$ifh or open $ifh, "<", $argv or next;
|
||||
binmode $ifh => "raw:encoding($from)";
|
||||
print while (<$ifh>);
|
||||
}
|
||||
}
|
||||
|
||||
sub list_encodings {
|
||||
print join( "\n", Encode->encodings(":all") ), "\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
sub resolve_encoding {
|
||||
if ( my $alias = Encode::resolve_alias( $_[0] ) ) {
|
||||
print $alias, "\n";
|
||||
exit 0;
|
||||
}
|
||||
else {
|
||||
warn "$name: $_[0] is not known to Encode\n";
|
||||
exit 1;
|
||||
}
|
||||
}
|
||||
|
||||
sub help {
|
||||
my $message = shift;
|
||||
$message and print STDERR "$name error: $message\n";
|
||||
print STDERR <<"EOT";
|
||||
$name [-f from_encoding] [-t to_encoding]
|
||||
[-p|--perlqq|--htmlcref|--xmlcref] [-C N|-c] [-D] [-S scheme]
|
||||
[-s string|file...]
|
||||
$name -l
|
||||
$name -r encoding_alias
|
||||
$name -h
|
||||
Common options:
|
||||
-l,--list
|
||||
lists all available encodings
|
||||
-r,--resolve encoding_alias
|
||||
resolve encoding to its (Encode) canonical name
|
||||
-f,--from from_encoding
|
||||
when omitted, the current locale will be used
|
||||
-t,--to to_encoding
|
||||
when omitted, the current locale will be used
|
||||
-s,--string string
|
||||
"string" will be the input instead of STDIN or files
|
||||
The following are mainly of interest to Encode hackers:
|
||||
-C N | -c check the validity of the input
|
||||
-D,--debug show debug information
|
||||
-S,--scheme scheme use the scheme for conversion
|
||||
Those are handy when you can only see ASCII characters:
|
||||
-p,--perlqq transliterate characters missing in encoding to \\x{HHHH}
|
||||
where HHHH is the hexadecimal Unicode code point
|
||||
--htmlcref transliterate characters missing in encoding to &#NNN;
|
||||
where NNN is the decimal Unicode code point
|
||||
--xmlcref transliterate characters missing in encoding to &#xHHHH;
|
||||
where HHHH is the hexadecimal Unicode code point
|
||||
|
||||
EOT
|
||||
exit;
|
||||
}
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
piconv -- iconv(1), reinvented in perl
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
piconv [-f from_encoding] [-t to_encoding]
|
||||
[-p|--perlqq|--htmlcref|--xmlcref] [-C N|-c] [-D] [-S scheme]
|
||||
[-s string|file...]
|
||||
piconv -l
|
||||
piconv -r encoding_alias
|
||||
piconv -h
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<piconv> is perl version of B<iconv>, a character encoding converter
|
||||
widely available for various Unixen today. This script was primarily
|
||||
a technology demonstrator for Perl 5.8.0, but you can use piconv in the
|
||||
place of iconv for virtually any case.
|
||||
|
||||
piconv converts the character encoding of either STDIN or files
|
||||
specified in the argument and prints out to STDOUT.
|
||||
|
||||
Here is the list of options. Some options can be in short format (-f)
|
||||
or long (--from) one.
|
||||
|
||||
=over 4
|
||||
|
||||
=item -f,--from I<from_encoding>
|
||||
|
||||
Specifies the encoding you are converting from. Unlike B<iconv>,
|
||||
this option can be omitted. In such cases, the current locale is used.
|
||||
|
||||
=item -t,--to I<to_encoding>
|
||||
|
||||
Specifies the encoding you are converting to. Unlike B<iconv>,
|
||||
this option can be omitted. In such cases, the current locale is used.
|
||||
|
||||
Therefore, when both -f and -t are omitted, B<piconv> just acts
|
||||
like B<cat>.
|
||||
|
||||
=item -s,--string I<string>
|
||||
|
||||
uses I<string> instead of file for the source of text.
|
||||
|
||||
=item -l,--list
|
||||
|
||||
Lists all available encodings, one per line, in case-insensitive
|
||||
order. Note that only the canonical names are listed; many aliases
|
||||
exist. For example, the names are case-insensitive, and many standard
|
||||
and common aliases work, such as "latin1" for "ISO-8859-1", or "ibm850"
|
||||
instead of "cp850", or "winlatin1" for "cp1252". See L<Encode::Supported>
|
||||
for a full discussion.
|
||||
|
||||
=item -r,--resolve I<encoding_alias>
|
||||
|
||||
Resolve I<encoding_alias> to Encode canonical encoding name.
|
||||
|
||||
=item -C,--check I<N>
|
||||
|
||||
Check the validity of the stream if I<N> = 1. When I<N> = -1, something
|
||||
interesting happens when it encounters an invalid character.
|
||||
|
||||
=item -c
|
||||
|
||||
Same as C<-C 1>.
|
||||
|
||||
=item -p,--perlqq
|
||||
|
||||
Transliterate characters missing in encoding to \x{HHHH} where HHHH is the
|
||||
hexadecimal Unicode code point.
|
||||
|
||||
=item --htmlcref
|
||||
|
||||
Transliterate characters missing in encoding to &#NNN; where NNN is the
|
||||
decimal Unicode code point.
|
||||
|
||||
=item --xmlcref
|
||||
|
||||
Transliterate characters missing in encoding to &#xHHHH; where HHHH is the
|
||||
hexadecimal Unicode code point.
|
||||
|
||||
=item -h,--help
|
||||
|
||||
Show usage.
|
||||
|
||||
=item -D,--debug
|
||||
|
||||
Invokes debugging mode. Primarily for Encode hackers.
|
||||
|
||||
=item -S,--scheme I<scheme>
|
||||
|
||||
Selects which scheme is to be used for conversion. Available schemes
|
||||
are as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item from_to
|
||||
|
||||
Uses Encode::from_to for conversion. This is the default.
|
||||
|
||||
=item decode_encode
|
||||
|
||||
Input strings are decode()d then encode()d. A straight two-step
|
||||
implementation.
|
||||
|
||||
=item perlio
|
||||
|
||||
The new perlIO layer is used. NI-S' favorite.
|
||||
|
||||
You should use this option if you are using UTF-16 and others which
|
||||
linefeed is not $/.
|
||||
|
||||
=back
|
||||
|
||||
Like the I<-D> option, this is also for Encode hackers.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<iconv(1)>
|
||||
L<locale(3)>
|
||||
L<Encode>
|
||||
L<Encode::Supported>
|
||||
L<Encode::Alias>
|
||||
L<PerlIO>
|
||||
|
||||
=cut
|
||||
378
msys2/usr/bin/core_perl/pl2pm
Normal file
378
msys2/usr/bin/core_perl/pl2pm
Normal file
|
|
@ -0,0 +1,378 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
|
||||
=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@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
|
||||
CHECK
|
||||
CORE
|
||||
DESTROY
|
||||
END
|
||||
INIT
|
||||
UNITCHECK
|
||||
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
|
||||
225
msys2/usr/bin/core_perl/pod2html
Normal file
225
msys2/usr/bin/core_perl/pod2html
Normal file
|
|
@ -0,0 +1,225 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
pod2html - convert .pod files to .html files
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
pod2html --help --htmldir=<name> --htmlroot=<URL>
|
||||
--infile=<name> --outfile=<name>
|
||||
--podpath=<name>:...:<name> --podroot=<name>
|
||||
--cachedir=<name> --flush --recurse --norecurse
|
||||
--quiet --noquiet --verbose --noverbose
|
||||
--index --noindex --backlink --nobacklink
|
||||
--header --noheader --poderrors --nopoderrors
|
||||
--css=<URL> --title=<name>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Converts files from pod format (see L<perlpod>) to HTML format.
|
||||
|
||||
=head1 ARGUMENTS
|
||||
|
||||
pod2html takes the following arguments:
|
||||
|
||||
=over 4
|
||||
|
||||
=item help
|
||||
|
||||
--help
|
||||
|
||||
Displays the usage message.
|
||||
|
||||
=item htmldir
|
||||
|
||||
--htmldir=name
|
||||
|
||||
Sets the directory to which all cross references in the resulting HTML file
|
||||
will be relative. Not passing this causes all links to be absolute since this
|
||||
is the value that tells Pod::Html the root of the documentation tree.
|
||||
|
||||
Do not use this and --htmlroot in the same call to pod2html; they are mutually
|
||||
exclusive.
|
||||
|
||||
=item htmlroot
|
||||
|
||||
--htmlroot=URL
|
||||
|
||||
Sets the base URL for the HTML files. When cross-references are made, the
|
||||
HTML root is prepended to the URL.
|
||||
|
||||
Do not use this if relative links are desired: use --htmldir instead.
|
||||
|
||||
Do not pass both this and --htmldir to pod2html; they are mutually exclusive.
|
||||
|
||||
=item infile
|
||||
|
||||
--infile=name
|
||||
|
||||
Specify the pod file to convert. Input is taken from STDIN if no
|
||||
infile is specified.
|
||||
|
||||
=item outfile
|
||||
|
||||
--outfile=name
|
||||
|
||||
Specify the HTML file to create. Output goes to STDOUT if no outfile
|
||||
is specified.
|
||||
|
||||
=item podroot
|
||||
|
||||
--podroot=name
|
||||
|
||||
Specify the base directory for finding library pods.
|
||||
|
||||
=item podpath
|
||||
|
||||
--podpath=name:...:name
|
||||
|
||||
Specify which subdirectories of the podroot contain pod files whose
|
||||
HTML converted forms can be linked-to in cross-references.
|
||||
|
||||
=item cachedir
|
||||
|
||||
--cachedir=name
|
||||
|
||||
Specify which directory is used for storing cache. Default directory is the
|
||||
current working directory.
|
||||
|
||||
=item flush
|
||||
|
||||
--flush
|
||||
|
||||
Flush the cache.
|
||||
|
||||
=item backlink
|
||||
|
||||
--backlink
|
||||
|
||||
Turn =head1 directives into links pointing to the top of the HTML file.
|
||||
|
||||
=item nobacklink
|
||||
|
||||
--nobacklink
|
||||
|
||||
Do not turn =head1 directives into links pointing to the top of the HTML file
|
||||
(default behaviour).
|
||||
|
||||
=item header
|
||||
|
||||
--header
|
||||
|
||||
Create header and footer blocks containing the text of the "NAME" section.
|
||||
|
||||
=item noheader
|
||||
|
||||
--noheader
|
||||
|
||||
Do not create header and footer blocks containing the text of the "NAME"
|
||||
section (default behaviour).
|
||||
|
||||
=item poderrors
|
||||
|
||||
--poderrors
|
||||
|
||||
Include a "POD ERRORS" section in the outfile if there were any POD errors in
|
||||
the infile (default behaviour).
|
||||
|
||||
=item nopoderrors
|
||||
|
||||
--nopoderrors
|
||||
|
||||
Do not include a "POD ERRORS" section in the outfile if there were any POD
|
||||
errors in the infile.
|
||||
|
||||
=item index
|
||||
|
||||
--index
|
||||
|
||||
Generate an index at the top of the HTML file (default behaviour).
|
||||
|
||||
=item noindex
|
||||
|
||||
--noindex
|
||||
|
||||
Do not generate an index at the top of the HTML file.
|
||||
|
||||
|
||||
=item recurse
|
||||
|
||||
--recurse
|
||||
|
||||
Recurse into subdirectories specified in podpath (default behaviour).
|
||||
|
||||
=item norecurse
|
||||
|
||||
--norecurse
|
||||
|
||||
Do not recurse into subdirectories specified in podpath.
|
||||
|
||||
=item css
|
||||
|
||||
--css=URL
|
||||
|
||||
Specify the URL of cascading style sheet to link from resulting HTML file.
|
||||
Default is none style sheet.
|
||||
|
||||
=item title
|
||||
|
||||
--title=title
|
||||
|
||||
Specify the title of the resulting HTML file.
|
||||
|
||||
=item quiet
|
||||
|
||||
--quiet
|
||||
|
||||
Don't display mostly harmless warning messages.
|
||||
|
||||
=item noquiet
|
||||
|
||||
--noquiet
|
||||
|
||||
Display mostly harmless warning messages (default behaviour). But this is not
|
||||
the same as "verbose" mode.
|
||||
|
||||
=item verbose
|
||||
|
||||
--verbose
|
||||
|
||||
Display progress messages.
|
||||
|
||||
=item noverbose
|
||||
|
||||
--noverbose
|
||||
|
||||
Do not display progress messages (default behaviour).
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Tom Christiansen, E<lt>tchrist@perl.comE<gt>.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
See L<Pod::Html> for a list of known bugs in the translator.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<perlpod>, L<Pod::Html>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
This program is distributed under the Artistic License.
|
||||
|
||||
=cut
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use Pod::Html;
|
||||
|
||||
pod2html @ARGV;
|
||||
396
msys2/usr/bin/core_perl/pod2man
Normal file
396
msys2/usr/bin/core_perl/pod2man
Normal file
|
|
@ -0,0 +1,396 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
|
||||
# Convert POD data to formatted *roff input.
|
||||
#
|
||||
# The driver script for Pod::Man.
|
||||
#
|
||||
# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl
|
||||
|
||||
use 5.006;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Getopt::Long qw(GetOptions);
|
||||
use Pod::Man ();
|
||||
use Pod::Usage qw(pod2usage);
|
||||
|
||||
use strict;
|
||||
|
||||
# Clean up $0 for error reporting.
|
||||
$0 =~ s%.*/%%;
|
||||
|
||||
# Insert -- into @ARGV before any single dash argument to hide it from
|
||||
# Getopt::Long; we want to interpret it as meaning stdin.
|
||||
my $stdin;
|
||||
@ARGV = map { $_ eq '-' && !$stdin++ ? ('--', $_) : $_ } @ARGV;
|
||||
|
||||
# Parse our options, trying to retain backward compatibility with pod2man but
|
||||
# allowing short forms as well. --lax is currently ignored.
|
||||
my %options;
|
||||
Getopt::Long::config ('bundling_override');
|
||||
GetOptions (\%options, 'center|c=s', 'date|d=s', 'errors=s', 'fixed=s',
|
||||
'fixedbold=s', 'fixeditalic=s', 'fixedbolditalic=s', 'help|h',
|
||||
'lax|l', 'lquote=s', 'name|n=s', 'nourls', 'official|o',
|
||||
'quotes|q=s', 'release|r=s', 'rquote=s', 'section|s=s', 'stderr',
|
||||
'verbose|v', 'utf8|u')
|
||||
or exit 1;
|
||||
pod2usage (0) if $options{help};
|
||||
|
||||
# Official sets --center, but don't override things explicitly set.
|
||||
if ($options{official} && !defined $options{center}) {
|
||||
$options{center} = 'Perl Programmers Reference Guide';
|
||||
}
|
||||
|
||||
# Verbose is only our flag, not a Pod::Man flag.
|
||||
my $verbose = $options{verbose};
|
||||
delete $options{verbose};
|
||||
|
||||
# This isn't a valid Pod::Man option and is only accepted for backward
|
||||
# compatibility.
|
||||
delete $options{lax};
|
||||
|
||||
# If neither stderr nor errors is set, default to errors = die.
|
||||
if (!defined $options{stderr} && !defined $options{errors}) {
|
||||
$options{errors} = 'die';
|
||||
}
|
||||
|
||||
# Initialize and run the formatter, pulling a pair of input and output off at
|
||||
# a time. For each file, we check whether the document was completely empty
|
||||
# and, if so, will remove the created file and exit with a non-zero exit
|
||||
# status.
|
||||
my $parser = Pod::Man->new (%options);
|
||||
my $status = 0;
|
||||
my @files;
|
||||
do {
|
||||
@files = splice (@ARGV, 0, 2);
|
||||
print " $files[1]\n" if $verbose;
|
||||
$parser->parse_from_file (@files);
|
||||
if ($parser->{CONTENTLESS}) {
|
||||
$status = 1;
|
||||
if (defined $files[0]) {
|
||||
warn "$0: unable to format $files[0]\n";
|
||||
} else {
|
||||
warn "$0: unable to format standard input\n";
|
||||
}
|
||||
if (defined ($files[1]) and $files[1] ne '-') {
|
||||
unlink $files[1] unless (-s $files[1]);
|
||||
}
|
||||
}
|
||||
} while (@ARGV);
|
||||
exit $status;
|
||||
|
||||
__END__
|
||||
|
||||
=for stopwords
|
||||
en em --stderr stderr --utf8 UTF-8 overdo markup MT-LEVEL Allbery Solaris URL
|
||||
troff troff-specific formatters uppercased Christiansen --nourls UTC prepend
|
||||
lquote rquote
|
||||
|
||||
=head1 NAME
|
||||
|
||||
pod2man - Convert POD data to formatted *roff input
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
pod2man [B<--center>=I<string>] [B<--date>=I<string>] [B<--errors>=I<style>]
|
||||
[B<--fixed>=I<font>] [B<--fixedbold>=I<font>] [B<--fixeditalic>=I<font>]
|
||||
[B<--fixedbolditalic>=I<font>] [B<--name>=I<name>] [B<--nourls>]
|
||||
[B<--official>] [B<--release>=I<version>] [B<--section>=I<manext>]
|
||||
[B<--quotes>=I<quotes>] [B<--lquote>=I<quote>] [B<--rquote>=I<quote>]
|
||||
[B<--stderr>] [B<--utf8>] [B<--verbose>] [I<input> [I<output>] ...]
|
||||
|
||||
pod2man B<--help>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<pod2man> is a front-end for Pod::Man, using it to generate *roff input
|
||||
from POD source. The resulting *roff code is suitable for display on a
|
||||
terminal using nroff(1), normally via man(1), or printing using troff(1).
|
||||
|
||||
I<input> is the file to read for POD source (the POD can be embedded in
|
||||
code). If I<input> isn't given, it defaults to C<STDIN>. I<output>, if
|
||||
given, is the file to which to write the formatted output. If I<output>
|
||||
isn't given, the formatted output is written to C<STDOUT>. Several POD
|
||||
files can be processed in the same B<pod2man> invocation (saving module
|
||||
load and compile times) by providing multiple pairs of I<input> and
|
||||
I<output> files on the command line.
|
||||
|
||||
B<--section>, B<--release>, B<--center>, B<--date>, and B<--official> can
|
||||
be used to set the headers and footers to use; if not given, Pod::Man will
|
||||
assume various defaults. See below or L<Pod::Man> for details.
|
||||
|
||||
B<pod2man> assumes that your *roff formatters have a fixed-width font
|
||||
named C<CW>. If yours is called something else (like C<CR>), use
|
||||
B<--fixed> to specify it. This generally only matters for troff output
|
||||
for printing. Similarly, you can set the fonts used for bold, italic, and
|
||||
bold italic fixed-width output.
|
||||
|
||||
Besides the obvious pod conversions, Pod::Man, and therefore pod2man also
|
||||
takes care of formatting func(), func(n), and simple variable references
|
||||
like $foo or @bar so you don't have to use code escapes for them; complex
|
||||
expressions like C<$fred{'stuff'}> will still need to be escaped, though.
|
||||
It also translates dashes that aren't used as hyphens into en dashes, makes
|
||||
long dashes--like this--into proper em dashes, fixes "paired quotes," and
|
||||
takes care of several other troff-specific tweaks. See L<Pod::Man> for
|
||||
complete information.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<-c> I<string>, B<--center>=I<string>
|
||||
|
||||
Sets the centered page header for the C<.TH> macro to I<string>. The
|
||||
default is "User Contributed Perl Documentation", but also see
|
||||
B<--official> below.
|
||||
|
||||
=item B<-d> I<string>, B<--date>=I<string>
|
||||
|
||||
Set the left-hand footer string for the C<.TH> macro to I<string>. By
|
||||
default, the modification date of the input file will be used, or the
|
||||
current date if input comes from C<STDIN>, and will be based on UTC (so
|
||||
that the output will be reproducible regardless of local time zone).
|
||||
|
||||
=item B<--errors>=I<style>
|
||||
|
||||
Set the error handling style. C<die> says to throw an exception on any
|
||||
POD formatting error. C<stderr> says to report errors on standard error,
|
||||
but not to throw an exception. C<pod> says to include a POD ERRORS
|
||||
section in the resulting documentation summarizing the errors. C<none>
|
||||
ignores POD errors entirely, as much as possible.
|
||||
|
||||
The default is C<die>.
|
||||
|
||||
=item B<--fixed>=I<font>
|
||||
|
||||
The fixed-width font to use for verbatim text and code. Defaults to
|
||||
C<CW>. Some systems may want C<CR> instead. Only matters for troff(1)
|
||||
output.
|
||||
|
||||
=item B<--fixedbold>=I<font>
|
||||
|
||||
Bold version of the fixed-width font. Defaults to C<CB>. Only matters
|
||||
for troff(1) output.
|
||||
|
||||
=item B<--fixeditalic>=I<font>
|
||||
|
||||
Italic version of the fixed-width font (actually, something of a misnomer,
|
||||
since most fixed-width fonts only have an oblique version, not an italic
|
||||
version). Defaults to C<CI>. Only matters for troff(1) output.
|
||||
|
||||
=item B<--fixedbolditalic>=I<font>
|
||||
|
||||
Bold italic (probably actually oblique) version of the fixed-width font.
|
||||
Pod::Man doesn't assume you have this, and defaults to C<CB>. Some
|
||||
systems (such as Solaris) have this font available as C<CX>. Only matters
|
||||
for troff(1) output.
|
||||
|
||||
=item B<-h>, B<--help>
|
||||
|
||||
Print out usage information.
|
||||
|
||||
=item B<-l>, B<--lax>
|
||||
|
||||
No longer used. B<pod2man> used to check its input for validity as a
|
||||
manual page, but this should now be done by L<podchecker(1)> instead.
|
||||
Accepted for backward compatibility; this option no longer does anything.
|
||||
|
||||
=item B<--lquote>=I<quote>
|
||||
|
||||
=item B<--rquote>=I<quote>
|
||||
|
||||
Sets the quote marks used to surround CE<lt>> text. B<--lquote> sets the
|
||||
left quote mark and B<--rquote> sets the right quote mark. Either may also
|
||||
be set to the special value C<none>, in which case no quote mark is added
|
||||
on that side of CE<lt>> text (but the font is still changed for troff
|
||||
output).
|
||||
|
||||
Also see the B<--quotes> option, which can be used to set both quotes at once.
|
||||
If both B<--quotes> and one of the other options is set, B<--lquote> or
|
||||
B<--rquote> overrides B<--quotes>.
|
||||
|
||||
=item B<-n> I<name>, B<--name>=I<name>
|
||||
|
||||
Set the name of the manual page for the C<.TH> macro to I<name>. Without
|
||||
this option, the manual name is set to the uppercased base name of the
|
||||
file being converted unless the manual section is 3, in which case the
|
||||
path is parsed to see if it is a Perl module path. If it is, a path like
|
||||
C<.../lib/Pod/Man.pm> is converted into a name like C<Pod::Man>. This
|
||||
option, if given, overrides any automatic determination of the name.
|
||||
|
||||
Although one does not have to follow this convention, be aware that the
|
||||
convention for UNIX man pages for commands is for the man page title to be
|
||||
in all-uppercase, even if the command isn't.
|
||||
|
||||
This option is probably not useful when converting multiple POD files at
|
||||
once.
|
||||
|
||||
When converting POD source from standard input, the name will be set to
|
||||
C<STDIN> if this option is not provided. Providing this option is strongly
|
||||
recommended to set a meaningful manual page name.
|
||||
|
||||
=item B<--nourls>
|
||||
|
||||
Normally, LZ<><> formatting codes with a URL but anchor text are formatted
|
||||
to show both the anchor text and the URL. In other words:
|
||||
|
||||
L<foo|http://example.com/>
|
||||
|
||||
is formatted as:
|
||||
|
||||
foo <http://example.com/>
|
||||
|
||||
This flag, if given, suppresses the URL when anchor text is given, so this
|
||||
example would be formatted as just C<foo>. This can produce less
|
||||
cluttered output in cases where the URLs are not particularly important.
|
||||
|
||||
=item B<-o>, B<--official>
|
||||
|
||||
Set the default header to indicate that this page is part of the standard
|
||||
Perl release, if B<--center> is not also given.
|
||||
|
||||
=item B<-q> I<quotes>, B<--quotes>=I<quotes>
|
||||
|
||||
Sets the quote marks used to surround CE<lt>> text to I<quotes>. If
|
||||
I<quotes> is a single character, it is used as both the left and right
|
||||
quote. Otherwise, it is split in half, and the first half of the string
|
||||
is used as the left quote and the second is used as the right quote.
|
||||
|
||||
I<quotes> may also be set to the special value C<none>, in which case no
|
||||
quote marks are added around CE<lt>> text (but the font is still changed for
|
||||
troff output).
|
||||
|
||||
Also see the B<--lquote> and B<--rquote> options, which can be used to set the
|
||||
left and right quotes independently. If both B<--quotes> and one of the other
|
||||
options is set, B<--lquote> or B<--rquote> overrides B<--quotes>.
|
||||
|
||||
=item B<-r> I<version>, B<--release>=I<version>
|
||||
|
||||
Set the centered footer for the C<.TH> macro to I<version>. By default,
|
||||
this is set to the version of Perl you run B<pod2man> under. Setting this
|
||||
to the empty string will cause some *roff implementations to use the
|
||||
system default value.
|
||||
|
||||
Note that some system C<an> macro sets assume that the centered footer
|
||||
will be a modification date and will prepend something like "Last
|
||||
modified: ". If this is the case for your target system, you may want to
|
||||
set B<--release> to the last modified date and B<--date> to the version
|
||||
number.
|
||||
|
||||
=item B<-s> I<string>, B<--section>=I<string>
|
||||
|
||||
Set the section for the C<.TH> macro. The standard section numbering
|
||||
convention is to use 1 for user commands, 2 for system calls, 3 for
|
||||
functions, 4 for devices, 5 for file formats, 6 for games, 7 for
|
||||
miscellaneous information, and 8 for administrator commands. There is a lot
|
||||
of variation here, however; some systems (like Solaris) use 4 for file
|
||||
formats, 5 for miscellaneous information, and 7 for devices. Still others
|
||||
use 1m instead of 8, or some mix of both. About the only section numbers
|
||||
that are reliably consistent are 1, 2, and 3.
|
||||
|
||||
By default, section 1 will be used unless the file ends in C<.pm>, in
|
||||
which case section 3 will be selected.
|
||||
|
||||
=item B<--stderr>
|
||||
|
||||
By default, B<pod2man> dies if any errors are detected in the POD input.
|
||||
If B<--stderr> is given and no B<--errors> flag is present, errors are
|
||||
sent to standard error, but B<pod2man> does not abort. This is equivalent
|
||||
to C<--errors=stderr> and is supported for backward compatibility.
|
||||
|
||||
=item B<-u>, B<--utf8>
|
||||
|
||||
By default, B<pod2man> produces the most conservative possible *roff
|
||||
output to try to ensure that it will work with as many different *roff
|
||||
implementations as possible. Many *roff implementations cannot handle
|
||||
non-ASCII characters, so this means all non-ASCII characters are converted
|
||||
either to a *roff escape sequence that tries to create a properly accented
|
||||
character (at least for troff output) or to C<X>.
|
||||
|
||||
This option says to instead output literal UTF-8 characters. If your
|
||||
*roff implementation can handle it, this is the best output format to use
|
||||
and avoids corruption of documents containing non-ASCII characters.
|
||||
However, be warned that *roff source with literal UTF-8 characters is not
|
||||
supported by many implementations and may even result in segfaults and
|
||||
other bad behavior.
|
||||
|
||||
Be aware that, when using this option, the input encoding of your POD
|
||||
source should be properly declared unless it's US-ASCII. Pod::Simple will
|
||||
attempt to guess the encoding and may be successful if it's Latin-1 or
|
||||
UTF-8, but it will warn, which by default results in a B<pod2man> failure.
|
||||
Use the C<=encoding> command to declare the encoding. See L<perlpod(1)>
|
||||
for more information.
|
||||
|
||||
=item B<-v>, B<--verbose>
|
||||
|
||||
Print out the name of each output file as it is being generated.
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXIT STATUS
|
||||
|
||||
As long as all documents processed result in some output, even if that
|
||||
output includes errata (a C<POD ERRORS> section generated with
|
||||
C<--errors=pod>), B<pod2man> will exit with status 0. If any of the
|
||||
documents being processed do not result in an output document, B<pod2man>
|
||||
will exit with status 1. If there are syntax errors in a POD document
|
||||
being processed and the error handling style is set to the default of
|
||||
C<die>, B<pod2man> will abort immediately with exit status 255.
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
If B<pod2man> fails with errors, see L<Pod::Man> and L<Pod::Simple> for
|
||||
information about what those errors might mean.
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
pod2man program > program.1
|
||||
pod2man SomeModule.pm /usr/perl/man/man3/SomeModule.3
|
||||
pod2man --section=7 note.pod > note.7
|
||||
|
||||
If you would like to print out a lot of man page continuously, you probably
|
||||
want to set the C and D registers to set contiguous page numbering and
|
||||
even/odd paging, at least on some versions of man(7).
|
||||
|
||||
troff -man -rC1 -rD1 perl.1 perldata.1 perlsyn.1 ...
|
||||
|
||||
To get index entries on C<STDERR>, turn on the F register, as in:
|
||||
|
||||
troff -man -rF1 perl.1
|
||||
|
||||
The indexing merely outputs messages via C<.tm> for each major page,
|
||||
section, subsection, item, and any C<XE<lt>E<gt>> directives. See
|
||||
L<Pod::Man> for more details.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Lots of this documentation is duplicated from L<Pod::Man>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Russ Allbery <rra@cpan.org>, based I<very> heavily on the original
|
||||
B<pod2man> by Larry Wall and Tom Christiansen.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 1999-2001, 2004, 2006, 2008, 2010, 2012-2019 Russ Allbery
|
||||
<rra@cpan.org>
|
||||
|
||||
This program is free software; you may redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Man>, L<Pod::Simple>, L<man(1)>, L<nroff(1)>, L<perlpod(1)>,
|
||||
L<podchecker(1)>, L<perlpodstyle(1)>, L<troff(1)>, L<man(7)>
|
||||
|
||||
The man page documenting the an macro set may be L<man(5)> instead of
|
||||
L<man(7)> on your system.
|
||||
|
||||
The current version of this script is always available from its web site at
|
||||
L<https://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
|
||||
Perl core distribution as of 5.6.0.
|
||||
|
||||
=cut
|
||||
322
msys2/usr/bin/core_perl/pod2text
Normal file
322
msys2/usr/bin/core_perl/pod2text
Normal file
|
|
@ -0,0 +1,322 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
|
||||
# Convert POD data to formatted ASCII text.
|
||||
#
|
||||
# The driver script for Pod::Text, Pod::Text::Termcap, and Pod::Text::Color,
|
||||
# invoked by perldoc -t among other things.
|
||||
#
|
||||
# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl
|
||||
|
||||
use 5.006;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Getopt::Long qw(GetOptions);
|
||||
use Pod::Text ();
|
||||
use Pod::Usage qw(pod2usage);
|
||||
|
||||
# Clean up $0 for error reporting.
|
||||
$0 =~ s%.*/%%;
|
||||
|
||||
# Take an initial pass through our options, looking for one of the form
|
||||
# -<number>. We turn that into -w <number> for compatibility with the
|
||||
# original pod2text script.
|
||||
for (my $i = 0; $i < @ARGV; $i++) {
|
||||
last if $ARGV[$i] =~ /^--$/;
|
||||
if ($ARGV[$i] =~ /^-(\d+)$/) {
|
||||
splice (@ARGV, $i++, 1, '-w', $1);
|
||||
}
|
||||
}
|
||||
|
||||
# Insert -- into @ARGV before any single dash argument to hide it from
|
||||
# Getopt::Long; we want to interpret it as meaning stdin (which Pod::Simple
|
||||
# does correctly).
|
||||
my $stdin;
|
||||
@ARGV = map { $_ eq '-' && !$stdin++ ? ('--', $_) : $_ } @ARGV;
|
||||
|
||||
# Parse our options. Use the same names as Pod::Text for simplicity.
|
||||
my %options;
|
||||
Getopt::Long::config ('bundling');
|
||||
GetOptions (\%options, 'alt|a', 'code', 'color|c', 'errors=s', 'help|h',
|
||||
'indent|i=i', 'loose|l', 'margin|left-margin|m=i', 'nourls',
|
||||
'overstrike|o', 'quotes|q=s', 'sentence|s', 'stderr', 'termcap|t',
|
||||
'utf8|u', 'width|w=i')
|
||||
or exit 1;
|
||||
pod2usage (1) if $options{help};
|
||||
|
||||
# Figure out what formatter we're going to use. -c overrides -t.
|
||||
my $formatter = 'Pod::Text';
|
||||
if ($options{color}) {
|
||||
$formatter = 'Pod::Text::Color';
|
||||
eval { require Term::ANSIColor };
|
||||
if ($@) { die "-c (--color) requires Term::ANSIColor be installed\n" }
|
||||
require Pod::Text::Color;
|
||||
} elsif ($options{termcap}) {
|
||||
$formatter = 'Pod::Text::Termcap';
|
||||
require Pod::Text::Termcap;
|
||||
} elsif ($options{overstrike}) {
|
||||
$formatter = 'Pod::Text::Overstrike';
|
||||
require Pod::Text::Overstrike;
|
||||
}
|
||||
delete @options{'color', 'termcap', 'overstrike'};
|
||||
|
||||
# If neither stderr nor errors is set, default to errors = die.
|
||||
if (!defined $options{stderr} && !defined $options{errors}) {
|
||||
$options{errors} = 'die';
|
||||
}
|
||||
|
||||
# Initialize and run the formatter.
|
||||
my $parser = $formatter->new (%options);
|
||||
my $status = 0;
|
||||
do {
|
||||
my ($input, $output) = splice (@ARGV, 0, 2);
|
||||
$parser->parse_from_file ($input, $output);
|
||||
if ($parser->{CONTENTLESS}) {
|
||||
$status = 1;
|
||||
if (defined $input) {
|
||||
warn "$0: unable to format $input\n";
|
||||
} else {
|
||||
warn "$0: unable to format standard input\n";
|
||||
}
|
||||
if (defined ($output) and $output ne '-') {
|
||||
unlink $output unless (-s $output);
|
||||
}
|
||||
}
|
||||
} while (@ARGV);
|
||||
exit $status;
|
||||
|
||||
__END__
|
||||
|
||||
=for stopwords
|
||||
-aclostu --alt --stderr Allbery --overstrike overstrike --termcap --utf8
|
||||
UTF-8 subclasses --nourls
|
||||
|
||||
=head1 NAME
|
||||
|
||||
pod2text - Convert POD data to formatted ASCII text
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
pod2text [B<-aclostu>] [B<--code>] [B<--errors>=I<style>] [B<-i> I<indent>]
|
||||
S<[B<-q> I<quotes>]> [B<--nourls>] [B<--stderr>] S<[B<-w> I<width>]>
|
||||
[I<input> [I<output> ...]]
|
||||
|
||||
pod2text B<-h>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<pod2text> is a front-end for Pod::Text and its subclasses. It uses them
|
||||
to generate formatted ASCII text from POD source. It can optionally use
|
||||
either termcap sequences or ANSI color escape sequences to format the text.
|
||||
|
||||
I<input> is the file to read for POD source (the POD can be embedded in
|
||||
code). If I<input> isn't given, it defaults to C<STDIN>. I<output>, if
|
||||
given, is the file to which to write the formatted output. If I<output>
|
||||
isn't given, the formatted output is written to C<STDOUT>. Several POD
|
||||
files can be processed in the same B<pod2text> invocation (saving module
|
||||
load and compile times) by providing multiple pairs of I<input> and
|
||||
I<output> files on the command line.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<-a>, B<--alt>
|
||||
|
||||
Use an alternate output format that, among other things, uses a different
|
||||
heading style and marks C<=item> entries with a colon in the left margin.
|
||||
|
||||
=item B<--code>
|
||||
|
||||
Include any non-POD text from the input file in the output as well. Useful
|
||||
for viewing code documented with POD blocks with the POD rendered and the
|
||||
code left intact.
|
||||
|
||||
=item B<-c>, B<--color>
|
||||
|
||||
Format the output with ANSI color escape sequences. Using this option
|
||||
requires that Term::ANSIColor be installed on your system.
|
||||
|
||||
=item B<--errors>=I<style>
|
||||
|
||||
Set the error handling style. C<die> says to throw an exception on any
|
||||
POD formatting error. C<stderr> says to report errors on standard error,
|
||||
but not to throw an exception. C<pod> says to include a POD ERRORS
|
||||
section in the resulting documentation summarizing the errors. C<none>
|
||||
ignores POD errors entirely, as much as possible.
|
||||
|
||||
The default is C<die>.
|
||||
|
||||
=item B<-i> I<indent>, B<--indent=>I<indent>
|
||||
|
||||
Set the number of spaces to indent regular text, and the default indentation
|
||||
for C<=over> blocks. Defaults to 4 spaces if this option isn't given.
|
||||
|
||||
=item B<-h>, B<--help>
|
||||
|
||||
Print out usage information and exit.
|
||||
|
||||
=item B<-l>, B<--loose>
|
||||
|
||||
Print a blank line after a C<=head1> heading. Normally, no blank line is
|
||||
printed after C<=head1>, although one is still printed after C<=head2>,
|
||||
because this is the expected formatting for manual pages; if you're
|
||||
formatting arbitrary text documents, using this option is recommended.
|
||||
|
||||
=item B<-m> I<width>, B<--left-margin>=I<width>, B<--margin>=I<width>
|
||||
|
||||
The width of the left margin in spaces. Defaults to 0. This is the margin
|
||||
for all text, including headings, not the amount by which regular text is
|
||||
indented; for the latter, see B<-i> option.
|
||||
|
||||
=item B<--nourls>
|
||||
|
||||
Normally, LZ<><> formatting codes with a URL but anchor text are formatted
|
||||
to show both the anchor text and the URL. In other words:
|
||||
|
||||
L<foo|http://example.com/>
|
||||
|
||||
is formatted as:
|
||||
|
||||
foo <http://example.com/>
|
||||
|
||||
This flag, if given, suppresses the URL when anchor text is given, so this
|
||||
example would be formatted as just C<foo>. This can produce less
|
||||
cluttered output in cases where the URLs are not particularly important.
|
||||
|
||||
=item B<-o>, B<--overstrike>
|
||||
|
||||
Format the output with overstrike printing. Bold text is rendered as
|
||||
character, backspace, character. Italics and file names are rendered as
|
||||
underscore, backspace, character. Many pagers, such as B<less>, know how
|
||||
to convert this to bold or underlined text.
|
||||
|
||||
=item B<-q> I<quotes>, B<--quotes>=I<quotes>
|
||||
|
||||
Sets the quote marks used to surround CE<lt>> text to I<quotes>. If
|
||||
I<quotes> is a single character, it is used as both the left and right
|
||||
quote. Otherwise, it is split in half, and the first half of the string
|
||||
is used as the left quote and the second is used as the right quote.
|
||||
|
||||
I<quotes> may also be set to the special value C<none>, in which case no
|
||||
quote marks are added around CE<lt>> text.
|
||||
|
||||
=item B<-s>, B<--sentence>
|
||||
|
||||
Assume each sentence ends with two spaces and try to preserve that spacing.
|
||||
Without this option, all consecutive whitespace in non-verbatim paragraphs
|
||||
is compressed into a single space.
|
||||
|
||||
=item B<--stderr>
|
||||
|
||||
By default, B<pod2text> dies if any errors are detected in the POD input.
|
||||
If B<--stderr> is given and no B<--errors> flag is present, errors are
|
||||
sent to standard error, but B<pod2text> does not abort. This is
|
||||
equivalent to C<--errors=stderr> and is supported for backward
|
||||
compatibility.
|
||||
|
||||
=item B<-t>, B<--termcap>
|
||||
|
||||
Try to determine the width of the screen and the bold and underline
|
||||
sequences for the terminal from termcap, and use that information in
|
||||
formatting the output. Output will be wrapped at two columns less than the
|
||||
width of your terminal device. Using this option requires that your system
|
||||
have a termcap file somewhere where Term::Cap can find it and requires that
|
||||
your system support termios. With this option, the output of B<pod2text>
|
||||
will contain terminal control sequences for your current terminal type.
|
||||
|
||||
=item B<-u>, B<--utf8>
|
||||
|
||||
By default, B<pod2text> tries to use the same output encoding as its input
|
||||
encoding (to be backward-compatible with older versions). This option
|
||||
says to instead force the output encoding to UTF-8.
|
||||
|
||||
Be aware that, when using this option, the input encoding of your POD
|
||||
source should be properly declared unless it's US-ASCII. Pod::Simple
|
||||
will attempt to guess the encoding and may be successful if it's
|
||||
Latin-1 or UTF-8, but it will warn, which by default results in a
|
||||
B<pod2text> failure. Use the C<=encoding> command to declare the
|
||||
encoding. See L<perlpod(1)> for more information.
|
||||
|
||||
=item B<-w>, B<--width=>I<width>, B<->I<width>
|
||||
|
||||
The column at which to wrap text on the right-hand side. Defaults to 76,
|
||||
unless B<-t> is given, in which case it's two columns less than the width of
|
||||
your terminal device.
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXIT STATUS
|
||||
|
||||
As long as all documents processed result in some output, even if that
|
||||
output includes errata (a C<POD ERRORS> section generated with
|
||||
C<--errors=pod>), B<pod2text> will exit with status 0. If any of the
|
||||
documents being processed do not result in an output document, B<pod2text>
|
||||
will exit with status 1. If there are syntax errors in a POD document
|
||||
being processed and the error handling style is set to the default of
|
||||
C<die>, B<pod2text> will abort immediately with exit status 255.
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
If B<pod2text> fails with errors, see L<Pod::Text> and L<Pod::Simple> for
|
||||
information about what those errors might mean. Internally, it can also
|
||||
produce the following diagnostics:
|
||||
|
||||
=over 4
|
||||
|
||||
=item -c (--color) requires Term::ANSIColor be installed
|
||||
|
||||
(F) B<-c> or B<--color> were given, but Term::ANSIColor could not be
|
||||
loaded.
|
||||
|
||||
=item Unknown option: %s
|
||||
|
||||
(F) An unknown command line option was given.
|
||||
|
||||
=back
|
||||
|
||||
In addition, other L<Getopt::Long> error messages may result from invalid
|
||||
command-line options.
|
||||
|
||||
=head1 ENVIRONMENT
|
||||
|
||||
=over 4
|
||||
|
||||
=item COLUMNS
|
||||
|
||||
If B<-t> is given, B<pod2text> will take the current width of your screen
|
||||
from this environment variable, if available. It overrides terminal width
|
||||
information in TERMCAP.
|
||||
|
||||
=item TERMCAP
|
||||
|
||||
If B<-t> is given, B<pod2text> will use the contents of this environment
|
||||
variable if available to determine the correct formatting sequences for your
|
||||
current terminal device.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Russ Allbery <rra@cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 1999-2001, 2004, 2006, 2008, 2010, 2012-2019 Russ Allbery
|
||||
<rra@cpan.org>
|
||||
|
||||
This program is free software; you may redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Text>, L<Pod::Text::Color>, L<Pod::Text::Overstrike>,
|
||||
L<Pod::Text::Termcap>, L<Pod::Simple>, L<perlpod(1)>
|
||||
|
||||
The current version of this script is always available from its web site at
|
||||
L<https://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
|
||||
Perl core distribution as of 5.6.0.
|
||||
|
||||
=cut
|
||||
160
msys2/usr/bin/core_perl/pod2usage
Normal file
160
msys2/usr/bin/core_perl/pod2usage
Normal file
|
|
@ -0,0 +1,160 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec perl -S $0 "$@"'
|
||||
if 0;
|
||||
|
||||
#############################################################################
|
||||
# pod2usage -- command to print usage messages from embedded pod docs
|
||||
#
|
||||
# Copyright (c) 1996-2000 by Bradford Appleton. All rights reserved.
|
||||
# Copyright (c) 2001-2016 by Marek Rouchal.
|
||||
# This file is part of "Pod-Usage". Pod-Usage is free software;
|
||||
# you can redistribute it and/or modify it under the same terms
|
||||
# as Perl itself.
|
||||
#############################################################################
|
||||
|
||||
use strict;
|
||||
#use diagnostics;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
pod2usage - print usage messages from embedded pod docs in files
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
=over 12
|
||||
|
||||
=item B<pod2usage>
|
||||
|
||||
[B<-help>]
|
||||
[B<-man>]
|
||||
[B<-exit>S< >I<exitval>]
|
||||
[B<-output>S< >I<outfile>]
|
||||
[B<-verbose> I<level>]
|
||||
[B<-pathlist> I<dirlist>]
|
||||
[B<-formatter> I<module>]
|
||||
[B<-utf8>]
|
||||
I<file>
|
||||
|
||||
=back
|
||||
|
||||
=head1 OPTIONS AND ARGUMENTS
|
||||
|
||||
=over 8
|
||||
|
||||
=item B<-help>
|
||||
|
||||
Print a brief help message and exit.
|
||||
|
||||
=item B<-man>
|
||||
|
||||
Print this command's manual page and exit.
|
||||
|
||||
=item B<-exit> I<exitval>
|
||||
|
||||
The exit status value to return.
|
||||
|
||||
=item B<-output> I<outfile>
|
||||
|
||||
The output file to print to. If the special names "-" or ">&1" or ">&STDOUT"
|
||||
are used then standard output is used. If ">&2" or ">&STDERR" is used then
|
||||
standard error is used.
|
||||
|
||||
=item B<-verbose> I<level>
|
||||
|
||||
The desired level of verbosity to use:
|
||||
|
||||
1 : print SYNOPSIS only
|
||||
2 : print SYNOPSIS sections and any OPTIONS/ARGUMENTS sections
|
||||
3 : print the entire manpage (similar to running pod2text)
|
||||
|
||||
=item B<-pathlist> I<dirlist>
|
||||
|
||||
Specifies one or more directories to search for the input file if it
|
||||
was not supplied with an absolute path. Each directory path in the given
|
||||
list should be separated by a ':' on Unix (';' on MSWin32 and DOS).
|
||||
|
||||
=item B<-formatter> I<module>
|
||||
|
||||
Which text formatter to use. Default is L<Pod::Text>, or for very old
|
||||
Perl versions L<Pod::PlainText>. An alternative would be e.g.
|
||||
L<Pod::Text::Termcap>.
|
||||
|
||||
=item B<-utf8>
|
||||
|
||||
This option assumes that the formatter (see above) understands the option
|
||||
"utf8". It turns on generation of utf8 output.
|
||||
|
||||
=item I<file>
|
||||
|
||||
The pathname of a file containing pod documentation to be output in
|
||||
usage message format (defaults to standard input).
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<pod2usage> will read the given input file looking for pod
|
||||
documentation and will print the corresponding usage message.
|
||||
If no input file is specified then standard input is read.
|
||||
|
||||
B<pod2usage> invokes the B<pod2usage()> function in the B<Pod::Usage>
|
||||
module. Please see L<Pod::Usage/pod2usage()>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Usage>, L<pod2text(1)>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Please report bugs using L<http://rt.cpan.org>.
|
||||
|
||||
Brad Appleton E<lt>bradapp@enteract.comE<gt>
|
||||
|
||||
Based on code for B<pod2text(1)> written by
|
||||
Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
|
||||
|
||||
=cut
|
||||
|
||||
use Getopt::Long;
|
||||
|
||||
## Define options
|
||||
my %options = ();
|
||||
my @opt_specs = (
|
||||
'help',
|
||||
'man',
|
||||
'exit=i',
|
||||
'output=s',
|
||||
'pathlist=s',
|
||||
'formatter=s',
|
||||
'verbose=i',
|
||||
'utf8!'
|
||||
);
|
||||
|
||||
## Parse options
|
||||
GetOptions(\%options, @opt_specs) || pod2usage(2);
|
||||
$Pod::Usage::Formatter = $options{formatter} if $options{formatter};
|
||||
require Pod::Usage;
|
||||
Pod::Usage->import();
|
||||
pod2usage(1) if ($options{help});
|
||||
pod2usage(VERBOSE => 2) if ($options{man});
|
||||
|
||||
## Dont default to STDIN if connected to a terminal
|
||||
pod2usage(2) if ((@ARGV == 0) && (-t STDIN));
|
||||
|
||||
@ARGV = ('-') unless (@ARGV);
|
||||
if (@ARGV > 1) {
|
||||
print STDERR "pod2usage: Too many filenames given\n\n";
|
||||
pod2usage(2);
|
||||
}
|
||||
|
||||
my %usage = ();
|
||||
$usage{-input} = shift(@ARGV);
|
||||
$usage{-exitval} = $options{'exit'} if (defined $options{'exit'});
|
||||
$usage{-output} = $options{'output'} if (defined $options{'output'});
|
||||
$usage{-verbose} = $options{'verbose'} if (defined $options{'verbose'});
|
||||
$usage{-pathlist} = $options{'pathlist'} if (defined $options{'pathlist'});
|
||||
$usage{-utf8} = $options{'utf8'} if (defined $options{'utf8'});
|
||||
|
||||
pod2usage(\%usage);
|
||||
|
||||
|
||||
144
msys2/usr/bin/core_perl/podchecker
Normal file
144
msys2/usr/bin/core_perl/podchecker
Normal file
|
|
@ -0,0 +1,144 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec perl -S $0 "$@"'
|
||||
if 0;
|
||||
#############################################################################
|
||||
# podchecker -- command to invoke the podchecker function in Pod::Checker
|
||||
#
|
||||
# Copyright (c) 1998-2000 by Bradford Appleton. All rights reserved.
|
||||
# This is free software; you can redistribute it and/or modify it under the
|
||||
# same terms as Perl itself.
|
||||
#############################################################################
|
||||
|
||||
use strict;
|
||||
#use diagnostics;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
podchecker - check the syntax of POD format documentation files
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
B<podchecker> [B<-help>] [B<-man>] [B<-(no)warnings>] [I<file>S< >...]
|
||||
|
||||
=head1 OPTIONS AND ARGUMENTS
|
||||
|
||||
=over 8
|
||||
|
||||
=item B<-help>
|
||||
|
||||
Print a brief help message and exit.
|
||||
|
||||
=item B<-man>
|
||||
|
||||
Print the manual page and exit.
|
||||
|
||||
=item B<-warnings> B<-nowarnings>
|
||||
|
||||
Turn on/off printing of warnings. Repeating B<-warnings> increases the
|
||||
warning level, i.e. more warnings are printed. Currently increasing to
|
||||
level two causes flagging of unescaped "E<lt>,E<gt>" characters.
|
||||
|
||||
=item I<file>
|
||||
|
||||
The pathname of a POD file to syntax-check (defaults to standard input).
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<podchecker> will read the given input files looking for POD
|
||||
syntax errors in the POD documentation and will print any errors
|
||||
it find to STDERR. At the end, it will print a status message
|
||||
indicating the number of errors found.
|
||||
|
||||
Directories are ignored, an appropriate warning message is printed.
|
||||
|
||||
B<podchecker> invokes the B<podchecker()> function exported by B<Pod::Checker>
|
||||
Please see L<Pod::Checker/podchecker()> for more details.
|
||||
|
||||
=head1 RETURN VALUE
|
||||
|
||||
B<podchecker> returns a 0 (zero) exit status if all specified
|
||||
POD files are ok.
|
||||
|
||||
=head1 ERRORS
|
||||
|
||||
B<podchecker> returns the exit status 1 if at least one of
|
||||
the given POD files has syntax errors.
|
||||
|
||||
The status 2 indicates that at least one of the specified
|
||||
files does not contain I<any> POD commands.
|
||||
|
||||
Status 1 overrides status 2. If you want unambiguous
|
||||
results, call B<podchecker> with one single argument only.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple> and L<Pod::Checker>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Please report bugs using L<http://rt.cpan.org>.
|
||||
|
||||
Brad Appleton E<lt>bradapp@enteract.comE<gt>,
|
||||
Marek Rouchal E<lt>marekr@cpan.orgE<gt>
|
||||
|
||||
Based on code for B<Pod::Text::pod2text(1)> written by
|
||||
Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
use Pod::Checker;
|
||||
use Pod::Usage;
|
||||
use Getopt::Long;
|
||||
|
||||
## Define options
|
||||
my %options;
|
||||
|
||||
## Parse options
|
||||
GetOptions(\%options, qw(help man warnings+ nowarnings)) || pod2usage(2);
|
||||
pod2usage(1) if ($options{help});
|
||||
pod2usage(-verbose => 2) if ($options{man});
|
||||
|
||||
if($options{nowarnings}) {
|
||||
$options{warnings} = 0;
|
||||
}
|
||||
elsif(!defined $options{warnings}) {
|
||||
$options{warnings} = 1; # default is warnings on
|
||||
}
|
||||
|
||||
## Dont default to STDIN if connected to a terminal
|
||||
pod2usage(2) if ((@ARGV == 0) && (-t STDIN));
|
||||
|
||||
## Invoke podchecker()
|
||||
my $status = 0;
|
||||
@ARGV = qw(-) unless(@ARGV);
|
||||
for my $podfile (@ARGV) {
|
||||
if($podfile eq '-') {
|
||||
$podfile = '<&STDIN';
|
||||
}
|
||||
elsif(-d $podfile) {
|
||||
warn "podchecker: Warning: Ignoring directory '$podfile'\n";
|
||||
next;
|
||||
}
|
||||
my $errors =
|
||||
podchecker($podfile, undef, '-warnings' => $options{warnings});
|
||||
if($errors > 0) {
|
||||
# errors occurred
|
||||
$status = 1;
|
||||
printf STDERR ("%s has %d pod syntax %s.\n",
|
||||
$podfile, $errors,
|
||||
($errors == 1) ? 'error' : 'errors');
|
||||
}
|
||||
elsif($errors < 0) {
|
||||
# no pod found
|
||||
$status = 2 unless($status);
|
||||
print STDERR "$podfile does not contain any pod commands.\n";
|
||||
}
|
||||
else {
|
||||
print STDERR "$podfile pod syntax OK.\n";
|
||||
}
|
||||
}
|
||||
exit $status;
|
||||
|
||||
410
msys2/usr/bin/core_perl/prove
Normal file
410
msys2/usr/bin/core_perl/prove
Normal file
|
|
@ -0,0 +1,410 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use strict;
|
||||
use warnings;
|
||||
use App::Prove;
|
||||
|
||||
my $app = App::Prove->new;
|
||||
$app->process_args(@ARGV);
|
||||
exit( $app->run ? 0 : 1 );
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
prove - Run tests through a TAP harness.
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
prove [options] [files or directories]
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
Boolean options:
|
||||
|
||||
-v, --verbose Print all test lines.
|
||||
-l, --lib Add 'lib' to the path for your tests (-Ilib).
|
||||
-b, --blib Add 'blib/lib' and 'blib/arch' to the path for
|
||||
your tests
|
||||
-s, --shuffle Run the tests in random order.
|
||||
-c, --color Colored test output (default).
|
||||
--nocolor Do not color test output.
|
||||
--count Show the X/Y test count when not verbose
|
||||
(default)
|
||||
--nocount Disable the X/Y test count.
|
||||
-D --dry Dry run. Show test that would have run.
|
||||
-f, --failures Show failed tests.
|
||||
-o, --comments Show comments.
|
||||
--ignore-exit Ignore exit status from test scripts.
|
||||
-m, --merge Merge test scripts' STDERR with their STDOUT.
|
||||
-r, --recurse Recursively descend into directories.
|
||||
--reverse Run the tests in reverse order.
|
||||
-q, --quiet Suppress some test output while running tests.
|
||||
-Q, --QUIET Only print summary results.
|
||||
-p, --parse Show full list of TAP parse errors, if any.
|
||||
--directives Only show results with TODO or SKIP directives.
|
||||
--timer Print elapsed time after each test.
|
||||
--trap Trap Ctrl-C and print summary on interrupt.
|
||||
--normalize Normalize TAP output in verbose output
|
||||
-T Enable tainting checks.
|
||||
-t Enable tainting warnings.
|
||||
-W Enable fatal warnings.
|
||||
-w Enable warnings.
|
||||
-h, --help Display this help
|
||||
-?, Display this help
|
||||
-V, --version Display the version
|
||||
-H, --man Longer manpage for prove
|
||||
--norc Don't process default .proverc
|
||||
|
||||
Options that take arguments:
|
||||
|
||||
-I Library paths to include.
|
||||
-P Load plugin (searches App::Prove::Plugin::*.)
|
||||
-M Load a module.
|
||||
-e, --exec Interpreter to run the tests ('' for compiled
|
||||
tests.)
|
||||
--ext Set the extension for tests (default '.t')
|
||||
--harness Define test harness to use. See TAP::Harness.
|
||||
--formatter Result formatter to use. See FORMATTERS.
|
||||
--source Load and/or configure a SourceHandler. See
|
||||
SOURCE HANDLERS.
|
||||
-a, --archive out.tgz Store the resulting TAP in an archive file.
|
||||
-j, --jobs N Run N test jobs in parallel (try 9.)
|
||||
--state=opts Control prove's persistent state.
|
||||
--statefile=file Use `file` instead of `.prove` for state
|
||||
--rc=rcfile Process options from rcfile
|
||||
--rules Rules for parallel vs sequential processing.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
=head2 .proverc
|
||||
|
||||
If F<~/.proverc> or F<./.proverc> exist they will be read and any
|
||||
options they contain processed before the command line options. Options
|
||||
in F<.proverc> are specified in the same way as command line options:
|
||||
|
||||
# .proverc
|
||||
--state=hot,fast,save
|
||||
-j9
|
||||
|
||||
Additional option files may be specified with the C<--rc> option.
|
||||
Default option file processing is disabled by the C<--norc> option.
|
||||
|
||||
Under Windows and VMS the option file is named F<_proverc> rather than
|
||||
F<.proverc> and is sought only in the current directory.
|
||||
|
||||
=head2 Reading from C<STDIN>
|
||||
|
||||
If you have a list of tests (or URLs, or anything else you want to test) in a
|
||||
file, you can add them to your tests by using a '-':
|
||||
|
||||
prove - < my_list_of_things_to_test.txt
|
||||
|
||||
See the C<README> in the C<examples> directory of this distribution.
|
||||
|
||||
=head2 Default Test Directory
|
||||
|
||||
If no files or directories are supplied, C<prove> looks for all files
|
||||
matching the pattern C<t/*.t>.
|
||||
|
||||
=head2 Colored Test Output
|
||||
|
||||
Colored test output using L<TAP::Formatter::Color> is the default, but
|
||||
if output is not to a terminal, color is disabled. You can override this by
|
||||
adding the C<--color> switch.
|
||||
|
||||
Color support requires L<Term::ANSIColor> and, on windows platforms, also
|
||||
L<Win32::Console::ANSI>. If the necessary module(s) are not installed
|
||||
colored output will not be available.
|
||||
|
||||
=head2 Exit Code
|
||||
|
||||
If the tests fail C<prove> will exit with non-zero status.
|
||||
|
||||
=head2 Arguments to Tests
|
||||
|
||||
It is possible to supply arguments to tests. To do so separate them from
|
||||
prove's own arguments with the arisdottle, '::'. For example
|
||||
|
||||
prove -v t/mytest.t :: --url http://example.com
|
||||
|
||||
would run F<t/mytest.t> with the options '--url http://example.com'.
|
||||
When running multiple tests they will each receive the same arguments.
|
||||
|
||||
=head2 C<--exec>
|
||||
|
||||
Normally you can just pass a list of Perl tests and the harness will know how
|
||||
to execute them. However, if your tests are not written in Perl or if you
|
||||
want all tests invoked exactly the same way, use the C<-e>, or C<--exec>
|
||||
switch:
|
||||
|
||||
prove --exec '/usr/bin/ruby -w' t/
|
||||
prove --exec '/usr/bin/perl -Tw -mstrict -Ilib' t/
|
||||
prove --exec '/path/to/my/customer/exec'
|
||||
|
||||
=head2 C<--merge>
|
||||
|
||||
If you need to make sure your diagnostics are displayed in the correct
|
||||
order relative to test results you can use the C<--merge> option to
|
||||
merge the test scripts' STDERR into their STDOUT.
|
||||
|
||||
This guarantees that STDOUT (where the test results appear) and STDERR
|
||||
(where the diagnostics appear) will stay in sync. The harness will
|
||||
display any diagnostics your tests emit on STDERR.
|
||||
|
||||
Caveat: this is a bit of a kludge. In particular note that if anything
|
||||
that appears on STDERR looks like a test result the test harness will
|
||||
get confused. Use this option only if you understand the consequences
|
||||
and can live with the risk.
|
||||
|
||||
=head2 C<--trap>
|
||||
|
||||
The C<--trap> option will attempt to trap SIGINT (Ctrl-C) during a test
|
||||
run and display the test summary even if the run is interrupted
|
||||
|
||||
=head2 C<--state>
|
||||
|
||||
You can ask C<prove> to remember the state of previous test runs and
|
||||
select and/or order the tests to be run based on that saved state.
|
||||
|
||||
The C<--state> switch requires an argument which must be a comma
|
||||
separated list of one or more of the following options.
|
||||
|
||||
=over
|
||||
|
||||
=item C<last>
|
||||
|
||||
Run the same tests as the last time the state was saved. This makes it
|
||||
possible, for example, to recreate the ordering of a shuffled test.
|
||||
|
||||
# Run all tests in random order
|
||||
$ prove -b --state=save --shuffle
|
||||
|
||||
# Run them again in the same order
|
||||
$ prove -b --state=last
|
||||
|
||||
=item C<failed>
|
||||
|
||||
Run only the tests that failed on the last run.
|
||||
|
||||
# Run all tests
|
||||
$ prove -b --state=save
|
||||
|
||||
# Run failures
|
||||
$ prove -b --state=failed
|
||||
|
||||
If you also specify the C<save> option newly passing tests will be
|
||||
excluded from subsequent runs.
|
||||
|
||||
# Repeat until no more failures
|
||||
$ prove -b --state=failed,save
|
||||
|
||||
=item C<passed>
|
||||
|
||||
Run only the passed tests from last time. Useful to make sure that no
|
||||
new problems have been introduced.
|
||||
|
||||
=item C<all>
|
||||
|
||||
Run all tests in normal order. Multple options may be specified, so to
|
||||
run all tests with the failures from last time first:
|
||||
|
||||
$ prove -b --state=failed,all,save
|
||||
|
||||
=item C<hot>
|
||||
|
||||
Run the tests that most recently failed first. The last failure time of
|
||||
each test is stored. The C<hot> option causes tests to be run in most-recent-
|
||||
failure order.
|
||||
|
||||
$ prove -b --state=hot,save
|
||||
|
||||
Tests that have never failed will not be selected. To run all tests with
|
||||
the most recently failed first use
|
||||
|
||||
$ prove -b --state=hot,all,save
|
||||
|
||||
This combination of options may also be specified thus
|
||||
|
||||
$ prove -b --state=adrian
|
||||
|
||||
=item C<todo>
|
||||
|
||||
Run any tests with todos.
|
||||
|
||||
=item C<slow>
|
||||
|
||||
Run the tests in slowest to fastest order. This is useful in conjunction
|
||||
with the C<-j> parallel testing switch to ensure that your slowest tests
|
||||
start running first.
|
||||
|
||||
$ prove -b --state=slow -j9
|
||||
|
||||
=item C<fast>
|
||||
|
||||
Run test tests in fastest to slowest order.
|
||||
|
||||
=item C<new>
|
||||
|
||||
Run the tests in newest to oldest order based on the modification times
|
||||
of the test scripts.
|
||||
|
||||
=item C<old>
|
||||
|
||||
Run the tests in oldest to newest order.
|
||||
|
||||
=item C<fresh>
|
||||
|
||||
Run those test scripts that have been modified since the last test run.
|
||||
|
||||
=item C<save>
|
||||
|
||||
Save the state on exit. The state is stored in a file called F<.prove>
|
||||
(F<_prove> on Windows and VMS) in the current directory.
|
||||
|
||||
=back
|
||||
|
||||
The C<--state> switch may be used more than once.
|
||||
|
||||
$ prove -b --state=hot --state=all,save
|
||||
|
||||
=head2 --rules
|
||||
|
||||
The C<--rules> option is used to control which tests are run sequentially and
|
||||
which are run in parallel, if the C<--jobs> option is specified. The option may
|
||||
be specified multiple times, and the order matters.
|
||||
|
||||
The most practical use is likely to specify that some tests are not
|
||||
"parallel-ready". Since mentioning a file with --rules doesn't cause it to
|
||||
be selected to run as a test, you can "set and forget" some rules preferences in
|
||||
your .proverc file. Then you'll be able to take maximum advantage of the
|
||||
performance benefits of parallel testing, while some exceptions are still run
|
||||
in parallel.
|
||||
|
||||
=head3 --rules examples
|
||||
|
||||
# All tests are allowed to run in parallel, except those starting with "p"
|
||||
--rules='seq=t/p*.t' --rules='par=**'
|
||||
|
||||
# All tests must run in sequence except those starting with "p", which should be run parallel
|
||||
--rules='par=t/p*.t'
|
||||
|
||||
=head3 --rules resolution
|
||||
|
||||
=over 4
|
||||
|
||||
=item * By default, all tests are eligible to be run in parallel. Specifying any of your own rules removes this one.
|
||||
|
||||
=item * "First match wins". The first rule that matches a test will be the one that applies.
|
||||
|
||||
=item * Any test which does not match a rule will be run in sequence at the end of the run.
|
||||
|
||||
=item * The existence of a rule does not imply selecting a test. You must still specify the tests to run.
|
||||
|
||||
=item * Specifying a rule to allow tests to run in parallel does not make them run in parallel. You still need specify the number of parallel C<jobs> in your Harness object.
|
||||
|
||||
=back
|
||||
|
||||
=head3 --rules Glob-style pattern matching
|
||||
|
||||
We implement our own glob-style pattern matching for --rules. Here are the
|
||||
supported patterns:
|
||||
|
||||
** is any number of characters, including /, within a pathname
|
||||
* is zero or more characters within a filename/directory name
|
||||
? is exactly one character within a filename/directory name
|
||||
{foo,bar,baz} is any of foo, bar or baz.
|
||||
\ is an escape character
|
||||
|
||||
=head3 More advanced specifications for parallel vs sequence run rules
|
||||
|
||||
If you need more advanced management of what runs in parallel vs in sequence, see
|
||||
the associated 'rules' documentation in L<TAP::Harness> and L<TAP::Parser::Scheduler>.
|
||||
If what's possible directly through C<prove> is not sufficient, you can write your own
|
||||
harness to access these features directly.
|
||||
|
||||
=head2 @INC
|
||||
|
||||
prove introduces a separation between "options passed to the perl which
|
||||
runs prove" and "options passed to the perl which runs tests"; this
|
||||
distinction is by design. Thus the perl which is running a test starts
|
||||
with the default C<@INC>. Additional library directories can be added
|
||||
via the C<PERL5LIB> environment variable, via -Ifoo in C<PERL5OPT> or
|
||||
via the C<-Ilib> option to F<prove>.
|
||||
|
||||
=head2 Taint Mode
|
||||
|
||||
Normally when a Perl program is run in taint mode the contents of the
|
||||
C<PERL5LIB> environment variable do not appear in C<@INC>.
|
||||
|
||||
Because C<PERL5LIB> is often used during testing to add build
|
||||
directories to C<@INC> prove passes the names of any directories found
|
||||
in C<PERL5LIB> as -I switches. The net effect of this is that
|
||||
C<PERL5LIB> is honoured even when prove is run in taint mode.
|
||||
|
||||
|
||||
=head1 FORMATTERS
|
||||
|
||||
You can load a custom L<TAP::Parser::Formatter>:
|
||||
|
||||
prove --formatter MyFormatter
|
||||
|
||||
=head1 SOURCE HANDLERS
|
||||
|
||||
You can load custom L<TAP::Parser::SourceHandler>s, to change the way the
|
||||
parser interprets particular I<sources> of TAP.
|
||||
|
||||
prove --source MyHandler --source YetAnother t
|
||||
|
||||
If you want to provide config to the source you can use:
|
||||
|
||||
prove --source MyCustom \
|
||||
--source Perl --perl-option 'foo=bar baz' --perl-option avg=0.278 \
|
||||
--source File --file-option extensions=.txt --file-option extensions=.tmp t
|
||||
--source pgTAP --pgtap-option pset=format=html --pgtap-option pset=border=2
|
||||
|
||||
Each C<--$source-option> option must specify a key/value pair separated by an
|
||||
C<=>. If an option can take multiple values, just specify it multiple times,
|
||||
as with the C<extensions=> examples above. If the option should be a hash
|
||||
reference, specify the value as a second pair separated by a C<=>, as in the
|
||||
C<pset=> examples above (escape C<=> with a backslash).
|
||||
|
||||
All C<--sources> are combined into a hash, and passed to L<TAP::Harness/new>'s
|
||||
C<sources> parameter.
|
||||
|
||||
See L<TAP::Parser::IteratorFactory> for more details on how configuration is
|
||||
passed to I<SourceHandlers>.
|
||||
|
||||
=head1 PLUGINS
|
||||
|
||||
Plugins can be loaded using the C<< -PI<plugin> >> syntax, eg:
|
||||
|
||||
prove -PMyPlugin
|
||||
|
||||
This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
|
||||
that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit.
|
||||
|
||||
You can pass arguments to your plugin by appending C<=arg1,arg2,etc> to the
|
||||
plugin name:
|
||||
|
||||
prove -PMyPlugin=fou,du,fafa
|
||||
|
||||
Please check individual plugin documentation for more details.
|
||||
|
||||
=head2 Available Plugins
|
||||
|
||||
For an up-to-date list of plugins available, please check CPAN:
|
||||
|
||||
L<http://search.cpan.org/search?query=App%3A%3AProve+Plugin>
|
||||
|
||||
=head2 Writing Plugins
|
||||
|
||||
Please see L<App::Prove/PLUGINS>.
|
||||
|
||||
=cut
|
||||
|
||||
# vim:ts=4:sw=4:et:sta
|
||||
142
msys2/usr/bin/core_perl/ptar
Normal file
142
msys2/usr/bin/core_perl/ptar
Normal file
|
|
@ -0,0 +1,142 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!/usr/bin/perl
|
||||
use strict;
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use File::Find;
|
||||
use Getopt::Std;
|
||||
use Archive::Tar;
|
||||
use Data::Dumper;
|
||||
|
||||
# Allow historic support for dashless bundled options
|
||||
# tar cvf file.tar
|
||||
# is valid (GNU) tar style
|
||||
@ARGV && $ARGV[0] =~ m/^[DdcvzthxIC]+[fT]?$/ and
|
||||
unshift @ARGV, map { "-$_" } split m// => shift @ARGV;
|
||||
my $opts = {};
|
||||
getopts('Ddcvzthxf:ICT:', $opts) or die usage();
|
||||
|
||||
### show the help message ###
|
||||
die usage() if $opts->{h};
|
||||
|
||||
### enable debugging (undocumented feature)
|
||||
local $Archive::Tar::DEBUG = 1 if $opts->{d};
|
||||
|
||||
### enable insecure extracting.
|
||||
local $Archive::Tar::INSECURE_EXTRACT_MODE = 1 if $opts->{I};
|
||||
|
||||
### sanity checks ###
|
||||
unless ( 1 == grep { defined $opts->{$_} } qw[x t c] ) {
|
||||
die "You need exactly one of 'x', 't' or 'c' options: " . usage();
|
||||
}
|
||||
|
||||
my $compress = $opts->{z} ? 1 : 0;
|
||||
my $verbose = $opts->{v} ? 1 : 0;
|
||||
my $file = $opts->{f} ? $opts->{f} : 'default.tar';
|
||||
my $tar = Archive::Tar->new();
|
||||
|
||||
if( $opts->{c} ) {
|
||||
my @files;
|
||||
my @src = @ARGV;
|
||||
if( $opts->{T} ) {
|
||||
if( $opts->{T} eq "-" ) {
|
||||
chomp( @src = <STDIN> );
|
||||
} elsif( open my $fh, "<", $opts->{T} ) {
|
||||
chomp( @src = <$fh> );
|
||||
} else {
|
||||
die "$0: $opts->{T}: $!\n";
|
||||
}
|
||||
}
|
||||
|
||||
find( sub { push @files, $File::Find::name;
|
||||
print $File::Find::name.$/ if $verbose }, @src );
|
||||
|
||||
if ($file eq '-') {
|
||||
use IO::Handle;
|
||||
$file = IO::Handle->new();
|
||||
$file->fdopen(fileno(STDOUT),"w");
|
||||
}
|
||||
|
||||
my $tar = Archive::Tar->new;
|
||||
$tar->add_files(@files);
|
||||
if( $opts->{C} ) {
|
||||
for my $f ($tar->get_files) {
|
||||
$f->mode($f->mode & ~022); # chmod go-w
|
||||
}
|
||||
}
|
||||
$tar->write($file, $compress);
|
||||
} else {
|
||||
if ($file eq '-') {
|
||||
use IO::Handle;
|
||||
$file = IO::Handle->new();
|
||||
$file->fdopen(fileno(STDIN),"r");
|
||||
}
|
||||
|
||||
### print the files we're finding?
|
||||
my $print = $verbose || $opts->{'t'} || 0;
|
||||
|
||||
my $iter = Archive::Tar->iter( $file );
|
||||
|
||||
while( my $f = $iter->() ) {
|
||||
print $f->full_path . $/ if $print;
|
||||
|
||||
### data dumper output
|
||||
print Dumper( $f ) if $opts->{'D'};
|
||||
|
||||
### extract it
|
||||
$f->extract if $opts->{'x'};
|
||||
}
|
||||
}
|
||||
|
||||
### pod & usage in one
|
||||
sub usage {
|
||||
my $usage .= << '=cut';
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
ptar - a tar-like program written in perl
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
ptar is a small, tar look-alike program that uses the perl module
|
||||
Archive::Tar to extract, create and list tar archives.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
ptar -c [-v] [-z] [-C] [-f ARCHIVE_FILE | -] FILE FILE ...
|
||||
ptar -c [-v] [-z] [-C] [-T index | -] [-f ARCHIVE_FILE | -]
|
||||
ptar -x [-v] [-z] [-f ARCHIVE_FILE | -]
|
||||
ptar -t [-z] [-f ARCHIVE_FILE | -]
|
||||
ptar -h
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
c Create ARCHIVE_FILE or STDOUT (-) from FILE
|
||||
x Extract from ARCHIVE_FILE or STDIN (-)
|
||||
t List the contents of ARCHIVE_FILE or STDIN (-)
|
||||
f Name of the ARCHIVE_FILE to use. Default is './default.tar'
|
||||
z Read/Write zlib compressed ARCHIVE_FILE (not always available)
|
||||
v Print filenames as they are added or extracted from ARCHIVE_FILE
|
||||
h Prints this help message
|
||||
C CPAN mode - drop 022 from permissions
|
||||
T get names to create from file
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<tar(1)>, L<Archive::Tar>.
|
||||
|
||||
=cut
|
||||
|
||||
### strip the pod directives
|
||||
$usage =~ s/=pod\n//g;
|
||||
$usage =~ s/=head1 //g;
|
||||
|
||||
### add some newlines
|
||||
$usage .= $/.$/;
|
||||
|
||||
return $usage;
|
||||
}
|
||||
|
||||
120
msys2/usr/bin/core_perl/ptardiff
Normal file
120
msys2/usr/bin/core_perl/ptardiff
Normal file
|
|
@ -0,0 +1,120 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!/usr/bin/perl
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use strict;
|
||||
use Archive::Tar;
|
||||
use Getopt::Std;
|
||||
|
||||
my $opts = {};
|
||||
getopts('h:', $opts) or die usage();
|
||||
|
||||
die usages() if $opts->{h};
|
||||
|
||||
### need Text::Diff -- give a polite error (not a standard prereq)
|
||||
unless ( eval { require Text::Diff; Text::Diff->import; 1 } ) {
|
||||
die "\n\t This tool requires the 'Text::Diff' module to be installed\n";
|
||||
}
|
||||
|
||||
my $arch = shift or die usage();
|
||||
my $tar = Archive::Tar->new( $arch ) or die "Couldn't read '$arch': $!";
|
||||
|
||||
|
||||
foreach my $file ( $tar->get_files ) {
|
||||
next unless $file->is_file;
|
||||
my $prefix = $file->prefix;
|
||||
my $name = $file->name;
|
||||
if (defined $prefix) {
|
||||
$name = File::Spec->catfile($prefix, $name);
|
||||
}
|
||||
|
||||
diff( \($file->get_content), $name,
|
||||
{ FILENAME_A => $name,
|
||||
MTIME_A => $file->mtime,
|
||||
OUTPUT => \*STDOUT
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
sub usage {
|
||||
return q[
|
||||
|
||||
Usage: ptardiff ARCHIVE_FILE
|
||||
ptardiff -h
|
||||
|
||||
ptardiff is a small program that diffs an extracted archive
|
||||
against an unextracted one, using the perl module Archive::Tar.
|
||||
|
||||
This effectively lets you view changes made to an archives contents.
|
||||
|
||||
Provide the progam with an ARCHIVE_FILE and it will look up all
|
||||
the files with in the archive, scan the current working directory
|
||||
for a file with the name and diff it against the contents of the
|
||||
archive.
|
||||
|
||||
|
||||
Options:
|
||||
h Prints this help message
|
||||
|
||||
|
||||
Sample Usage:
|
||||
|
||||
$ tar -xzf Acme-Buffy-1.3.tar.gz
|
||||
$ vi Acme-Buffy-1.3/README
|
||||
|
||||
[...]
|
||||
|
||||
$ ptardiff Acme-Buffy-1.3.tar.gz > README.patch
|
||||
|
||||
|
||||
See Also:
|
||||
tar(1)
|
||||
ptar
|
||||
Archive::Tar
|
||||
|
||||
] . $/;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
ptardiff - program that diffs an extracted archive against an unextracted one
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
ptardiff is a small program that diffs an extracted archive
|
||||
against an unextracted one, using the perl module Archive::Tar.
|
||||
|
||||
This effectively lets you view changes made to an archives contents.
|
||||
|
||||
Provide the progam with an ARCHIVE_FILE and it will look up all
|
||||
the files with in the archive, scan the current working directory
|
||||
for a file with the name and diff it against the contents of the
|
||||
archive.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
ptardiff ARCHIVE_FILE
|
||||
ptardiff -h
|
||||
|
||||
$ tar -xzf Acme-Buffy-1.3.tar.gz
|
||||
$ vi Acme-Buffy-1.3/README
|
||||
[...]
|
||||
$ ptardiff Acme-Buffy-1.3.tar.gz > README.patch
|
||||
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
h Prints this help message
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
tar(1), L<Archive::Tar>.
|
||||
|
||||
=cut
|
||||
196
msys2/usr/bin/core_perl/ptargrep
Normal file
196
msys2/usr/bin/core_perl/ptargrep
Normal file
|
|
@ -0,0 +1,196 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!/usr/bin/perl
|
||||
##############################################################################
|
||||
# Tool for using regular expressions against the contents of files in a tar
|
||||
# archive. See 'ptargrep --help' for more documentation.
|
||||
#
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Pod::Usage qw(pod2usage);
|
||||
use Getopt::Long qw(GetOptions);
|
||||
use Archive::Tar qw();
|
||||
use File::Path qw(mkpath);
|
||||
|
||||
my(%opt, $pattern);
|
||||
|
||||
if(!GetOptions(\%opt,
|
||||
'basename|b',
|
||||
'ignore-case|i',
|
||||
'list-only|l',
|
||||
'verbose|v',
|
||||
'help|?',
|
||||
)) {
|
||||
pod2usage(-exitval => 1, -verbose => 0);
|
||||
}
|
||||
|
||||
|
||||
pod2usage(-exitstatus => 0, -verbose => 2) if $opt{help};
|
||||
|
||||
pod2usage(-exitval => 1, -verbose => 0,
|
||||
-message => "No pattern specified",
|
||||
) unless @ARGV;
|
||||
make_pattern( shift(@ARGV) );
|
||||
|
||||
pod2usage(-exitval => 1, -verbose => 0,
|
||||
-message => "No tar files specified",
|
||||
) unless @ARGV;
|
||||
|
||||
process_archive($_) foreach @ARGV;
|
||||
|
||||
exit 0;
|
||||
|
||||
|
||||
sub make_pattern {
|
||||
my($pat) = @_;
|
||||
|
||||
if($opt{'ignore-case'}) {
|
||||
$pattern = qr{(?im)$pat};
|
||||
}
|
||||
else {
|
||||
$pattern = qr{(?m)$pat};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub process_archive {
|
||||
my($filename) = @_;
|
||||
|
||||
_log("Processing archive: $filename");
|
||||
my $next = Archive::Tar->iter($filename);
|
||||
while( my $f = $next->() ) {
|
||||
next unless $f->is_file;
|
||||
match_file($f) if $f->size > 0;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub match_file {
|
||||
my($f) = @_;
|
||||
my $path = $f->name;
|
||||
my $prefix = $f->prefix;
|
||||
if (defined $prefix) {
|
||||
$path = File::Spec->catfile($prefix, $path);
|
||||
}
|
||||
|
||||
_log("filename: %s (%d bytes)", $path, $f->size);
|
||||
|
||||
my $body = $f->get_content();
|
||||
if($body !~ $pattern) {
|
||||
_log(" no match");
|
||||
return;
|
||||
}
|
||||
|
||||
if($opt{'list-only'}) {
|
||||
print $path, "\n";
|
||||
return;
|
||||
}
|
||||
|
||||
save_file($path, $body);
|
||||
}
|
||||
|
||||
|
||||
sub save_file {
|
||||
my($path, $body) = @_;
|
||||
|
||||
_log(" found match - extracting");
|
||||
my($fh);
|
||||
my($dir, $file) = $path =~ m{\A(?:(.*)/)?([^/]+)\z};
|
||||
if($dir and not $opt{basename}) {
|
||||
_log(" writing to $dir/$file");
|
||||
$dir =~ s{\A/}{./};
|
||||
mkpath($dir) unless -d $dir;
|
||||
open $fh, '>', "$dir/$file" or die "open($dir/$file): $!";
|
||||
}
|
||||
else {
|
||||
_log(" writing to ./$file");
|
||||
open $fh, '>', $file or die "open($file): $!";
|
||||
}
|
||||
print $fh $body;
|
||||
close($fh);
|
||||
}
|
||||
|
||||
|
||||
sub _log {
|
||||
return unless $opt{verbose};
|
||||
my($format, @args) = @_;
|
||||
warn sprintf($format, @args) . "\n";
|
||||
}
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
ptargrep - Apply pattern matching to the contents of files in a tar archive
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
ptargrep [options] <pattern> <tar file> ...
|
||||
|
||||
Options:
|
||||
|
||||
--basename|-b ignore directory paths from archive
|
||||
--ignore-case|-i do case-insensitive pattern matching
|
||||
--list-only|-l list matching filenames rather than extracting matches
|
||||
--verbose|-v write debugging message to STDERR
|
||||
--help|-? detailed help message
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This utility allows you to apply pattern matching to B<the contents> of files
|
||||
contained in a tar archive. You might use this to identify all files in an
|
||||
archive which contain lines matching the specified pattern and either print out
|
||||
the pathnames or extract the files.
|
||||
|
||||
The pattern will be used as a Perl regular expression (as opposed to a simple
|
||||
grep regex).
|
||||
|
||||
Multiple tar archive filenames can be specified - they will each be processed
|
||||
in turn.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<--basename> (alias -b)
|
||||
|
||||
When matching files are extracted, ignore the directory path from the archive
|
||||
and write to the current directory using the basename of the file from the
|
||||
archive. Beware: if two matching files in the archive have the same basename,
|
||||
the second file extracted will overwrite the first.
|
||||
|
||||
=item B<--ignore-case> (alias -i)
|
||||
|
||||
Make pattern matching case-insensitive.
|
||||
|
||||
=item B<--list-only> (alias -l)
|
||||
|
||||
Print the pathname of each matching file from the archive to STDOUT. Without
|
||||
this option, the default behaviour is to extract each matching file.
|
||||
|
||||
=item B<--verbose> (alias -v)
|
||||
|
||||
Log debugging info to STDERR.
|
||||
|
||||
=item B<--help> (alias -?)
|
||||
|
||||
Display this documentation.
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2010 Grant McLean E<lt>grantm@cpan.orgE<gt>
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
340
msys2/usr/bin/core_perl/shasum
Normal file
340
msys2/usr/bin/core_perl/shasum
Normal file
|
|
@ -0,0 +1,340 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!perl
|
||||
|
||||
## shasum: filter for computing SHA digests (ref. sha1sum/md5sum)
|
||||
##
|
||||
## Copyright (C) 2003-2018 Mark Shelor, All Rights Reserved
|
||||
##
|
||||
## Version: 6.02
|
||||
## Fri Apr 20 16:25:30 MST 2018
|
||||
|
||||
## shasum SYNOPSIS adapted from GNU Coreutils sha1sum. Add
|
||||
## "-a" option for algorithm selection,
|
||||
## "-U" option for Universal Newlines support, and
|
||||
## "-0" option for reading bit strings.
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Fcntl;
|
||||
use Getopt::Long;
|
||||
use Digest::SHA qw($errmsg);
|
||||
|
||||
my $POD = <<'END_OF_POD';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
shasum - Print or Check SHA Checksums
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Usage: shasum [OPTION]... [FILE]...
|
||||
Print or check SHA checksums.
|
||||
With no FILE, or when FILE is -, read standard input.
|
||||
|
||||
-a, --algorithm 1 (default), 224, 256, 384, 512, 512224, 512256
|
||||
-b, --binary read in binary mode
|
||||
-c, --check read SHA sums from the FILEs and check them
|
||||
--tag create a BSD-style checksum
|
||||
-t, --text read in text mode (default)
|
||||
-U, --UNIVERSAL read in Universal Newlines mode
|
||||
produces same digest on Windows/Unix/Mac
|
||||
-0, --01 read in BITS mode
|
||||
ASCII '0' interpreted as 0-bit,
|
||||
ASCII '1' interpreted as 1-bit,
|
||||
all other characters ignored
|
||||
|
||||
The following five options are useful only when verifying checksums:
|
||||
--ignore-missing don't fail or report status for missing files
|
||||
-q, --quiet don't print OK for each successfully verified file
|
||||
-s, --status don't output anything, status code shows success
|
||||
--strict exit non-zero for improperly formatted checksum lines
|
||||
-w, --warn warn about improperly formatted checksum lines
|
||||
|
||||
-h, --help display this help and exit
|
||||
-v, --version output version information and exit
|
||||
|
||||
When verifying SHA-512/224 or SHA-512/256 checksums, indicate the
|
||||
algorithm explicitly using the -a option, e.g.
|
||||
|
||||
shasum -a 512224 -c checksumfile
|
||||
|
||||
The sums are computed as described in FIPS PUB 180-4. When checking,
|
||||
the input should be a former output of this program. The default
|
||||
mode is to print a line with checksum, a character indicating type
|
||||
(`*' for binary, ` ' for text, `U' for UNIVERSAL, `^' for BITS),
|
||||
and name for each FILE. The line starts with a `\' character if the
|
||||
FILE name contains either newlines or backslashes, which are then
|
||||
replaced by the two-character sequences `\n' and `\\' respectively.
|
||||
|
||||
Report shasum bugs to mshelor@cpan.org
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Running I<shasum> is often the quickest way to compute SHA message
|
||||
digests. The user simply feeds data to the script through files or
|
||||
standard input, and then collects the results from standard output.
|
||||
|
||||
The following command shows how to compute digests for typical inputs
|
||||
such as the NIST test vector "abc":
|
||||
|
||||
perl -e "print qq(abc)" | shasum
|
||||
|
||||
Or, if you want to use SHA-256 instead of the default SHA-1, simply say:
|
||||
|
||||
perl -e "print qq(abc)" | shasum -a 256
|
||||
|
||||
Since I<shasum> mimics the behavior of the combined GNU I<sha1sum>,
|
||||
I<sha224sum>, I<sha256sum>, I<sha384sum>, and I<sha512sum> programs,
|
||||
you can install this script as a convenient drop-in replacement.
|
||||
|
||||
Unlike the GNU programs, I<shasum> encompasses the full SHA standard by
|
||||
allowing partial-byte inputs. This is accomplished through the BITS
|
||||
option (I<-0>). The following example computes the SHA-224 digest of
|
||||
the 7-bit message I<0001100>:
|
||||
|
||||
perl -e "print qq(0001100)" | shasum -0 -a 224
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Copyright (C) 2003-2018 Mark Shelor <mshelor@cpan.org>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
I<shasum> is implemented using the Perl module L<Digest::SHA>.
|
||||
|
||||
=cut
|
||||
|
||||
END_OF_POD
|
||||
|
||||
my $VERSION = "6.02";
|
||||
|
||||
sub usage {
|
||||
my($err, $msg) = @_;
|
||||
|
||||
$msg = "" unless defined $msg;
|
||||
if ($err) {
|
||||
warn($msg . "Type shasum -h for help\n");
|
||||
exit($err);
|
||||
}
|
||||
my($USAGE) = $POD =~ /SYNOPSIS(.+?)^=/sm;
|
||||
$USAGE =~ s/^\s*//;
|
||||
$USAGE =~ s/\s*$//;
|
||||
$USAGE =~ s/^ //gm;
|
||||
print $USAGE, "\n";
|
||||
exit($err);
|
||||
}
|
||||
|
||||
|
||||
## Sync stdout and stderr by forcing a flush after every write
|
||||
|
||||
select((select(STDOUT), $| = 1)[0]);
|
||||
select((select(STDERR), $| = 1)[0]);
|
||||
|
||||
|
||||
## Collect options from command line
|
||||
|
||||
my ($alg, $binary, $check, $text, $status, $quiet, $warn, $help);
|
||||
my ($version, $BITS, $UNIVERSAL, $tag, $strict, $ignore_missing);
|
||||
|
||||
eval { Getopt::Long::Configure ("bundling") };
|
||||
GetOptions(
|
||||
'b|binary' => \$binary, 'c|check' => \$check,
|
||||
't|text' => \$text, 'a|algorithm=i' => \$alg,
|
||||
's|status' => \$status, 'w|warn' => \$warn,
|
||||
'q|quiet' => \$quiet,
|
||||
'h|help' => \$help, 'v|version' => \$version,
|
||||
'0|01' => \$BITS,
|
||||
'U|UNIVERSAL' => \$UNIVERSAL,
|
||||
'tag' => \$tag,
|
||||
'strict' => \$strict,
|
||||
'ignore-missing' => \$ignore_missing,
|
||||
) or usage(1, "");
|
||||
|
||||
|
||||
## Deal with help requests and incorrect uses
|
||||
|
||||
usage(0)
|
||||
if $help;
|
||||
usage(1, "shasum: Ambiguous file mode\n")
|
||||
if scalar(grep {defined $_}
|
||||
($binary, $text, $BITS, $UNIVERSAL)) > 1;
|
||||
usage(1, "shasum: --warn option used only when verifying checksums\n")
|
||||
if $warn && !$check;
|
||||
usage(1, "shasum: --status option used only when verifying checksums\n")
|
||||
if $status && !$check;
|
||||
usage(1, "shasum: --quiet option used only when verifying checksums\n")
|
||||
if $quiet && !$check;
|
||||
usage(1, "shasum: --ignore-missing option used only when verifying checksums\n")
|
||||
if $ignore_missing && !$check;
|
||||
usage(1, "shasum: --strict option used only when verifying checksums\n")
|
||||
if $strict && !$check;
|
||||
usage(1, "shasum: --tag does not support --text mode\n")
|
||||
if $tag && $text;
|
||||
usage(1, "shasum: --tag does not support Universal Newlines mode\n")
|
||||
if $tag && $UNIVERSAL;
|
||||
usage(1, "shasum: --tag does not support BITS mode\n")
|
||||
if $tag && $BITS;
|
||||
|
||||
|
||||
## Default to SHA-1 unless overridden by command line option
|
||||
|
||||
my %isAlg = map { $_ => 1 } (1, 224, 256, 384, 512, 512224, 512256);
|
||||
$alg = 1 unless defined $alg;
|
||||
usage(1, "shasum: Unrecognized algorithm\n") unless $isAlg{$alg};
|
||||
|
||||
my %Tag = map { $_ => "SHA$_" } (1, 224, 256, 384, 512);
|
||||
$Tag{512224} = "SHA512/224";
|
||||
$Tag{512256} = "SHA512/256";
|
||||
|
||||
|
||||
## Display version information if requested
|
||||
|
||||
if ($version) {
|
||||
print "$VERSION\n";
|
||||
exit(0);
|
||||
}
|
||||
|
||||
|
||||
## Try to figure out if the OS is DOS-like. If it is,
|
||||
## default to binary mode when reading files, unless
|
||||
## explicitly overridden by command line "--text" or
|
||||
## "--UNIVERSAL" options.
|
||||
|
||||
my $isDOSish = ($^O =~ /^(MSWin\d\d|os2|dos|mint|cygwin|msys)$/);
|
||||
if ($isDOSish) { $binary = 1 unless $text || $UNIVERSAL }
|
||||
|
||||
my $modesym = $binary ? '*' : ($UNIVERSAL ? 'U' : ($BITS ? '^' : ' '));
|
||||
|
||||
|
||||
## Read from STDIN (-) if no files listed on command line
|
||||
|
||||
@ARGV = ("-") unless @ARGV;
|
||||
|
||||
|
||||
## sumfile($file): computes SHA digest of $file
|
||||
|
||||
sub sumfile {
|
||||
my $file = shift;
|
||||
|
||||
my $mode = $binary ? 'b' : ($UNIVERSAL ? 'U' : ($BITS ? '0' : ''));
|
||||
my $digest = eval { Digest::SHA->new($alg)->addfile($file, $mode) };
|
||||
if ($@) { warn "shasum: $file: $errmsg\n"; return }
|
||||
$digest->hexdigest;
|
||||
}
|
||||
|
||||
|
||||
## %len2alg: maps hex digest length to SHA algorithm
|
||||
|
||||
my %len2alg = (40 => 1, 56 => 224, 64 => 256, 96 => 384, 128 => 512);
|
||||
$len2alg{56} = 512224 if $alg == 512224;
|
||||
$len2alg{64} = 512256 if $alg == 512256;
|
||||
|
||||
|
||||
## unescape: convert backslashed filename to plain filename
|
||||
|
||||
sub unescape {
|
||||
$_ = shift;
|
||||
s/\\\\/\0/g;
|
||||
s/\\n/\n/g;
|
||||
s/\0/\\/g;
|
||||
return $_;
|
||||
}
|
||||
|
||||
|
||||
## verify: confirm the digest values in a checksum file
|
||||
|
||||
sub verify {
|
||||
my $checkfile = shift;
|
||||
my ($err, $fmt_errs, $read_errs, $match_errs) = (0, 0, 0, 0);
|
||||
my ($num_fmt_OK, $num_OK) = (0, 0);
|
||||
my ($bslash, $sum, $fname, $rsp, $digest, $isOK);
|
||||
|
||||
local *FH;
|
||||
$checkfile eq '-' and open(FH, '< -')
|
||||
and $checkfile = 'standard input'
|
||||
or sysopen(FH, $checkfile, O_RDONLY)
|
||||
or die "shasum: $checkfile: $!\n";
|
||||
while (<FH>) {
|
||||
next if /^#/;
|
||||
if (/^[ \t]*\\?SHA/) {
|
||||
$modesym = '*';
|
||||
($bslash, $alg, $fname, $sum) =
|
||||
/^[ \t]*(\\?)SHA(\S+) \((.+)\) = ([\da-fA-F]+)/;
|
||||
$alg =~ tr{/}{}d if defined $alg;
|
||||
}
|
||||
else {
|
||||
($bslash, $sum, $modesym, $fname) =
|
||||
/^[ \t]*(\\?)([\da-fA-F]+)[ \t]([ *^U])(.+)/;
|
||||
$alg = defined $sum ? $len2alg{length($sum)} : undef;
|
||||
}
|
||||
if (grep { ! defined $_ } ($alg, $sum, $modesym, $fname) or
|
||||
! $isAlg{$alg}) {
|
||||
warn("shasum: $checkfile: $.: improperly " .
|
||||
"formatted SHA checksum line\n") if $warn;
|
||||
$fmt_errs++;
|
||||
$err = 1 if $strict;
|
||||
next;
|
||||
}
|
||||
$num_fmt_OK++;
|
||||
$fname = unescape($fname) if $bslash;
|
||||
next if $ignore_missing && ! -e $fname;
|
||||
$rsp = "$fname: ";
|
||||
($binary, $text, $UNIVERSAL, $BITS) =
|
||||
map { $_ eq $modesym } ('*', ' ', 'U', '^');
|
||||
$isOK = 0;
|
||||
unless ($digest = sumfile($fname)) {
|
||||
$rsp .= "FAILED open or read\n";
|
||||
$err = 1; $read_errs++;
|
||||
}
|
||||
elsif (lc($sum) eq $digest) {
|
||||
$rsp .= "OK\n";
|
||||
$isOK = 1;
|
||||
$num_OK++;
|
||||
}
|
||||
else { $rsp .= "FAILED\n"; $err = 1; $match_errs++ }
|
||||
print $rsp unless ($status || ($quiet && $isOK));
|
||||
}
|
||||
close(FH);
|
||||
if (! $num_fmt_OK) {
|
||||
warn("shasum: $checkfile: no properly formatted " .
|
||||
"SHA checksum lines found\n");
|
||||
$err = 1;
|
||||
}
|
||||
elsif (! $status) {
|
||||
warn("shasum: WARNING: $fmt_errs line" . ($fmt_errs>1?
|
||||
's are':' is') . " improperly formatted\n") if $fmt_errs;
|
||||
warn("shasum: WARNING: $read_errs listed file" .
|
||||
($read_errs>1?'s':'') . " could not be read\n") if $read_errs;
|
||||
warn("shasum: WARNING: $match_errs computed checksum" .
|
||||
($match_errs>1?'s':'') . " did NOT match\n") if $match_errs;
|
||||
}
|
||||
if ($ignore_missing && ! $num_OK && $num_fmt_OK) {
|
||||
warn("shasum: $checkfile: no file was verified\n")
|
||||
unless $status;
|
||||
$err = 1;
|
||||
}
|
||||
return($err == 0);
|
||||
}
|
||||
|
||||
|
||||
## Verify or compute SHA checksums of requested files
|
||||
|
||||
my($file, $digest);
|
||||
my $STATUS = 0;
|
||||
for $file (@ARGV) {
|
||||
if ($check) { $STATUS = 1 unless verify($file) }
|
||||
elsif ($digest = sumfile($file)) {
|
||||
if ($file =~ /[\n\\]/) {
|
||||
$file =~ s/\\/\\\\/g; $file =~ s/\n/\\n/g;
|
||||
print "\\";
|
||||
}
|
||||
unless ($tag) { print "$digest $modesym$file\n" }
|
||||
else { print "$Tag{$alg} ($file) = $digest\n" }
|
||||
}
|
||||
else { $STATUS = 1 }
|
||||
}
|
||||
exit($STATUS);
|
||||
722
msys2/usr/bin/core_perl/splain
Normal file
722
msys2/usr/bin/core_perl/splain
Normal file
|
|
@ -0,0 +1,722 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
diagnostics, splain - produce verbose warning diagnostics
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Using the C<diagnostics> pragma:
|
||||
|
||||
use diagnostics;
|
||||
use diagnostics -verbose;
|
||||
|
||||
enable diagnostics;
|
||||
disable diagnostics;
|
||||
|
||||
Using the C<splain> standalone filter program:
|
||||
|
||||
perl program 2>diag.out
|
||||
splain [-v] [-p] diag.out
|
||||
|
||||
Using diagnostics to get stack traces from a misbehaving script:
|
||||
|
||||
perl -Mdiagnostics=-traceonly my_script.pl
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=head2 The C<diagnostics> Pragma
|
||||
|
||||
This module extends the terse diagnostics normally emitted by both the
|
||||
perl compiler and the perl interpreter (from running perl with a -w
|
||||
switch or C<use warnings>), augmenting them with the more
|
||||
explicative and endearing descriptions found in L<perldiag>. Like the
|
||||
other pragmata, it affects the compilation phase of your program rather
|
||||
than merely the execution phase.
|
||||
|
||||
To use in your program as a pragma, merely invoke
|
||||
|
||||
use diagnostics;
|
||||
|
||||
at the start (or near the start) of your program. (Note
|
||||
that this I<does> enable perl's B<-w> flag.) Your whole
|
||||
compilation will then be subject(ed :-) to the enhanced diagnostics.
|
||||
These still go out B<STDERR>.
|
||||
|
||||
Due to the interaction between runtime and compiletime issues,
|
||||
and because it's probably not a very good idea anyway,
|
||||
you may not use C<no diagnostics> to turn them off at compiletime.
|
||||
However, you may control their behaviour at runtime using the
|
||||
disable() and enable() methods to turn them off and on respectively.
|
||||
|
||||
The B<-verbose> flag first prints out the L<perldiag> introduction before
|
||||
any other diagnostics. The $diagnostics::PRETTY variable can generate nicer
|
||||
escape sequences for pagers.
|
||||
|
||||
Warnings dispatched from perl itself (or more accurately, those that match
|
||||
descriptions found in L<perldiag>) are only displayed once (no duplicate
|
||||
descriptions). User code generated warnings a la warn() are unaffected,
|
||||
allowing duplicate user messages to be displayed.
|
||||
|
||||
This module also adds a stack trace to the error message when perl dies.
|
||||
This is useful for pinpointing what
|
||||
caused the death. The B<-traceonly> (or
|
||||
just B<-t>) flag turns off the explanations of warning messages leaving just
|
||||
the stack traces. So if your script is dieing, run it again with
|
||||
|
||||
perl -Mdiagnostics=-traceonly my_bad_script
|
||||
|
||||
to see the call stack at the time of death. By supplying the B<-warntrace>
|
||||
(or just B<-w>) flag, any warnings emitted will also come with a stack
|
||||
trace.
|
||||
|
||||
=head2 The I<splain> Program
|
||||
|
||||
While apparently a whole nuther program, I<splain> is actually nothing
|
||||
more than a link to the (executable) F<diagnostics.pm> module, as well as
|
||||
a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
|
||||
the C<use diagnostics -verbose> directive.
|
||||
The B<-p> flag is like the
|
||||
$diagnostics::PRETTY variable. Since you're post-processing with
|
||||
I<splain>, there's no sense in being able to enable() or disable() processing.
|
||||
|
||||
Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
The following file is certain to trigger a few errors at both
|
||||
runtime and compiletime:
|
||||
|
||||
use diagnostics;
|
||||
print NOWHERE "nothing\n";
|
||||
print STDERR "\n\tThis message should be unadorned.\n";
|
||||
warn "\tThis is a user warning";
|
||||
print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
|
||||
my $a, $b = scalar <STDIN>;
|
||||
print "\n";
|
||||
print $x/$y;
|
||||
|
||||
If you prefer to run your program first and look at its problem
|
||||
afterwards, do this:
|
||||
|
||||
perl -w test.pl 2>test.out
|
||||
./splain < test.out
|
||||
|
||||
Note that this is not in general possible in shells of more dubious heritage,
|
||||
as the theoretical
|
||||
|
||||
(perl -w test.pl >/dev/tty) >& test.out
|
||||
./splain < test.out
|
||||
|
||||
Because you just moved the existing B<stdout> to somewhere else.
|
||||
|
||||
If you don't want to modify your source code, but still have on-the-fly
|
||||
warnings, do this:
|
||||
|
||||
exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
|
||||
|
||||
Nifty, eh?
|
||||
|
||||
If you want to control warnings on the fly, do something like this.
|
||||
Make sure you do the C<use> first, or you won't be able to get
|
||||
at the enable() or disable() methods.
|
||||
|
||||
use diagnostics; # checks entire compilation phase
|
||||
print "\ntime for 1st bogus diags: SQUAWKINGS\n";
|
||||
print BOGUS1 'nada';
|
||||
print "done with 1st bogus\n";
|
||||
|
||||
disable diagnostics; # only turns off runtime warnings
|
||||
print "\ntime for 2nd bogus: (squelched)\n";
|
||||
print BOGUS2 'nada';
|
||||
print "done with 2nd bogus\n";
|
||||
|
||||
enable diagnostics; # turns back on runtime warnings
|
||||
print "\ntime for 3rd bogus: SQUAWKINGS\n";
|
||||
print BOGUS3 'nada';
|
||||
print "done with 3rd bogus\n";
|
||||
|
||||
disable diagnostics;
|
||||
print "\ntime for 4th bogus: (squelched)\n";
|
||||
print BOGUS4 'nada';
|
||||
print "done with 4th bogus\n";
|
||||
|
||||
=head1 INTERNALS
|
||||
|
||||
Diagnostic messages derive from the F<perldiag.pod> file when available at
|
||||
runtime. Otherwise, they may be embedded in the file itself when the
|
||||
splain package is built. See the F<Makefile> for details.
|
||||
|
||||
If an extant $SIG{__WARN__} handler is discovered, it will continue
|
||||
to be honored, but only after the diagnostics::splainthis() function
|
||||
(the module's $SIG{__WARN__} interceptor) has had its way with your
|
||||
warnings.
|
||||
|
||||
There is a $diagnostics::DEBUG variable you may set if you're desperately
|
||||
curious what sorts of things are being intercepted.
|
||||
|
||||
BEGIN { $diagnostics::DEBUG = 1 }
|
||||
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Not being able to say "no diagnostics" is annoying, but may not be
|
||||
insurmountable.
|
||||
|
||||
The C<-pretty> directive is called too late to affect matters.
|
||||
You have to do this instead, and I<before> you load the module.
|
||||
|
||||
BEGIN { $diagnostics::PRETTY = 1 }
|
||||
|
||||
I could start up faster by delaying compilation until it should be
|
||||
needed, but this gets a "panic: top_level" when using the pragma form
|
||||
in Perl 5.001e.
|
||||
|
||||
While it's true that this documentation is somewhat subserious, if you use
|
||||
a program named I<splain>, you should expect a bit of whimsy.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use 5.009001;
|
||||
use Carp;
|
||||
$Carp::Internal{__PACKAGE__.""}++;
|
||||
|
||||
our $VERSION = '1.37';
|
||||
our $DEBUG;
|
||||
our $VERBOSE;
|
||||
our $PRETTY;
|
||||
our $TRACEONLY = 0;
|
||||
our $WARNTRACE = 0;
|
||||
|
||||
use Config;
|
||||
use Text::Tabs 'expand';
|
||||
my $privlib = $Config{privlibexp};
|
||||
if ($^O eq 'VMS') {
|
||||
require VMS::Filespec;
|
||||
$privlib = VMS::Filespec::unixify($privlib);
|
||||
}
|
||||
my @trypod = (
|
||||
"$privlib/pod/perldiag.pod",
|
||||
"$privlib/pods/perldiag.pod",
|
||||
);
|
||||
# handy for development testing of new warnings etc
|
||||
unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
|
||||
(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
|
||||
|
||||
$DEBUG ||= 0;
|
||||
|
||||
local $| = 1;
|
||||
local $_;
|
||||
local $.;
|
||||
|
||||
my $standalone;
|
||||
my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
|
||||
|
||||
CONFIG: {
|
||||
our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
|
||||
|
||||
unless (caller) {
|
||||
$standalone++;
|
||||
require Getopt::Std;
|
||||
Getopt::Std::getopts('pdvf:')
|
||||
or die "Usage: $0 [-v] [-p] [-f splainpod]";
|
||||
$PODFILE = $opt_f if $opt_f;
|
||||
$DEBUG = 2 if $opt_d;
|
||||
$VERBOSE = $opt_v;
|
||||
$PRETTY = $opt_p;
|
||||
}
|
||||
|
||||
if (open(POD_DIAG, '<', $PODFILE)) {
|
||||
warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
|
||||
last CONFIG;
|
||||
}
|
||||
|
||||
if (caller) {
|
||||
INCPATH: {
|
||||
for my $file ( (map { "$_/".__PACKAGE__.".pm" } @INC), $0) {
|
||||
warn "Checking $file\n" if $DEBUG;
|
||||
if (open(POD_DIAG, '<', $file)) {
|
||||
while (<POD_DIAG>) {
|
||||
next unless
|
||||
/^__END__\s*# wish diag dbase were more accessible/;
|
||||
print STDERR "podfile is $file\n" if $DEBUG;
|
||||
last INCPATH;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
} else {
|
||||
print STDERR "podfile is <DATA>\n" if $DEBUG;
|
||||
*POD_DIAG = *main::DATA;
|
||||
}
|
||||
}
|
||||
if (eof(POD_DIAG)) {
|
||||
die "couldn't find diagnostic data in $PODFILE @INC $0";
|
||||
}
|
||||
|
||||
|
||||
%HTML_2_Troff = (
|
||||
'amp' => '&', # ampersand
|
||||
'lt' => '<', # left chevron, less-than
|
||||
'gt' => '>', # right chevron, greater-than
|
||||
'quot' => '"', # double quote
|
||||
'sol' => '/', # forward slash / solidus
|
||||
'verbar' => '|', # vertical bar
|
||||
|
||||
"Aacute" => "A\\*'", # capital A, acute accent
|
||||
# etc
|
||||
|
||||
);
|
||||
|
||||
%HTML_2_Latin_1 = (
|
||||
'amp' => '&', # ampersand
|
||||
'lt' => '<', # left chevron, less-than
|
||||
'gt' => '>', # right chevron, greater-than
|
||||
'quot' => '"', # double quote
|
||||
'sol' => '/', # Forward slash / solidus
|
||||
'verbar' => '|', # vertical bar
|
||||
|
||||
"Aacute" => "\xC1" # capital A, acute accent
|
||||
|
||||
# etc
|
||||
);
|
||||
|
||||
%HTML_2_ASCII_7 = (
|
||||
'amp' => '&', # ampersand
|
||||
'lt' => '<', # left chevron, less-than
|
||||
'gt' => '>', # right chevron, greater-than
|
||||
'quot' => '"', # double quote
|
||||
'sol' => '/', # Forward slash / solidus
|
||||
'verbar' => '|', # vertical bar
|
||||
|
||||
"Aacute" => "A" # capital A, acute accent
|
||||
# etc
|
||||
);
|
||||
|
||||
our %HTML_Escapes;
|
||||
*HTML_Escapes = do {
|
||||
if ($standalone) {
|
||||
$PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
|
||||
} else {
|
||||
\%HTML_2_Latin_1;
|
||||
}
|
||||
};
|
||||
|
||||
*THITHER = $standalone ? *STDOUT : *STDERR;
|
||||
|
||||
my %transfmt = ();
|
||||
my $transmo = <<EOFUNC;
|
||||
sub transmo {
|
||||
#local \$^W = 0; # recursive warnings we do NOT need!
|
||||
EOFUNC
|
||||
|
||||
my %msg;
|
||||
my $over_level = 0; # We look only at =item lines at the first =over level
|
||||
{
|
||||
print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
|
||||
local $/ = '';
|
||||
local $_;
|
||||
my $header;
|
||||
my @headers;
|
||||
my $for_item;
|
||||
my $seen_body;
|
||||
while (<POD_DIAG>) {
|
||||
|
||||
sub _split_pod_link {
|
||||
$_[0] =~ m'(?:([^|]*)\|)?([^/]*)(?:/("?)(.*)\3)?'s;
|
||||
($1,$2,$4);
|
||||
}
|
||||
|
||||
unescape();
|
||||
if ($PRETTY) {
|
||||
sub noop { return $_[0] } # spensive for a noop
|
||||
sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
|
||||
sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
|
||||
s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
|
||||
s/[IF]<(.*?)>/italic($1)/ges;
|
||||
s/L<(.*?)>/
|
||||
my($text,$page,$sect) = _split_pod_link($1);
|
||||
defined $text
|
||||
? $text
|
||||
: defined $sect
|
||||
? italic($sect) . ' in ' . italic($page)
|
||||
: italic($page)
|
||||
/ges;
|
||||
s/S<(.*?)>/
|
||||
$1
|
||||
/ges;
|
||||
} else {
|
||||
s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
|
||||
s/[IF]<(.*?)>/$1/gs;
|
||||
s/L<(.*?)>/
|
||||
my($text,$page,$sect) = _split_pod_link($1);
|
||||
defined $text
|
||||
? $text
|
||||
: defined $sect
|
||||
? qq '"$sect" in $page'
|
||||
: $page
|
||||
/ges;
|
||||
s/S<(.*?)>/
|
||||
$1
|
||||
/ges;
|
||||
}
|
||||
unless (/^=/) {
|
||||
if (defined $header) {
|
||||
if ( $header eq 'DESCRIPTION' &&
|
||||
( /Optional warnings are enabled/
|
||||
|| /Some of these messages are generic./
|
||||
) )
|
||||
{
|
||||
next;
|
||||
}
|
||||
$_ = expand $_;
|
||||
s/^/ /gm;
|
||||
$msg{$header} .= $_;
|
||||
for my $h(@headers) { $msg{$h} .= $_ }
|
||||
++$seen_body;
|
||||
undef $for_item;
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
# If we have not come across the body of the description yet, then
|
||||
# the previous header needs to share the same description.
|
||||
if ($seen_body) {
|
||||
@headers = ();
|
||||
}
|
||||
else {
|
||||
push @headers, $header if defined $header;
|
||||
}
|
||||
|
||||
if ( ! s/=item (.*?)\s*\z//s || $over_level != 1) {
|
||||
|
||||
if ( s/=head1\sDESCRIPTION//) {
|
||||
$msg{$header = 'DESCRIPTION'} = '';
|
||||
undef $for_item;
|
||||
}
|
||||
elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
|
||||
$for_item = $1;
|
||||
}
|
||||
elsif( /^=over\b/ ) {
|
||||
$over_level++;
|
||||
}
|
||||
elsif( /^=back\b/ ) { # Stop processing body here
|
||||
$over_level--;
|
||||
if ($over_level == 0) {
|
||||
undef $header;
|
||||
undef $for_item;
|
||||
$seen_body = 0;
|
||||
next;
|
||||
}
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
if( $for_item ) { $header = $for_item; undef $for_item }
|
||||
else {
|
||||
$header = $1;
|
||||
|
||||
$header =~ s/\n/ /gs; # Allow multi-line headers
|
||||
}
|
||||
|
||||
# strip formatting directives from =item line
|
||||
$header =~ s/[A-Z]<(.*?)>/$1/g;
|
||||
|
||||
# Since we strip "(\.\s*)\n" when we search a warning, strip it here as well
|
||||
$header =~ s/(\.\s*)?$//;
|
||||
|
||||
my @toks = split( /(%l?[dxX]|%[ucp]|%(?:\.\d+)?[fs])/, $header );
|
||||
if (@toks > 1) {
|
||||
my $conlen = 0;
|
||||
for my $i (0..$#toks){
|
||||
if( $i % 2 ){
|
||||
if( $toks[$i] eq '%c' ){
|
||||
$toks[$i] = '.';
|
||||
} elsif( $toks[$i] =~ /^%(?:d|u)$/ ){
|
||||
$toks[$i] = '\d+';
|
||||
} elsif( $toks[$i] =~ '^%(?:s|.*f)$' ){
|
||||
$toks[$i] = $i == $#toks ? '.*' : '.*?';
|
||||
} elsif( $toks[$i] =~ '%.(\d+)s' ){
|
||||
$toks[$i] = ".{$1}";
|
||||
} elsif( $toks[$i] =~ '^%l*([pxX])$' ){
|
||||
$toks[$i] = $1 eq 'X' ? '[\dA-F]+' : '[\da-f]+';
|
||||
}
|
||||
} elsif( length( $toks[$i] ) ){
|
||||
$toks[$i] = quotemeta $toks[$i];
|
||||
$conlen += length( $toks[$i] );
|
||||
}
|
||||
}
|
||||
my $lhs = join( '', @toks );
|
||||
$lhs =~ s/(\\\s)+/\\s+/g; # Replace lit space with multi-space match
|
||||
$transfmt{$header}{pat} =
|
||||
" s^\\s*$lhs\\s*\Q$header\Es\n\t&& return 1;\n";
|
||||
$transfmt{$header}{len} = $conlen;
|
||||
} else {
|
||||
my $lhs = "\Q$header\E";
|
||||
$lhs =~ s/(\\\s)+/\\s+/g; # Replace lit space with multi-space match
|
||||
$transfmt{$header}{pat} =
|
||||
" s^\\s*$lhs\\s*\Q$header\E\n\t && return 1;\n";
|
||||
$transfmt{$header}{len} = length( $header );
|
||||
}
|
||||
|
||||
print STDERR __PACKAGE__.": Duplicate entry: \"$header\"\n"
|
||||
if $msg{$header};
|
||||
|
||||
$msg{$header} = '';
|
||||
$seen_body = 0;
|
||||
}
|
||||
|
||||
|
||||
close POD_DIAG unless *main::DATA eq *POD_DIAG;
|
||||
|
||||
die "No diagnostics?" unless %msg;
|
||||
|
||||
# Apply patterns in order of decreasing sum of lengths of fixed parts
|
||||
# Seems the best way of hitting the right one.
|
||||
for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} }
|
||||
keys %transfmt ){
|
||||
$transmo .= $transfmt{$hdr}{pat};
|
||||
}
|
||||
$transmo .= " return 0;\n}\n";
|
||||
print STDERR $transmo if $DEBUG;
|
||||
eval $transmo;
|
||||
die $@ if $@;
|
||||
}
|
||||
|
||||
if ($standalone) {
|
||||
if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
|
||||
while (defined (my $error = <>)) {
|
||||
splainthis($error) || print THITHER $error;
|
||||
}
|
||||
exit;
|
||||
}
|
||||
|
||||
my $olddie;
|
||||
my $oldwarn;
|
||||
|
||||
sub import {
|
||||
shift;
|
||||
$^W = 1; # yup, clobbered the global variable;
|
||||
# tough, if you want diags, you want diags.
|
||||
return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap);
|
||||
|
||||
for (@_) {
|
||||
|
||||
/^-d(ebug)?$/ && do {
|
||||
$DEBUG++;
|
||||
next;
|
||||
};
|
||||
|
||||
/^-v(erbose)?$/ && do {
|
||||
$VERBOSE++;
|
||||
next;
|
||||
};
|
||||
|
||||
/^-p(retty)?$/ && do {
|
||||
print STDERR "$0: I'm afraid it's too late for prettiness.\n";
|
||||
$PRETTY++;
|
||||
next;
|
||||
};
|
||||
# matches trace and traceonly for legacy doc mixup reasons
|
||||
/^-t(race(only)?)?$/ && do {
|
||||
$TRACEONLY++;
|
||||
next;
|
||||
};
|
||||
/^-w(arntrace)?$/ && do {
|
||||
$WARNTRACE++;
|
||||
next;
|
||||
};
|
||||
|
||||
warn "Unknown flag: $_";
|
||||
}
|
||||
|
||||
$oldwarn = $SIG{__WARN__};
|
||||
$olddie = $SIG{__DIE__};
|
||||
$SIG{__WARN__} = \&warn_trap;
|
||||
$SIG{__DIE__} = \&death_trap;
|
||||
}
|
||||
|
||||
sub enable { &import }
|
||||
|
||||
sub disable {
|
||||
shift;
|
||||
return unless $SIG{__WARN__} eq \&warn_trap;
|
||||
$SIG{__WARN__} = $oldwarn || '';
|
||||
$SIG{__DIE__} = $olddie || '';
|
||||
}
|
||||
|
||||
sub warn_trap {
|
||||
my $warning = $_[0];
|
||||
if (caller eq __PACKAGE__ or !splainthis($warning)) {
|
||||
if ($WARNTRACE) {
|
||||
print STDERR Carp::longmess($warning);
|
||||
} else {
|
||||
print STDERR $warning;
|
||||
}
|
||||
}
|
||||
goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
|
||||
};
|
||||
|
||||
sub death_trap {
|
||||
my $exception = $_[0];
|
||||
|
||||
# See if we are coming from anywhere within an eval. If so we don't
|
||||
# want to explain the exception because it's going to get caught.
|
||||
my $in_eval = 0;
|
||||
my $i = 0;
|
||||
while (my $caller = (caller($i++))[3]) {
|
||||
if ($caller eq '(eval)') {
|
||||
$in_eval = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
splainthis($exception) unless $in_eval;
|
||||
if (caller eq __PACKAGE__) {
|
||||
print STDERR "INTERNAL EXCEPTION: $exception";
|
||||
}
|
||||
&$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
|
||||
|
||||
return if $in_eval;
|
||||
|
||||
# We don't want to unset these if we're coming from an eval because
|
||||
# then we've turned off diagnostics.
|
||||
|
||||
# Switch off our die/warn handlers so we don't wind up in our own
|
||||
# traps.
|
||||
$SIG{__DIE__} = $SIG{__WARN__} = '';
|
||||
|
||||
$exception =~ s/\n(?=.)/\n\t/gas;
|
||||
|
||||
die Carp::longmess("__diagnostics__")
|
||||
=~ s/^__diagnostics__.*?line \d+\.?\n/
|
||||
"Uncaught exception from user code:\n\t$exception"
|
||||
/re;
|
||||
# up we go; where we stop, nobody knows, but i think we die now
|
||||
# but i'm deeply afraid of the &$olddie guy reraising and us getting
|
||||
# into an indirect recursion loop
|
||||
};
|
||||
|
||||
my %exact_duplicate;
|
||||
my %old_diag;
|
||||
my $count;
|
||||
my $wantspace;
|
||||
sub splainthis {
|
||||
return 0 if $TRACEONLY;
|
||||
for (my $tmp = shift) {
|
||||
local $\;
|
||||
local $!;
|
||||
### &finish_compilation unless %msg;
|
||||
s/(\.\s*)?\n+$//;
|
||||
my $orig = $_;
|
||||
# return unless defined;
|
||||
|
||||
# get rid of the where-are-we-in-input part
|
||||
s/, <.*?> (?:line|chunk).*$//;
|
||||
|
||||
# Discard 1st " at <file> line <no>" and all text beyond
|
||||
# but be aware of messages containing " at this-or-that"
|
||||
my $real = 0;
|
||||
my @secs = split( / at / );
|
||||
return unless @secs;
|
||||
$_ = $secs[0];
|
||||
for my $i ( 1..$#secs ){
|
||||
if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
|
||||
$real = 1;
|
||||
last;
|
||||
} else {
|
||||
$_ .= ' at ' . $secs[$i];
|
||||
}
|
||||
}
|
||||
|
||||
# remove parenthesis occurring at the end of some messages
|
||||
s/^\((.*)\)$/$1/;
|
||||
|
||||
if ($exact_duplicate{$orig}++) {
|
||||
return &transmo;
|
||||
} else {
|
||||
return 0 unless &transmo;
|
||||
}
|
||||
|
||||
my $short = shorten($orig);
|
||||
if ($old_diag{$_}) {
|
||||
autodescribe();
|
||||
print THITHER "$short (#$old_diag{$_})\n";
|
||||
$wantspace = 1;
|
||||
} elsif (!$msg{$_} && $orig =~ /\n./s) {
|
||||
# A multiline message, like "Attempt to reload /
|
||||
# Compilation failed"
|
||||
my $found;
|
||||
for (split /^/, $orig) {
|
||||
splainthis($_) and $found = 1;
|
||||
}
|
||||
return $found;
|
||||
} else {
|
||||
autodescribe();
|
||||
$old_diag{$_} = ++$count;
|
||||
print THITHER "\n" if $wantspace;
|
||||
$wantspace = 0;
|
||||
print THITHER "$short (#$old_diag{$_})\n";
|
||||
if ($msg{$_}) {
|
||||
print THITHER $msg{$_};
|
||||
} else {
|
||||
if (0 and $standalone) {
|
||||
print THITHER " **** Error #$old_diag{$_} ",
|
||||
($real ? "is" : "appears to be"),
|
||||
" an unknown diagnostic message.\n\n";
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
sub autodescribe {
|
||||
if ($VERBOSE and not $count) {
|
||||
print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
|
||||
"\n$msg{DESCRIPTION}\n";
|
||||
}
|
||||
}
|
||||
|
||||
sub unescape {
|
||||
s {
|
||||
E<
|
||||
( [A-Za-z]+ )
|
||||
>
|
||||
} {
|
||||
do {
|
||||
exists $HTML_Escapes{$1}
|
||||
? do { $HTML_Escapes{$1} }
|
||||
: do {
|
||||
warn "Unknown escape: E<$1> in $_";
|
||||
"E<$1>";
|
||||
}
|
||||
}
|
||||
}egx;
|
||||
}
|
||||
|
||||
sub shorten {
|
||||
my $line = $_[0];
|
||||
if (length($line) > 79 and index($line, "\n") == -1) {
|
||||
my $space_place = rindex($line, ' ', 79);
|
||||
if ($space_place != -1) {
|
||||
substr($line, $space_place, 1) = "\n\t";
|
||||
}
|
||||
}
|
||||
return $line;
|
||||
}
|
||||
|
||||
|
||||
1 unless $standalone; # or it'll complain about itself
|
||||
__END__ # wish diag dbase were more accessible
|
||||
215
msys2/usr/bin/core_perl/streamzip
Normal file
215
msys2/usr/bin/core_perl/streamzip
Normal file
|
|
@ -0,0 +1,215 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!/usr/bin/perl
|
||||
|
||||
# Streaming zip
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use IO::Compress::Zip qw(zip
|
||||
ZIP_CM_STORE
|
||||
ZIP_CM_DEFLATE
|
||||
ZIP_CM_BZIP2
|
||||
ZIP_CM_LZMA );
|
||||
use Getopt::Long;
|
||||
|
||||
my $VERSION = '1.0';
|
||||
|
||||
my $compression_method = ZIP_CM_DEFLATE;
|
||||
my $stream = 0;
|
||||
my $zipfile = '-';
|
||||
my $memberName = '-' ;
|
||||
my $zip64 = 0 ;
|
||||
|
||||
GetOptions("zip64" => \$zip64,
|
||||
"method=s" => \&lookupMethod,
|
||||
"stream" => \$stream,
|
||||
"zipfile=s" => \$zipfile,
|
||||
"member-name=s" => \$memberName,
|
||||
'version' => sub { print "$VERSION\n"; exit 0 },
|
||||
'help' => \&Usage,
|
||||
)
|
||||
or Usage();
|
||||
|
||||
Usage()
|
||||
if @ARGV;
|
||||
|
||||
|
||||
zip '-' => $zipfile,
|
||||
Name => $memberName,
|
||||
Zip64 => $zip64,
|
||||
Method => $compression_method,
|
||||
Stream => $stream
|
||||
or die "Error creating zip file '$zipfile': $\n" ;
|
||||
|
||||
exit 0;
|
||||
|
||||
sub lookupMethod
|
||||
{
|
||||
my $name = shift;
|
||||
my $value = shift ;
|
||||
|
||||
my %valid = ( store => ZIP_CM_STORE,
|
||||
deflate => ZIP_CM_DEFLATE,
|
||||
bzip2 => ZIP_CM_BZIP2,
|
||||
lzma => ZIP_CM_LZMA,
|
||||
);
|
||||
|
||||
my $method = $valid{ lc $value };
|
||||
|
||||
Usage("Unknown method '$value'")
|
||||
if ! defined $method;
|
||||
|
||||
# If LZMA was rquested, check that it is available
|
||||
if ($method == ZIP_CM_LZMA)
|
||||
{
|
||||
eval ' use IO::Compress::Adapter::Lzma';
|
||||
die "Method =. LZMA needs IO::Compress::Adapter::Lzma\n"
|
||||
if ! defined $IO::Compress::Lzma::VERSION;
|
||||
}
|
||||
|
||||
$compression_method = $method;
|
||||
}
|
||||
|
||||
sub Usage
|
||||
{
|
||||
die <<EOM;
|
||||
streamzip [OPTIONS]
|
||||
|
||||
Stream data from stdin, compress into a Zip container, and stream to stdout.
|
||||
|
||||
OPTIONS
|
||||
|
||||
-zipfile=F Write zip container to the filename F
|
||||
-member-name=M member name [Default '-']
|
||||
-zip64 Create a Zip64-compliant zip file [Default: No]
|
||||
Use Zip64 if input is greater than 4Gig.
|
||||
-stream Write a streamed zip file
|
||||
Only applies when 'zipfile' option is used. [Default: No]
|
||||
Always enabled when writing to stdout.
|
||||
-method=M Compress using method "M".
|
||||
Valid methods are
|
||||
store Store without compression
|
||||
deflate Use Deflate compression [Deflault]
|
||||
bzip2 Use Bzip2 compression
|
||||
lzma Use LZMA compression [needs IO::Compress::Lzma]
|
||||
Lzma needs IO::Compress::Lzma to be installed.
|
||||
-version Display version number [$VERSION]
|
||||
|
||||
Copyright (c) 2019 Paul Marquess. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
EOM
|
||||
}
|
||||
|
||||
|
||||
__END__
|
||||
=head1 NAME
|
||||
|
||||
streamzip - create a zip file from stdin
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
producer | streamzip [opts] | consumer
|
||||
producer | streamzip [opts] -zipfile=output.zip
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This program will read data from stdin, compress it into a zip container and,
|
||||
by default, write a I<streamed> zip file to stdout. No temporary files are created.
|
||||
|
||||
The zip container written to stdout is, by necessity, written in streaming
|
||||
format. Most programs that read Zip files can cope with a streamed zip file,
|
||||
but if interoperability is important, and your workflow allows you to write the
|
||||
zip file directly to disk you can create a non-streamed zip file using the C<zipfile> option.
|
||||
|
||||
=head2 OPTIONS
|
||||
|
||||
=over 5
|
||||
|
||||
=item -zip64
|
||||
|
||||
Create a Zip64-compliant zip container.
|
||||
Use this option if the input is greater than 4Gig.
|
||||
|
||||
Default is disabled.
|
||||
|
||||
=item -zipfile=F
|
||||
|
||||
Write zip container to the filename F.
|
||||
|
||||
Use the C<Stream> option to enable the creation of a streamed zip file.
|
||||
|
||||
=item -member-name=M
|
||||
|
||||
This option is used to name the "file" in the zip container.
|
||||
|
||||
Default is '-'.
|
||||
|
||||
=item -stream
|
||||
|
||||
Ignored when writing to stdout.
|
||||
|
||||
If the C<zipfile> option is specified, including this option
|
||||
will trigger the creation of a streamed zip file.
|
||||
|
||||
Default: Always enabled when writing to stdout, otherwise disabled.
|
||||
|
||||
=item -method=M
|
||||
|
||||
Compress using method "M".
|
||||
|
||||
Valid method names are
|
||||
|
||||
* store Store without compression
|
||||
* deflate Use Deflate compression [Deflault]
|
||||
* bzip2 Use Bzip2 compression
|
||||
* lzma Use LZMA compression
|
||||
|
||||
Note that Lzma compress needs IO::Compress::Lzma to be installed.
|
||||
|
||||
Default is deflate.
|
||||
|
||||
=item -version
|
||||
|
||||
Display version number [$VERSION]
|
||||
|
||||
=item -help
|
||||
|
||||
Display help
|
||||
|
||||
=back
|
||||
|
||||
=head2 When to use a Streamed Zip File
|
||||
|
||||
A Zip file created with streaming mode enabled allows you to create a zip file
|
||||
in situations where you cannot seek backwards/forwards in the file.
|
||||
|
||||
A good examples is when you are
|
||||
serving dynamic content from a Web Server straight into a socket
|
||||
without needing to create a temporary zip file in the filesystsm.
|
||||
|
||||
Similarly if your workfow uses a Linux pipelined commands.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
General feedback/questions/bug reports should be sent to
|
||||
L<https://github.com/pmqs/IO-Compress/issues> (preferred) or
|
||||
L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>.
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Marquess F<pmqs@cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2019 Paul Marquess. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
188
msys2/usr/bin/core_perl/xsubpp
Normal file
188
msys2/usr/bin/core_perl/xsubpp
Normal file
|
|
@ -0,0 +1,188 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!perl
|
||||
use 5.006;
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use strict;
|
||||
eval {
|
||||
require ExtUtils::ParseXS;
|
||||
1;
|
||||
}
|
||||
or do {
|
||||
my $err = $@ || 'Zombie error';
|
||||
my $v = $ExtUtils::ParseXS::VERSION;
|
||||
$v = '<undef>' if not defined $v;
|
||||
die "Failed to load or import from ExtUtils::ParseXS (version $v). Please check that ExtUtils::ParseXS is installed correctly and that the newest version will be found in your \@INC path: $err";
|
||||
};
|
||||
|
||||
use Getopt::Long;
|
||||
|
||||
my %args = ();
|
||||
|
||||
my $usage = "Usage: xsubpp [-v] [-csuffix csuffix] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-strip|s pattern] [-typemap typemap]... file.xs\n";
|
||||
|
||||
Getopt::Long::Configure qw(no_auto_abbrev no_ignore_case);
|
||||
|
||||
@ARGV = grep {$_ ne '-C++'} @ARGV; # Allow -C++ for backward compatibility
|
||||
GetOptions(\%args, qw(hiertype!
|
||||
prototypes!
|
||||
versioncheck!
|
||||
linenumbers!
|
||||
optimize!
|
||||
inout!
|
||||
argtypes!
|
||||
object_capi!
|
||||
except!
|
||||
v
|
||||
typemap=s@
|
||||
output=s
|
||||
s|strip=s
|
||||
csuffix=s
|
||||
))
|
||||
or die $usage;
|
||||
|
||||
if ($args{v}) {
|
||||
print "xsubpp version $ExtUtils::ParseXS::VERSION\n";
|
||||
exit;
|
||||
}
|
||||
|
||||
@ARGV == 1 or die $usage;
|
||||
|
||||
$args{filename} = shift @ARGV;
|
||||
|
||||
my $pxs = ExtUtils::ParseXS->new;
|
||||
$pxs->process_file(%args);
|
||||
exit( $pxs->report_error_count() ? 1 : 0 );
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
xsubpp - compiler to convert Perl XS code into C code
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
B<xsubpp> [B<-v>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] [B<-output filename>]... file.xs
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This compiler is typically run by the makefiles created by L<ExtUtils::MakeMaker>
|
||||
or by L<Module::Build> or other Perl module build tools.
|
||||
|
||||
I<xsubpp> will compile XS code into C code by embedding the constructs
|
||||
necessary to let C functions manipulate Perl values and creates the glue
|
||||
necessary to let Perl access those functions. The compiler uses typemaps to
|
||||
determine how to map C function parameters and variables to Perl values.
|
||||
|
||||
The compiler will search for typemap files called I<typemap>. It will use
|
||||
the following search path to find default typemaps, with the rightmost
|
||||
typemap taking precedence.
|
||||
|
||||
../../../typemap:../../typemap:../typemap:typemap
|
||||
|
||||
It will also use a default typemap installed as C<ExtUtils::typemap>.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
Note that the C<XSOPT> MakeMaker option may be used to add these options to
|
||||
any makefiles generated by MakeMaker.
|
||||
|
||||
=over 5
|
||||
|
||||
=item B<-hiertype>
|
||||
|
||||
Retains '::' in type names so that C++ hierarchical types can be mapped.
|
||||
|
||||
=item B<-except>
|
||||
|
||||
Adds exception handling stubs to the C code.
|
||||
|
||||
=item B<-typemap typemap>
|
||||
|
||||
Indicates that a user-supplied typemap should take precedence over the
|
||||
default typemaps. This option may be used multiple times, with the last
|
||||
typemap having the highest precedence.
|
||||
|
||||
=item B<-output filename>
|
||||
|
||||
Specifies the name of the output file to generate. If no file is
|
||||
specified, output will be written to standard output.
|
||||
|
||||
=item B<-v>
|
||||
|
||||
Prints the I<xsubpp> version number to standard output, then exits.
|
||||
|
||||
=item B<-prototypes>
|
||||
|
||||
By default I<xsubpp> will not automatically generate prototype code for
|
||||
all xsubs. This flag will enable prototypes.
|
||||
|
||||
=item B<-noversioncheck>
|
||||
|
||||
Disables the run time test that determines if the object file (derived
|
||||
from the C<.xs> file) and the C<.pm> files have the same version
|
||||
number.
|
||||
|
||||
=item B<-nolinenumbers>
|
||||
|
||||
Prevents the inclusion of '#line' directives in the output.
|
||||
|
||||
=item B<-nooptimize>
|
||||
|
||||
Disables certain optimizations. The only optimization that is currently
|
||||
affected is the use of I<target>s by the output C code (see L<perlguts>).
|
||||
This may significantly slow down the generated code, but this is the way
|
||||
B<xsubpp> of 5.005 and earlier operated.
|
||||
|
||||
=item B<-noinout>
|
||||
|
||||
Disable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> declarations.
|
||||
|
||||
=item B<-noargtypes>
|
||||
|
||||
Disable recognition of ANSI-like descriptions of function signature.
|
||||
|
||||
=item B<-C++>
|
||||
|
||||
Currently doesn't do anything at all. This flag has been a no-op for
|
||||
many versions of perl, at least as far back as perl5.003_07. It's
|
||||
allowed here for backwards compatibility.
|
||||
|
||||
=item B<-s=...> or B<-strip=...>
|
||||
|
||||
I<This option is obscure and discouraged.>
|
||||
|
||||
If specified, the given string will be stripped off from the beginning
|
||||
of the C function name in the generated XS functions (if it starts with that prefix).
|
||||
This only applies to XSUBs without C<CODE> or C<PPCODE> blocks.
|
||||
For example, the XS:
|
||||
|
||||
void foo_bar(int i);
|
||||
|
||||
when C<xsubpp> is invoked with C<-s foo_> will install a C<foo_bar>
|
||||
function in Perl, but really call C<bar(i)> in C. Most of the time,
|
||||
this is the opposite of what you want and failure modes are somewhat
|
||||
obscure, so please avoid this option where possible.
|
||||
|
||||
=back
|
||||
|
||||
=head1 ENVIRONMENT
|
||||
|
||||
No environment variables are used.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Originally by Larry Wall. Turned into the C<ExtUtils::ParseXS> module
|
||||
by Ken Williams.
|
||||
|
||||
=head1 MODIFICATION HISTORY
|
||||
|
||||
See the file F<Changes>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), perlxs(1), perlxstut(1), ExtUtils::ParseXS
|
||||
|
||||
=cut
|
||||
|
||||
2215
msys2/usr/bin/core_perl/zipdetails
Normal file
2215
msys2/usr/bin/core_perl/zipdetails
Normal file
File diff suppressed because it is too large
Load diff
Loading…
Add table
Add a link
Reference in a new issue