#!/usr/bin/env perl
# This chunk of stuff was generated by App::FatPacker. To find the original
# file's code, look for the end of this BEGIN block or the string 'FATPACK'
BEGIN {
my %fatpacked;
$fatpacked{"CPAN/Meta/YAML.pm"} = <<'CPAN_META_YAML';
package CPAN::Meta::YAML;
{
$CPAN::Meta::YAML::VERSION = '0.008';
}
use strict;
# UTF Support?
sub HAVE_UTF8 () { $] >= 5.007003 }
BEGIN {
if ( HAVE_UTF8 ) {
# The string eval helps hide this from Test::MinimumVersion
eval "require utf8;";
die "Failed to load UTF-8 support" if $@;
}
# Class structure
require 5.004;
require Exporter;
require Carp;
@CPAN::Meta::YAML::ISA = qw{ Exporter };
@CPAN::Meta::YAML::EXPORT = qw{ Load Dump };
@CPAN::Meta::YAML::EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
# Error storage
$CPAN::Meta::YAML::errstr = '';
}
# The character class of all characters we need to escape
# NOTE: Inlined, since it's only used once
# my $RE_ESCAPE = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f\"\n]';
# Printed form of the unprintable characters in the lowest range
# of ASCII characters, listed by ASCII ordinal position.
my @UNPRINTABLE = qw(
z x01 x02 x03 x04 x05 x06 a
x08 t n v f r x0e x0f
x10 x11 x12 x13 x14 x15 x16 x17
x18 x19 x1a e x1c x1d x1e x1f
);
# Printable characters for escapes
my %UNESCAPES = (
z => "\x00", a => "\x07", t => "\x09",
n => "\x0a", v => "\x0b", f => "\x0c",
r => "\x0d", e => "\x1b", '\\' => '\\',
);
# Special magic boolean words
my %QUOTE = map { $_ => 1 } qw{
null Null NULL
y Y yes Yes YES n N no No NO
true True TRUE false False FALSE
on On ON off Off OFF
};
#####################################################################
# Implementation
# Create an empty CPAN::Meta::YAML object
sub new {
my $class = shift;
bless [ @_ ], $class;
}
# Create an object from a file
sub read {
my $class = ref $_[0] ? ref shift : shift;
# Check the file
my $file = shift or return $class->_error( 'You did not specify a file name' );
return $class->_error( "File '$file' does not exist" ) unless -e $file;
return $class->_error( "'$file' is a directory, not a file" ) unless -f _;
return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _;
# Slurp in the file
local $/ = undef;
local *CFG;
unless ( open(CFG, $file) ) {
return $class->_error("Failed to open file '$file': $!");
}
my $contents = <CFG>;
unless ( close(CFG) ) {
return $class->_error("Failed to close file '$file': $!");
}
$class->read_string( $contents );
}
# Create an object from a string
sub read_string {
my $class = ref $_[0] ? ref shift : shift;
my $self = bless [], $class;
my $string = $_[0];
eval {
unless ( defined $string ) {
die \"Did not provide a string to load";
}
# Byte order marks
# NOTE: Keeping this here to educate maintainers
# my %BOM = (
# "\357\273\277" => 'UTF-8',
# "\376\377" => 'UTF-16BE',
# "\377\376" => 'UTF-16LE',
# "\377\376\0\0" => 'UTF-32LE'
# "\0\0\376\377" => 'UTF-32BE',
# );
if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) {
die \"Stream has a non UTF-8 BOM";
} else {
# Strip UTF-8 bom if found, we'll just ignore it
$string =~ s/^\357\273\277//;
}
# Try to decode as utf8
utf8::decode($string) if HAVE_UTF8;
# Check for some special cases
return $self unless length $string;
unless ( $string =~ /[\012\015]+\z/ ) {
die \"Stream does not end with newline character";
}
# Split the file into lines
my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
split /(?:\015{1,2}\012|\015|\012)/, $string;
# Strip the initial YAML header
@lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
# A nibbling parser
while ( @lines ) {
# Do we have a document header?
if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
# Handle scalar documents
shift @lines;
if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
push @$self, $self->_read_scalar( "$1", [ undef ], \@lines );
next;
}
}
if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
# A naked document
push @$self, undef;
while ( @lines and $lines[0] !~ /^---/ ) {
shift @lines;
}
} elsif ( $lines[0] =~ /^\s*\-/ ) {
# An array at the root
my $document = [ ];
push @$self, $document;
$self->_read_array( $document, [ 0 ], \@lines );
} elsif ( $lines[0] =~ /^(\s*)\S/ ) {
# A hash at the root
my $document = { };
push @$self, $document;
$self->_read_hash( $document, [ length($1) ], \@lines );
} else {
die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
}
}
};
if ( ref $@ eq 'SCALAR' ) {
return $self->_error(${$@});
} elsif ( $@ ) {
require Carp;
Carp::croak($@);
}
return $self;
}
# Deparse a scalar string to the actual scalar
sub _read_scalar {
my ($self, $string, $indent, $lines) = @_;
# Trim trailing whitespace
$string =~ s/\s*\z//;
# Explitic null/undef
return undef if $string eq '~';
# Single quote
if ( $string =~ /^\'(.*?)\'(?:\s+\#.*)?\z/ ) {
return '' unless defined $1;
$string = $1;
$string =~ s/\'\'/\'/g;
return $string;
}
# Double quote.
# The commented out form is simpler, but overloaded the Perl regex
# engine due to recursion and backtracking problems on strings
# larger than 32,000ish characters. Keep it for reference purposes.
# if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) {
if ( $string =~ /^\"([^\\"]*(?:\\.[^\\"]*)*)\"(?:\s+\#.*)?\z/ ) {
# Reusing the variable is a little ugly,
# but avoids a new variable and a string copy.
$string = $1;
$string =~ s/\\"/"/g;
$string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex;
return $string;
}
# Special cases
if ( $string =~ /^[\'\"!&]/ ) {
die \"CPAN::Meta::YAML does not support a feature in line '$string'";
}
return {} if $string =~ /^{}(?:\s+\#.*)?\z/;
return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;
# Regular unquoted string
if ( $string !~ /^[>|]/ ) {
if (
$string =~ /^(?:-(?:\s|$)|[\@\%\`])/
or
$string =~ /:(?:\s|$)/
) {
die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'";
}
$string =~ s/\s+#.*\z//;
return $string;
}
# Error
die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;
# Check the indent depth
$lines->[0] =~ /^(\s*)/;
$indent->[-1] = length("$1");
if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
}
# Pull the lines
my @multiline = ();
while ( @$lines ) {
$lines->[0] =~ /^(\s*)/;
last unless length($1) >= $indent->[-1];
push @multiline, substr(shift(@$lines), length($1));
}
my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
return join( $j, @multiline ) . $t;
}
# Parse an array
sub _read_array {
my ($self, $array, $indent, $lines) = @_;
while ( @$lines ) {
# Check for a new document
if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
while ( @$lines and $lines->[0] !~ /^---/ ) {
shift @$lines;
}
return 1;
}
# Check the indent level
$lines->[0] =~ /^(\s*)/;
if ( length($1) < $indent->[-1] ) {
return 1;
} elsif ( length($1) > $indent->[-1] ) {
die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
}
if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
# Inline nested hash
my $indent2 = length("$1");
$lines->[0] =~ s/-/ /;
push @$array, { };
$self->_read_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
} elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
# Array entry with a value
shift @$lines;
push @$array, $self->_read_scalar( "$2", [ @$indent, undef ], $lines );
} elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
shift @$lines;
unless ( @$lines ) {
push @$array, undef;
return 1;
}
if ( $lines->[0] =~ /^(\s*)\-/ ) {
my $indent2 = length("$1");
if ( $indent->[-1] == $indent2 ) {
# Null array entry
push @$array, undef;
} else {
# Naked indenter
push @$array, [ ];
$self->_read_array( $array->[-1], [ @$indent, $indent2 ], $lines );
}
} elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
push @$array, { };
$self->_read_hash( $array->[-1], [ @$indent, length("$1") ], $lines );
} else {
die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
}
} elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
# This is probably a structure like the following...
# ---
# foo:
# - list
# bar: value
#
# ... so lets return and let the hash parser handle it
return 1;
} else {
die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
}
}
return 1;
}
# Parse an array
sub _read_hash {
my ($self, $hash, $indent, $lines) = @_;
while ( @$lines ) {
# Check for a new document
if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
while ( @$lines and $lines->[0] !~ /^---/ ) {
shift @$lines;
}
return 1;
}
# Check the indent level
$lines->[0] =~ /^(\s*)/;
if ( length($1) < $indent->[-1] ) {
return 1;
} elsif ( length($1) > $indent->[-1] ) {
die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
}
# Get the key
unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+(?:\#.*)?|$)// ) {
if ( $lines->[0] =~ /^\s*[?\'\"]/ ) {
die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'";
}
die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
}
my $key = $1;
# Do we have a value?
if ( length $lines->[0] ) {
# Yes
$hash->{$key} = $self->_read_scalar( shift(@$lines), [ @$indent, undef ], $lines );
} else {
# An indent
shift @$lines;
unless ( @$lines ) {
$hash->{$key} = undef;
return 1;
}
if ( $lines->[0] =~ /^(\s*)-/ ) {
$hash->{$key} = [];
$self->_read_array( $hash->{$key}, [ @$indent, length($1) ], $lines );
} elsif ( $lines->[0] =~ /^(\s*)./ ) {
my $indent2 = length("$1");
if ( $indent->[-1] >= $indent2 ) {
# Null hash entry
$hash->{$key} = undef;
} else {
$hash->{$key} = {};
$self->_read_hash( $hash->{$key}, [ @$indent, length($1) ], $lines );
}
}
}
}
return 1;
}
# Save an object to a file
sub write {
my $self = shift;
my $file = shift or return $self->_error('No file name provided');
# Write it to the file
open( CFG, '>' . $file ) or return $self->_error(
"Failed to open file '$file' for writing: $!"
);
print CFG $self->write_string;
close CFG;
return 1;
}
# Save an object to a string
sub write_string {
my $self = shift;
return '' unless @$self;
# Iterate over the documents
my $indent = 0;
my @lines = ();
foreach my $cursor ( @$self ) {
push @lines, '---';
# An empty document
if ( ! defined $cursor ) {
# Do nothing
# A scalar document
} elsif ( ! ref $cursor ) {
$lines[-1] .= ' ' . $self->_write_scalar( $cursor, $indent );
# A list at the root
} elsif ( ref $cursor eq 'ARRAY' ) {
unless ( @$cursor ) {
$lines[-1] .= ' []';
next;
}
push @lines, $self->_write_array( $cursor, $indent, {} );
# A hash at the root
} elsif ( ref $cursor eq 'HASH' ) {
unless ( %$cursor ) {
$lines[-1] .= ' {}';
next;
}
push @lines, $self->_write_hash( $cursor, $indent, {} );
} else {
Carp::croak("Cannot serialize " . ref($cursor));
}
}
join '', map { "$_\n" } @lines;
}
sub _write_scalar {
my $string = $_[1];
return '~' unless defined $string;
return "''" unless length $string;
if ( $string =~ /[\x00-\x08\x0b-\x0d\x0e-\x1f\"\'\n]/ ) {
$string =~ s/\\/\\\\/g;
$string =~ s/"/\\"/g;
$string =~ s/\n/\\n/g;
$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
return qq|"$string"|;
}
if ( $string =~ /(?:^\W|\s|:\z)/ or $QUOTE{$string} ) {
return "'$string'";
}
return $string;
}
sub _write_array {
my ($self, $array, $indent, $seen) = @_;
if ( $seen->{refaddr($array)}++ ) {
die "CPAN::Meta::YAML does not support circular references";
}
my @lines = ();
foreach my $el ( @$array ) {
my $line = (' ' x $indent) . '-';
my $type = ref $el;
if ( ! $type ) {
$line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
push @lines, $line;
} elsif ( $type eq 'ARRAY' ) {
if ( @$el ) {
push @lines, $line;
push @lines, $self->_write_array( $el, $indent + 1, $seen );
} else {
$line .= ' []';
push @lines, $line;
}
} elsif ( $type eq 'HASH' ) {
if ( keys %$el ) {
push @lines, $line;
push @lines, $self->_write_hash( $el, $indent + 1, $seen );
} else {
$line .= ' {}';
push @lines, $line;
}
} else {
die "CPAN::Meta::YAML does not support $type references";
}
}
@lines;
}
sub _write_hash {
my ($self, $hash, $indent, $seen) = @_;
if ( $seen->{refaddr($hash)}++ ) {
die "CPAN::Meta::YAML does not support circular references";
}
my @lines = ();
foreach my $name ( sort keys %$hash ) {
my $el = $hash->{$name};
my $line = (' ' x $indent) . "$name:";
my $type = ref $el;
if ( ! $type ) {
$line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
push @lines, $line;
} elsif ( $type eq 'ARRAY' ) {
if ( @$el ) {
push @lines, $line;
push @lines, $self->_write_array( $el, $indent + 1, $seen );
} else {
$line .= ' []';
push @lines, $line;
}
} elsif ( $type eq 'HASH' ) {
if ( keys %$el ) {
push @lines, $line;
push @lines, $self->_write_hash( $el, $indent + 1, $seen );
} else {
$line .= ' {}';
push @lines, $line;
}
} else {
die "CPAN::Meta::YAML does not support $type references";
}
}
@lines;
}
# Set error
sub _error {
$CPAN::Meta::YAML::errstr = $_[1];
undef;
}
# Retrieve error
sub errstr {
$CPAN::Meta::YAML::errstr;
}
#####################################################################
# YAML Compatibility
sub Dump {
CPAN::Meta::YAML->new(@_)->write_string;
}
sub Load {
my $self = CPAN::Meta::YAML->read_string(@_);
unless ( $self ) {
Carp::croak("Failed to load YAML document from string");
}
if ( wantarray ) {
return @$self;
} else {
# To match YAML.pm, return the last document
return $self->[-1];
}
}
BEGIN {
*freeze = *Dump;
*thaw = *Load;
}
sub DumpFile {
my $file = shift;
CPAN::Meta::YAML->new(@_)->write($file);
}
sub LoadFile {
my $self = CPAN::Meta::YAML->read($_[0]);
unless ( $self ) {
Carp::croak("Failed to load YAML document from '" . ($_[0] || '') . "'");
}
if ( wantarray ) {
return @$self;
} else {
# Return only the last document to match YAML.pm,
return $self->[-1];
}
}
#####################################################################
# Use Scalar::Util if possible, otherwise emulate it
BEGIN {
local $@;
eval {
require Scalar::Util;
};
my $v = eval("$Scalar::Util::VERSION") || 0;
if ( $@ or $v < 1.18 ) {
eval <<'END_PERL';
# Scalar::Util failed to load or too old
sub refaddr {
my $pkg = ref($_[0]) or return undef;
if ( !! UNIVERSAL::can($_[0], 'can') ) {
bless $_[0], 'Scalar::Util::Fake';
} else {
$pkg = undef;
}
"$_[0]" =~ /0x(\w+)/;
my $i = do { local $^W; hex $1 };
bless $_[0], $pkg if defined $pkg;
$i;
}
END_PERL
} else {
*refaddr = *Scalar::Util::refaddr;
}
}
1;
=pod
=head1 NAME
CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files
=head1 VERSION
version 0.008
=head1 SYNOPSIS
use CPAN::Meta::YAML;
# reading a META file
open $fh, "<:utf8", "META.yml";
$yaml_text = do { local $/; <$fh> };
$yaml = CPAN::Meta::YAML->read_string($yaml_text)
or die CPAN::Meta::YAML->errstr;
# finding the metadata
$meta = $yaml->[0];
# writing a META file
$yaml_text = $yaml->write_string
or die CPAN::Meta::YAML->errstr;
open $fh, ">:utf8", "META.yml";
print $fh $yaml_text;
=head1 DESCRIPTION
This module implements a subset of the YAML specification for use in reading
and writing CPAN metadata files like F<META.yml> and F<MYMETA.yml>. It should
not be used for any other general YAML parsing or generation task.
NOTE: F<META.yml> (and F<MYMETA.yml>) files should be UTF-8 encoded. Users are
responsible for proper encoding and decoding. In particular, the C<read> and
C<write> methods do B<not> support UTF-8 and should not be used.
=head1 SUPPORT
This module is currently derived from L<YAML::Tiny> by Adam Kennedy. If
there are bugs in how it parses a particular META.yml file, please file
a bug report in the YAML::Tiny bugtracker:
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=YAML-Tiny>
=head1 SEE ALSO
L<YAML::Tiny>, L<YAML>, L<YAML::XS>
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
at L<http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta-YAML>.
You will be notified automatically of any progress on your issue.
=head2 Source Code
This is open source software. The code repository is available for
public review and contribution under the terms of the license.
L<https://github.com/dagolden/cpan-meta-yaml>
git clone https://github.com/dagolden/cpan-meta-yaml.git
=head1 AUTHORS
=over 4
=item *
Adam Kennedy <adamk@cpan.org>
=item *
David Golden <dagolden@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by Adam Kennedy.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
# ABSTRACT: Read and write a subset of YAML for CPAN Meta files
CPAN_META_YAML
$fatpacked{"CPAN/Perl/Releases.pm"} = <<'CPAN_PERL_RELEASES';
package CPAN::Perl::Releases;
{
$CPAN::Perl::Releases::VERSION = '1.08';
}
#ABSTRACT: Mapping Perl releases on CPAN to the location of the tarballs
use strict;
use warnings;
use vars qw[@ISA @EXPORT_OK];
use Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(perl_tarballs);
# Data gathered from using findlinks.pl script in this dists tools/
# directory, run over the src/5.0 of a local CPAN mirror.
our $data =
{
"5.003_07" => {
"tar.gz" => "A/AN/ANDYD/perl5.003_07.tar.gz",
},
"5.004" => {
"tar.gz" => "C/CH/CHIPS/perl5.004.tar.gz",
},
"5.004_01" => {
"tar.gz" => "T/TI/TIMB/perl5.004_01.tar.gz",
},
"5.004_02" => {
"tar.gz" => "T/TI/TIMB/perl5.004_02.tar.gz",
},
"5.004_03" => {
"tar.gz" => "T/TI/TIMB/perl5.004_03.tar.gz",
},
"5.004_04" => {
"tar.gz" => "T/TI/TIMB/perl5.004_04.tar.gz",
},
"5.004_05" => {
"tar.gz" => "C/CH/CHIPS/perl5.004_05.tar.gz",
},
"5.005" => {
"tar.gz" => "G/GS/GSAR/perl5.005.tar.gz",
},
"5.005_01" => {
"tar.gz" => "G/GS/GSAR/perl5.005_01.tar.gz",
},
"5.005_02" => {
"tar.gz" => "G/GS/GSAR/perl5.005_02.tar.gz",
},
"5.005_03" => {
"tar.gz" => "G/GB/GBARR/perl5.005_03.tar.gz",
},
"5.005_04" => {
"tar.gz" => "L/LB/LBROCARD/perl5.005_04.tar.gz",
},
"5.10.0" => {
"tar.gz" => "R/RG/RGARCIA/perl-5.10.0.tar.gz",
},
"5.10.0-RC1" => {
"tar.gz" => "R/RG/RGARCIA/perl-5.10.0-RC1.tar.gz",
},
"5.10.0-RC2" => {
"tar.gz" => "R/RG/RGARCIA/perl-5.10.0-RC2.tar.gz",
},
"5.10.1" => {
"tar.bz2" => "D/DA/DAPM/perl-5.10.1.tar.bz2",
"tar.gz" => "D/DA/DAPM/perl-5.10.1.tar.gz",
},
"5.11.0" => {
"tar.bz2" => "J/JE/JESSE/perl-5.11.0.tar.bz2",
"tar.gz" => "J/JE/JESSE/perl-5.11.0.tar.gz",
},
"5.11.1" => {
"tar.bz2" => "J/JE/JESSE/perl-5.11.1.tar.bz2",
"tar.gz" => "J/JE/JESSE/perl-5.11.1.tar.gz",
},
"5.11.2" => {
"tar.bz2" => "L/LB/LBROCARD/perl-5.11.2.tar.bz2",
"tar.gz" => "L/LB/LBROCARD/perl-5.11.2.tar.gz",
},
"5.11.3" => {
"tar.bz2" => "J/JE/JESSE/perl-5.11.3.tar.bz2",
"tar.gz" => "J/JE/JESSE/perl-5.11.3.tar.gz",
},
"5.11.4" => {
"tar.bz2" => "R/RJ/RJBS/perl-5.11.4.tar.bz2",
"tar.gz" => "R/RJ/RJBS/perl-5.11.4.tar.gz",
},
"5.11.5" => {
"tar.bz2" => "S/SH/SHAY/perl-5.11.5.tar.bz2",
"tar.gz" => "S/SH/SHAY/perl-5.11.5.tar.gz",
},
"5.12.0" => {
"tar.bz2" => "J/JE/JESSE/perl-5.12.0.tar.bz2",
"tar.gz" => "J/JE/JESSE/perl-5.12.0.tar.gz",
},
"5.12.1" => {
"tar.bz2" => "J/JE/JESSE/perl-5.12.1.tar.bz2",
"tar.gz" => "J/JE/JESSE/perl-5.12.1.tar.gz",
},
"5.12.1-RC1" => {
"tar.bz2" => "J/JE/JESSE/perl-5.12.1-RC1.tar.bz2",
"tar.gz" => "J/JE/JESSE/perl-5.12.1-RC1.tar.gz",
},
"5.12.1-RC2" => {
"tar.bz2" => "J/JE/JESSE/perl-5.12.1-RC2.tar.bz2",
"tar.gz" => "J/JE/JESSE/perl-5.12.1-RC2.tar.gz",
},
"5.12.2" => {
"tar.bz2" => "J/JE/JESSE/perl-5.12.2.tar.bz2",
"tar.gz" => "J/JE/JESSE/perl-5.12.2.tar.gz",
},
"5.12.2-RC1" => {
"tar.bz2" => "J/JE/JESSE/perl-5.12.2-RC1.tar.bz2",
"tar.gz" => "J/JE/JESSE/perl-5.12.2-RC1.tar.gz",
},
"5.12.3" => {
"tar.bz2" => "R/RJ/RJBS/perl-5.12.3.tar.bz2",
"tar.gz" => "R/RJ/RJBS/perl-5.12.3.tar.gz",
},
"5.12.4-RC1" => {
"tar.bz2" => "L/LB/LBROCARD/perl-5.12.4-RC1.tar.bz2",
"tar.gz" => "L/LB/LBROCARD/perl-5.12.4-RC1.tar.gz",
},
"5.12.4-RC2" => {
"tar.bz2" => "L/LB/LBROCARD/perl-5.12.4-RC2.tar.bz2",
"tar.gz" => "L/LB/LBROCARD/perl-5.12.4-RC2.tar.gz",
},
"5.12.4" => {
"tar.bz2" => "L/LB/LBROCARD/perl-5.12.4.tar.bz2",
"tar.gz" => "L/LB/LBROCARD/perl-5.12.4.tar.gz",
},
"5.12.5-RC1" => {
"tar.bz2" => "D/DO/DOM/perl-5.12.5-RC1.tar.bz2",
"tar.gz" => "D/DO/DOM/perl-5.12.5-RC1.tar.gz",
},
"5.12.5-RC2" => {
"tar.bz2" => "D/DO/DOM/perl-5.12.5-RC2.tar.bz2",
"tar.gz" => "D/DO/DOM/perl-5.12.5-RC2.tar.gz",
},
"5.12.5" => {
"tar.bz2" => "D/DO/DOM/perl-5.12.5.tar.bz2",
"tar.gz" => "D/DO/DOM/perl-5.12.5.tar.gz",
},
"5.13.0" => {
"tar.bz2" => "L/LB/LBROCARD/perl-5.13.0.tar.bz2",
"tar.gz" => "L/LB/LBROCARD/perl-5.13.0.tar.gz",
},
"5.13.1" => {
"tar.bz2" => "R/RJ/RJBS/perl-5.13.1.tar.bz2",
"tar.gz" => "R/RJ/RJBS/perl-5.13.1.tar.gz",
},
"5.13.10" => {
"tar.bz2" => "A/AV/AVAR/perl-5.13.10.tar.bz2",
"tar.gz" => "A/AV/AVAR/perl-5.13.10.tar.gz",
},
"5.13.11" => {
"tar.bz2" => "F/FL/FLORA/perl-5.13.11.tar.bz2",
"tar.gz" => "F/FL/FLORA/perl-5.13.11.tar.gz",
},
"5.13.2" => {
"tar.bz2" => "M/MS/MSTROUT/perl-5.13.2.tar.bz2",
"tar.gz" => "M/MS/MSTROUT/perl-5.13.2.tar.gz",
},
"5.13.3" => {
"tar.bz2" => "D/DA/DAGOLDEN/perl-5.13.3.tar.bz2",
"tar.gz" => "D/DA/DAGOLDEN/perl-5.13.3.tar.gz",
},
"5.13.4" => {
"tar.bz2" => "F/FL/FLORA/perl-5.13.4.tar.bz2",
"tar.gz" => "F/FL/FLORA/perl-5.13.4.tar.gz",
},
"5.13.5" => {
"tar.bz2" => "S/SH/SHAY/perl-5.13.5.tar.bz2",
"tar.gz" => "S/SH/SHAY/perl-5.13.5.tar.gz",
},
"5.13.6" => {
"tar.bz2" => "M/MI/MIYAGAWA/perl-5.13.6.tar.bz2",
"tar.gz" => "M/MI/MIYAGAWA/perl-5.13.6.tar.gz",
},
"5.13.7" => {
"tar.bz2" => "B/BI/BINGOS/perl-5.13.7.tar.bz2",
"tar.gz" => "B/BI/BINGOS/perl-5.13.7.tar.gz",
},
"5.13.8" => {
"tar.bz2" => "Z/ZE/ZEFRAM/perl-5.13.8.tar.bz2",
"tar.gz" => "Z/ZE/ZEFRAM/perl-5.13.8.tar.gz",
},
"5.13.9" => {
"tar.bz2" => "J/JE/JESSE/perl-5.13.9.tar.bz2",
"tar.gz" => "J/JE/JESSE/perl-5.13.9.tar.gz",
},
"5.14.0" => {
"tar.bz2" => "J/JE/JESSE/perl-5.14.0.tar.bz2",
"tar.gz" => "J/JE/JESSE/perl-5.14.0.tar.gz",
},
"5.14.0-RC1" => {
"tar.bz2" => "J/JE/JESSE/perl-5.14.0-RC1.tar.bz2",
"tar.gz" => "J/JE/JESSE/perl-5.14.0-RC1.tar.gz",
},
"5.14.0-RC2" => {
"tar.bz2" => "J/JE/JESSE/perl-5.14.0-RC2.tar.bz2",
"tar.gz" => "J/JE/JESSE/perl-5.14.0-RC2.tar.gz",
},
"5.14.0-RC3" => {
"tar.bz2" => "J/JE/JESSE/perl-5.14.0-RC3.tar.bz2",
"tar.gz" => "J/JE/JESSE/perl-5.14.0-RC3.tar.gz",
},
"5.14.1-RC1" => {
"tar.bz2" => "J/JE/JESSE/perl-5.14.1-RC1.tar.bz2",
"tar.gz" => "J/JE/JESSE/perl-5.14.1-RC1.tar.gz",
},
"5.14.1" => {
"tar.bz2" => "J/JE/JESSE/perl-5.14.1.tar.bz2",
"tar.gz" => "J/JE/JESSE/perl-5.14.1.tar.gz",
},
"5.14.2-RC1" => {
"tar.bz2" => "F/FL/FLORA/perl-5.14.2-RC1.tar.bz2",
"tar.gz" => "F/FL/FLORA/perl-5.14.2-RC1.tar.gz",
},
"5.14.2" => {
"tar.bz2" => "F/FL/FLORA/perl-5.14.2.tar.bz2",
"tar.gz" => "F/FL/FLORA/perl-5.14.2.tar.gz",
},
"5.14.3-RC1" => {
"tar.bz2" => "D/DO/DOM/perl-5.14.3-RC1.tar.bz2",
"tar.gz" => "D/DO/DOM/perl-5.14.3-RC1.tar.gz",
},
"5.14.3-RC2" => {
"tar.bz2" => "D/DO/DOM/perl-5.14.3-RC2.tar.bz2",
"tar.gz" => "D/DO/DOM/perl-5.14.3-RC2.tar.gz",
},
"5.14.3" => {
"tar.bz2" => "D/DO/DOM/perl-5.14.3.tar.bz2",
"tar.gz" => "D/DO/DOM/perl-5.14.3.tar.gz",
},
"5.14.4-RC1" => {
"tar.bz2" => "D/DA/DAPM/perl-5.14.4-RC1.tar.bz2",
"tar.gz" => "D/DA/DAPM/perl-5.14.4-RC1.tar.gz",
},
"5.14.4-RC2" => {
"tar.bz2" => "D/DA/DAPM/perl-5.14.4-RC2.tar.bz2",
"tar.gz" => "D/DA/DAPM/perl-5.14.4-RC2.tar.gz",
},
"5.14.4" => {
"tar.bz2" => "D/DA/DAPM/perl-5.14.4.tar.bz2",
"tar.gz" => "D/DA/DAPM/perl-5.14.4.tar.gz",
},
"5.15.0" => {
"tar.bz2" => "D/DA/DAGOLDEN/perl-5.15.0.tar.bz2",
"tar.gz" => "D/DA/DAGOLDEN/perl-5.15.0.tar.gz",
},
"5.15.1" => {
"tar.bz2" => "Z/ZE/ZEFRAM/perl-5.15.1.tar.bz2",
"tar.gz" => "Z/ZE/ZEFRAM/perl-5.15.1.tar.gz",
},
"5.15.2" => {
"tar.bz2" => "R/RJ/RJBS/perl-5.15.2.tar.bz2",
"tar.gz" => "R/RJ/RJBS/perl-5.15.2.tar.gz",
},
"5.15.3" => {
"tar.bz2" => "S/ST/STEVAN/perl-5.15.3.tar.bz2",
"tar.gz" => "S/ST/STEVAN/perl-5.15.3.tar.gz",
},
"5.15.4" => {
"tar.bz2" => "F/FL/FLORA/perl-5.15.4.tar.bz2",
"tar.gz" => "F/FL/FLORA/perl-5.15.4.tar.gz",
},
"5.15.5" => {
"tar.bz2" => "S/SH/SHAY/perl-5.15.5.tar.bz2",
"tar.gz" => "S/SH/SHAY/perl-5.15.5.tar.gz",
},
"5.15.6" => {
"tar.bz2" => "D/DR/DROLSKY/perl-5.15.6.tar.bz2",
"tar.gz" => "D/DR/DROLSKY/perl-5.15.6.tar.gz",
},
"5.15.7" => {
"tar.bz2" => "B/BI/BINGOS/perl-5.15.7.tar.bz2",
"tar.gz" => "B/BI/BINGOS/perl-5.15.7.tar.gz",
},
"5.15.8" => {
"tar.bz2" => "C/CO/CORION/perl-5.15.8.tar.bz2",
"tar.gz" => "C/CO/CORION/perl-5.15.8.tar.gz",
},
"5.15.9" => {
"tar.bz2" => "A/AB/ABIGAIL/perl-5.15.9.tar.bz2",
"tar.gz" => "A/AB/ABIGAIL/perl-5.15.9.tar.gz",
},
"5.16.0-RC0" => {
"tar.gz" => "R/RJ/RJBS/perl-5.16.0-RC0.tar.gz",
},
"5.16.0-RC1" => {
"tar.bz2" => "R/RJ/RJBS/perl-5.16.0-RC1.tar.bz2",
"tar.gz" => "R/RJ/RJBS/perl-5.16.0-RC1.tar.gz",
},
"5.16.0-RC2" => {
"tar.bz2" => "R/RJ/RJBS/perl-5.16.0-RC2.tar.bz2",
"tar.gz" => "R/RJ/RJBS/perl-5.16.0-RC2.tar.gz",
},
"5.16.0" => {
"tar.bz2" => "R/RJ/RJBS/perl-5.16.0.tar.bz2",
"tar.gz" => "R/RJ/RJBS/perl-5.16.0.tar.gz",
},
"5.16.1-RC1" => {
"tar.bz2" => "R/RJ/RJBS/perl-5.16.1-RC1.tar.bz2",
"tar.gz" => "R/RJ/RJBS/perl-5.16.1-RC1.tar.gz",
},
"5.16.1" => {
"tar.bz2" => "R/RJ/RJBS/perl-5.16.1.tar.bz2",
"tar.gz" => "R/RJ/RJBS/perl-5.16.1.tar.gz",
},
"5.16.2-RC1" => {
"tar.bz2" => "R/RJ/RJBS/perl-5.16.2-RC1.tar.bz2",
"tar.gz" => "R/RJ/RJBS/perl-5.16.2-RC1.tar.gz",
},
"5.16.2" => {
"tar.bz2" => "R/RJ/RJBS/perl-5.16.2.tar.bz2",
"tar.gz" => "R/RJ/RJBS/perl-5.16.2.tar.gz",
},
"5.16.3-RC1" => {
"tar.bz2" => "R/RJ/RJBS/perl-5.16.3-RC1.tar.bz2",
"tar.gz" => "R/RJ/RJBS/perl-5.16.3-RC1.tar.gz",
},
"5.16.3" => {
"tar.bz2" => "R/RJ/RJBS/perl-5.16.3.tar.bz2",
"tar.gz" => "R/RJ/RJBS/perl-5.16.3.tar.gz",
},
"5.17.0" => {
"tar.bz2" => "Z/ZE/ZEFRAM/perl-5.17.0.tar.bz2",
"tar.gz" => "Z/ZE/ZEFRAM/perl-5.17.0.tar.gz",
},
"5.17.1" => {
"tar.bz2" => "D/DO/DOY/perl-5.17.1.tar.bz2",
"tar.gz" => "D/DO/DOY/perl-5.17.1.tar.gz",
},
"5.17.2" => {
"tar.bz2" => "T/TO/TONYC/perl-5.17.2.tar.bz2",
"tar.gz" => "T/TO/TONYC/perl-5.17.2.tar.gz",
},
"5.17.3" => {
"tar.bz2" => "S/SH/SHAY/perl-5.17.3.tar.bz2",
"tar.gz" => "S/SH/SHAY/perl-5.17.3.tar.gz",
},
"5.17.4" => {
"tar.bz2" => "F/FL/FLORA/perl-5.17.4.tar.bz2",
"tar.gz" => "F/FL/FLORA/perl-5.17.4.tar.gz",
},
"5.17.5" => {
"tar.bz2" => "F/FL/FLORA/perl-5.17.5.tar.bz2",
"tar.gz" => "F/FL/FLORA/perl-5.17.5.tar.gz",
},
"5.17.6" => {
"tar.bz2" => "R/RJ/RJBS/perl-5.17.6.tar.bz2",
"tar.gz" => "R/RJ/RJBS/perl-5.17.6.tar.gz",
},
"5.17.7" => {
"tar.bz2" => "D/DR/DROLSKY/perl-5.17.7.tar.bz2",
"tar.gz" => "D/DR/DROLSKY/perl-5.17.7.tar.gz",
},
"5.17.8" => {
"tar.bz2" => "A/AR/ARC/perl-5.17.8.tar.bz2",
"tar.gz" => "A/AR/ARC/perl-5.17.8.tar.gz",
},
"5.17.9" => {
"tar.bz2" => "B/BI/BINGOS/perl-5.17.9.tar.bz2",
"tar.gz" => "B/BI/BINGOS/perl-5.17.9.tar.gz",
},
"5.17.10" => {
"tar.bz2" => "C/CO/CORION/perl-5.17.10.tar.bz2",
"tar.gz" => "C/CO/CORION/perl-5.17.10.tar.gz",
},
"5.6.0" => {
"tar.gz" => "G/GS/GSAR/perl-5.6.0.tar.gz",
},
"5.6.1" => {
"tar.gz" => "G/GS/GSAR/perl-5.6.1.tar.gz",
},
"5.6.1-TRIAL1" => {
"tar.gz" => "G/GS/GSAR/perl-5.6.1-TRIAL1.tar.gz",
},
"5.6.1-TRIAL2" => {
"tar.gz" => "G/GS/GSAR/perl-5.6.1-TRIAL2.tar.gz",
},
"5.6.1-TRIAL3" => {
"tar.gz" => "G/GS/GSAR/perl-5.6.1-TRIAL3.tar.gz",
},
"5.6.2" => {
"tar.gz" => "R/RG/RGARCIA/perl-5.6.2.tar.gz",
},
"5.7.0" => {
"tar.gz" => "J/JH/JHI/perl-5.7.0.tar.gz",
},
"5.7.1" => {
"tar.gz" => "J/JH/JHI/perl-5.7.1.tar.gz",
},
"5.7.2" => {
"tar.gz" => "J/JH/JHI/perl-5.7.2.tar.gz",
},
"5.7.3" => {
"tar.gz" => "J/JH/JHI/perl-5.7.3.tar.gz",
},
"5.8.0" => {
"tar.gz" => "J/JH/JHI/perl-5.8.0.tar.gz",
},
"5.8.1" => {
"tar.gz" => "J/JH/JHI/perl-5.8.1.tar.gz",
},
"5.8.2" => {
"tar.bz2" => "N/NW/NWCLARK/perl-5.8.2.tar.bz2",
"tar.gz" => "N/NW/NWCLARK/perl-5.8.2.tar.gz",
},
"5.8.3" => {
"tar.bz2" => "N/NW/NWCLARK/perl-5.8.3.tar.bz2",
"tar.gz" => "N/NW/NWCLARK/perl-5.8.3.tar.gz",
},
"5.8.4" => {
"tar.bz2" => "N/NW/NWCLARK/perl-5.8.4.tar.bz2",
"tar.gz" => "N/NW/NWCLARK/perl-5.8.4.tar.gz",
},
"5.8.5" => {
"tar.bz2" => "N/NW/NWCLARK/perl-5.8.5.tar.bz2",
"tar.gz" => "N/NW/NWCLARK/perl-5.8.5.tar.gz",
},
"5.8.6" => {
"tar.bz2" => "N/NW/NWCLARK/perl-5.8.6.tar.bz2",
"tar.gz" => "N/NW/NWCLARK/perl-5.8.6.tar.gz",
},
"5.8.7" => {
"tar.bz2" => "N/NW/NWCLARK/perl-5.8.7.tar.bz2",
"tar.gz" => "N/NW/NWCLARK/perl-5.8.7.tar.gz",
},
"5.8.8" => {
"tar.bz2" => "N/NW/NWCLARK/perl-5.8.8.tar.bz2",
"tar.gz" => "N/NW/NWCLARK/perl-5.8.8.tar.gz",
},
"5.8.9" => {
"tar.bz2" => "N/NW/NWCLARK/perl-5.8.9.tar.bz2",
"tar.gz" => "N/NW/NWCLARK/perl-5.8.9.tar.gz",
},
"5.9.0" => {
"tar.bz2" => "H/HV/HVDS/perl-5.9.0.tar.bz2",
"tar.gz" => "H/HV/HVDS/perl-5.9.0.tar.gz",
},
"5.9.1" => {
"tar.gz" => "R/RG/RGARCIA/perl-5.9.1.tar.gz",
},
"5.9.2" => {
"tar.gz" => "R/RG/RGARCIA/perl-5.9.2.tar.gz",
},
"5.9.3" => {
"tar.gz" => "R/RG/RGARCIA/perl-5.9.3.tar.gz",
},
"5.9.4" => {
"tar.gz" => "R/RG/RGARCIA/perl-5.9.4.tar.gz",
},
"5.9.5" => {
"tar.gz" => "R/RG/RGARCIA/perl-5.9.5.tar.gz",
},
};
sub perl_tarballs {
my $vers = shift;
$vers = shift if eval { $vers->isa(__PACKAGE__) };
return unless exists $data->{ $vers };
return { %{ $data->{ $vers } } };
}
q|Acme::Why::Did::I::Not::Read::The::Fecking::Memo|;
__END__
=pod
=head1 NAME
CPAN::Perl::Releases - Mapping Perl releases on CPAN to the location of the tarballs
=head1 VERSION
version 1.08
=head1 SYNOPSIS
use CPAN::Perl::Releases qw[perl_tarballs];
my $perl = '5.14.0';
my $hashref = perl_tarballs( $perl );
print "Location: ", $_, "\n" for values %{ $hashref };
=head1 DESCRIPTION
CPAN::Perl::Releases is a module that contains the mappings of all C<perl> releases that have been uploaded to CPAN to the
C<authors/id/> path that the tarballs reside in.
This is static data, but newer versions of this module will be made available as new releases of C<perl> are uploaded to CPAN.
=head1 FUNCTIONS
=over
=item C<perl_tarballs>
Takes one parameter, a C<perl> version to search for. Returns an hashref on success or C<undef> otherwise.
The returned hashref will have a key/value for each type of tarball. A key of C<tar.gz> indicates the location
of a gzipped tar file and C<tar.bz2> of a bzip2'd tar file. The values will be the relative path under C<authors/id/>
on CPAN where the indicated tarball will be located.
perl_tarballs( '5.14.0' );
Returns a hashref like:
{
"tar.bz2" => "J/JE/JESSE/perl-5.14.0.tar.bz2",
"tar.gz" => "J/JE/JESSE/perl-5.14.0.tar.gz"
}
Not all C<perl> releases had C<tar.bz2>, but only a C<tar.gz>.
=back
=head1 SEE ALSO
L<http://www.cpan.org/src/5.0/>
L<http://search.cpan.org/faq.html#Is_there_a_API?>
=head1 AUTHOR
Chris Williams <chris@bingosnet.co.uk>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2013 by Chris Williams.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
CPAN_PERL_RELEASES
$fatpacked{"Devel/InnerPackage.pm"} = <<'DEVEL_INNERPACKAGE';
package Devel::InnerPackage;
use strict;
use base qw(Exporter);
use vars qw($VERSION @EXPORT_OK);
use if $] > 5.017, 'deprecate';
$VERSION = '0.4';
@EXPORT_OK = qw(list_packages);
=pod
=head1 NAME
Devel::InnerPackage - find all the inner packages of a package
=head1 SYNOPSIS
use Foo::Bar;
use Devel::InnerPackage qw(list_packages);
my @inner_packages = list_packages('Foo::Bar');
=head1 DESCRIPTION
Given a file like this
package Foo::Bar;
sub foo {}
package Foo::Bar::Quux;
sub quux {}
package Foo::Bar::Quirka;
sub quirka {}
1;
then
list_packages('Foo::Bar');
will return
Foo::Bar::Quux
Foo::Bar::Quirka
=head1 METHODS
=head2 list_packages <package name>
Return a list of all inner packages of that package.
=cut
sub list_packages {
my $pack = shift; $pack .= "::" unless $pack =~ m!::$!;
no strict 'refs';
my @packs;
my @stuff = grep !/^(main|)::$/, keys %{$pack};
for my $cand (grep /::$/, @stuff)
{
$cand =~ s!::$!!;
my @children = list_packages($pack.$cand);
push @packs, "$pack$cand" unless $cand =~ /^::/ ||
!__PACKAGE__->_loaded($pack.$cand); # or @children;
push @packs, @children;
}
return grep {$_ !~ /::(::ISA::CACHE|SUPER)/} @packs;
}
### XXX this is an inlining of the Class-Inspector->loaded()
### method, but inlined to remove the dependency.
sub _loaded {
my ($class, $name) = @_;
no strict 'refs';
# Handle by far the two most common cases
# This is very fast and handles 99% of cases.
return 1 if defined ${"${name}::VERSION"};
return 1 if @{"${name}::ISA"};
# Are there any symbol table entries other than other namespaces
foreach ( keys %{"${name}::"} ) {
next if substr($_, -2, 2) eq '::';
return 1 if defined &{"${name}::$_"};
}
# No functions, and it doesn't have a version, and isn't anything.
# As an absolute last resort, check for an entry in %INC
my $filename = join( '/', split /(?:'|::)/, $name ) . '.pm';
return 1 if defined $INC{$filename};
'';
}
=head1 AUTHOR
Simon Wistow <simon@thegestalt.org>
=head1 COPYING
Copyright, 2005 Simon Wistow
Distributed under the same terms as Perl itself.
=head1 BUGS
None known.
=cut
1;
DEVEL_INNERPACKAGE
$fatpacked{"Devel/PatchPerl.pm"} = <<'DEVEL_PATCHPERL';
package Devel::PatchPerl;
{
$Devel::PatchPerl::VERSION = '0.84';
}
# ABSTRACT: Patch perl source a la Devel::PPPort's buildperl.pl
use strict;
use warnings;
use File::pushd qw[pushd];
use File::Spec;
use IO::File;
use Devel::PatchPerl::Hints qw[hint_file];
use Module::Pluggable search_path => ['Devel::PatchPerl::Plugin'];
use vars qw[@ISA @EXPORT_OK];
@ISA = qw(Exporter);
@EXPORT_OK = qw(patch_source);
my $patch_exe = _can_run('patch');
my @patch = (
{
perl => [
qr/^5\.00[01234]/,
qw/
5.005
5.005_01
5.005_02
5.005_03
/,
],
subs => [
[ \&_patch_db, 1 ],
],
},
{
perl => [
qw/
5.6.0
5.6.1
5.7.0
5.7.1
5.7.2
5.7.3
5.8.0
/,
],
subs => [
[ \&_patch_db, 3 ],
],
},
{
perl => [
qr/^5\.004_0[1234]$/,
],
subs => [
[ \&_patch_doio ],
],
},
{
perl => [
qw/
5.005
5.005_01
5.005_02
/,
],
subs => [
[ \&_patch_sysv, old_format => 1 ],
],
},
{
perl => [
qw/
5.005_03
5.005_04
/,
qr/^5\.6\.[0-2]$/,
qr/^5\.7\.[0-3]$/,
qr/^5\.8\.[0-8]$/,
qr/^5\.9\.[0-5]$/
],
subs => [
[ \&_patch_sysv, old_format => 0 ],
],
},
{
perl => [
qr/^5\.004_05$/,
qr/^5\.005(?:_0[1-4])?$/,
qr/^5\.6\.[01]$/,
],
subs => [
[ \&_patch_configure ],
[ \&_patch_makedepend_lc ],
],
},
{
perl => [
'5.8.0',
],
subs => [
[ \&_patch_makedepend_lc ],
],
},
{
perl => [
qr/.*/,
],
subs => [
[ \&_patch_hints ],
],
},
{
perl => [
qr/^5\.6\.[0-2]$/,
qr/^5\.7\.[0-3]$/,
qr/^5\.8\.[0-8]$/,
],
subs => [
[ \&_patch_makedepend_SH ],
],
},
{
perl => [
qr/^5\.1[0-2]/,
],
subs => [
[ \&_patch_archive_tar_tests ],
[ \&_patch_odbm_file_hints_linux ],
],
},
{
perl => [
qr/^5.1([24].\d+|0.1)/,
],
subs => [
[ \&_patch_make_ext_pl ],
],
},
{
perl => [ qr/^5\.8\.9$/, ],
subs => [ [ \&_patch_589_perlio_c ], ],
},
);
sub patch_source {
my $vers = shift;
$vers = shift if eval { $vers->isa(__PACKAGE__) };
my $source = shift || '.';
if ( !$vers ) {
$vers = _determine_version($source);
if ( $vers ) {
warn "Auto-guessed '$vers'\n";
}
else {
die "You didn't provide a perl version and I don't appear to be in a perl source tree\n";
}
}
$source = File::Spec->rel2abs($source);
{
my $dir = pushd( $source );
for my $p ( grep { _is( $_->{perl}, $vers ) } @patch ) {
for my $s (@{$p->{subs}}) {
my($sub, @args) = @$s;
push @args, $vers unless scalar @args;
$sub->(@args);
}
}
_process_plugin( version => $vers, source => $source, patchexe => $patch_exe );
}
}
sub _process_plugin {
my %args = @_;
return unless my $possible = $ENV{PERL5_PATCHPERL_PLUGIN};
my ($plugin) = grep { $possible eq $_ or /\Q$possible\E$/ } __PACKAGE__->plugins;
unless ( $plugin ) {
warn "# You specified a plugin '", $ENV{PERL5_PATCHPERL_PLUGIN},
"' that isn't installed, just thought you might be interested.\n";
return;
}
{
local $@;
eval "require $plugin";
if ($@) {
die "# I tried to load '", $ENV{PERL5_PATCHPERL_PLUGIN},
"' but it didn't work out. Here is what happened '$@'\n";
}
}
{
local $@;
eval {
$plugin->patchperl(
%args,
);
};
if ($@) {
warn "# Warnings from the plugin: '$@'\n";
}
}
return 1;
}
sub _can_run {
my $command = shift;
# a lot of VMS executables have a symbol defined
# check those first
if ( $^O eq 'VMS' ) {
require VMS::DCLsym;
my $syms = VMS::DCLsym->new;
return $command if scalar $syms->getsym( uc $command );
}
require File::Spec;
require ExtUtils::MakeMaker;
my @possibles;
if( File::Spec->file_name_is_absolute($command) ) {
return MM->maybe_command($command);
} else {
for my $dir (
File::Spec->path,
File::Spec->curdir
) {
next if ! $dir || ! -d $dir;
my $abs = File::Spec->catfile( $^O eq 'MSWin32' ? Win32::GetShortPathName( $dir ) : $dir, $command);
push @possibles, $abs if $abs = MM->maybe_command($abs);
}
}
return @possibles if wantarray;
return shift @possibles;
}
sub _is
{
my($s1, $s2) = @_;
defined $s1 != defined $s2 and return 0;
ref $s2 and ($s1, $s2) = ($s2, $s1);
if (ref $s1) {
if (ref $s1 eq 'ARRAY') {
_is($_, $s2) and return 1 for @$s1;
return 0;
}
return $s2 =~ $s1;
}
return $s1 eq $s2;
}
sub _patch
{
my($patch) = @_;
print "patching $_\n" for $patch =~ /^\+{3}\s+(\S+)/gm;
my $diff = 'tmp.diff';
_write_or_die($diff, $patch);
die "No patch utility found\n" unless $patch_exe;
_run_or_die("$patch_exe -f -s -p0 <$diff");
unlink $diff or die "unlink $diff: $!\n";
}
sub _write_or_die
{
my($file, $data) = @_;
my $fh = IO::File->new(">$file") or die "$file: $!\n";
$fh->print($data);
}
sub _run_or_die
{
# print "[running @_]\n";
die unless system( @_ ) == 0;
}
sub _determine_version {
my ($source) = @_;
my $patchlevel_h = File::Spec->catfile($source, 'patchlevel.h');
return unless -e $patchlevel_h;
my $version;
{
my %defines;
open my $fh, '<', $patchlevel_h;
my @vers;
while (<$fh>) {
chomp;
next unless /^#define/;
my ($foo,$bar) = ( split /\s+/ )[1,2];
$defines{$foo} = $bar;
}
if ( my @wotsits = grep { defined $defines{$_} } qw(PERL_REVISION PERL_VERSION PERL_SUBVERSION) ) {
$version = join '.', map { $defines{$_} } @wotsits;
}
else {
$version = sprintf '5.%03d_%02d', map { $defines{$_} } qw(PATCHLEVEL SUBVERSION);
}
}
return $version;
}
sub _patch_hints {
my @os;
push @os, $^O;
push @os, 'linux' if $^O eq 'gnukfreebsd'; # kfreebsd uses linux hints
foreach my $os ( @os ) {
return unless my ($file,$data) = hint_file( $os );
my $path = File::Spec->catfile( 'hints', $file );
chmod 0644, $path or die "$!\n";
open my $fh, '>', $path or die "$!\n";
print $fh $data;
close $fh;
}
return 1;
}
sub _patch_db
{
my $ver = shift;
print "patching ext/DB_File/DB_File.xs\n";
_run_or_die($^X, '-pi.bak', '-e', "s/<db.h>/<db$ver\\/db.h>/", 'ext/DB_File/DB_File.xs');
unlink 'ext/DB_File/DB_File.xs.bak' if -e 'ext/DB_File/DB_File.xs.bak';
}
sub _patch_doio
{
_patch(<<'END');
--- doio.c.org 2004-06-07 23:14:45.000000000 +0200
+++ doio.c 2003-11-04 08:03:03.000000000 +0100
@@ -75,6 +75,16 @@
# endif
#endif
+#if _SEM_SEMUN_UNDEFINED
+union semun
+{
+ int val;
+ struct semid_ds *buf;
+ unsigned short int *array;
+ struct seminfo *__buf;
+};
+#endif
+
bool
do_open(gv,name,len,as_raw,rawmode,rawperm,supplied_fp)
GV *gv;
END
}
sub _patch_sysv
{
my %opt = @_;
# check if patching is required
return if $^O ne 'linux' or -f '/usr/include/asm/page.h';
if ($opt{old_format}) {
_patch(<<'END');
--- ext/IPC/SysV/SysV.xs.org 1998-07-20 10:20:07.000000000 +0200
+++ ext/IPC/SysV/SysV.xs 2007-08-12 10:51:06.000000000 +0200
@@ -3,9 +3,6 @@
#include "XSUB.h"
#include <sys/types.h>
-#ifdef __linux__
-#include <asm/page.h>
-#endif
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
#include <sys/ipc.h>
#ifdef HAS_MSG
END
}
else {
_patch(<<'END');
--- ext/IPC/SysV/SysV.xs.org 2007-08-11 00:12:46.000000000 +0200
+++ ext/IPC/SysV/SysV.xs 2007-08-11 00:10:51.000000000 +0200
@@ -3,9 +3,6 @@
#include "XSUB.h"
#include <sys/types.h>
-#ifdef __linux__
-# include <asm/page.h>
-#endif
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
#ifndef HAS_SEM
# include <sys/ipc.h>
END
}
}
sub _patch_configure
{
_patch(<<'END');
--- Configure
+++ Configure
@@ -3380,6 +3380,18 @@
test "X$gfpthkeep" != Xy && gfpth=""
EOSC
+# gcc 3.1 complains about adding -Idirectories that it already knows about,
+# so we will take those off from locincpth.
+case "$gccversion" in
+3*)
+ echo "main(){}">try.c
+ for incdir in `$cc -v -c try.c 2>&1 | \
+ sed '1,/^#include <\.\.\.>/d;/^End of search list/,$d;s/^ //'` ; do
+ locincpth=`echo $locincpth | sed s!$incdir!!`
+ done
+ $rm -f try try.*
+esac
+
: What should the include directory be ?
echo " "
$echo $n "Hmm... $c"
END
}
sub _patch_makedepend_lc
{
_patch(<<'END');
--- makedepend.SH
+++ makedepend.SH
@@ -58,6 +58,10 @@ case $PERL_CONFIG_SH in
;;
esac
+# Avoid localized gcc/cc messages
+LC_ALL=C
+export LC_ALL
+
# We need .. when we are in the x2p directory if we are using the
# cppstdin wrapper script.
# Put .. and . first so that we pick up the present cppstdin, not
END
}
sub _patch_makedepend_SH
{
my $perl = shift;
SWITCH: {
# If 5.6.0
if ( $perl eq '5.6.0' ) {
_patch(<<'BADGER');
--- makedepend.SH.org 2000-03-02 18:12:26.000000000 +0000
+++ makedepend.SH 2010-09-01 10:13:37.000000000 +0100
@@ -1,5 +1,5 @@
#! /bin/sh
-case $CONFIGDOTSH in
+case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
@@ -29,6 +29,13 @@
!GROK!THIS!
$spitshell >>makedepend <<'!NO!SUBS!'
+if test -d .depending; then
+ echo "$0: Already running, exiting."
+ exit 0
+fi
+
+mkdir .depending
+
# This script should be called with
# sh ./makedepend MAKE=$(MAKE)
case "$1" in
@@ -37,7 +44,7 @@
export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$)
-case $CONFIGDOTSH in
+case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
@@ -51,6 +58,11 @@
;;
esac
+# Avoid localized gcc messages
+case "$ccname" in
+ gcc) LC_ALL=C ; export LC_ALL ;;
+esac
+
# We need .. when we are in the x2p directory if we are using the
# cppstdin wrapper script.
# Put .. and . first so that we pick up the present cppstdin, not
@@ -58,6 +70,10 @@
PATH=".$path_sep..$path_sep$PATH"
export PATH
+case "$osname" in
+amigaos) cat=/bin/cat ;; # must be absolute
+esac
+
$cat /dev/null >.deptmp
$rm -f *.c.c c/*.c.c
if test -f Makefile; then
@@ -67,7 +83,6 @@
# to be out of date. I don't know if OS/2 has touch, so do this:
case "$osname" in
os2) ;;
- netbsd) ;;
*) $touch $firstmakefile ;;
esac
fi
@@ -99,25 +114,20 @@
$echo *.c | $tr ' ' $trnl | $egrep -v '\*' >.clist)
for file in `$cat .clist`; do
# for file in `cat /dev/null`; do
- if [ "$osname" = uwin ]; then
- uwinfix="-e s,\\\\\\\\,/,g -e s,\\([a-zA-Z]\\):/,/\\1/,g"
- else
- if [ "$osname" = os2 ]; then
- uwinfix="-e s,\\\\\\\\,/,g"
- else
- if [ "$archname" = cygwin ]; then
- uwinfix="-e s,\\\\\\\\,/,g"
- else
- uwinfix=
- fi
- fi
- fi
+ case "$osname" in
+ uwin) uwinfix="-e s,\\\\\\\\,/,g -e s,\\([a-zA-Z]\\):/,/\\1/,g" ;;
+ os2) uwinfix="-e s,\\\\\\\\,/,g" ;;
+ cygwin) uwinfix="-e s,\\\\\\\\,/,g" ;;
+ posix-bc) uwinfix="-e s/\\*POSIX(\\(.*\\))/\\1/" ;;
+ vos) uwinfix="-e s/\#/\\\#/" ;;
+ *) uwinfix="" ;;
+ esac
case "$file" in
*.c) filebase=`basename $file .c` ;;
*.y) filebase=`basename $file .y` ;;
esac
case "$file" in
- */*) finc="-I`echo $file | sed 's#/[^/]*$##`" ;;
+ */*) finc="-I`echo $file | sed 's#/[^/]*$##'`" ;;
*) finc= ;;
esac
$echo "Finding dependencies for $filebase$_o."
@@ -130,22 +140,45 @@
-e 's|\\$||' \
-e p \
-e '}' ) >UU/$file.c
+
if [ "$osname" = os390 -a "$file" = perly.c ]; then
$echo '#endif' >>UU/$file.c
fi
- $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c |
- $sed \
- -e '1d' \
- -e '/^#.*<stdin>/d' \
- -e '/^#.*"-"/d' \
- -e 's#\.[0-9][0-9]*\.c#'"$file.c#" \
- -e 's/^[ ]*#[ ]*line/#/' \
- -e '/^# *[0-9][0-9]* *[".\/]/!d' \
- -e 's/^.*"\(.*\)".*$/'$filebase'\$(OBJ_EXT): \1/' \
- -e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'\$(OBJ_EXT): \1/' \
- -e 's|: \./|: |' \
- -e 's|\.c\.c|.c|' $uwinfix | \
- $uniq | $sort | $uniq >> .deptmp
+
+ if [ "$osname" = os390 ]; then
+ $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c |
+ $sed \
+ -e '/^#.*<stdin>/d' \
+ -e '/^#.*"-"/d' \
+ -e 's#\.[0-9][0-9]*\.c#'"$file.c#" \
+ -e 's/^[ ]*#[ ]*line/#/' \
+ -e '/^# *[0-9][0-9]* *[".\/]/!d' \
+ -e 's/^.*"\(.*\)".*$/'$filebase'\$(OBJ_EXT): \1/' \
+ -e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'\$(OBJ_EXT): \1/' \
+ -e 's|: \./|: |' \
+ -e 's|\.c\.c|.c|' $uwinfix | \
+ $uniq | $sort | $uniq >> .deptmp
+ else
+ $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c >.cout 2>.cerr
+ $sed \
+ -e '1d' \
+ -e '/^#.*<stdin>/d' \
+ -e '/^#.*<builtin>/d' \
+ -e '/^#.*<built-in>/d' \
+ -e '/^#.*<command line>/d' \
+ -e '/^#.*<command-line>/d' \
+ -e '/^#.*"-"/d' \
+ -e '/^#.*"\/.*\/"/d' \
+ -e '/: file path prefix .* never used$/d' \
+ -e 's#\.[0-9][0-9]*\.c#'"$file.c#" \
+ -e 's/^[ ]*#[ ]*line/#/' \
+ -e '/^# *[0-9][0-9]* *[".\/]/!d' \
+ -e 's/^.*"\(.*\)".*$/'$filebase'\$(OBJ_EXT): \1/' \
+ -e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'\$(OBJ_EXT): \1/' \
+ -e 's|: \./|: |' \
+ -e 's|\.c\.c|.c|' $uwinfix .cout .cerr| \
+ $uniq | $sort | $uniq >> .deptmp
+ fi
done
$sed <$mf >$mf.new -e '1,/^# AUTOMATICALLY/!d'
@@ -177,6 +210,10 @@
$echo "Updating $mf..."
$echo "# If this runs make out of memory, delete /usr/include lines." \
>> $mf.new
+ if [ "$osname" = vos ]; then
+ $sed 's|.incl.c|.h|' .deptmp >.deptmp.vos
+ mv -f .deptmp.vos .deptmp
+ fi
$sed 's|^\(.*\$(OBJ_EXT):\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \
>>$mf.new
else
@@ -208,7 +245,8 @@
$cp $mf.new $mf
$rm $mf.new
$echo "# WARNING: Put nothing here or make depend will gobble it up!" >> $mf
-$rm -rf .deptmp UU .shlist .clist .hlist .hsed
+$rm -rf .deptmp UU .shlist .clist .hlist .hsed .cout .cerr
+rmdir .depending
!NO!SUBS!
$eunicefix makedepend
BADGER
last SWITCH;
}
# If 5.6.1
if ( $perl eq '5.6.1' ) {
_patch(<<'BADGER');
--- makedepend.SH.org 2001-03-19 07:33:17.000000000 +0000
+++ makedepend.SH 2010-09-01 10:14:47.000000000 +0100
@@ -1,5 +1,5 @@
#! /bin/sh
-case $CONFIGDOTSH in
+case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
@@ -29,6 +29,13 @@
!GROK!THIS!
$spitshell >>makedepend <<'!NO!SUBS!'
+if test -d .depending; then
+ echo "$0: Already running, exiting."
+ exit 0
+fi
+
+mkdir .depending
+
# This script should be called with
# sh ./makedepend MAKE=$(MAKE)
case "$1" in
@@ -37,7 +44,7 @@
export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$)
-case $CONFIGDOTSH in
+case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
@@ -51,6 +58,11 @@
;;
esac
+# Avoid localized gcc messages
+case "$ccname" in
+ gcc) LC_ALL=C ; export LC_ALL ;;
+esac
+
# We need .. when we are in the x2p directory if we are using the
# cppstdin wrapper script.
# Put .. and . first so that we pick up the present cppstdin, not
@@ -58,6 +70,10 @@
PATH=".$path_sep..$path_sep$PATH"
export PATH
+case "$osname" in
+amigaos) cat=/bin/cat ;; # must be absolute
+esac
+
$cat /dev/null >.deptmp
$rm -f *.c.c c/*.c.c
if test -f Makefile; then
@@ -67,7 +83,6 @@
# to be out of date. I don't know if OS/2 has touch, so do this:
case "$osname" in
os2) ;;
- netbsd) ;;
*) $touch $firstmakefile ;;
esac
fi
@@ -99,29 +114,20 @@
$echo *.c | $tr ' ' $trnl | $egrep -v '\*' >.clist)
for file in `$cat .clist`; do
# for file in `cat /dev/null`; do
- if [ "$osname" = uwin ]; then
- uwinfix="-e s,\\\\\\\\,/,g -e s,\\([a-zA-Z]\\):/,/\\1/,g"
- else
- if [ "$osname" = os2 ]; then
- uwinfix="-e s,\\\\\\\\,/,g"
- else
- if [ "$archname" = cygwin ]; then
- uwinfix="-e s,\\\\\\\\,/,g"
- else
- if [ "$osname" = posix-bc ]; then
- uwinfix="-e s/\\*POSIX(\\(.*\\))/\\1/"
- else
- uwinfix=
- fi
- fi
- fi
- fi
+ case "$osname" in
+ uwin) uwinfix="-e s,\\\\\\\\,/,g -e s,\\([a-zA-Z]\\):/,/\\1/,g" ;;
+ os2) uwinfix="-e s,\\\\\\\\,/,g" ;;
+ cygwin) uwinfix="-e s,\\\\\\\\,/,g" ;;
+ posix-bc) uwinfix="-e s/\\*POSIX(\\(.*\\))/\\1/" ;;
+ vos) uwinfix="-e s/\#/\\\#/" ;;
+ *) uwinfix="" ;;
+ esac
case "$file" in
*.c) filebase=`basename $file .c` ;;
*.y) filebase=`basename $file .y` ;;
esac
case "$file" in
- */*) finc="-I`echo $file | sed 's#/[^/]*$##`" ;;
+ */*) finc="-I`echo $file | sed 's#/[^/]*$##'`" ;;
*) finc= ;;
esac
$echo "Finding dependencies for $filebase$_o."
@@ -134,10 +140,12 @@
-e 's|\\$||' \
-e p \
-e '}' ) >UU/$file.c
+
+ if [ "$osname" = os390 -a "$file" = perly.c ]; then
+ $echo '#endif' >>UU/$file.c
+ fi
+
if [ "$osname" = os390 ]; then
- if [ "$file" = perly.c ]; then
- $echo '#endif' >>UU/$file.c
- fi
$cppstdin $finc -I. $cppflags $cppminus <UU/$file.c |
$sed \
-e '/^#.*<stdin>/d' \
@@ -151,18 +159,24 @@
-e 's|\.c\.c|.c|' $uwinfix | \
$uniq | $sort | $uniq >> .deptmp
else
- $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c |
+ $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c >.cout 2>.cerr
$sed \
-e '1d' \
-e '/^#.*<stdin>/d' \
+ -e '/^#.*<builtin>/d' \
+ -e '/^#.*<built-in>/d' \
+ -e '/^#.*<command line>/d' \
+ -e '/^#.*<command-line>/d' \
-e '/^#.*"-"/d' \
+ -e '/^#.*"\/.*\/"/d' \
+ -e '/: file path prefix .* never used$/d' \
-e 's#\.[0-9][0-9]*\.c#'"$file.c#" \
-e 's/^[ ]*#[ ]*line/#/' \
-e '/^# *[0-9][0-9]* *[".\/]/!d' \
-e 's/^.*"\(.*\)".*$/'$filebase'\$(OBJ_EXT): \1/' \
-e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'\$(OBJ_EXT): \1/' \
-e 's|: \./|: |' \
- -e 's|\.c\.c|.c|' $uwinfix | \
+ -e 's|\.c\.c|.c|' $uwinfix .cout .cerr| \
$uniq | $sort | $uniq >> .deptmp
fi
done
@@ -196,6 +210,10 @@
$echo "Updating $mf..."
$echo "# If this runs make out of memory, delete /usr/include lines." \
>> $mf.new
+ if [ "$osname" = vos ]; then
+ $sed 's|.incl.c|.h|' .deptmp >.deptmp.vos
+ mv -f .deptmp.vos .deptmp
+ fi
$sed 's|^\(.*\$(OBJ_EXT):\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \
>>$mf.new
else
@@ -227,7 +245,8 @@
$cp $mf.new $mf
$rm $mf.new
$echo "# WARNING: Put nothing here or make depend will gobble it up!" >> $mf
-$rm -rf .deptmp UU .shlist .clist .hlist .hsed
+$rm -rf .deptmp UU .shlist .clist .hlist .hsed .cout .cerr
+rmdir .depending
!NO!SUBS!
$eunicefix makedepend
BADGER
last SWITCH;
}
# If 5.6.2
if ( $perl eq '5.6.2' ) {
_patch(<<'BADGER');
--- makedepend.SH.org 2003-07-30 23:46:59.000000000 +0100
+++ makedepend.SH 2010-09-01 10:15:47.000000000 +0100
@@ -1,5 +1,5 @@
#! /bin/sh
-case $CONFIGDOTSH in
+case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
@@ -29,6 +29,13 @@
!GROK!THIS!
$spitshell >>makedepend <<'!NO!SUBS!'
+if test -d .depending; then
+ echo "$0: Already running, exiting."
+ exit 0
+fi
+
+mkdir .depending
+
# This script should be called with
# sh ./makedepend MAKE=$(MAKE)
case "$1" in
@@ -37,7 +44,7 @@
export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$)
-case $CONFIGDOTSH in
+case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
@@ -63,6 +70,10 @@
PATH=".$path_sep..$path_sep$PATH"
export PATH
+case "$osname" in
+amigaos) cat=/bin/cat ;; # must be absolute
+esac
+
$cat /dev/null >.deptmp
$rm -f *.c.c c/*.c.c
if test -f Makefile; then
@@ -72,7 +83,6 @@
# to be out of date. I don't know if OS/2 has touch, so do this:
case "$osname" in
os2) ;;
- netbsd) ;;
*) $touch $firstmakefile ;;
esac
fi
@@ -104,29 +114,20 @@
$echo *.c | $tr ' ' $trnl | $egrep -v '\*' >.clist)
for file in `$cat .clist`; do
# for file in `cat /dev/null`; do
- if [ "$osname" = uwin ]; then
- uwinfix="-e s,\\\\\\\\,/,g -e s,\\([a-zA-Z]\\):/,/\\1/,g"
- else
- if [ "$osname" = os2 ]; then
- uwinfix="-e s,\\\\\\\\,/,g"
- else
- if [ "$archname" = cygwin ]; then
- uwinfix="-e s,\\\\\\\\,/,g"
- else
- if [ "$osname" = posix-bc ]; then
- uwinfix="-e s/\\*POSIX(\\(.*\\))/\\1/"
- else
- uwinfix=
- fi
- fi
- fi
- fi
+ case "$osname" in
+ uwin) uwinfix="-e s,\\\\\\\\,/,g -e s,\\([a-zA-Z]\\):/,/\\1/,g" ;;
+ os2) uwinfix="-e s,\\\\\\\\,/,g" ;;
+ cygwin) uwinfix="-e s,\\\\\\\\,/,g" ;;
+ posix-bc) uwinfix="-e s/\\*POSIX(\\(.*\\))/\\1/" ;;
+ vos) uwinfix="-e s/\#/\\\#/" ;;
+ *) uwinfix="" ;;
+ esac
case "$file" in
*.c) filebase=`basename $file .c` ;;
*.y) filebase=`basename $file .y` ;;
esac
case "$file" in
- */*) finc="-I`echo $file | sed 's#/[^/]*$##`" ;;
+ */*) finc="-I`echo $file | sed 's#/[^/]*$##'`" ;;
*) finc= ;;
esac
$echo "Finding dependencies for $filebase$_o."
@@ -139,10 +140,12 @@
-e 's|\\$||' \
-e p \
-e '}' ) >UU/$file.c
+
+ if [ "$osname" = os390 -a "$file" = perly.c ]; then
+ $echo '#endif' >>UU/$file.c
+ fi
+
if [ "$osname" = os390 ]; then
- if [ "$file" = perly.c ]; then
- $echo '#endif' >>UU/$file.c
- fi
$cppstdin $finc -I. $cppflags $cppminus <UU/$file.c |
$sed \
-e '/^#.*<stdin>/d' \
@@ -156,21 +159,24 @@
-e 's|\.c\.c|.c|' $uwinfix | \
$uniq | $sort | $uniq >> .deptmp
else
- $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c |
+ $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c >.cout 2>.cerr
$sed \
-e '1d' \
-e '/^#.*<stdin>/d' \
- -e '/^#.*<builtin>/d' \
- -e '/^#.*<built-in>/d' \
- -e '/^#.*<command line>/d' \
+ -e '/^#.*<builtin>/d' \
+ -e '/^#.*<built-in>/d' \
+ -e '/^#.*<command line>/d' \
+ -e '/^#.*<command-line>/d' \
-e '/^#.*"-"/d' \
+ -e '/^#.*"\/.*\/"/d' \
+ -e '/: file path prefix .* never used$/d' \
-e 's#\.[0-9][0-9]*\.c#'"$file.c#" \
-e 's/^[ ]*#[ ]*line/#/' \
-e '/^# *[0-9][0-9]* *[".\/]/!d' \
-e 's/^.*"\(.*\)".*$/'$filebase'\$(OBJ_EXT): \1/' \
-e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'\$(OBJ_EXT): \1/' \
-e 's|: \./|: |' \
- -e 's|\.c\.c|.c|' $uwinfix | \
+ -e 's|\.c\.c|.c|' $uwinfix .cout .cerr| \
$uniq | $sort | $uniq >> .deptmp
fi
done
@@ -204,6 +210,10 @@
$echo "Updating $mf..."
$echo "# If this runs make out of memory, delete /usr/include lines." \
>> $mf.new
+ if [ "$osname" = vos ]; then
+ $sed 's|.incl.c|.h|' .deptmp >.deptmp.vos
+ mv -f .deptmp.vos .deptmp
+ fi
$sed 's|^\(.*\$(OBJ_EXT):\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \
>>$mf.new
else
@@ -235,7 +245,8 @@
$cp $mf.new $mf
$rm $mf.new
$echo "# WARNING: Put nothing here or make depend will gobble it up!" >> $mf
-$rm -rf .deptmp UU .shlist .clist .hlist .hsed
+$rm -rf .deptmp UU .shlist .clist .hlist .hsed .cout .cerr
+rmdir .depending
!NO!SUBS!
$eunicefix makedepend
BADGER
last SWITCH;
}
# If 5.7.0
if ( $perl eq '5.7.0' ) {
_patch(<<'BADGER');
--- makedepend.SH.org 2000-08-13 19:35:04.000000000 +0100
+++ makedepend.SH 2010-09-01 10:47:14.000000000 +0100
@@ -1,5 +1,5 @@
#! /bin/sh
-case $CONFIGDOTSH in
+case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
@@ -29,6 +29,13 @@
!GROK!THIS!
$spitshell >>makedepend <<'!NO!SUBS!'
+if test -d .depending; then
+ echo "$0: Already running, exiting."
+ exit 0
+fi
+
+mkdir .depending
+
# This script should be called with
# sh ./makedepend MAKE=$(MAKE)
case "$1" in
@@ -37,7 +44,7 @@
export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$)
-case $CONFIGDOTSH in
+case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
@@ -51,6 +58,11 @@
;;
esac
+# Avoid localized gcc messages
+case "$ccname" in
+ gcc) LC_ALL=C ; export LC_ALL ;;
+esac
+
# We need .. when we are in the x2p directory if we are using the
# cppstdin wrapper script.
# Put .. and . first so that we pick up the present cppstdin, not
@@ -58,6 +70,10 @@
PATH=".$path_sep..$path_sep$PATH"
export PATH
+case "$osname" in
+amigaos) cat=/bin/cat ;; # must be absolute
+esac
+
$cat /dev/null >.deptmp
$rm -f *.c.c c/*.c.c
if test -f Makefile; then
@@ -67,7 +83,6 @@
# to be out of date. I don't know if OS/2 has touch, so do this:
case "$osname" in
os2) ;;
- netbsd) ;;
*) $touch $firstmakefile ;;
esac
fi
@@ -99,25 +114,20 @@
$echo *.c | $tr ' ' $trnl | $egrep -v '\*' >.clist)
for file in `$cat .clist`; do
# for file in `cat /dev/null`; do
- if [ "$osname" = uwin ]; then
- uwinfix="-e s,\\\\\\\\,/,g -e s,\\([a-zA-Z]\\):/,/\\1/,g"
- else
- if [ "$osname" = os2 ]; then
- uwinfix="-e s,\\\\\\\\,/,g"
- else
- if [ "$archname" = cygwin ]; then
- uwinfix="-e s,\\\\\\\\,/,g"
- else
- uwinfix=
- fi
- fi
- fi
+ case "$osname" in
+ uwin) uwinfix="-e s,\\\\\\\\,/,g -e s,\\([a-zA-Z]\\):/,/\\1/,g" ;;
+ os2) uwinfix="-e s,\\\\\\\\,/,g" ;;
+ cygwin) uwinfix="-e s,\\\\\\\\,/,g" ;;
+ posix-bc) uwinfix="-e s/\\*POSIX(\\(.*\\))/\\1/" ;;
+ vos) uwinfix="-e s/\#/\\\#/" ;;
+ *) uwinfix="" ;;
+ esac
case "$file" in
*.c) filebase=`basename $file .c` ;;
*.y) filebase=`basename $file .y` ;;
esac
case "$file" in
- */*) finc="-I`echo $file | sed 's#/[^/]*$##`" ;;
+ */*) finc="-I`echo $file | sed 's#/[^/]*$##'`" ;;
*) finc= ;;
esac
$echo "Finding dependencies for $filebase$_o."
@@ -130,10 +140,12 @@
-e 's|\\$||' \
-e p \
-e '}' ) >UU/$file.c
+
+ if [ "$osname" = os390 -a "$file" = perly.c ]; then
+ $echo '#endif' >>UU/$file.c
+ fi
+
if [ "$osname" = os390 ]; then
- if [ "$file" = perly.c ]; then
- $echo '#endif' >>UU/$file.c
- fi
$cppstdin $finc -I. $cppflags $cppminus <UU/$file.c |
$sed \
-e '/^#.*<stdin>/d' \
@@ -147,18 +159,24 @@
-e 's|\.c\.c|.c|' $uwinfix | \
$uniq | $sort | $uniq >> .deptmp
else
- $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c |
+ $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c >.cout 2>.cerr
$sed \
-e '1d' \
-e '/^#.*<stdin>/d' \
+ -e '/^#.*<builtin>/d' \
+ -e '/^#.*<built-in>/d' \
+ -e '/^#.*<command line>/d' \
+ -e '/^#.*<command-line>/d' \
-e '/^#.*"-"/d' \
+ -e '/^#.*"\/.*\/"/d' \
+ -e '/: file path prefix .* never used$/d' \
-e 's#\.[0-9][0-9]*\.c#'"$file.c#" \
-e 's/^[ ]*#[ ]*line/#/' \
-e '/^# *[0-9][0-9]* *[".\/]/!d' \
-e 's/^.*"\(.*\)".*$/'$filebase'\$(OBJ_EXT): \1/' \
-e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'\$(OBJ_EXT): \1/' \
-e 's|: \./|: |' \
- -e 's|\.c\.c|.c|' $uwinfix | \
+ -e 's|\.c\.c|.c|' $uwinfix .cout .cerr| \
$uniq | $sort | $uniq >> .deptmp
fi
done
@@ -192,6 +210,10 @@
$echo "Updating $mf..."
$echo "# If this runs make out of memory, delete /usr/include lines." \
>> $mf.new
+ if [ "$osname" = vos ]; then
+ $sed 's|.incl.c|.h|' .deptmp >.deptmp.vos
+ mv -f .deptmp.vos .deptmp
+ fi
$sed 's|^\(.*\$(OBJ_EXT):\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \
>>$mf.new
else
@@ -223,7 +245,8 @@
$cp $mf.new $mf
$rm $mf.new
$echo "# WARNING: Put nothing here or make depend will gobble it up!" >> $mf
-$rm -rf .deptmp UU .shlist .clist .hlist .hsed
+$rm -rf .deptmp UU .shlist .clist .hlist .hsed .cout .cerr
+rmdir .depending
!NO!SUBS!
$eunicefix makedepend
BADGER
last SWITCH;
}
# If 5.7.1
if ( $perl eq '5.7.1' ) {
_patch(<<'BADGER');
--- makedepend.SH.org 2001-03-11 16:30:08.000000000 +0000
+++ makedepend.SH 2010-09-01 10:44:54.000000000 +0100
@@ -1,5 +1,5 @@
#! /bin/sh
-case $CONFIGDOTSH in
+case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
@@ -29,6 +29,13 @@
!GROK!THIS!
$spitshell >>makedepend <<'!NO!SUBS!'
+if test -d .depending; then
+ echo "$0: Already running, exiting."
+ exit 0
+fi
+
+mkdir .depending
+
# This script should be called with
# sh ./makedepend MAKE=$(MAKE)
case "$1" in
@@ -37,7 +44,7 @@
export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$)
-case $CONFIGDOTSH in
+case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
@@ -51,6 +58,11 @@
;;
esac
+# Avoid localized gcc messages
+case "$ccname" in
+ gcc) LC_ALL=C ; export LC_ALL ;;
+esac
+
# We need .. when we are in the x2p directory if we are using the
# cppstdin wrapper script.
# Put .. and . first so that we pick up the present cppstdin, not
@@ -58,6 +70,10 @@
PATH=".$path_sep..$path_sep$PATH"
export PATH
+case "$osname" in
+amigaos) cat=/bin/cat ;; # must be absolute
+esac
+
$cat /dev/null >.deptmp
$rm -f *.c.c c/*.c.c
if test -f Makefile; then
@@ -67,7 +83,6 @@
# to be out of date. I don't know if OS/2 has touch, so do this:
case "$osname" in
os2) ;;
- netbsd) ;;
*) $touch $firstmakefile ;;
esac
fi
@@ -99,29 +114,20 @@
$echo *.c | $tr ' ' $trnl | $egrep -v '\*' >.clist)
for file in `$cat .clist`; do
# for file in `cat /dev/null`; do
- if [ "$osname" = uwin ]; then
- uwinfix="-e s,\\\\\\\\,/,g -e s,\\([a-zA-Z]\\):/,/\\1/,g"
- else
- if [ "$osname" = os2 ]; then
- uwinfix="-e s,\\\\\\\\,/,g"
- else
- if [ "$archname" = cygwin ]; then
- uwinfix="-e s,\\\\\\\\,/,g"
- else
- if [ "$osname" = posix-bc ]; then
- uwinfix="-e s/\\*POSIX(\\(.*\\))/\\1/"
- else
- uwinfix=
- fi
- fi
- fi
- fi
+ case "$osname" in
+ uwin) uwinfix="-e s,\\\\\\\\,/,g -e s,\\([a-zA-Z]\\):/,/\\1/,g" ;;
+ os2) uwinfix="-e s,\\\\\\\\,/,g" ;;
+ cygwin) uwinfix="-e s,\\\\\\\\,/,g" ;;
+ posix-bc) uwinfix="-e s/\\*POSIX(\\(.*\\))/\\1/" ;;
+ vos) uwinfix="-e s/\#/\\\#/" ;;
+ *) uwinfix="" ;;
+ esac
case "$file" in
*.c) filebase=`basename $file .c` ;;
*.y) filebase=`basename $file .y` ;;
esac
case "$file" in
- */*) finc="-I`echo $file | sed 's#/[^/]*$##`" ;;
+ */*) finc="-I`echo $file | sed 's#/[^/]*$##'`" ;;
*) finc= ;;
esac
$echo "Finding dependencies for $filebase$_o."
@@ -134,10 +140,12 @@
-e 's|\\$||' \
-e p \
-e '}' ) >UU/$file.c
+
+ if [ "$osname" = os390 -a "$file" = perly.c ]; then
+ $echo '#endif' >>UU/$file.c
+ fi
+
if [ "$osname" = os390 ]; then
- if [ "$file" = perly.c ]; then
- $echo '#endif' >>UU/$file.c
- fi
$cppstdin $finc -I. $cppflags $cppminus <UU/$file.c |
$sed \
-e '/^#.*<stdin>/d' \
@@ -151,18 +159,24 @@
-e 's|\.c\.c|.c|' $uwinfix | \
$uniq | $sort | $uniq >> .deptmp
else
- $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c |
+ $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c >.cout 2>.cerr
$sed \
-e '1d' \
-e '/^#.*<stdin>/d' \
+ -e '/^#.*<builtin>/d' \
+ -e '/^#.*<built-in>/d' \
+ -e '/^#.*<command line>/d' \
+ -e '/^#.*<command-line>/d' \
-e '/^#.*"-"/d' \
+ -e '/^#.*"\/.*\/"/d' \
+ -e '/: file path prefix .* never used$/d' \
-e 's#\.[0-9][0-9]*\.c#'"$file.c#" \
-e 's/^[ ]*#[ ]*line/#/' \
-e '/^# *[0-9][0-9]* *[".\/]/!d' \
-e 's/^.*"\(.*\)".*$/'$filebase'\$(OBJ_EXT): \1/' \
-e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'\$(OBJ_EXT): \1/' \
-e 's|: \./|: |' \
- -e 's|\.c\.c|.c|' $uwinfix | \
+ -e 's|\.c\.c|.c|' $uwinfix .cout .cerr| \
$uniq | $sort | $uniq >> .deptmp
fi
done
@@ -196,6 +210,10 @@
$echo "Updating $mf..."
$echo "# If this runs make out of memory, delete /usr/include lines." \
>> $mf.new
+ if [ "$osname" = vos ]; then
+ $sed 's|.incl.c|.h|' .deptmp >.deptmp.vos
+ mv -f .deptmp.vos .deptmp
+ fi
$sed 's|^\(.*\$(OBJ_EXT):\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \
>>$mf.new
else
@@ -227,7 +245,8 @@
$cp $mf.new $mf
$rm $mf.new
$echo "# WARNING: Put nothing here or make depend will gobble it up!" >> $mf
-$rm -rf .deptmp UU .shlist .clist .hlist .hsed
+$rm -rf .deptmp UU .shlist .clist .hlist .hsed .cout .cerr
+rmdir .depending
!NO!SUBS!
$eunicefix makedepend
BADGER
last SWITCH;
}
# If 5.7.2
if ( $perl eq '5.7.2' ) {
_patch(<<'BADGER');
--- makedepend.SH.org 2001-07-09 15:11:05.000000000 +0100
+++ makedepend.SH 2010-09-01 10:45:32.000000000 +0100
@@ -18,10 +18,6 @@
*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
esac
-case "$osname" in
-amigaos) cat=/bin/cat ;; # must be absolute
-esac
-
echo "Extracting makedepend (with variable substitutions)"
rm -f makedepend
$spitshell >makedepend <<!GROK!THIS!
@@ -33,6 +29,13 @@
!GROK!THIS!
$spitshell >>makedepend <<'!NO!SUBS!'
+if test -d .depending; then
+ echo "$0: Already running, exiting."
+ exit 0
+fi
+
+mkdir .depending
+
# This script should be called with
# sh ./makedepend MAKE=$(MAKE)
case "$1" in
@@ -55,6 +58,11 @@
;;
esac
+# Avoid localized gcc messages
+case "$ccname" in
+ gcc) LC_ALL=C ; export LC_ALL ;;
+esac
+
# We need .. when we are in the x2p directory if we are using the
# cppstdin wrapper script.
# Put .. and . first so that we pick up the present cppstdin, not
@@ -62,6 +70,10 @@
PATH=".$path_sep..$path_sep$PATH"
export PATH
+case "$osname" in
+amigaos) cat=/bin/cat ;; # must be absolute
+esac
+
$cat /dev/null >.deptmp
$rm -f *.c.c c/*.c.c
if test -f Makefile; then
@@ -71,7 +83,6 @@
# to be out of date. I don't know if OS/2 has touch, so do this:
case "$osname" in
os2) ;;
- netbsd) ;;
*) $touch $firstmakefile ;;
esac
fi
@@ -103,29 +114,20 @@
$echo *.c | $tr ' ' $trnl | $egrep -v '\*' >.clist)
for file in `$cat .clist`; do
# for file in `cat /dev/null`; do
- if [ "$osname" = uwin ]; then
- uwinfix="-e s,\\\\\\\\,/,g -e s,\\([a-zA-Z]\\):/,/\\1/,g"
- else
- if [ "$osname" = os2 ]; then
- uwinfix="-e s,\\\\\\\\,/,g"
- else
- if [ "$archname" = cygwin ]; then
- uwinfix="-e s,\\\\\\\\,/,g"
- else
- if [ "$osname" = posix-bc ]; then
- uwinfix="-e s/\\*POSIX(\\(.*\\))/\\1/"
- else
- uwinfix=
- fi
- fi
- fi
- fi
+ case "$osname" in
+ uwin) uwinfix="-e s,\\\\\\\\,/,g -e s,\\([a-zA-Z]\\):/,/\\1/,g" ;;
+ os2) uwinfix="-e s,\\\\\\\\,/,g" ;;
+ cygwin) uwinfix="-e s,\\\\\\\\,/,g" ;;
+ posix-bc) uwinfix="-e s/\\*POSIX(\\(.*\\))/\\1/" ;;
+ vos) uwinfix="-e s/\#/\\\#/" ;;
+ *) uwinfix="" ;;
+ esac
case "$file" in
*.c) filebase=`basename $file .c` ;;
*.y) filebase=`basename $file .y` ;;
esac
case "$file" in
- */*) finc="-I`echo $file | sed 's#/[^/]*$##`" ;;
+ */*) finc="-I`echo $file | sed 's#/[^/]*$##'`" ;;
*) finc= ;;
esac
$echo "Finding dependencies for $filebase$_o."
@@ -138,10 +140,12 @@
-e 's|\\$||' \
-e p \
-e '}' ) >UU/$file.c
+
+ if [ "$osname" = os390 -a "$file" = perly.c ]; then
+ $echo '#endif' >>UU/$file.c
+ fi
+
if [ "$osname" = os390 ]; then
- if [ "$file" = perly.c ]; then
- $echo '#endif' >>UU/$file.c
- fi
$cppstdin $finc -I. $cppflags $cppminus <UU/$file.c |
$sed \
-e '/^#.*<stdin>/d' \
@@ -155,18 +159,24 @@
-e 's|\.c\.c|.c|' $uwinfix | \
$uniq | $sort | $uniq >> .deptmp
else
- $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c |
+ $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c >.cout 2>.cerr
$sed \
-e '1d' \
-e '/^#.*<stdin>/d' \
+ -e '/^#.*<builtin>/d' \
+ -e '/^#.*<built-in>/d' \
+ -e '/^#.*<command line>/d' \
+ -e '/^#.*<command-line>/d' \
-e '/^#.*"-"/d' \
+ -e '/^#.*"\/.*\/"/d' \
+ -e '/: file path prefix .* never used$/d' \
-e 's#\.[0-9][0-9]*\.c#'"$file.c#" \
-e 's/^[ ]*#[ ]*line/#/' \
-e '/^# *[0-9][0-9]* *[".\/]/!d' \
-e 's/^.*"\(.*\)".*$/'$filebase'\$(OBJ_EXT): \1/' \
-e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'\$(OBJ_EXT): \1/' \
-e 's|: \./|: |' \
- -e 's|\.c\.c|.c|' $uwinfix | \
+ -e 's|\.c\.c|.c|' $uwinfix .cout .cerr| \
$uniq | $sort | $uniq >> .deptmp
fi
done
@@ -200,6 +210,10 @@
$echo "Updating $mf..."
$echo "# If this runs make out of memory, delete /usr/include lines." \
>> $mf.new
+ if [ "$osname" = vos ]; then
+ $sed 's|.incl.c|.h|' .deptmp >.deptmp.vos
+ mv -f .deptmp.vos .deptmp
+ fi
$sed 's|^\(.*\$(OBJ_EXT):\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \
>>$mf.new
else
@@ -231,7 +245,8 @@
$cp $mf.new $mf
$rm $mf.new
$echo "# WARNING: Put nothing here or make depend will gobble it up!" >> $mf
-$rm -rf .deptmp UU .shlist .clist .hlist .hsed
+$rm -rf .deptmp UU .shlist .clist .hlist .hsed .cout .cerr
+rmdir .depending
!NO!SUBS!
$eunicefix makedepend
BADGER
last SWITCH;
}
# If 5.7.3
if ( $perl eq '5.7.3' ) {
_patch(<<'BADGER');
--- makedepend.SH.org 2002-03-05 01:10:22.000000000 +0000
+++ makedepend.SH 2010-09-01 10:46:13.000000000 +0100
@@ -18,10 +18,6 @@
*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
esac
-case "$osname" in
-amigaos) cat=/bin/cat ;; # must be absolute
-esac
-
echo "Extracting makedepend (with variable substitutions)"
rm -f makedepend
$spitshell >makedepend <<!GROK!THIS!
@@ -33,6 +29,13 @@
!GROK!THIS!
$spitshell >>makedepend <<'!NO!SUBS!'
+if test -d .depending; then
+ echo "$0: Already running, exiting."
+ exit 0
+fi
+
+mkdir .depending
+
# This script should be called with
# sh ./makedepend MAKE=$(MAKE)
case "$1" in
@@ -55,6 +58,11 @@
;;
esac
+# Avoid localized gcc messages
+case "$ccname" in
+ gcc) LC_ALL=C ; export LC_ALL ;;
+esac
+
# We need .. when we are in the x2p directory if we are using the
# cppstdin wrapper script.
# Put .. and . first so that we pick up the present cppstdin, not
@@ -62,6 +70,10 @@
PATH=".$path_sep..$path_sep$PATH"
export PATH
+case "$osname" in
+amigaos) cat=/bin/cat ;; # must be absolute
+esac
+
$cat /dev/null >.deptmp
$rm -f *.c.c c/*.c.c
if test -f Makefile; then
@@ -71,7 +83,6 @@
# to be out of date. I don't know if OS/2 has touch, so do this:
case "$osname" in
os2) ;;
- netbsd) ;;
*) $touch $firstmakefile ;;
esac
fi
@@ -116,7 +127,7 @@
*.y) filebase=`basename $file .y` ;;
esac
case "$file" in
- */*) finc="-I`echo $file | sed 's#/[^/]*$##`" ;;
+ */*) finc="-I`echo $file | sed 's#/[^/]*$##'`" ;;
*) finc= ;;
esac
$echo "Finding dependencies for $filebase$_o."
@@ -129,6 +140,11 @@
-e 's|\\$||' \
-e p \
-e '}' ) >UU/$file.c
+
+ if [ "$osname" = os390 -a "$file" = perly.c ]; then
+ $echo '#endif' >>UU/$file.c
+ fi
+
if [ "$osname" = os390 ]; then
$cppstdin $finc -I. $cppflags $cppminus <UU/$file.c |
$sed \
@@ -143,13 +159,16 @@
-e 's|\.c\.c|.c|' $uwinfix | \
$uniq | $sort | $uniq >> .deptmp
else
- $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c 2>&1 |
+ $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c >.cout 2>.cerr
$sed \
-e '1d' \
-e '/^#.*<stdin>/d' \
-e '/^#.*<builtin>/d' \
+ -e '/^#.*<built-in>/d' \
-e '/^#.*<command line>/d' \
+ -e '/^#.*<command-line>/d' \
-e '/^#.*"-"/d' \
+ -e '/^#.*"\/.*\/"/d' \
-e '/: file path prefix .* never used$/d' \
-e 's#\.[0-9][0-9]*\.c#'"$file.c#" \
-e 's/^[ ]*#[ ]*line/#/' \
@@ -157,7 +176,7 @@
-e 's/^.*"\(.*\)".*$/'$filebase'\$(OBJ_EXT): \1/' \
-e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'\$(OBJ_EXT): \1/' \
-e 's|: \./|: |' \
- -e 's|\.c\.c|.c|' $uwinfix | \
+ -e 's|\.c\.c|.c|' $uwinfix .cout .cerr| \
$uniq | $sort | $uniq >> .deptmp
fi
done
@@ -191,6 +210,10 @@
$echo "Updating $mf..."
$echo "# If this runs make out of memory, delete /usr/include lines." \
>> $mf.new
+ if [ "$osname" = vos ]; then
+ $sed 's|.incl.c|.h|' .deptmp >.deptmp.vos
+ mv -f .deptmp.vos .deptmp
+ fi
$sed 's|^\(.*\$(OBJ_EXT):\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \
>>$mf.new
else
@@ -222,7 +245,8 @@
$cp $mf.new $mf
$rm $mf.new
$echo "# WARNING: Put nothing here or make depend will gobble it up!" >> $mf
-$rm -rf .deptmp UU .shlist .clist .hlist .hsed
+$rm -rf .deptmp UU .shlist .clist .hlist .hsed .cout .cerr
+rmdir .depending
!NO!SUBS!
$eunicefix makedepend
BADGER
last SWITCH;
}
# If 5.8.0
if ( $perl eq '5.8.0' ) {
_patch(<<'BADGER');
--- makedepend.SH.org 2002-07-09 15:06:42.000000000 +0100
+++ makedepend.SH 2010-09-01 10:16:37.000000000 +0100
@@ -58,6 +58,11 @@
;;
esac
+# Avoid localized gcc messages
+case "$ccname" in
+ gcc) LC_ALL=C ; export LC_ALL ;;
+esac
+
# We need .. when we are in the x2p directory if we are using the
# cppstdin wrapper script.
# Put .. and . first so that we pick up the present cppstdin, not
@@ -78,7 +83,6 @@
# to be out of date. I don't know if OS/2 has touch, so do this:
case "$osname" in
os2) ;;
- netbsd) ;;
*) $touch $firstmakefile ;;
esac
fi
@@ -123,7 +127,7 @@
*.y) filebase=`basename $file .y` ;;
esac
case "$file" in
- */*) finc="-I`echo $file | sed 's#/[^/]*$##`" ;;
+ */*) finc="-I`echo $file | sed 's#/[^/]*$##'`" ;;
*) finc= ;;
esac
$echo "Finding dependencies for $filebase$_o."
@@ -136,6 +140,11 @@
-e 's|\\$||' \
-e p \
-e '}' ) >UU/$file.c
+
+ if [ "$osname" = os390 -a "$file" = perly.c ]; then
+ $echo '#endif' >>UU/$file.c
+ fi
+
if [ "$osname" = os390 ]; then
$cppstdin $finc -I. $cppflags $cppminus <UU/$file.c |
$sed \
@@ -157,7 +166,9 @@
-e '/^#.*<builtin>/d' \
-e '/^#.*<built-in>/d' \
-e '/^#.*<command line>/d' \
+ -e '/^#.*<command-line>/d' \
-e '/^#.*"-"/d' \
+ -e '/^#.*"\/.*\/"/d' \
-e '/: file path prefix .* never used$/d' \
-e 's#\.[0-9][0-9]*\.c#'"$file.c#" \
-e 's/^[ ]*#[ ]*line/#/' \
@@ -199,6 +210,10 @@
$echo "Updating $mf..."
$echo "# If this runs make out of memory, delete /usr/include lines." \
>> $mf.new
+ if [ "$osname" = vos ]; then
+ $sed 's|.incl.c|.h|' .deptmp >.deptmp.vos
+ mv -f .deptmp.vos .deptmp
+ fi
$sed 's|^\(.*\$(OBJ_EXT):\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \
>>$mf.new
else
BADGER
last SWITCH;
}
# If 5.8.[12345678]
_patch(<<'BADGER');
--- makedepend.SH.org 2003-06-05 19:11:10.000000000 +0100
+++ makedepend.SH 2010-09-01 10:24:39.000000000 +0100
@@ -83,7 +83,6 @@
# to be out of date. I don't know if OS/2 has touch, so do this:
case "$osname" in
os2) ;;
- netbsd) ;;
*) $touch $firstmakefile ;;
esac
fi
@@ -128,7 +127,7 @@
*.y) filebase=`basename $file .y` ;;
esac
case "$file" in
- */*) finc="-I`echo $file | sed 's#/[^/]*$##`" ;;
+ */*) finc="-I`echo $file | sed 's#/[^/]*$##'`" ;;
*) finc= ;;
esac
$echo "Finding dependencies for $filebase$_o."
@@ -167,7 +166,9 @@
-e '/^#.*<builtin>/d' \
-e '/^#.*<built-in>/d' \
-e '/^#.*<command line>/d' \
+ -e '/^#.*<command-line>/d' \
-e '/^#.*"-"/d' \
+ -e '/^#.*"\/.*\/"/d' \
-e '/: file path prefix .* never used$/d' \
-e 's#\.[0-9][0-9]*\.c#'"$file.c#" \
-e 's/^[ ]*#[ ]*line/#/' \
@@ -209,6 +210,10 @@
$echo "Updating $mf..."
$echo "# If this runs make out of memory, delete /usr/include lines." \
>> $mf.new
+ if [ "$osname" = vos ]; then
+ $sed 's|.incl.c|.h|' .deptmp >.deptmp.vos
+ mv -f .deptmp.vos .deptmp
+ fi
$sed 's|^\(.*\$(OBJ_EXT):\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \
>>$mf.new
else
BADGER
}
}
sub _patch_archive_tar_tests
{
my $perl = shift;
if ($perl =~ /^5\.10/) {
_patch(<<'END');
--- lib/Archive/Tar/t/02_methods.t
+++ lib/Archive/Tar/t/02_methods.t
@@ -70,6 +70,20 @@ my $LONG_FILE = qq[directory/really-really-really-really-really-really-really-re
my $TOO_LONG = ($^O eq 'MSWin32' or $^O eq 'cygwin' or $^O eq 'VMS')
&& length( cwd(). $LONG_FILE ) > 247;
+if(!$TOO_LONG) {
+ my $alt = File::Spec->catfile( cwd(), $LONG_FILE);
+ eval 'mkpath([$alt]);';
+ if($@)
+ {
+ $TOO_LONG = 1;
+ }
+ else
+ {
+ $@ = '';
+ my $base = File::Spec->catfile( cwd(), 'directory');
+ rmtree $base;
+ }
+}
### warn if we are going to skip long file names
if ($TOO_LONG) {
diag("No long filename support - long filename extraction disabled") if ! $ENV{PERL_CORE};
END
}
else {
_patch(<<'END');
--- cpan/Archive-Tar/t/02_methods.t
+++ cpan/Archive-Tar/t/02_methods.t
@@ -70,6 +70,20 @@ my $LONG_FILE = qq[directory/really-really-really-really-really-really-really-re
my $TOO_LONG = ($^O eq 'MSWin32' or $^O eq 'cygwin' or $^O eq 'VMS')
&& length( cwd(). $LONG_FILE ) > 247;
+if(!$TOO_LONG) {
+ my $alt = File::Spec->catfile( cwd(), $LONG_FILE);
+ eval 'mkpath([$alt]);';
+ if($@)
+ {
+ $TOO_LONG = 1;
+ }
+ else
+ {
+ $@ = '';
+ my $base = File::Spec->catfile( cwd(), 'directory');
+ rmtree $base;
+ }
+}
### warn if we are going to skip long file names
if ($TOO_LONG) {
diag("No long filename support - long filename extraction disabled") if ! $ENV{PERL_CORE};
END
}
}
sub _patch_odbm_file_hints_linux
{
_patch(<<'END');
--- ext/ODBM_File/hints/linux.pl
+++ ext/ODBM_File/hints/linux.pl
@@ -1,8 +1,8 @@
# uses GDBM dbm compatibility feature - at least on SuSE 8.0
$self->{LIBS} = ['-lgdbm'];
-# Debian/Ubuntu have /usr/lib/libgdbm_compat.so.3* but not this file,
+# Debian/Ubuntu have libgdbm_compat.so but not this file,
# so linking may fail
-if (-e '/usr/lib/libgdbm_compat.so' or -e '/usr/lib64/libgdbm_compat.so') {
- $self->{LIBS}->[0] .= ' -lgdbm_compat';
+foreach (split / /, $Config{libpth}) {
+ $self->{LIBS}->[0] .= ' -lgdbm_compat' if -e $_.'/libgdbm_compat.so';
}
END
}
sub _patch_make_ext_pl
{
_patch(<<'END');
--- make_ext.pl
+++ make_ext.pl
@@ -377,6 +377,10 @@ WriteMakefile(
EOM
close $fh or die "Can't close Makefile.PL: $!";
}
+ eval {
+ my $ftime = time - 4;
+ utime $ftime, $ftime, 'Makefile.PL';
+ };
print "\nRunning Makefile.PL in $ext_dir\n";
# Presumably this can be simplified
END
}
sub _patch_589_perlio_c
{
_patch(<<'END');
--- perlio.c
+++ perlio.c
@@ -2323,6 +2323,12 @@ PerlIO_init(pTHX)
{
/* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
PERL_UNUSED_CONTEXT;
+ /*
+ * No, for backwards compatibility (before PERL_SYS_INIT3 changed to be
+ * defined as a separate function call), we need to call
+ * MUTEX_INIT(&PL_perlio_mutex) (via the PERLIO_INIT macro).
+ */
+ PERLIO_INIT;
}
void
END
}
qq[patchin'];
__END__
=pod
=head1 NAME
Devel::PatchPerl - Patch perl source a la Devel::PPPort's buildperl.pl
=head1 VERSION
version 0.84
=head1 SYNOPSIS
use strict;
use warnings;
use Devel::PatchPerl;
Devel::PatchPerl->patch_source( '5.6.1', '/path/to/untarred/perl/source/perl-5.6.1' );
=head1 DESCRIPTION
Devel::PatchPerl is a modularisation of the patching code contained in L<Devel::PPPort>'s
C<buildperl.pl>.
It does not build perls, it merely provides an interface to the source patching
functionality.
=head1 FUNCTION
=over
=item C<patch_source>
Takes two parameters, a C<perl> version and the path to unwrapped perl source for that version.
It dies on any errors.
If you don't supply a C<perl> version, it will attempt to auto-determine the
C<perl> version from the specified path.
If you don't supply the path to unwrapped perl source, it will assume the
current working directory.
=back
=head1 PLUGIN SYSTEM
See L<Devel::PatchPerl::Plugin> for details of Devel::PatchPerl's plugin system.
=head1 CAVEAT
Devel::PatchPerl is intended only to facilitate the C<building> of perls, not to
facilitate the C<testing> of perls. This means that it will not patch failing tests
in the perl testsuite.
=head1 SEE ALSO
L<Devel::PPPort>
L<Devel::PatchPerl::Plugin>
=head1 AUTHOR
Chris Williams <chris@bingosnet.co.uk>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2013 by Chris Williams and Marcus Holland-Moritz.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
DEVEL_PATCHPERL
$fatpacked{"Devel/PatchPerl/Hints.pm"} = <<'DEVEL_PATCHPERL_HINTS';
package Devel::PatchPerl::Hints;
{
$Devel::PatchPerl::Hints::VERSION = '0.84';
}
#ABSTRACT: replacement 'hints' files
use strict;
use warnings;
use MIME::Base64 qw[decode_base64];
use File::Spec;
our @ISA = qw[Exporter];
our @EXPORT_OK = qw[hint_file];
my %hints = (
'hpux' =>
'IyEvdXNyL2Jpbi9zaAoKIyMjIFNZU1RFTSBBUkNISVRFQ1RVUkUKCiMgRGV0ZXJtaW5lIHRoZSBh
cmNoaXRlY3R1cmUgdHlwZSBvZiB0aGlzIHN5c3RlbS4KIyBLZWVwIGxlYWRpbmcgdGFiIGJlbG93
IC0tIENvbmZpZ3VyZSBCbGFjayBNYWdpYyAtLSBSQU0sIDAzLzAyLzk3Cgl4eE9zUmV2TWFqb3I9
YHVuYW1lIC1yIHwgc2VkIC1lICdzL15bXjAtOV0qLy8nIHwgY3V0IC1kLiAtZjFgOwoJeHhPc1Jl
dk1pbm9yPWB1bmFtZSAtciB8IHNlZCAtZSAncy9eW14wLTldKi8vJyB8IGN1dCAtZC4gLWYyYDsK
CXh4T3NSZXY9YGV4cHIgMTAwIFwqICR4eE9zUmV2TWFqb3IgKyAkeHhPc1Jldk1pbm9yYAppZiBb
ICIkeHhPc1Jldk1ham9yIiAtZ2UgMTAgXTsgdGhlbgogICAgIyBUaGlzIHN5c3RlbSBpcyBydW5u
aW5nID49IDEwLngKCiAgICAjIFRlc3RlZCBvbiAxMC4wMSBQQTEueCBhbmQgMTAuMjAgUEFbMTJd
LnguCiAgICAjIElkZWE6IFNjYW4gL3Vzci9pbmNsdWRlL3N5cy91bmlzdGQuaCBmb3IgbWF0Y2hl
cyB3aXRoCiAgICAjICIjZGVmaW5lIENQVV8qIGBnZXRjb25mICMgQ1BVX1ZFUlNJT05gIiB0byBk
ZXRlcm1pbmUgQ1BVIHR5cGUuCiAgICAjIE5vdGUgdGhlIHRleHQgZm9sbG93aW5nICJDUFVfIiBp
cyB1c2VkLCAqTk9UKiB0aGUgY29tbWVudC4KICAgICMKICAgICMgQVNTVU1QVElPTlM6IE51bWJl
cnMgd2lsbCBjb250aW51ZSB0byBiZSBkZWZpbmVkIGluIGhleCAtLSBhbmQgaW4KICAgICMgL3Vz
ci9pbmNsdWRlL3N5cy91bmlzdGQuaCAtLSBhbmQgdGhlIENQVV8qICNkZWZpbmVzIHdpbGwgYmUg
a2VwdAogICAgIyB1cCB0byBkYXRlIHdpdGggbmV3IENQVS9PUyByZWxlYXNlcy4KICAgIHh4Y3B1
PWBnZXRjb25mIENQVV9WRVJTSU9OYDsgIyBHZXQgdGhlIG51bWJlci4KICAgIHh4Y3B1PWBwcmlu
dGYgJzB4JXgnICR4eGNwdWA7ICMgY29udmVydCB0byBoZXgKICAgIGFyY2huYW1lPWBzZWQgLW4g
LWUgInMvXiNbWzpzcGFjZTpdXSpkZWZpbmVbWzpzcGFjZTpdXSpDUFVfLy9wIiAvdXNyL2luY2x1
ZGUvc3lzL3VuaXN0ZC5oIHwKCXNlZCAtbiAtZSAicy9bWzpzcGFjZTpdXSokeHhjcHVbWzpzcGFj
ZTpdXS4qLy9wIiB8CglzZWQgLWUgcy9fUklTQy8tUklTQy8gLWUgcy9IUF8vLyAtZSBzL18vLi8g
LWUgInMvW1s6c3BhY2U6XV0qLy9nImA7CmVsc2UKICAgICMgVGhpcyBzeXN0ZW0gaXMgcnVubmlu
ZyA8PSA5LngKICAgICMgVGVzdGVkIG9uIDkuMFs1N10gUEEgYW5kIFs3OF0uMCBNQzY4MFsyM10w
LiAgSWRlYTogQWZ0ZXIgcmVtb3ZpbmcKICAgICMgTUM2ODg4WzEyXSBmcm9tIGNvbnRleHQgc3Ry
aW5nLCB1c2UgZmlyc3QgQ1BVIGlkZW50aWZpZXIuCiAgICAjCiAgICAjIEFTU1VNUFRJT046IE9u
bHkgQ1BVIGlkZW50aWZpZXJzIGNvbnRhaW4gbm8gbG93ZXJjYXNlIGxldHRlcnMuCiAgICBhcmNo
bmFtZT1gZ2V0Y29udGV4dCB8IHRyICcgJyAnXDAxMicgfCBncmVwIC12ICdbYS16XScgfCBncmVw
IC12IE1DNjg4IHwKCXNlZCAtZSAncy9IUC0vLycgLWUgMXFgOwogICAgc2VsZWN0dHlwZT0naW50
IConCiAgICBmaQoKIyBGb3Igc29tZSBzdHJhbmdlIHJlYXNvbiwgdGhlIHUzMmFsaWduIHRlc3Qg
ZnJvbSBDb25maWd1cmUgaGFuZ3MgaW4KIyBIUC1VWCAxMC4yMCBzaW5jZSB0aGUgRGVjZW1iZXIg
MjAwMSBwYXRjaGVzLiAgU28gaGludCBpdCB0byBhdm9pZAojIHRoZSB0ZXN0LgppZiBbICIkeHhP
c1Jldk1ham9yIiAtbGUgMTAgXTsgdGhlbgogICAgZF91MzJhbGlnbj0kZGVmaW5lCiAgICBmaQoK
ZWNobyAiQXJjaG5hbWUgaXMgJGFyY2huYW1lIgoKIyBGaXggWFNsaWIgKENQQU4pIGNvbmZ1c2lv
biB3aGVuIHJlLXVzaW5nIGEgcHJlZml4IGJ1dCBjaGFuZ2luZyBmcm9tIElMUDMyCiMgdG8gTFA2
NCBidWlsZHMuICBUaGV5J3JlIE5PVCBiaW5hcnkgY29tcGF0aWJsZSwgc28gcXVpdCBjbGFpbWlu
ZyB0aGV5IGFyZS4KYXJjaG5hbWU2ND1MUDY0CgoKIyMjIEhQLVVYIE9TIHNwZWNpZmljIGJlaGF2
aW91cgoKIyAtbGRibSBpcyBvYnNvbGV0ZSBhbmQgc2hvdWxkIG5vdCBiZSB1c2VkCiMgLWxCU0Qg
Y29udGFpbnMgQlNELXN0eWxlIGR1cGxpY2F0ZXMgb2YgU1ZSNCByb3V0aW5lcyB0aGF0IGNhdXNl
IGNvbmZ1c2lvbgojIC1sUFcgaXMgb2Jzb2xldGUgYW5kIHNob3VsZCBub3QgYmUgdXNlZAojIFRo
ZSBsaWJyYXJpZXMgY3J5cHQsIG1hbGxvYywgbmRpciwgYW5kIG5ldCBhcmUgZW1wdHkuCnNldCBg
ZWNobyAiWCAkbGlic3dhbnRlZCAiIHwgc2VkIC1lICdzLyBsZCAvIC8nIC1lICdzLyBkYm0gLyAv
JyAtZSAncy8gQlNEIC8gLycgLWUgJ3MvIFBXIC8gLydgCnNoaWZ0CmxpYnN3YW50ZWQ9IiQqIgoK
Y2M9JHtjYzotY2N9CmFyPS91c3IvYmluL2FyCSMgWWVzLCB0cnVseSBvdmVycmlkZS4gIFdlIGRv
IG5vdCB3YW50IHRoZSBHTlUgYXIuCmZ1bGxfYXI9JGFyCSMgSSByZXBlYXQsIG5vIEdOVSBhci4g
IGFycnIuCgpzZXQgYGVjaG8gIlggJGNjZmxhZ3MgIiB8IHNlZCAtZSAncy8gLUFbZWFdIC8gLycg
LWUgJ3MvIC1EX0hQVVhfU09VUkNFIC8gLydgCnNoaWZ0CgljY19jcHBmbGFncz0iJCogLURfSFBV
WF9TT1VSQ0UiCmNwcGZsYWdzPSItQWEgLURfX1NURENfRVhUX18gJGNjX2NwcGZsYWdzIgoKY2Fz
ZSAiJHByZWZpeCIgaW4KICAgICIiKSBwcmVmaXg9Jy9vcHQvcGVybDUnIDs7CiAgICBlc2FjCgog
ICAgZ251X2FzPW5vCiAgICBnbnVfbGQ9bm8KY2FzZSBgJGNjIC12IDI+JjFgIiIgaW4KICAgICpn
Y2MqKSAgY2Npc2djYz0iJGRlZmluZSIKCSAgICBjY2ZsYWdzPSIkY2NfY3BwZmxhZ3MiCgkgICAg
aWYgWyAiWCRnY2N2ZXJzaW9uIiA9ICJYIiBdOyB0aGVuCgkJIyBEb25lIHRvbyBsYXRlIGluIENv
bmZpZ3VyZSBpZiBoaW50ZWQKCQlnY2N2ZXJzaW9uPWAkY2MgLWR1bXB2ZXJzaW9uYAoJCWZpCgkg
ICAgY2FzZSAiJGdjY3ZlcnNpb24iIGluCgkJWzAxMl0qKSAjIEhQLVVYIGFuZCBnY2MtMi4qIGJy
ZWFrIFVJTlQzMl9NQVggOi0oCgkJCWNjZmxhZ3M9IiRjY2ZsYWdzIC1EVUlOVDMyX01BWF9CUk9L
RU4iCgkJCTs7CgkJWzM0XSopICMgR0NDIChib3RoIDMyYml0IGFuZCA2NGJpdCkgd2lsbCBkZWZp
bmUgX19TVERDX0VYVF9fCiAgICAgICAgICAgICAgICAgICAgICAgIyBieSBkZWZhdWx0IHdoZW4g
dXNpbmcgR0NDIDMuMCBhbmQgbmV3ZXIgdmVyc2lvbnMgb2YKICAgICAgICAgICAgICAgICAgICAg
ICAjIHRoZSBjb21waWxlci4KICAgICAgICAgICAgICAgICAgICAgICBjcHBmbGFncz0iJGNjX2Nw
cGZsYWdzIgogICAgICAgICAgICAgICAgICAgICAgIDs7CgkJZXNhYwoJICAgIGNhc2UgImBnZXRj
b25mIEtFUk5FTF9CSVRTIDI+L2Rldi9udWxsYCIgaW4KCQkqNjQqKQoJCSAgICBlY2hvICJtYWlu
KCl7fSI+dHJ5LmMKCQkgICAgY2FzZSAiJGdjY3ZlcnNpb24iIGluCgkJCVszNF0qKQoJCQkgICAg
Y2FzZSAiJGFyY2huYW1lIiBpbgogICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgUEEtUklT
QyopCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgY2FzZSAiJGNjZmxhZ3MiIGlu
CiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICotbXBhLXJpc2MqKSA7Owog
ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAqKSBjY2ZsYWdzPSIkY2NmbGFn
cyAtbXBhLXJpc2MtMi0wIiA7OwogICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg
ICBlc2FjCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgOzsKCQkJCWVzYWMKCQkJ
ICAgIDs7CgkJCSopICAjIGdjYyB3aXRoIGdhcyB3aWxsIG5vdCBhY2NlcHQgK0RBMi4wCgkJCSAg
ICBjYXNlICJgJGNjIC1jIC1XYSwrREEyLjAgdHJ5LmMgMj4mMWAiIGluCgkJCQkqIitEQTIuMCIq
KQkJIyBnYXMKCQkJCSAgICBnbnVfYXM9eWVzCgkJCQkgICAgOzsKCQkJCSopCQkJIyBIUGFzCgkJ
CQkgICAgY2NmbGFncz0iJGNjZmxhZ3MgLVdhLCtEQTIuMCIKCQkJCSAgICA7OwoJCQkJZXNhYwoJ
CQkgICAgOzsKCQkJZXNhYwoJCSAgICAjIGdjYyB3aXRoIGdsZCB3aWxsIG5vdCBhY2NlcHQgK3Zu
b2NvbXBhdHdhcm5pbmdzCgkJICAgIGNhc2UgImAkY2MgLW8gdHJ5IC1XbCwrdm5vY29tcGF0d2Fy
bmluZ3MgdHJ5LmMgMj4mMWAiIGluCgkJCSoiK3Zub2NvbXBhdCIqKQkJIyBnbGQKCQkJICAgIGdu
dV9sZD15ZXMKCQkJICAgIDs7CgkJCSopCQkJIyBIUGxkCgkJCSAgIGNhc2UgIiRnY2N2ZXJzaW9u
IiBpbgoJCQkgICAgICAgWzEyXSopCgkJCQkgICAjIFdoeSBub3QgMyBhcyB3ZWxsIGhlcmU/CgkJ
CQkgICAjIFNpbmNlIG5vdCByZWxldmFudCB0byBJQTY0LCBub3QgY2hhbmdlZC4KCQkJCSAgIGxk
ZmxhZ3M9IiRsZGZsYWdzIC1XbCwrdm5vY29tcGF0d2FybmluZ3MiCgkJCQkgICBjY2ZsYWdzPSIk
Y2NmbGFncyAtV2wsK3Zub2NvbXBhdHdhcm5pbmdzIgoJCQkJICAgOzsKCQkJICAgICAgIGVzYWMK
CQkJICAgIDs7CgkJCWVzYWMKCQkgICAgcm0gLWYgdHJ5LmMKCQkgICAgOzsKCQllc2FjCgkgICAg
OzsKICAgICopICAgICAgY2Npc2djYz0nJwoJICAgICMgV2hhdCBjYW5ub3QgYmUgdXNlIGluIGNv
bWJpbmF0aW9uIHdpdGggY2NhY2hlIGxpbmtzIDooCgkgICAgY2NfZm91bmQ9IiIKCSAgICBmb3Ig
cCBpbiBgZWNobyAkUEFUSCB8IHRyIDogJyAnJ2AgOyBkbwoJCXg9IiRwL2NjIgoJCWlmIFsgLWYg
JHggXSAmJiBbIC14ICR4IF07IHRoZW4KCQkgICAgaWYgWyAtaCAkeCBdOyB0aGVuCgkJCWw9YGxz
IC1sICR4IHwgc2VkICdzLC4qLT4gLCwnYAoJCQljYXNlICRsIGluCgkJCSAgICAvKikgeD0kbAkJ
OzsKCQkJICAgICopICB4PSIkcC8kbCIJOzsKCQkJICAgIGVzYWMKCQkJZmkKCQkgICAgeD1gZWNo
byAkeCB8IHNlZCAncywvXC4vLC8sZydgCgkJICAgIGNhc2UgJHggaW4KCQkJKmNjYWNoZSopIDs7
CgkJCSopIFsgLXogIiRjY19mb3VuZCIgXSAmJiBjY19mb3VuZD0keCA7OwoJCQllc2FjCgkJICAg
IGZpCgkJZG9uZQoJICAgIFsgLXogIiRjY19mb3VuZCIgXSAmJiBjY19mb3VuZD1gd2hpY2ggY2Ng
CgkgICAgd2hhdCAkY2NfZm91bmQgPiY0CgkgICAgY2N2ZXJzaW9uPWB3aGF0ICRjY19mb3VuZCB8
IGF3ayAnL0NvbXBpbGVyL3twcmludCAkMn0vSXRhbml1bS97cHJpbnQgJDYsJDd9L2ZvciBJbnRl
Z3JpdHkve3ByaW50ICQ2LCQ3fSdgCgkgICAgY2FzZSAiJGNjZmxhZ3MiIGluCiAgICAgICAgICAg
ICAgICItQWUgIiopIDs7CgkJKikgIGNjZmxhZ3M9Ii1BZSAkY2NfY3BwZmxhZ3MiCgkJICAgICMg
K3Zub2NvbXBhdHdhcm5pbmdzIG5vdCBrbm93biBpbiAxMC4xMCBhbmQgb2xkZXIKCQkgICAgaWYg
WyAkeHhPc1JldiAtZ2UgMTAyMCBdOyB0aGVuCgkJCWNjZmxhZ3M9IiRjY2ZsYWdzIC1XbCwrdm5v
Y29tcGF0d2FybmluZ3MiCgkJCWZpCgkJICAgIDs7CiAgICAgICAgICAgICAgIGVzYWMKCSAgICAj
IE5lZWRlZCBiZWNhdXNlIGNwcCBkb2VzIG9ubHkgc3VwcG9ydCAtQWEgKG5vdCAtQWUpCgkgICAg
Y3BwbGFzdD0nLScKCSAgICBjcHBtaW51cz0nLScKCSAgICBjcHBzdGRpbj0nY2MgLUUgLUFhIC1E
X19TVERDX0VYVF9fJwoJICAgIGNwcHJ1bj0kY3Bwc3RkaW4KIwkgICAgY2FzZSAiJGRfY2FzdGkz
MiIgaW4KIwkJIiIpIGRfY2FzdGkzMj0ndW5kZWYnIDs7CiMJCWVzYWMKCSAgICA7OwogICAgZXNh
YwoKIyBXaGVuIEhQLVVYIHJ1bnMgYSBzY3JpcHQgd2l0aCAiIyEiLCBpdCBzZXRzIGFyZ3ZbMF0g
dG8gdGhlIHNjcmlwdCBuYW1lLgp0b2tlX2NmbGFncz0nY2NmbGFncz0iJGNjZmxhZ3MgLURBUkdf
WkVST19JU19TQ1JJUFQiJwoKIyMjIDY0IEJJVE5FU1MKCiMgU29tZSBnY2MgdmVyc2lvbnMgZG8g
bmF0aXZlIDY0IGJpdCBsb25nIChlLmcuIDIuOS1ocHBhLTAwMDMxMCBhbmQgZ2NjLTMuMCkKIyBX
ZSBoYXZlIHRvIGZvcmNlIDY0Yml0bmVzcyB0byBnbyBzZWFyY2ggdGhlIHJpZ2h0IGxpYnJhcmll
cwogICAgZ2NjXzY0bmF0aXZlPW5vCmNhc2UgIiRjY2lzZ2NjIiBpbgogICAgJGRlZmluZXx0cnVl
fFtZeV0pCgllY2hvICcjaW5jbHVkZSA8c3RkaW8uaD5cbmludCBtYWluKCl7bG9uZyBsO3ByaW50
ZigiJWRcXG4iLHNpemVvZihsKSk7fSc+dHJ5LmMKCSRjYyAtbyB0cnkgJGNjZmxhZ3MgJGxkZmxh
Z3MgdHJ5LmMKCWlmIFsgImB0cnlgIiA9ICI4IiBdOyB0aGVuCgkgICAgY2FzZSAiJHVzZTY0Yml0
YWxsIiBpbgoJCSRkZWZpbmV8dHJ1ZXxbWXldKSA7OwoJCSopICBjYXQgPDxFT00gPiY0CgoqKiog
VGhpcyB2ZXJzaW9uIG9mIGdjYyB1c2VzIDY0IGJpdCBsb25ncy4gLUR1c2U2NGJpdGFsbCBpcwoq
KiogaW1wbGljaXRseSBzZXQgdG8gZW5hYmxlIGNvbnRpbnVhdGlvbgpFT00KCQllc2FjCgkgICAg
dXNlNjRiaXRhbGw9JGRlZmluZQoJICAgIGdjY182NG5hdGl2ZT15ZXMKCSAgICBmaQoJOzsKICAg
IGVzYWMKCmNhc2UgIiR1c2U2NGJpdGFsbCIgaW4KICAgICRkZWZpbmV8dHJ1ZXxbeVldKikgdXNl
NjRiaXRpbnQ9IiRkZWZpbmUiIDs7CiAgICBlc2FjCgpjYXNlICIkdXNlbW9yZWJpdHMiIGluCiAg
ICAkZGVmaW5lfHRydWV8W3lZXSopIHVzZTY0Yml0aW50PSIkZGVmaW5lIjsgdXNlbG9uZ2RvdWJs
ZT0iJGRlZmluZSIgOzsKICAgIGVzYWMKCmNhc2UgIiRhcmNobmFtZSIgaW4KICAgIElBNjQqKQoJ
IyBXaGlsZSBoZXJlLCBvdmVycmlkZSBzbz1zbCBhdXRvLWRldGVjdGlvbgoJc289J3NvJwoJOzsK
ICAgIGVzYWMKCmNhc2UgIiR1c2U2NGJpdGFsbCIgaW4KICAgICRkZWZpbmV8dHJ1ZXxbWXldKQoK
CWlmIFsgIiR4eE9zUmV2TWFqb3IiIC1sdCAxMSBdOyB0aGVuCgkgICAgY2F0IDw8RU9NID4mNAoK
KioqIDY0LWJpdCBjb21waWxhdGlvbiBpcyBub3Qgc3VwcG9ydGVkIG9uIEhQLVVYICR4eE9zUmV2
TWFqb3IuCioqKiBZb3UgbmVlZCBhdCBsZWFzdCBIUC1VWCAxMS4wLgoqKiogQ2Fubm90IGNvbnRp
bnVlLCBhYm9ydGluZy4KRU9NCgkgICAgZXhpdCAxCgkgICAgZmkKCglpZiBbICR4eE9zUmV2IC1l
cSAxMTAwIF07IHRoZW4KCSAgICAjIEhQLVVYIDExLjAwIHVzZXMgb25seSA0OCBiaXRzIGludGVy
bmFsbHkgaW4gNjRiaXQgbW9kZSwgbm90IDY0CgkgICAgIyBmb3JjZSBtaW4vbWF4IHRvIDIqKjQ3
LTEKCSAgICBzR01USU1FX21heD0xNDA3Mzc0ODgzNTUzMjcKCSAgICBzR01USU1FX21pbj0tNjIx
NjcyMTkyMDAKCSAgICBzTE9DQUxUSU1FX21heD0xNDA3Mzc0ODgzNTUzMjcKCSAgICBzTE9DQUxU
SU1FX21pbj0tNjIxNjcyMTkyMDAKCSAgICBmaQoKCSMgU2V0IGxpYmMgYW5kIHRoZSBsaWJyYXJ5
IHBhdGhzCgljYXNlICIkYXJjaG5hbWUiIGluCgkgICAgUEEtUklTQyopCgkJbG9jbGlicHRoPSIk
bG9jbGlicHRoIC9saWIvcGEyMF82NCIKCQlsaWJjPScvbGliL3BhMjBfNjQvbGliYy5zbCcgOzsK
CSAgICBJQTY0KikKCQlsb2NsaWJwdGg9IiRsb2NsaWJwdGggL3Vzci9saWIvaHB1eDY0IgoJCWxp
YmM9Jy91c3IvbGliL2hwdXg2NC9saWJjLnNvJyA7OwoJICAgIGVzYWMKCWlmIFsgISAtZiAiJGxp
YmMiIF07IHRoZW4KCSAgICBjYXQgPDxFT00gPiY0CgoqKiogWW91IGRvIG5vdCBzZWVtIHRvIGhh
dmUgdGhlIDY0LWJpdCBsaWJjLgoqKiogSSBjYW5ub3QgZmluZCB0aGUgZmlsZSAkbGliYy4KKioq
IENhbm5vdCBjb250aW51ZSwgYWJvcnRpbmcuCkVPTQoJICAgIGV4aXQgMQoJICAgIGZpCgoJY2Fz
ZSAiJGNjaXNnY2MiIGluCgkgICAgJGRlZmluZXx0cnVlfFtZeV0pCgkJIyBUaGUgZml4ZWQgc29j
a2V0LmggaGVhZGVyIGZpbGUgaXMgd3JvbmcgZm9yIGdjYy00LngKCQkjIG9uIFBBLVJJU0MyLjBX
LCBzbyBTb2NrX3R5cGVfdCBpcyBzaXplX3Qgd2hpY2ggaXMKCQkjIHVuc2lnbmVkIGxvbmcgd2hp
Y2ggaXMgNjRiaXQgd2hpY2ggaXMgdG9vIGxvbmcKCQljYXNlICIkZ2NjdmVyc2lvbiIgaW4KCQkg
ICAgNCopIGNhc2UgIiRhcmNobmFtZSIgaW4KCQkJICAgIFBBLVJJU0MqKSBzb2Nrc2l6ZXR5cGU9
aW50IDs7CgkJCSAgICBlc2FjCgkJCTs7CgkJICAgIGVzYWMKCgkJIyBGb3IgdGhlIG1vbWVudCwg
ZG9uJ3QgY2FyZSB0aGF0IGl0IGFpbid0IHN1cHBvcnRlZCAoeWV0KQoJCSMgYnkgZ2NjICh1cCB0
byBhbmQgaW5jbHVkaW5nIDIuOTUuMyksIGNhdXNlIGl0J2xsIGNyYXNoCgkJIyBhbnl3YXkuIEV4
cGVjdCBhdXRvLWRldGVjdGlvbiBvZiA2NC1iaXQgZW5hYmxlZCBnY2Mgb24KCQkjIEhQLVVYIHNv
b24sIGluY2x1ZGluZyBhIHVzZXItZnJpZW5kbHkgZXhpdAoJCWNhc2UgJGdjY182NG5hdGl2ZSBp
bgoJCSAgICBubykgY2FzZSAiJGdjY3ZlcnNpb24iIGluCgkJCSAgICBbMTIzNF0qKQoJCQkJY2Nm
bGFncz0iJGNjZmxhZ3MgLW1scDY0IgoJCQkJY2FzZSAiJGFyY2huYW1lIiBpbgoJCQkJICAgIFBB
LVJJU0MqKQoJCQkJCWxkZmxhZ3M9IiRsZGZsYWdzIC1XbCwrREQ2NCIKCQkJCQk7OwoJCQkJICAg
IElBNjQqKQoJCQkJCWxkZmxhZ3M9IiRsZGZsYWdzIC1tbHA2NCIKCQkJCQk7OwoJCQkJICAgIGVz
YWMKCQkJCTs7CgkJCSAgICBlc2FjCgkJCTs7CgkJICAgIGVzYWMKCQk7OwoJICAgICopCgkJY2Fz
ZSAiJHVzZTY0Yml0YWxsIiBpbgoJCSAgICAkZGVmaW5lfHRydWV8W3lZXSopCgkJCWNjZmxhZ3M9
IiRjY2ZsYWdzICtERDY0IgoJCQlsZGZsYWdzPSIkbGRmbGFncyArREQ2NCIKCQkJOzsKCQkgICAg
ZXNhYwoJCTs7CgkgICAgZXNhYwoKCSMgUmVzZXQgdGhlIGxpYnJhcnkgY2hlY2tlciB0byBtYWtl
IHN1cmUgbGlicmFyaWVzCgkjIGFyZSB0aGUgcmlnaHQgdHlwZQoJIyAoTk9URTogb24gSUE2NCwg
dGhpcyBkb2Vzbid0IHdvcmsgd2l0aCAuYSBmaWxlcy4pCglsaWJzY2hlY2s9J2Nhc2UgImAvdXNy
L2Jpbi9maWxlICR4eHhgIiBpbgoJCSAgICAgICAqRUxGLTY0KnwqTFA2NCp8KlBBLVJJU0MyLjAq
KSA7OwoJCSAgICAgICAqKSB4eHg9L25vLzY0LWJpdCR4eHggOzsKCQkgICAgICAgZXNhYycKCgk7
OwoKICAgICopCSMgTm90IGluIDY0LWJpdCBtb2RlCgoJY2FzZSAiJGFyY2huYW1lIiBpbgoJICAg
IFBBLVJJU0MqKQoJCWxpYmM9Jy9saWIvbGliYy5zbCcgOzsKCSAgICBJQTY0KikKCQlsb2NsaWJw
dGg9IiRsb2NsaWJwdGggL3Vzci9saWIvaHB1eDMyIgoJCWxpYmM9Jy91c3IvbGliL2hwdXgzMi9s
aWJjLnNvJyA7OwoJICAgIGVzYWMKCTs7CiAgICBlc2FjCgojIEJ5IHNldHRpbmcgdGhlIGRlZmVy
cmVkIGZsYWcgYmVsb3csIHRoaXMgbWVhbnMgdGhhdCBpZiB5b3UgcnVuIHBlcmwKIyBvbiBhIHN5
c3RlbSB0aGF0IGRvZXMgbm90IGhhdmUgdGhlIHJlcXVpcmVkIHNoYXJlZCBsaWJyYXJ5IHRoYXQg
eW91CiMgbGlua2VkIGl0IHdpdGgsIGl0IHdpbGwgZGllIHdoZW4geW91IHRyeSB0byBhY2Nlc3Mg
YSBzeW1ib2wgaW4gdGhlCiMgKG1pc3NpbmcpIHNoYXJlZCBsaWJyYXJ5LiAgSWYgeW91IHdvdWxk
IHJhdGhlciBrbm93IGF0IHBlcmwgc3RhcnR1cAojIHRpbWUgdGhhdCB5b3UgYXJlIG1pc3Npbmcg
YW4gaW1wb3J0YW50IHNoYXJlZCBsaWJyYXJ5LCBzd2l0Y2ggdGhlCiMgY29tbWVudHMgc28gdGhh
dCBpbW1lZGlhdGUsIHJhdGhlciB0aGFuIGRlZmVycmVkIGxvYWRpbmcgaXMKIyBwZXJmb3JtZWQu
ICBFdmVuIHdpdGggaW1tZWRpYXRlIGxvYWRpbmcsIHlvdSBjYW4gcG9zdHBvbmUgZXJyb3JzIGZv
cgojIHVuZGVmaW5lZCAob3IgbXVsdGlwbHkgZGVmaW5lZCkgcm91dGluZXMgdW50aWwgYWN0dWFs
IGFjY2VzcyBieQojIGFkZGluZyB0aGUgIm5vbmZhdGFsIiBvcHRpb24uCiMgY2NkbGZsYWdzPSIt
V2wsLUUgLVdsLC1CLGltbWVkaWF0ZSAkY2NkbGZsYWdzIgojIGNjZGxmbGFncz0iLVdsLC1FIC1X
bCwtQixpbW1lZGlhdGUsLUIsbm9uZmF0YWwgJGNjZGxmbGFncyIKaWYgWyAiJGdudV9sZCIgPSAi
eWVzIiBdOyB0aGVuCiAgICBjY2RsZmxhZ3M9Ii1XbCwtRSAkY2NkbGZsYWdzIgplbHNlCiAgICBj
Y2RsZmxhZ3M9Ii1XbCwtRSAtV2wsLUIsZGVmZXJyZWQgJGNjZGxmbGFncyIKICAgIGZpCgoKIyMj
IENPTVBJTEVSIFNQRUNJRklDUwoKIyMgTG9jYWwgcmVzdHJpY3Rpb25zIChwb2ludCB0byBSRUFE
TUUuaHB1eCB0byBsaWZ0IHRoZXNlKQoKIyMgT3B0aW1pemF0aW9uIGxpbWl0cwpjYXQgPnRyeS5j
IDw8RU9GCiNpbmNsdWRlIDxzdGRpby5oPgojaW5jbHVkZSA8c3lzL3Jlc291cmNlLmg+CgppbnQg
bWFpbiAoKQp7CiAgICBzdHJ1Y3QgcmxpbWl0IHJsOwogICAgaW50IGkgPSBnZXRybGltaXQgKFJM
SU1JVF9EQVRBLCAmcmwpOwogICAgcHJpbnRmICgiJWRcbiIsIChpbnQpKHJsLnJsaW1fY3VyIC8g
KDEwMjQgKiAxMDI0KSkpOwogICAgfSAvKiBtYWluICovCkVPRgokY2MgLW8gdHJ5ICRjY2ZsYWdz
ICRsZGZsYWdzIHRyeS5jCgltYXhkc2l6PWB0cnlgCnJtIC1mIHRyeSB0cnkuYyBjb3JlCmlmIFsg
JG1heGRzaXogLWxlIDY0IF07IHRoZW4KICAgICMgNjQgTWIgaXMgcHJvYmFibHkgbm90IGVub3Vn
aCB0byBvcHRpbWl6ZSB0b2tlLmMKICAgICMgYW5kIHJlZ2V4cC5jIHdpdGggLU8yCiAgICBjYXQg
PDxFT00gPiY0CllvdXIga2VybmVsIGxpbWl0cyB0aGUgZGF0YSBzZWN0aW9uIG9mIHlvdXIgcHJv
Z3JhbXMgdG8gJG1heGRzaXogTWIsCndoaWNoIGlzIChzYWRseSkgbm90IGVub3VnaCB0byBmdWxs
eSBvcHRpbWl6ZSBzb21lIHBhcnRzIG9mIHRoZQpwZXJsIGJpbmFyeS4gSSdsbCB0cnkgdG8gdXNl
IGEgbG93ZXIgb3B0aW1pemF0aW9uIGxldmVsIGZvcgp0aG9zZSBwYXJ0cy4gSWYgeW91IGFyZSBh
IHN5c2FkbWluLCBhbmQgeW91ICpkbyogd2FudCBmdWxsCm9wdGltaXphdGlvbiwgcmFpc2UgdGhl
ICdtYXhkc2l6JyBrZXJuZWwgY29uZmlndXJhdGlvbiBwYXJhbWV0ZXIKdG8gYXQgbGVhc3QgMHgw
ODAwMDAwMCAoMTI4IE1iKSBhbmQgcmVidWlsZCB5b3VyIGtlcm5lbC4KRU9NCnJlZ2V4ZWNfY2Zs
YWdzPScnCmRvb3BfY2ZsYWdzPScnCm9wX2NmbGFncz0nJwogICAgZmkKCmNhc2UgIiRjY2lzZ2Nj
IiBpbgogICAgJGRlZmluZXx0cnVlfFtZeV0pCgoJY2FzZSAiJG9wdGltaXplIiBpbgoJICAgICIi
KSAgICAgICAgICAgb3B0aW1pemU9Ii1nIC1PIiA7OwoJICAgICpPWzM0NTY3ODldKikgb3B0aW1p
emU9YGVjaG8gIiRvcHRpbWl6ZSIgfCBzZWQgLWUgJ3MvT1szLTldL08yLydgIDs7CgkgICAgZXNh
YwoJI2xkPSIkY2MiCglsZD0vdXNyL2Jpbi9sZAoJY2NjZGxmbGFncz0nLWZQSUMnCgkjbGRkbGZs
YWdzPSctc2hhcmVkJwoJbGRkbGZsYWdzPSctYicKCWNhc2UgIiRvcHRpbWl6ZSIgaW4KCSAgICAq
LWcqLU8qfCotTyotZyopCgkJIyBnY2Mgd2l0aG91dCBnYXMgd2lsbCBub3QgYWNjZXB0IC1nCgkJ
ZWNobyAibWFpbigpe30iPnRyeS5jCgkJY2FzZSAiYCRjYyAkb3B0aW1pemUgLWMgdHJ5LmMgMj4m
MWAiIGluCgkJICAgICoiLWcgb3B0aW9uIGRpc2FibGVkIiopCgkJCXNldCBgZWNobyAiWCAkb3B0
aW1pemUgIiB8IHNlZCAtZSAncy8gLWcgLyAvJ2AKCQkJc2hpZnQKCQkJb3B0aW1pemU9IiQqIgoJ
CQk7OwoJCSAgICBlc2FjCgkJOzsKCSAgICBlc2FjCglpZiBbICRtYXhkc2l6IC1sZSA2NCBdOyB0
aGVuCgkgICAgY2FzZSAiJG9wdGltaXplIiBpbgoJCSpPMiopCW9wdD1gZWNobyAiJG9wdGltaXpl
IiB8IHNlZCAtZSAncy9PMi9PMS8nYAoJCQl0b2tlX2NmbGFncz0iJHRva2VfY2ZsYWdzO29wdGlt
aXplPVwiJG9wdFwiIgoJCQlyZWdleGVjX2NmbGFncz0ib3B0aW1pemU9XCIkb3B0XCIiCgkJCTs7
CgkJZXNhYwoJICAgIGZpCgk7OwoKICAgICopCgljYXNlICIkb3B0aW1pemUiIGluCgkgICAgIiIp
ICAgICAgICAgICBvcHRpbWl6ZT0iK08yICtPbm9saW1pdCIgOzsKCSAgICAqT1szNDU2Nzg5XSop
IG9wdGltaXplPWBlY2hvICIkb3B0aW1pemUiIHwgc2VkIC1lICdzL09bMy05XS9PMi8nYCA7OwoJ
ICAgIGVzYWMKCWNhc2UgIiRvcHRpbWl6ZSIgaW4KCSAgICAqLU8qfFwKCSAgICAqTzIqKSAgIG9w
dD1gZWNobyAiJG9wdGltaXplIiB8IHNlZCAtZSAncy8tTy8rTzIvJyAtZSAncy9PMi9PMS8nIC1l
ICdzLyAqK09ub2xpbWl0Ly8nYAoJCSAgICA7OwoJICAgICopICAgICAgb3B0PSIkb3B0aW1pemUi
CgkJICAgIDs7CgkgICAgZXNhYwoJY2FzZSAiJGFyY2huYW1lIiBpbgoJICAgIElBNjQqKQoJCWNh
c2UgIiRjY3ZlcnNpb24iIGluCgkJICAgIEIzOTEwQipBLjA2LjBbMTIzNDVdKQoJCQkjID4gY2Mg
LS12ZXJzaW9uCgkJCSMgY2M6IEhQIGFDKysvQU5TSSBDIEIzOTEwQiBBLjA2LjA1IFtKdWwgMjUg
MjAwNV0KCQkJIyBIYXMgb3B0aW1pemluZyBwcm9ibGVtcyB3aXRoIC1PMiBhbmQgdXAgZm9yIGJv
dGgKCQkJIyBtYWludCAoNS44LjgrKSBhbmQgYmxlYWQgKDUuOS4zKykKCQkJIyAtTzEvK08xIHBh
c3NlZCBhbGwgdGVzdHMgKG0pJzA1IFsgMTAgSmFuIDIwMDUgXQoJCQlvcHRpbWl6ZT0iJG9wdCIJ
CQk7OwoJCQlCMzkxMEIqQS4wNi4xNSkKCQkJIyA+IGNjIC0tdmVyc2lvbgoJCQkjIGNjOiBIUCBD
L2FDKysgQjM5MTBCIEEuMDYuMTUgW01heSAxNiAyMDA3XQoJCQkjIEhhcyBvcHRpbWl6aW5nIHBy
b2JsZW1zIHdpdGggK08yIGZvciBibGVhZCAoNS4xNS45KSwKCQkJIyBzZWUgaHR0cHM6Ly9ydC5w
ZXJsLm9yZzo0NDMvcnQzL1RpY2tldC9EaXNwbGF5Lmh0bWw/aWQ9MTAzNjY4LgoJCQkjCgkJCSMg
K08yICtPbm9saW1pdCArT25vcHJvY2VsaW0gICtPc3RvcmVfb3JkZXJpbmcgXAoJCQkjICtPbm9s
aWJjYWxscz1zdHJjbXAKCQkJIyBwYXNzZXMgYWxsIHRlc3RzICh3aXRoL3dpdGhvdXQgLURERUJV
R0dJTkcpIFtOb3YgMTcgMjAxMV0KCQkJY2FzZSAiJG9wdGltaXplIiBpbgoJCQkJKk8yKikgb3B0
aW1pemU9IiRvcHRpbWl6ZSArT25vcHJvY2VsaW0gK09zdG9yZV9vcmRlcmluZyArT25vbGliY2Fs
bHM9c3RyY21wIiA7OwoJCQkJZXNhYwoJCQk7OwoJCSAgICAqKSAgZG9vcF9jZmxhZ3M9Im9wdGlt
aXplPVwiJG9wdFwiIgoJCQlvcF9jZmxhZ3M9Im9wdGltaXplPVwiJG9wdFwiIgk7OwoJCSAgICBl
c2FjCgkJOzsKCSAgICBlc2FjCglpZiBbICRtYXhkc2l6IC1sZSA2NCBdOyB0aGVuCgkgICAgdG9r
ZV9jZmxhZ3M9IiR0b2tlX2NmbGFncztvcHRpbWl6ZT1cIiRvcHRcIiIKCSAgICByZWdleGVjX2Nm
bGFncz0ib3B0aW1pemU9XCIkb3B0XCIiCgkgICAgZmkKCWxkPS91c3IvYmluL2xkCgljY2NkbGZs
YWdzPScrWicKCWxkZGxmbGFncz0nLWIgK3Zub2NvbXBhdHdhcm5pbmdzJwoJOzsKICAgIGVzYWMK
CiMjIExBUkdFRklMRVMKaWYgWyAkeHhPc1JldiAtbHQgMTAyMCBdOyB0aGVuCiAgICB1c2VsYXJn
ZWZpbGVzPSIkdW5kZWYiCiAgICBmaQoKI2Nhc2UgIiR1c2VsYXJnZWZpbGVzLSRjY2lzZ2NjIiBp
bgojICAgICIkZGVmaW5lLSRkZWZpbmUifCctZGVmaW5lJykKIwljYXQgPDxFT00gPiY0CiMKIyoq
KiBJJ20gaWdub3JpbmcgbGFyZ2UgZmlsZXMgZm9yIHRoaXMgYnVpbGQgYmVjYXVzZQojKioqIEkg
ZG9uJ3Qga25vdyBob3cgdG8gZG8gdXNlIGxhcmdlIGZpbGVzIGluIEhQLVVYIHVzaW5nIGdjYy4K
IwojRU9NCiMJdXNlbGFyZ2VmaWxlcz0iJHVuZGVmIgojCTs7CiMgICAgZXNhYwoKIyBPbmNlIHdl
IGhhdmUgdGhlIGNvbXBpbGVyIGZsYWdzIGRlZmluZWQsIENvbmZpZ3VyZSB3aWxsCiMgZXhlY3V0
ZSB0aGUgZm9sbG93aW5nIGNhbGwtYmFjayBzY3JpcHQuIFNlZSBoaW50cy9SRUFETUUuaGludHMK
IyBmb3IgZGV0YWlscy4KY2F0ID4gVVUvY2MuY2J1IDw8J0VPQ0JVJwojIFRoaXMgc2NyaXB0IFVV
L2NjLmNidSB3aWxsIGdldCAnY2FsbGVkLWJhY2snIGJ5IENvbmZpZ3VyZSBhZnRlciBpdAojIGhh
cyBwcm9tcHRlZCB0aGUgdXNlciBmb3IgdGhlIEMgY29tcGlsZXIgdG8gdXNlLgoKIyBDb21waWxl
IGFuZCBydW4gdGhlIGEgdGVzdCBjYXNlIHRvIHNlZSBpZiBhIGNlcnRhaW4gZ2NjIGJ1ZyBpcwoj
IHByZXNlbnQuIElmIHNvLCBsb3dlciB0aGUgb3B0aW1pemF0aW9uIGxldmVsIHdoZW4gY29tcGls
aW5nCiMgcHBfcGFjay5jLiAgVGhpcyB3b3JrcyBhcm91bmQgYSBidWcgaW4gdW5wYWNrLgoKaWYg
dGVzdCAteiAiJGNjaXNnY2MiIC1hIC16ICIkZ2NjdmVyc2lvbiI7IHRoZW4KICAgIDogbm8gdGVz
dHMgbmVlZGVkIGZvciBIUGMKZWxzZQogICAgZWNobyAiICIKICAgIGVjaG8gIlRlc3RpbmcgZm9y
IGEgY2VydGFpbiBnY2MgYnVnIGlzIGZpeGVkIGluIHlvdXIgY29tcGlsZXIuLi4iCgogICAgIyBU
cnkgY29tcGlsaW5nIHRoZSB0ZXN0IGNhc2UuCiAgICBpZiAkY2MgLW8gdDAwMSAtTyAkY2NmbGFn
cyAkbGRmbGFncyAtbG0gLi4vaGludHMvdDAwMS5jOyB0aGVuCiAgICAgICBnY2NidWc9YCRydW4g
Li90MDAxYAogICAgICAgY2FzZSAiJGdjY2J1ZyIgaW4KICAgICAgICAgICAqZmFpbHMqKQogICAg
ICAgICAgICAgICBjYXQgPiY0IDw8RU9GClRoaXMgQyBjb21waWxlciAoJGdjY3ZlcnNpb24pIGlz
IGtub3duIHRvIGhhdmUgb3B0aW1pemVyCnByb2JsZW1zIHdoZW4gY29tcGlsaW5nIHBwX3BhY2su
Yy4KCkRpc2FibGluZyBvcHRpbWl6YXRpb24gZm9yIHBwX3BhY2suYy4KRU9GCiAgICAgICAgICAg
ICAgIGNhc2UgIiRwcF9wYWNrX2NmbGFncyIgaW4KICAgICAgICAgICAgICAgICAgICcnKSBwcF9w
YWNrX2NmbGFncz0nb3B0aW1pemU9JwogICAgICAgICAgICAgICAgICAgICAgIGVjaG8gInBwX3Bh
Y2tfY2ZsYWdzPSdvcHRpbWl6ZT1cIlwiJyIgPj4gY29uZmlnLnNoIDs7CiAgICAgICAgICAgICAg
ICAgICAqKSAgZWNobyAiWW91IHNwZWNpZmllZCBwcF9wYWNrX2NmbGFncyB5b3Vyc2VsZiwgc28g
d2UnbGwgZ28gd2l0aCB5b3VyIHZhbHVlLiIgPiY0IDs7CiAgICAgICAgICAgICAgICAgICBlc2Fj
CiAgICAgICAgICAgICAgIDs7CiAgICAgICAgICAgKikgIGVjaG8gIllvdXIgY29tcGlsZXIgaXMg
b2suIiA+JjQKICAgICAgICAgICAgICAgOzsKICAgICAgICAgICBlc2FjCiAgICBlbHNlCiAgICAg
ICBlY2hvICIgIgogICAgICAgZWNobyAiKioqIFdIT0EgVEhFUkUhISEgKioqIiA+JjQKICAgICAg
IGVjaG8gIiAgICBZb3VyIEMgY29tcGlsZXIgXCIkY2NcIiBkb2Vzbid0IHNlZW0gdG8gYmUgd29y
a2luZyEiID4mNAogICAgICAgY2FzZSAiJGtub3dpdGFsbCIgaW4KICAgICAgICAgICAnJykgZWNo
byAiICAgIFlvdSdkIGJldHRlciBzdGFydCBodW50aW5nIGZvciBvbmUgYW5kIGxldCBtZSBrbm93
IGFib3V0IGl0LiIgPiY0CiAgICAgICAgICAgICAgIGV4aXQgMQogICAgICAgICAgICAgICA7Owog
ICAgICAgICAgIGVzYWMKICAgICAgIGZpCgogICAgcm0gLWYgdDAwMSRfbyB0MDAxJF9leGUKICAg
IGZpCkVPQ0JVCgpjYXQgPlVVL3VzZWxhcmdlZmlsZXMuY2J1IDw8J0VPQ0JVJwojIFRoaXMgc2Ny
aXB0IFVVL3VzZWxhcmdlZmlsZXMuY2J1IHdpbGwgZ2V0ICdjYWxsZWQtYmFjaycgYnkgQ29uZmln
dXJlCiMgYWZ0ZXIgaXQgaGFzIHByb21wdGVkIHRoZSB1c2VyIGZvciB3aGV0aGVyIHRvIHVzZSBs
YXJnZSBmaWxlcy4KY2FzZSAiJHVzZWxhcmdlZmlsZXMiIGluCiAgICAiInwkZGVmaW5lfHRydWV8
W3lZXSopCgkjIHRoZXJlIGFyZSBsYXJnZWZpbGUgZmxhZ3MgYXZhaWxhYmxlIHZpYSBnZXRjb25m
KDEpCgkjIGJ1dCB3ZSBjaGVhdCBmb3Igbm93LiAgKEtlZXAgdGhhdCBpbiB0aGUgbGVmdCBtYXJn
aW4uKQpjY2ZsYWdzX3VzZWxhcmdlZmlsZXM9Ii1EX0xBUkdFRklMRV9TT1VSQ0UgLURfRklMRV9P
RkZTRVRfQklUUz02NCIKCgljYXNlICIgJGNjZmxhZ3MgIiBpbgoJKiIgJGNjZmxhZ3NfdXNlbGFy
Z2VmaWxlcyAiKikgOzsKCSopIGNjZmxhZ3M9IiRjY2ZsYWdzICRjY2ZsYWdzX3VzZWxhcmdlZmls
ZXMiIDs7Cgllc2FjCgoJaWYgdGVzdCAteiAiJGNjaXNnY2MiIC1hIC16ICIkZ2NjdmVyc2lvbiI7
IHRoZW4KCSAgICAjIFRoZSBzdHJpY3QgQU5TSSBtb2RlICgtQWEpIGRvZXNuJ3QgbGlrZSBsYXJn
ZSBmaWxlcy4KCSAgICBjY2ZsYWdzPWBlY2hvICIgJGNjZmxhZ3MgInxzZWQgJ3NAIC1BYSBAIEBn
J2AKCSAgICBjYXNlICIkY2NmbGFncyIgaW4KCQkqLUFlKikgOzsKCQkqKSAgICAgY2NmbGFncz0i
JGNjZmxhZ3MgLUFlIiA7OwoJCWVzYWMKCSAgICBmaQoJOzsKICAgIGVzYWMKRU9DQlUKCiMgVEhS
RUFESU5HCgojIFRoaXMgc2NyaXB0IFVVL3VzZXRocmVhZHMuY2J1IHdpbGwgZ2V0ICdjYWxsZWQt
YmFjaycgYnkgQ29uZmlndXJlCiMgYWZ0ZXIgaXQgaGFzIHByb21wdGVkIHRoZSB1c2VyIGZvciB3
aGV0aGVyIHRvIHVzZSB0aHJlYWRzLgpjYXQgPlVVL3VzZXRocmVhZHMuY2J1IDw8J0VPQ0JVJwpj
YXNlICIkdXNldGhyZWFkcyIgaW4KICAgICRkZWZpbmV8dHJ1ZXxbeVldKikKCWlmIFsgIiR4eE9z
UmV2TWFqb3IiIC1sdCAxMCBdOyB0aGVuCgkgICAgY2F0IDw8RU9NID4mNAoKSFAtVVggJHh4T3NS
ZXZNYWpvciBjYW5ub3Qgc3VwcG9ydCBQT1NJWCB0aHJlYWRzLgpDb25zaWRlciB1cGdyYWRpbmcg
dG8gYXQgbGVhc3QgSFAtVVggMTEuCkNhbm5vdCBjb250aW51ZSwgYWJvcnRpbmcuCkVPTQoJICAg
IGV4aXQgMQoJICAgIGZpCgoJaWYgWyAiJHh4T3NSZXZNYWpvciIgLWVxIDEwIF07IHRoZW4KCSAg
ICAjIFVuZGVyIDEwLlgsIGEgdGhyZWFkZWQgcGVybCBjYW4gYmUgYnVpbHQKCSAgICBpZiBbIC1m
IC91c3IvaW5jbHVkZS9wdGhyZWFkLmggXTsgdGhlbgoJCWlmIFsgLWYgL3Vzci9saWIvbGliY21h
LnNsIF07IHRoZW4KCQkgICAgIyBEQ0UgKGZyb20gQ29yZSBPUyBDRCkgaXMgaW5zdGFsbGVkCgoJ
CSAgICMgQ2hlY2sgaWYgaXQgaXMgcHJpc3RpbmUsIG9yIHBhdGNoZWQKCQkgICBjbWF2c249YHdo
YXQgL3Vzci9saWIvbGliY21hLnNsIDI+JjEgfCBncmVwIDE5OTZgCgkJICAgaWYgWyAhIC16ICIk
Y21hdnNuIiBdOyB0aGVuCgkJICAgICAgIGNhdCA8PEVPTSA+JjQKBwoqKioqKioqKioqKioqKioq
KioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioq
KioKClBlcmwgd2lsbCBzdXBwb3J0IHRocmVhZGluZyB0aHJvdWdoIC91c3IvbGliL2xpYmNtYS5z
bCBmcm9tCnRoZSBIUCBEQ0UgcGFja2FnZSwgYnV0IHRoZSB2ZXJzaW9uIGZvdW5kIGlzIHRvbyBv
bGQgdG8gYmUKcmVsaWFibGUuCgpJZiB5b3UgYXJlIG5vdCBkZXBlbmRpbmcgb24gdGhpcyBzcGVj
aWZpYyB2ZXJzaW9uIG9mIHRoZSBsaWJyYXJ5LApjb25zaWRlciB0byB1cGdyYWRlIHVzaW5nIHBh
dGNoIFBIU1NfMjM2NzIgKHJlYWQgUkVBRE1FLmhwdXgpCgoqKioqKioqKioqKioqKioqKioqKioq
KioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioKCihz
bGVlcGluZyBmb3IgMTAgc2Vjb25kcy4uLikKRU9NCgkJICAgICAgIHNsZWVwIDEwCgkJICAgICAg
IGZpCgoJCSAgICAjIEl0IG5lZWRzICMgbGliY21hIGFuZCBPTERfUFRIUkVBRFNfQVBJLiBBbHNv
CgkJICAgICMgPHB0aHJlYWQuaD4gbmVlZHMgdG8gYmUgI2luY2x1ZGVkIGJlZm9yZSBhbnkKCQkg
ICAgIyBvdGhlciBpbmNsdWRlcyAoaW4gcGVybC5oKQoKCQkgICAgIyBIUC1VWCAxMC5YIHVzZXMg
dGhlIG9sZCBwdGhyZWFkcyBBUEkKCQkgICAgZF9vbGRwdGhyZWFkcz0iJGRlZmluZSIKCgkJICAg
ICMgaW5jbHVkZSBsaWJjbWEgYmVmb3JlIGFsbCB0aGUgb3RoZXJzCgkJICAgIGxpYnN3YW50ZWQ9
ImNtYSAkbGlic3dhbnRlZCIKCgkJICAgICMgdGVsbCBwZXJsLmggdG8gaW5jbHVkZSA8cHRocmVh
ZC5oPiBiZWZvcmUgb3RoZXIKCQkgICAgIyBpbmNsdWRlIGZpbGVzCgkJICAgIGNjZmxhZ3M9IiRj
Y2ZsYWdzIC1EUFRIUkVBRF9IX0ZJUlNUIgojIEZpcnN0IGNvbHVtbiBvbiBwdXJwb3NlOgojIHRo
aXMgaXMgbm90IGEgc3RhbmRhcmQgQ29uZmlndXJlIHZhcmlhYmxlCiMgYnV0IHdlIG5lZWQgdG8g
Z2V0IHRoaXMgbm90aWNlZC4KcHRocmVhZF9oX2ZpcnN0PSIkZGVmaW5lIgoKCQkgICAgIyBIUC1V
WCAxMC5YIHNlZW1zIHRvIGhhdmUgbm8gZWFzeQoJCSAgICAjIHdheSBvZiBkZXRlY3RpbmcgdGhl
c2UgKnRpbWVfciBwcm90b3MuCgkJICAgIGRfZ210aW1lX3JfcHJvdG89J2RlZmluZScKCQkgICAg
Z210aW1lX3JfcHJvdG89J1JFRU5UUkFOVF9QUk9UT19JX1RTJwoJCSAgICBkX2xvY2FsdGltZV9y
X3Byb3RvPSdkZWZpbmUnCgkJICAgIGxvY2FsdGltZV9yX3Byb3RvPSdSRUVOVFJBTlRfUFJPVE9f
SV9UUycKCgkJICAgICMgQXZvaWQgdGhlIHBvaXNvbm91cyBjb25mbGljdGluZyAoYW5kIGlycmVs
ZXZhbnQpCgkJICAgICMgcHJvdG90eXBlcyBvZiBzZXRrZXkgKCkuCgkJICAgIGlfY3J5cHQ9IiR1
bmRlZiIKCgkJICAgICMgQ01BIHJlZGVmaW5lcyBzZWxlY3QgdG8gY21hX3NlbGVjdCwgYW5kIGNt
YV9zZWxlY3QKCQkgICAgIyBleHBlY3RzIGludCAqIGluc3RlYWQgb2YgZmRfc2V0ICogKGp1c3Qg
bGlrZSA5LlgpCgkJICAgIHNlbGVjdHR5cGU9J2ludCAqJwoKCQllbGlmIFsgLWYgL3Vzci9saWIv
bGlicHRocmVhZC5zbCBdOyB0aGVuCgkJICAgICMgUFRIIHBhY2thZ2UgaXMgaW5zdGFsbGVkCgkJ
ICAgIGxpYnN3YW50ZWQ9InB0aHJlYWQgJGxpYnN3YW50ZWQiCgkJZWxzZQoJCSAgICBsaWJzd2Fu
dGVkPSJub190aHJlYWRzX2F2YWlsYWJsZSIKCQkgICAgZmkKCSAgICBlbHNlCgkJbGlic3dhbnRl
ZD0ibm9fdGhyZWFkc19hdmFpbGFibGUiCgkJZmkKCgkgICAgaWYgWyAkbGlic3dhbnRlZCA9ICJu
b190aHJlYWRzX2F2YWlsYWJsZSIgXTsgdGhlbgoJCWNhdCA8PEVPTSA+JjQKCkluIEhQLVVYIDEw
LlggZm9yIFBPU0lYIHRocmVhZHMgeW91IG5lZWQgYm90aCBvZiB0aGUgZmlsZXMKL3Vzci9pbmNs
dWRlL3B0aHJlYWQuaCBhbmQgZWl0aGVyIC91c3IvbGliL2xpYmNtYS5zbCBvciAvdXNyL2xpYi9s
aWJwdGhyZWFkLnNsLgpFaXRoZXIgeW91IG11c3QgdXBncmFkZSB0byBIUC1VWCAxMSBvciBpbnN0
YWxsIGEgcG9zaXggdGhyZWFkIGxpYnJhcnk6CgogICAgRENFLUNvcmVUb29scyBmcm9tIEhQLVVY
IDEwLjIwIEhhcmR3YXJlIEV4dGVuc2lvbnMgMy4wIENEIChCMzkyMC0xMzk0MSkKCm9yCgogICAg
UFRIIHBhY2thZ2UgZnJvbSBlLmcuIGh0dHA6Ly9ocHV4LmNvbm5lY3Qub3JnLnVrL2hwcGQvaHB1
eC9HbnUvcHRoLTIuMC43LwoKQ2Fubm90IGNvbnRpbnVlLCBhYm9ydGluZy4KRU9NCgkJZXhpdCAx
CgkJZmkKCWVsc2UKCSAgICAjIDEyIG1heSB3YW50IHVwcGluZyB0aGUgX1BPU0lYX0NfU09VUkNF
IGRhdGVzdGFtcC4uLgoJICAgIGNjZmxhZ3M9IiAtRF9QT1NJWF9DX1NPVVJDRT0xOTk1MDZMIC1E
X1JFRU5UUkFOVCAkY2NmbGFncyIKCSAgICBzZXQgYGVjaG8gWCAiJGxpYnN3YW50ZWQgInwgc2Vk
IC1lICdzLyBjIC8gcHRocmVhZCBjIC8nYAoJICAgIHNoaWZ0CgkgICAgbGlic3dhbnRlZD0iJCoi
CgoJICAgICMgSFAtVVggMTEuWCBzZWVtcyB0byBoYXZlIG5vIGVhc3kKCSAgICAjIHdheSBvZiBk
ZXRlY3RpbmcgdGhlc2UgKnRpbWVfciBwcm90b3MuCgkgICAgZF9nbXRpbWVfcl9wcm90bz0nZGVm
aW5lJwoJICAgIGdtdGltZV9yX3Byb3RvPSdSRUVOVFJBTlRfUFJPVE9fU19UUycKCSAgICBkX2xv
Y2FsdGltZV9yX3Byb3RvPSdkZWZpbmUnCgkgICAgbG9jYWx0aW1lX3JfcHJvdG89J1JFRU5UUkFO
VF9QUk9UT19TX1RTJwoJICAgIGZpCgk7OwogICAgZXNhYwpFT0NCVQoKIyBUaGVyZSB1c2VkIHRv
IGJlOgojICBUaGUgbXlzdGVyaW91cyBpb194cyBtZW1vcnkgY29ycnVwdGlvbiBpbiAxMS4wMCAz
MmJpdCBzZWVtcyB0byBnZXQKIyAgZml4ZWQgYnkgbm90IHVzaW5nIFBlcmwncyBtYWxsb2MuICBG
bGlwIHNpZGUgaXMgcGVyZm9ybWFuY2UgbG9zcy4KIyAgU28gd2Ugd2FudCBteW1hbGxvYyBmb3Ig
YWxsIHNpdHVhdGlvbnMgcG9zc2libGUKIyBUaGF0IHNldCB1c2VteW1hbGxvYyB0byAnbicgZm9y
IHRocmVhZGVkIGJ1aWxkcyBhbmQgbm9uLWdjYyAzMmJpdAojICBub24tZGVidWdnaW5nIGJ1aWxk
cyBhbmQgJ3knIGZvciBhbGwgb3RoZXJzCgp1c2VteW1hbGxvYz0nbicKY2FzZSAiJHVzZXBlcmxp
byIgaW4KICAgICR1bmRlZnxmYWxzZXxbbk5dKikgdXNlbXltYWxsb2M9J3knIDs7CiAgICBlc2Fj
CgojIG1hbGxvYyB3cmFwIHdvcmtzCmNhc2UgIiR1c2VtYWxsb2N3cmFwIiBpbgogICAgJycpIHVz
ZW1hbGxvY3dyYXA9J2RlZmluZScgOzsKICAgIGVzYWMKCiMgY3RpbWVfciAoKSBhbmQgYXNjdGlt
ZV9yICgpIHNlZW0gdG8gaGF2ZSBpc3N1ZXMgZm9yIHZlcnNpb25zIGJlZm9yZQojIEhQLVVYIDEx
CmlmIFsgJHh4T3NSZXZNYWpvciAtbHQgMTEgXTsgdGhlbgogICAgZF9jdGltZV9yPSIkdW5kZWYi
CiAgICBkX2FzY3RpbWVfcj0iJHVuZGVmIgogICAgZmkKCiMgZnBjbGFzc2lmeSAoKSBpcyBhIG1h
Y3JvLCB0aGUgbGlicmFyeSBjYWxsIGlzIEZwY2xhc3NpZnkKIyBTaW1pbGFybHkgd2l0aCB0aGUg
b3RoZXJzIGJlbG93LgpkX2ZwY2xhc3NpZnk9J2RlZmluZScKZF9pc25hbj0nZGVmaW5lJwpkX2lz
aW5mPSdkZWZpbmUnCmRfaXNmaW5pdGU9J2RlZmluZScKZF91bm9yZGVyZWQ9J2RlZmluZScKIyBO
ZXh0IG9uZShzKSBuZWVkIHRoZSBsZWFkaW5nIHRhYi4gIFRoZXNlIGFyZSBzcGVjaWFsICdoaW50
JyBzeW1ib2xzIHRoYXQKIyBhcmUgbm90IHRvIGJlIHByb3BhZ2F0ZWQgdG8gY29uZmlnLnNoLCBh
bGwgcmVsYXRlZCB0byBwdGhyZWFkcyBkcmFmdCA0CiMgaW50ZXJmYWNlcy4KY2FzZSAiJGRfb2xk
cHRocmVhZHMiIGluCiAgICAnJ3wkdW5kZWYpCglkX2NyeXB0X3JfcHJvdG89J3VuZGVmJwoJZF9n
ZXRncmVudF9yX3Byb3RvPSd1bmRlZicKCWRfZ2V0cHdlbnRfcl9wcm90bz0ndW5kZWYnCglkX3N0
cmVycm9yX3JfcHJvdG89J3VuZGVmJwoJOzsKICAgIGVzYWMK',
'darwin' =>
'IyMKIyBEYXJ3aW4gKE1hYyBPUykgaGludHMKIyBXaWxmcmVkbyBTYW5jaGV6IDx3c2FuY2hlekB3
c2FuY2hlei5uZXQ+CiMjCgojIwojIFBhdGhzCiMjCgojIENvbmZpZ3VyZSBoYXNuJ3QgZmlndXJl
ZCBvdXQgdGhlIHZlcnNpb24gbnVtYmVyIHlldC4gIEJ1bW1lci4KcGVybF9yZXZpc2lvbj1gYXdr
ICcvZGVmaW5lWyAJXStQRVJMX1JFVklTSU9OLyB7cHJpbnQgJDN9JyAkc3JjL3BhdGNobGV2ZWwu
aGAKcGVybF92ZXJzaW9uPWBhd2sgJy9kZWZpbmVbIAldK1BFUkxfVkVSU0lPTi8ge3ByaW50ICQz
fScgJHNyYy9wYXRjaGxldmVsLmhgCnBlcmxfc3VidmVyc2lvbj1gYXdrICcvZGVmaW5lWyAJXStQ
RVJMX1NVQlZFUlNJT04vIHtwcmludCAkM30nICRzcmMvcGF0Y2hsZXZlbC5oYAp2ZXJzaW9uPSIk
e3BlcmxfcmV2aXNpb259LiR7cGVybF92ZXJzaW9ufS4ke3Blcmxfc3VidmVyc2lvbn0iCgojIFBy
ZXRlbmQgdGhhdCBEYXJ3aW4gZG9lc24ndCBrbm93IGFib3V0IHRob3NlIHN5c3RlbSBjYWxscyBp
biBUaWdlcgojICgxMC40L2RhcndpbiA4KSBhbmQgZWFybGllciBbcGVybCAjMjQxMjJdCmNhc2Ug
IiRvc3ZlcnMiIGluClsxLThdLiopCiAgICBkX3NldHJlZ2lkPSd1bmRlZicKICAgIGRfc2V0cmV1
aWQ9J3VuZGVmJwogICAgZF9zZXRyZ2lkPSd1bmRlZicKICAgIGRfc2V0cnVpZD0ndW5kZWYnCiAg
ICA7Owplc2FjCgojIFRoaXMgd2FzIHByZXZpb3VzbHkgdXNlZCBpbiBhbGwgYnV0IGNhdXNlcyB0
aHJlZSBjYXNlcwojIChubyAtRGRwcmVmaXg9LCAtRHByZWZpeD0vdXNyLCAtRHByZWZpeD0vc29t
ZS90aGluZy9lbHNlKQojIGJ1dCB0aGF0IGNhdXNlZCB0b28gbXVjaCBncmllZi4KIyB2ZW5kb3Js
aWI9Ii9TeXN0ZW0vTGlicmFyeS9QZXJsLyR7dmVyc2lvbn0iOyAjIEFwcGxlLXN1cHBsaWVkIG1v
ZHVsZXMKCiMgQlNEIHBhdGhzCmNhc2UgIiRwcmVmaXgiIGluCicnKQkjIERlZmF1bHQgaW5zdGFs
bDsgdXNlIG5vbi1zeXN0ZW0gZGlyZWN0b3JpZXMKCXByZWZpeD0nL3Vzci9sb2NhbCc7CglzaXRl
cHJlZml4PScvdXNyL2xvY2FsJzsKCTs7CicvdXNyJykJIyBXZSBhcmUgYnVpbGRpbmcvcmVwbGFj
aW5nIHRoZSBidWlsdC1pbiBwZXJsCglwcmVmaXg9Jy8nOwoJaW5zdGFsbHByZWZpeD0nLyc7Cgli
aW49Jy91c3IvYmluJzsKCXNpdGVwcmVmaXg9Jy91c3IvbG9jYWwnOwoJIyBXZSBkb24ndCB3YW50
IC91c3IvYmluL0hFQUQgaXNzdWVzLgoJc2l0ZWJpbj0nL3Vzci9sb2NhbC9iaW4nOwoJc2l0ZXNj
cmlwdD0nL3Vzci9sb2NhbC9iaW4nOwoJaW5zdGFsbHVzcmJpbnBlcmw9J2RlZmluZSc7ICMgWW91
IGtuZXcgd2hhdCB5b3Ugd2VyZSBkb2luZy4KCXByaXZsaWI9Ii9TeXN0ZW0vTGlicmFyeS9QZXJs
LyR7dmVyc2lvbn0iOwoJc2l0ZWxpYj0iL0xpYnJhcnkvUGVybC8ke3ZlcnNpb259IjsKCXZlbmRv
cnByZWZpeD0nLyc7Cgl1c2V2ZW5kb3JwcmVmaXg9J2RlZmluZSc7Cgl2ZW5kb3JiaW49Jy91c3Iv
YmluJzsKCXZlbmRvcnNjcmlwdD0nL3Vzci9iaW4nOwoJdmVuZG9ybGliPSIvTmV0d29yay9MaWJy
YXJ5L1BlcmwvJHt2ZXJzaW9ufSI7CgkjIDRCU0QgdXNlcyAke3ByZWZpeH0vc2hhcmUvbWFuLCBu
b3QgJHtwcmVmaXh9L21hbi4KCW1hbjFkaXI9Jy91c3Ivc2hhcmUvbWFuL21hbjEnOwoJbWFuM2Rp
cj0nL3Vzci9zaGFyZS9tYW4vbWFuMyc7CgkjIEJ1dCB1c2VycycgaW5zdGFsbHMgc2hvdWxkbid0
IHRvdWNoIHRoZSBzeXN0ZW0gbWFuIHBhZ2VzLgoJIyBUcmFuc2llbnQgb2Jzb2xldGVkIHN0eWxl
LgoJc2l0ZW1hbjE9Jy91c3IvbG9jYWwvc2hhcmUvbWFuL21hbjEnOwoJc2l0ZW1hbjM9Jy91c3Iv
bG9jYWwvc2hhcmUvbWFuL21hbjMnOwoJIyBOZXcgc3R5bGUuCglzaXRlbWFuMWRpcj0nL3Vzci9s
b2NhbC9zaGFyZS9tYW4vbWFuMSc7CglzaXRlbWFuM2Rpcj0nL3Vzci9sb2NhbC9zaGFyZS9tYW4v
bWFuMyc7Cgk7OwogICopCSMgQW55dGhpbmcgZWxzZTsgdXNlIG5vbi1zeXN0ZW0gZGlyZWN0b3Jp
ZXMsIHVzZSBDb25maWd1cmUgZGVmYXVsdHMKCTs7CmVzYWMKCiMjCiMgVG9vbCBjaGFpbiBzZXR0
aW5ncwojIwoKIyBTaW5jZSB3ZSBjYW4gYnVpbGQgZmF0LCB0aGUgYXJjaG5hbWUgZG9lc24ndCBu
ZWVkIHRoZSBwcm9jZXNzb3IgdHlwZQphcmNobmFtZT0nZGFyd2luJzsKCiMgbm0gaXNuJ3Qga25v
d24gdG8gd29yayBhZnRlciBTbm93IExlb3BhcmQgYW5kIFhDb2RlIDQ7IHRlc3Rpbmcgd2l0aCBP
UyBYIDEwLjUKIyBhbmQgWGNvZGUgMyBzaG93cyBhIHdvcmtpbmcgbm0sIGJ1dCBwcmV0ZW5kaW5n
IGl0IGRvZXNuJ3Qgd29yayBwcm9kdWNlcyBubwojIHByb2JsZW1zLgp1c2VubT0nZmFsc2UnOwoK
Y2FzZSAiJG9wdGltaXplIiBpbgonJykKIyAgICBPcHRpbWl6aW5nIGZvciBzaXplIGFsc28gbWVh
biBsZXNzIHJlc2lkZW50IG1lbW9yeSB1c2FnZSBvbiB0aGUgcGFydAojIG9mIFBlcmwuICBBcHBs
ZSBhc3NlcnRzIHRoYXQgdGhpcyBpcyBhIG1vcmUgaW1wb3J0YW50IG9wdGltaXphdGlvbiB0aGFu
CiMgc2F2aW5nIG9uIENQVSBjeWNsZXMuICBHaXZlbiB0aGF0IG1lbW9yeSBzcGVlZCBoYXMgbm90
IGluY3JlYXNlZCBhdAojIHBhY2Ugd2l0aCBDUFUgc3BlZWQgb3ZlciB0aW1lIChvbiBhbnkgcGxh
dGZvcm0pLCB0aGlzIGlzIHByb2JhYmx5IGEKIyByZWFzb25hYmxlIGFzc2VydGlvbi4KaWYgWyAt
eiAiJHtvcHRpbWl6ZX0iIF07IHRoZW4KICBjYXNlICJgJHtjYzotZ2NjfSAtdiAyPiYxYCIgaW4K
ICAgICoiZ2NjIHZlcnNpb24gMy4iKikgb3B0aW1pemU9Jy1PcycgOzsKICAgICopIG9wdGltaXpl
PSctTzMnIDs7CiAgZXNhYwplbHNlCiAgb3B0aW1pemU9Jy1PMycKZmkKOzsKZXNhYwoKIyAtZm5v
LWNvbW1vbiBiZWNhdXNlIGNvbW1vbiBzeW1ib2xzIGFyZSBub3QgYWxsb3dlZCBpbiBNSF9EWUxJ
QgojIC1EUEVSTF9EQVJXSU46IGFwcGFyZW50bHkgdGhlIF9fQVBQTEVfXyBpcyBub3Qgc2FuY3Rp
b25lZCBieSBBcHBsZQojIGFzIHRoZSB3YXkgdG8gZGlmZmVyZW50aWF0ZSBNYWMgT1MgWC4gIChU
aGUgb2ZmaWNpYWwgbGluZSBpcyB0aGF0CiMgKm5vKiBjcHAgc3ltYm9sIGRvZXMgZGlmZmVyZW50
aWF0ZSBNYWMgT1MgWC4pCmNjZmxhZ3M9IiR7Y2NmbGFnc30gLWZuby1jb21tb24gLURQRVJMX0RB
UldJTiIKCiMgQXQgbGVhc3Qgb24gRGFyd2luIDEuMy54OgojCiMgIyBkZWZpbmUgSU5UMzJfTUlO
IC0yMTQ3NDgzNjQ4CiMgaW50IG1haW4gKCkgewojICBkb3VibGUgYSA9IElOVDMyX01JTjsKIyAg
cHJpbnRmICgiSU5UMzJfTUlOPSVnXG4iLCBhKTsKIyAgcmV0dXJuIDA7CiMgfQojIHdpbGwgb3V0
cHV0OgojIElOVDMyX01JTj0yLjE0NzQ4ZSswOQojIE5vdGUgdGhhdCB0aGUgSU5UMzJfTUlOIGhh
cyBiZWNvbWUgcG9zaXRpdmUuCiMgSU5UMzJfTUlOIGlzIHNldCBpbiAvdXNyL2luY2x1ZGUvc3Rk
aW50LmggYnk6CiMgI2RlZmluZSBJTlQzMl9NSU4gICAgICAgIC0yMTQ3NDgzNjQ4CiMgd2hpY2gg
c2VlbXMgdG8gYnJlYWsgdGhlIGdjYy4gIERlZmluaW5nIElOVDMyX01JTiBhcyAoLTIxNDc0ODM2
NDctMSkKIyBzZWVtcyB0byB3b3JrLiAgSU5UNjRfTUlOIHNlZW1zIHRvIGJlIHNpbWlsYXJseSBi
cm9rZW4uCiMgLS0gTmljaG9sYXMgQ2xhcmssIEtlbiBXaWxsaWFtcywgYW5kIEVkd2FyZCBNb3kK
IwojIFRoaXMgc2VlbXMgdG8gaGF2ZSBiZWVuIGZpeGVkIHNpbmNlIGF0IGxlYXN0IE1hYyBPUyBY
IDEwLjEuMywKIyBzdGRpbnQuaCBkZWZpbmluZyBJTlQzMl9NSU4gYXMgKC1JTlQzMl9NQVgtMSkK
IyAtLSBFZHdhcmQgTW95CiMKY2FzZSAiJChncmVwICdeI2RlZmluZSBJTlQzMl9NSU4nIC91c3Iv
aW5jbHVkZS9zdGRpbnQuaCkiIGluCiAgKi0yMTQ3NDgzNjQ4KSBjY2ZsYWdzPSIke2NjZmxhZ3N9
IC1ESU5UMzJfTUlOX0JST0tFTiAtRElOVDY0X01JTl9CUk9LRU4iIDs7CmVzYWMKCiMgQXZvaWQg
QXBwbGUncyBjcHAgcHJlY29tcGlsZXIsIGJldHRlciBmb3IgZXh0ZW5zaW9ucwppZiBbICJYYGVj
aG8gfCAke2NjfSAtbm8tY3BwLXByZWNvbXAgLUUgLSAyPiYxID4vZGV2L251bGxgIiA9ICJYIiBd
OyB0aGVuCiAgICBjcHBmbGFncz0iJHtjcHBmbGFnc30gLW5vLWNwcC1wcmVjb21wIgoKICAgICMg
VGhpcyBpcyBuZWNlc3NhcnkgYmVjYXVzZSBwZXJsJ3MgYnVpbGQgc3lzdGVtIGRvZXNuJ3QKICAg
ICMgYXBwbHkgY3BwZmxhZ3MgdG8gY2MgY29tcGlsZSBsaW5lcyBhcyBpdCBzaG91bGQuCiAgICBj
Y2ZsYWdzPSIke2NjZmxhZ3N9ICR7Y3BwZmxhZ3N9IgpmaQoKIyBLbm93biBvcHRpbWl6ZXIgcHJv
YmxlbXMuCmNhc2UgImBjYyAtdiAyPiYxYCIgaW4KICAqIjMuMSAyMDAyMDEwNSIqKSB0b2tlX2Nm
bGFncz0nb3B0aW1pemU9IiInIDs7CmVzYWMKCiMgU2hhcmVkIGxpYnJhcnkgZXh0ZW5zaW9uIGlz
IC5keWxpYi4KIyBCdW5kbGUgZXh0ZW5zaW9uIGlzIC5idW5kbGUuCmxkPSdjYyc7CnNvPSdkeWxp
Yic7CmRsZXh0PSdidW5kbGUnOwp1c2VkbD0nZGVmaW5lJzsKCiMgMTAuNCBjYW4gdXNlIGRsb3Bl
bi4KIyAxMC40IGJyb2tlIHBvbGwoKS4KY2FzZSAiJG9zdmVycyIgaW4KWzEtN10uKikKICAgIGRs
c3JjPSdkbF9keWxkLnhzJzsKICAgIDs7CiopCiAgICBkbHNyYz0nZGxfZGxvcGVuLnhzJzsKICAg
IGRfcG9sbD0ndW5kZWYnOwogICAgaV9wb2xsPSd1bmRlZic7CiAgICA7Owplc2FjCgpjYXNlICIk
Y2NkbGZsYWdzIiBpbgkJIyBJZiBwYXNzZWQgaW4gZnJvbSBjb21tYW5kIGxpbmUsIHByZXN1bWUg
dXNlciBrbm93cyBiZXN0CicnKQogICBjY2NkbGZsYWdzPScgJzsgIyBzcGFjZSwgbm90IGVtcHR5
LCBiZWNhdXNlIG90aGVyd2lzZSB3ZSBnZXQgLWZwaWMKOzsKZXNhYwoKIyBQZXJsIGJ1bmRsZXMg
ZG8gbm90IGV4cGVjdCB0d28tbGV2ZWwgbmFtZXNwYWNlLCBhZGRlZCBpbiBEYXJ3aW4gMS40Lgoj
IEJ1dCBzdGFydGluZyBmcm9tIHBlcmwgNS44LjEvRGFyd2luIDcgdGhlIGRlZmF1bHQgaXMgdGhl
IHR3by1sZXZlbC4KY2FzZSAiJG9zdmVycyIgaW4KMS5bMC0zXS4qKQogICBsZGRsZmxhZ3M9IiR7
bGRmbGFnc30gLWJ1bmRsZSAtdW5kZWZpbmVkIHN1cHByZXNzIgogICA7OwoxLiopCiAgIGxkZmxh
Z3M9IiR7bGRmbGFnc30gLWZsYXRfbmFtZXNwYWNlIgogICBsZGRsZmxhZ3M9IiR7bGRmbGFnc30g
LWJ1bmRsZSAtdW5kZWZpbmVkIHN1cHByZXNzIgogICA7OwpbMi02XS4qKQogICBsZGZsYWdzPSIk
e2xkZmxhZ3N9IC1mbGF0X25hbWVzcGFjZSIKICAgbGRkbGZsYWdzPSIke2xkZmxhZ3N9IC1idW5k
bGUgLXVuZGVmaW5lZCBzdXBwcmVzcyIKICAgOzsKKikgCiAgIGxkZGxmbGFncz0iJHtsZGZsYWdz
fSAtYnVuZGxlIC11bmRlZmluZWQgZHluYW1pY19sb29rdXAiCiAgIGNhc2UgIiRsZCIgaW4KICAg
ICAgICpNQUNPU1hfREVWRUxPUE1FTlRfVEFSR0VUKikgOzsKICAgICAgICopIGxkPSJlbnYgTUFD
T1NYX0RFUExPWU1FTlRfVEFSR0VUPTEwLjMgJHtsZH0iIDs7CiAgIGVzYWMKICAgOzsKZXNhYwps
ZGxpYnB0aG5hbWU9J0RZTERfTElCUkFSWV9QQVRIJzsKCiMgdXNlc2hycGxpYj10cnVlIHJlc3Vs
dHMgaW4gbXVjaCBzbG93ZXIgc3RhcnR1cCB0aW1lcy4KIyAnZmFsc2UnIGlzIHRoZSBkZWZhdWx0
IHZhbHVlLiAgVXNlIENvbmZpZ3VyZSAtRHVzZXNocnBsaWIgdG8gb3ZlcnJpZGUuCgpjYXQgPiBV
VS9hcmNobmFtZS5jYnUgPDwnRU9DQlUnCiMgVGhpcyBzY3JpcHQgVVUvYXJjaG5hbWUuY2J1IHdp
bGwgZ2V0ICdjYWxsZWQtYmFjaycgYnkgQ29uZmlndXJlIAojIGFmdGVyIGl0IGhhcyBvdGhlcndp
c2UgZGV0ZXJtaW5lZCB0aGUgYXJjaGl0ZWN0dXJlIG5hbWUuCmNhc2UgIiRsZGZsYWdzIiBpbgoq
Ii1mbGF0X25hbWVzcGFjZSIqKSA7OyAjIEJhY2t3YXJkIGNvbXBhdCwgYmUgZmxhdC4KIyBJZiB3
ZSBhcmUgdXNpbmcgdHdvLWxldmVsIG5hbWVzcGFjZSwgd2Ugd2lsbCBtdW5nZSB0aGUgYXJjaG5h
bWUgdG8gc2hvdyBpdC4KKikgYXJjaG5hbWU9IiR7YXJjaG5hbWV9LTJsZXZlbCIgOzsKZXNhYwpF
T0NCVQoKIyA2NC1iaXQgYWRkcmVzc2luZyBzdXBwb3J0LiBDdXJyZW50bHkgc3RyaWN0bHkgZXhw
ZXJpbWVudGFsLiBERkQgMjAwNS0wNi0wNgpjYXNlICIkdXNlNjRiaXRhbGwiIGluCiRkZWZpbmV8
dHJ1ZXxbeVldKikKY2FzZSAiJG9zdmVycyIgaW4KWzEtN10uKikKICAgICBjYXQgPDxFT00gPiY0
CgoKCioqKiA2NC1iaXQgYWRkcmVzc2luZyBpcyBub3Qgc3VwcG9ydGVkIGZvciBNYWMgT1MgWCB2
ZXJzaW9ucwoqKiogYmVsb3cgMTAuNCAoIlRpZ2VyIikgb3IgRGFyd2luIHZlcnNpb25zIGJlbG93
IDguIFBsZWFzZSB0cnkKKioqIGFnYWluIHdpdGhvdXQgLUR1c2U2NGJpdGFsbC4gKC1EdXNlNjRi
aXRpbnQgd2lsbCB3b3JrLCBob3dldmVyLikKCkVPTQogICAgIGV4aXQgMQogIDs7CiopCiAgICBj
YXNlICIkb3N2ZXJzIiBpbgogICAgOC4qKQogICAgICAgIGNhdCA8PEVPTSA+JjQKCgoKKioqIFBl
cmwgNjQtYml0IGFkZHJlc3Npbmcgc3VwcG9ydCBpcyBleHBlcmltZW50YWwgZm9yIE1hYyBPUyBY
CioqKiAxMC40ICgiVGlnZXIiKSBhbmQgRGFyd2luIHZlcnNpb24gOC4gU3lzdGVtIFYgSVBDIGlz
IGRpc2FibGVkCioqKiBkdWUgdG8gcHJvYmxlbXMgd2l0aCB0aGUgNjQtYml0IHZlcnNpb25zIG9m
IG1zZ2N0bCwgc2VtY3RsLAoqKiogYW5kIHNobWN0bC4gWW91IHNob3VsZCBhbHNvIGV4cGVjdCB0
aGUgZm9sbG93aW5nIHRlc3QgZmFpbHVyZXM6CioqKgoqKiogICAgZXh0L3RocmVhZHMtc2hhcmVk
L3Qvd2FpdCAodGhyZWFkZWQgYnVpbGRzIG9ubHkpCgpFT00KCiAgICAgICAgWyAiJGRfbXNnY3Rs
IiBdIHx8IGRfbXNnY3RsPSd1bmRlZicKICAgICAgICBbICIkZF9zZW1jdGwiIF0gfHwgZF9zZW1j
dGw9J3VuZGVmJwogICAgICAgIFsgIiRkX3NobWN0bCIgXSB8fCBkX3NobWN0bD0ndW5kZWYnCiAg
ICA7OwogICAgZXNhYwoKICAgIGNhc2UgYHVuYW1lIC1wYCBpbiAKICAgIHBvd2VycGMpIGFyY2g9
cHBjNjQgOzsKICAgIGkzODYpIGFyY2g9eDg2XzY0IDs7CiAgICAqKSBjYXQgPDxFT00gPiY0Cgoq
KiogRG9uJ3QgcmVjb2duaXplIHByb2Nlc3NvciwgY2FuJ3Qgc3BlY2lmeSA2NCBiaXQgY29tcGls
YXRpb24uCgpFT00KICAgIDs7CiAgICBlc2FjCiAgICBmb3IgdmFyIGluIGNjZmxhZ3MgY3BwZmxh
Z3MgbGQgbGRmbGFncwogICAgZG8KICAgICAgIGV2YWwgJHZhcj0iXCQke3Zhcn1cIC1hcmNoXCAk
YXJjaCIKICAgIGRvbmUKCiAgICA7Owplc2FjCjs7CmVzYWMKCiMjCiMgU3lzdGVtIGxpYnJhcmll
cwojIwoKIyB2Zm9yayB3b3Jrcwp1c2V2Zm9yaz0ndHJ1ZSc7CgojIG1hbGxvYyB3cmFwIHdvcmtz
CmNhc2UgIiR1c2VtYWxsb2N3cmFwIiBpbgonJykgdXNlbWFsbG9jd3JhcD0nZGVmaW5lJyA7Owpl
c2FjCgojIG91ciBtYWxsb2Mgd29ya3MgKGJ1dCBhbGxvdyB1c2VycyB0byBvdmVycmlkZSkKY2Fz
ZSAiJHVzZW15bWFsbG9jIiBpbgonJykgdXNlbXltYWxsb2M9J24nIDs7CmVzYWMKIyBIb3dldmVy
IHNicmsoKSByZXR1cm5zIC0xIChmYWlsdXJlKSBzb21ld2hlcmUgaW4gbGliL3VuaWNvcmUvbWt0
YWJsZXMgYXQKIyBhcm91bmQgMTRNLCBzbyB3ZSBuZWVkIHRvIHVzZSBzeXN0ZW0gbWFsbG9jKCkg
YXMgb3VyIHNicmsoKQptYWxsb2NfY2ZsYWdzPSdjY2ZsYWdzPSItRFVTRV9QRVJMX1NCUksgLURQ
RVJMX1NCUktfVklBX01BTExPQyAkY2NmbGFncyInCgojIExvY2FsZXMgYXJlbid0IGZlZWxpbmcg
d2VsbC4KTENfQUxMPUM7IGV4cG9ydCBMQ19BTEw7CkxBTkc9QzsgZXhwb3J0IExBTkc7CgojCiMg
VGhlIGxpYnJhcmllcyBhcmUgbm90IHRocmVhZHNhZmUgYXMgb2YgT1MgWCAxMC4xLgojCiMgRml4
IHdoZW4gQXBwbGUgZml4ZXMgbGliYy4KIwpjYXNlICIkdXNldGhyZWFkcyR1c2VpdGhyZWFkcyIg
aW4KICAqZGVmaW5lKikKICBjYXNlICIkb3N2ZXJzIiBpbgogICAgWzEyMzQ1XS4qKSAgICAgY2F0
IDw8RU9NID4mNAoKCgoqKiogV2FybmluZywgdGhlcmUgbWlnaHQgYmUgcHJvYmxlbXMgd2l0aCB5
b3VyIGxpYnJhcmllcyB3aXRoCioqKiByZWdhcmRzIHRvIHRocmVhZGluZy4gIFRoZSB0ZXN0IGV4
dC90aHJlYWRzL3QvbGliYy50IGlzIGxpa2VseQoqKiogdG8gZmFpbC4KCkVPTQogICAgOzsKICAg
ICopIHVzZXJlZW50cmFudD0nZGVmaW5lJzs7CiAgZXNhYwoKZXNhYwoKIyBGaW5rIGNhbiBpbnN0
YWxsIGEgR0RCTSBsaWJyYXJ5IHRoYXQgY2xhaW1zIHRvIGhhdmUgdGhlIE9EQk0gaW50ZXJmYWNl
cwojIGJ1dCBQZXJsIGR5bmFsb2FkZXIgY2Fubm90IGZvciBzb21lIHJlYXNvbiB1c2UgdGhhdCBs
aWJyYXJ5LiAgV2UgZG9uJ3QKIyByZWFsbHkgbmVlZCBPREJNX0ZJbGUsIHRob3VnaCwgc28gbGV0
J3MganVzdCBoaW50IE9EQk0gYXdheS4KaV9kYm09dW5kZWY7CgojIENvbmZpZ3VyZSBkb2Vzbid0
IGRldGVjdCByYW5saWIgb24gVGlnZXIgcHJvcGVybHkuCiMgTmVpbFcgc2F5cyB0aGlzIHNob3Vs
ZCBiZSBhY2NlcHRhYmxlIG9uIGFsbCBkYXJ3aW4gdmVyc2lvbnMuCnJhbmxpYj0ncmFubGliJwoK
IyMKIyBCdWlsZCBwcm9jZXNzCiMjCgojIENhc2UtaW5zZW5zaXRpdmUgZmlsZXN5c3RlbXMgZG9u
J3QgZ2V0IGFsb25nIHdpdGggTWFrZWZpbGUgYW5kCiMgbWFrZWZpbGUgaW4gdGhlIHNhbWUgcGxh
Y2UuICBTaW5jZSBEYXJ3aW4gdXNlcyBHTlUgbWFrZSwgdGhpcyBkb2RnZXMKIyB0aGUgcHJvYmxl
bS4KZmlyc3RtYWtlZmlsZT1HTlVtYWtlZmlsZTsK',
'dragonfly' =>
'IyBoaW50cy9kcmFnb25mbHkuc2gKIwojIFRoaXMgZmlsZSBpcyBtb3N0bHkgY29waWVkIGZyb20g
aGludHMvZnJlZWJzZC5zaCB3aXRoIHRoZSBPUyB2ZXJzaW9uCiMgaW5mb3JtYXRpb24gdGFrZW4g
b3V0IGFuZCBvbmx5IHRoZSBGcmVlQlNELTQgaW5mb3JtYXRpb24gaW50YWN0LgojIFBsZWFzZSBj
aGVjayB3aXRoIFRvZGQgV2lsbGV5IDx4dG9kZHhAZ21haWwuY29tPiBiZWZvcmUgbWFraW5nCiMg
bW9kaWZpY2F0aW9ucyB0byB0aGlzIGZpbGUuIFNlZSBodHRwOi8vd3d3LmRyYWdvbmZseWJzZC5v
cmcvCgpjYXNlICIkb3N2ZXJzIiBpbgoqKSAgdXNldmZvcms9J3RydWUnCiAgICBjYXNlICIkdXNl
bXltYWxsb2MiIGluCgkiIikgdXNlbXltYWxsb2M9J24nCgkgICAgOzsKICAgIGVzYWMKICAgIGxp
YnN3YW50ZWQ9YGVjaG8gJGxpYnN3YW50ZWQgfCBzZWQgJ3MvIG1hbGxvYyAvIC8nYAogICAgOzsK
ZXNhYwoKIyBEeW5hbWljIExvYWRpbmcgZmxhZ3MgaGF2ZSBub3QgY2hhbmdlZCBtdWNoLCBzbyB0
aGV5IGFyZSBzZXBhcmF0ZWQKIyBvdXQgaGVyZSB0byBhdm9pZCBkdXBsaWNhdGluZyB0aGVtIGV2
ZXJ5d2hlcmUuCmNhc2UgIiRvc3ZlcnMiIGluCiopICBvYmpmb3JtYXQ9YC91c3IvYmluL29iamZv
cm1hdGAKICAgIGxpYnB0aD0iL3Vzci9saWIgL3Vzci9sb2NhbC9saWIiCiAgICBnbGlicHRoPSIv
dXNyL2xpYiAvdXNyL2xvY2FsL2xpYiIKICAgIGxkZmxhZ3M9Ii1XbCwtRSAiCiAgICBsZGRsZmxh
Z3M9Ii1zaGFyZWQgIgogICAgY2NjZGxmbGFncz0nLURQSUMgLWZQSUMnCiAgICA7Owplc2FjCgpj
YXNlICIkb3N2ZXJzIiBpbgoqKSAgY2NmbGFncz0iJHtjY2ZsYWdzfSAtREhBU19GUFNFVE1BU0sg
LURIQVNfRkxPQVRJTkdQT0lOVF9IIgogICAgaWYgL3Vzci9iaW4vZmlsZSAtTCAvdXNyL2xpYi9s
aWJjLnNvIHwgL3Vzci9iaW4vZ3JlcCAtdnEgIm5vdCBzdHJpcHBlZCIgOyB0aGVuCgl1c2VubT1m
YWxzZQogICAgZmkKICAgIDs7CmVzYWMKCmNhdCA8PCdFT00nID4mNAoKU29tZSB1c2VycyBoYXZl
IHJlcG9ydGVkIHRoYXQgQ29uZmlndXJlIGhhbHRzIHdoZW4gdGVzdGluZyBmb3IKdGhlIE9fTk9O
QkxPQ0sgc3ltYm9sIHdpdGggYSBzeW50YXggZXJyb3IuICBUaGlzIGlzIGFwcGFyZW50bHkgYQpz
aCBlcnJvci4gIFJlcnVubmluZyBDb25maWd1cmUgd2l0aCBrc2ggYXBwYXJlbnRseSBmaXhlcyB0
aGUKcHJvYmxlbS4gIFRyeQogICAgICAga3NoIENvbmZpZ3VyZSBbeW91ciBvcHRpb25zXQoKRU9N
CgojIEZyb206IEFudG9uIEJlcmV6aW4gPHRvYmV6QHBsYWIua3UuZGs+CiMgVG86IHBlcmw1LXBv
cnRlcnNAcGVybC5vcmcKIyBTdWJqZWN0OiBbUEFUQ0ggNS4wMDVfNTRdIENvbmZpZ3VyZSAtIGhp
bnRzL2ZyZWVic2Quc2ggc2lnbmFsIGhhbmRsZXIgdHlwZQojIERhdGU6IDMwIE5vdiAxOTk4IDE5
OjQ2OjI0ICswMTAwCiMgTWVzc2FnZS1JRDogPDg2NHNyaGh2Y3YuZnNmQGxpb24ucGxhYi5rdS5k
az4KCnNpZ25hbF90PSd2b2lkJwpkX3ZvaWRzaWc9J2RlZmluZScKCiMgVGhpcyBzY3JpcHQgVVUv
dXNldGhyZWFkcy5jYnUgd2lsbCBnZXQgJ2NhbGxlZC1iYWNrJyBieSBDb25maWd1cmUKIyBhZnRl
ciBpdCBoYXMgcHJvbXB0ZWQgdGhlIHVzZXIgZm9yIHdoZXRoZXIgdG8gdXNlIHRocmVhZHMuCmNh
dCA+IFVVL3VzZXRocmVhZHMuY2J1IDw8J0VPQ0JVJwpjYXNlICIkdXNldGhyZWFkcyIgaW4KJGRl
ZmluZXx0cnVlfFt5WV0qKQogICAgY2FzZSAiJG9zdmVycyIgaW4KICAgICopICBsZGZsYWdzPSIt
cHRocmVhZCAkbGRmbGFncyIKCgkjIEJvdGggaW4gNC54IGFuZCA1LnggZ2V0aG9zdGJ5YWRkcl9y
IGV4aXN0cyBidXQKCSMgaXQgaXMgIlRlbXBvcmFyeSBmdW5jdGlvbiwgbm90IHRocmVhZHNhZmUi
Li4uCgkjIFByZXN1bWFibHkgZWFybGllciBpdCBkaWRuJ3QgZXZlbiBleGlzdC4KCWRfZ2V0aG9z
dGJ5YWRkcl9yPSJ1bmRlZiIKCWRfZ2V0aG9zdGJ5YWRkcl9yX3Byb3RvPSIwIgoKCTs7CiAgICBl
c2FjCmVzYWMKRU9DQlUKCiMgbWFsbG9jIHdyYXAgd29ya3MKY2FzZSAiJHVzZW1hbGxvY3dyYXAi
IGluCicnKSB1c2VtYWxsb2N3cmFwPSdkZWZpbmUnIDs7CmVzYWMK',
'netbsd' =>
'IyBoaW50cy9uZXRic2Quc2gKIwojIFBsZWFzZSBjaGVjayB3aXRoIHBhY2thZ2VzQG5ldGJzZC5v
cmcgYmVmb3JlIG1ha2luZyBtb2RpZmljYXRpb25zCiMgdG8gdGhpcyBmaWxlLgoKY2FzZSAiJGFy
Y2huYW1lIiBpbgonJykKICAgIGFyY2huYW1lPWB1bmFtZSAtbWAtJHtvc25hbWV9CiAgICA7Owpl
c2FjCgojIE5ldEJTRCBrZWVwcyBkeW5hbWljIGxvYWRpbmcgZGwqKCkgZnVuY3Rpb25zIGluIC91
c3IvbGliL2NydDAubywKIyBzbyBDb25maWd1cmUgZG9lc24ndCBmaW5kIHRoZW0gKHVubGVzcyB5
b3UgYWJhbmRvbiB0aGUgbm0gc2NhbikuCiMgQWxzbywgTmV0QlNEIDAuOWEgd2FzIHRoZSBmaXJz
dCByZWxlYXNlIHRvIGludHJvZHVjZSBzaGFyZWQKIyBsaWJyYXJpZXMuCiMKY2FzZSAiJG9zdmVy
cyIgaW4KMC45fDAuOCopCgl1c2VkbD0iJHVuZGVmIgoJOzsKKikKCWNhc2UgYHVuYW1lIC1tYCBp
bgoJcG1heCkKCQkjIE5ldEJTRCAxLjMgYW5kIDEuMy4xIG9uIHBtYXggc2hpcHBlZCBhbiBgb2xk
JyBsZC5zbywKCQkjIHdoaWNoIHdpbGwgbm90IHdvcmsuCgkJY2FzZSAiJG9zdmVycyIgaW4KCQkx
LjN8MS4zLjEpCgkJCWRfZGxvcGVuPSR1bmRlZgoJCQk7OwoJCWVzYWMKCQk7OwoJZXNhYwoJaWYg
dGVzdCAtZiAvdXNyL2xpYmV4ZWMvbGQuZWxmX3NvOyB0aGVuCgkJIyBFTEYKCQlkX2Rsb3Blbj0k
ZGVmaW5lCgkJZF9kbGVycm9yPSRkZWZpbmUKCQljY2NkbGZsYWdzPSItRFBJQyAtZlBJQyAkY2Nj
ZGxmbGFncyIKCQlsZGRsZmxhZ3M9Ii1zaGFyZWQgJGxkZGxmbGFncyIKCQljYXQgPlVVL2NjLmNi
dSA8PCdFT0NCVScKIyBnY2MgNC42IGRvZXNuJ3Qgc3VwcG9ydCAtLXdob2xlLWFyY2hpdmUsIGJ1
dCBpdCdzIHJlcXVpcmVkIGZvciB0aGUKIyBzeXN0ZW0gZ2NjIHRvIGJ1aWxkIGNvcnJlY3RseSwg
c28gY2hlY2sgZm9yIGl0CmVjaG8gJ2ludCBmKHZvaWQpIHsgcmV0dXJuIDA7IH0nID50cnkuYwpp
ZiAke2NjOi1jY30gJGNjY2RsZmxhZ3MgLWMgdHJ5LmMgLW90cnkubyAyPiYxICYmCiAgICR7Y2M6
LWNjfSAtLXdob2xlLWFyY2hpdmUgJGxkZGxmbGFncyB0cnkubyAtb3RyeS5zbyAyPiYxIDsgdGhl
bgogICAgbGRkbGZsYWdzPSItLXdob2xlLWFyY2hpdmUgJGxkZGxmbGFncyIKZmkKcm0gdHJ5LmMg
dHJ5Lm8gdHJ5LnNvIDI+L2Rldi9udWxsCkVPQ0JVCgkJcnBhdGhmbGFnPSItV2wsLXJwYXRoLCIK
CQljYXNlICIkb3N2ZXJzIiBpbgoJCTEuWzAtNV0qKQoJCQkjCgkJCSMgSW5jbHVkZSB0aGUgd2hv
bGUgbGliZ2NjLmEgaW50byB0aGUgcGVybCBleGVjdXRhYmxlCgkJCSMgc28gdGhhdCBjZXJ0YWlu
IHN5bWJvbHMgbmVlZGVkIGJ5IGxvYWRhYmxlIG1vZHVsZXMKCQkJIyBidWlsdCBhcyBDKysgb2Jq
ZWN0cyAoX19laF9hbGxvYywgX19wdXJlX3ZpcnR1YWwsCgkJCSMgZXRjLikgd2lsbCBhbHdheXMg
YmUgZGVmaW5lZC4KCQkJIwoJCQljY2RsZmxhZ3M9Ii1XbCwtd2hvbGUtYXJjaGl2ZSAtbGdjYyBc
CgkJCQktV2wsLW5vLXdob2xlLWFyY2hpdmUgLVdsLC1FICRjY2RsZmxhZ3MiCgkJCTs7CgkJKikK
CQkJY2NkbGZsYWdzPSItV2wsLUUgJGNjZGxmbGFncyIKCQkJOzsKCQllc2FjCgllbGlmIHRlc3Qg
LWYgL3Vzci9saWJleGVjL2xkLnNvOyB0aGVuCgkJIyBhLm91dAoJCWRfZGxvcGVuPSRkZWZpbmUK
CQlkX2RsZXJyb3I9JGRlZmluZQoJCWNjY2RsZmxhZ3M9Ii1EUElDIC1mUElDICRjY2NkbGZsYWdz
IgoJCWxkZGxmbGFncz0iLUJzaGFyZWFibGUgJGxkZGxmbGFncyIKCQlycGF0aGZsYWc9Ii1SIgoJ
ZWxzZQoJCWRfZGxvcGVuPSR1bmRlZgoJCXJwYXRoZmxhZz0KCWZpCgk7Owplc2FjCgojIG5ldGJz
ZCBoYWQgdGhlc2UgYnV0IHRoZXkgZG9uJ3QgcmVhbGx5IHdvcmsgYXMgYWR2ZXJ0aXNlZCwgaW4g
dGhlCiMgdmVyc2lvbnMgbGlzdGVkIGJlbG93LiAgaWYgdGhleSBhcmUgZGVmaW5lZCwgdGhlbiB0
aGVyZSBpc24ndCBhCiMgd2F5IHRvIG1ha2UgcGVybCBjYWxsIHNldHVpZCgpIG9yIHNldGdpZCgp
LiAgaWYgdGhleSBhcmVuJ3QsIHRoZW4KIyAoJDwsICQ+KSA9ICgkdSwgJHUpOyB3aWxsIHdvcmsg
KHNhbWUgZm9yICQoLyQpKS4gIHRoaXMgaXMgYmVjYXVzZQojIHlvdSBjYW4gbm90IGNoYW5nZSB0
aGUgcmVhbCB1c2VyaWQgb2YgYSBwcm9jZXNzIHVuZGVyIDQuNEJTRC4KIyBuZXRic2QgZml4ZWQg
dGhpcyBpbiAxLjMuMi4KY2FzZSAiJG9zdmVycyIgaW4KMC45KnwxLlswMTJdKnwxLjN8MS4zLjEp
CglkX3NldHJlZ2lkPSIkdW5kZWYiCglkX3NldHJldWlkPSIkdW5kZWYiCgk7Owplc2FjCmNhc2Ug
IiRvc3ZlcnMiIGluCjAuOSp8MS4qfDIuKnwzLip8NC4qfDUuKnw2LiopCglkX2dldHByb3RvZW50
X3I9IiR1bmRlZiIKCWRfZ2V0cHJvdG9ieW5hbWVfcj0iJHVuZGVmIgoJZF9nZXRwcm90b2J5bnVt
YmVyX3I9IiR1bmRlZiIKCWRfc2V0cHJvdG9lbnRfcj0iJHVuZGVmIgoJZF9lbmRwcm90b2VudF9y
PSIkdW5kZWYiCglkX2dldHNlcnZlbnRfcj0iJHVuZGVmIgoJZF9nZXRzZXJ2YnluYW1lX3I9IiR1
bmRlZiIKCWRfZ2V0c2VydmJ5cG9ydF9yPSIkdW5kZWYiCglkX3NldHNlcnZlbnRfcj0iJHVuZGVm
IgoJZF9lbmRzZXJ2ZW50X3I9IiR1bmRlZiIKCWRfZ2V0cHJvdG9lbnRfcl9wcm90bz0iMCIKCWRf
Z2V0cHJvdG9ieW5hbWVfcl9wcm90bz0iMCIKCWRfZ2V0cHJvdG9ieW51bWJlcl9yX3Byb3RvPSIw
IgoJZF9zZXRwcm90b2VudF9yX3Byb3RvPSIwIgoJZF9lbmRwcm90b2VudF9yX3Byb3RvPSIwIgoJ
ZF9nZXRzZXJ2ZW50X3JfcHJvdG89IjAiCglkX2dldHNlcnZieW5hbWVfcl9wcm90bz0iMCIKCWRf
Z2V0c2VydmJ5cG9ydF9yX3Byb3RvPSIwIgoJZF9zZXRzZXJ2ZW50X3JfcHJvdG89IjAiCglkX2Vu
ZHNlcnZlbnRfcl9wcm90bz0iMCIKCTs7CmVzYWMKCiMgVGhlc2UgYXJlIG9ic29sZXRlIGluIGFu
eSBuZXRic2QuCmRfc2V0cmdpZD0iJHVuZGVmIgpkX3NldHJ1aWQ9IiR1bmRlZiIKCiMgdGhlcmUn
cyBubyBwcm9ibGVtIHdpdGggdmZvcmsuCnVzZXZmb3JrPXRydWUKCiMgVGhpcyBpcyB0aGVyZSBi
dXQgaW4gbWFjaGluZS9pZWVlZnBfaC4KaWVlZWZwX2g9ImRlZmluZSIKCiMgVGhpcyBzY3JpcHQg
VVUvdXNldGhyZWFkcy5jYnUgd2lsbCBnZXQgJ2NhbGxlZC1iYWNrJyBieSBDb25maWd1cmUKIyBh
ZnRlciBpdCBoYXMgcHJvbXB0ZWQgdGhlIHVzZXIgZm9yIHdoZXRoZXIgdG8gdXNlIHRocmVhZHMu
CmNhdCA+IFVVL3VzZXRocmVhZHMuY2J1IDw8J0VPQ0JVJwpjYXNlICIkdXNldGhyZWFkcyIgaW4K
JGRlZmluZXx0cnVlfFt5WV0qKQoJbHB0aHJlYWQ9Cglmb3IgeHh4IGluIHB0aHJlYWQ7IGRvCgkJ
Zm9yIHl5eSBpbiAkbG9jbGlicHRoICRwbGlicHRoICRnbGlicHRoIGR1bW15OyBkbwoJCQl6eno9
JHl5eS9saWIkeHh4LmEKCQkJaWYgdGVzdCAtZiAiJHp6eiI7IHRoZW4KCQkJCWxwdGhyZWFkPSR4
eHgKCQkJCWJyZWFrOwoJCQlmaQoJCQl6eno9JHl5eS9saWIkeHh4LnNvCgkJCWlmIHRlc3QgLWYg
IiR6enoiOyB0aGVuCgkJCQlscHRocmVhZD0keHh4CgkJCQlicmVhazsKCQkJZmkKCQkJenp6PWBs
cyAkeXl5L2xpYiR4eHguc28uKiAyPi9kZXYvbnVsbGAKCQkJaWYgdGVzdCAiWCR6enoiICE9IFg7
IHRoZW4KCQkJCWxwdGhyZWFkPSR4eHgKCQkJCWJyZWFrOwoJCQlmaQoJCWRvbmUKCQlpZiB0ZXN0
ICJYJGxwdGhyZWFkIiAhPSBYOyB0aGVuCgkJCWJyZWFrOwoJCWZpCglkb25lCglpZiB0ZXN0ICJY
JGxwdGhyZWFkIiAhPSBYOyB0aGVuCgkJIyBBZGQgLWxwdGhyZWFkLgoJCWxpYnN3YW50ZWQ9IiRs
aWJzd2FudGVkICRscHRocmVhZCIKCQkjIFRoZXJlIGlzIG5vIGxpYmNfciBhcyBvZiBOZXRCU0Qg
MS41LjIsIHNvIG5vIGMgLT4gY19yLgoJCSMgVGhpcyB3aWxsIGJlIHJldmlzaXRlZCB3aGVuIE5l
dEJTRCBnYWlucyBhIG5hdGl2ZSBwdGhyZWFkcwoJCSMgaW1wbGVtZW50YXRpb24uCgllbHNlCgkJ
ZWNobyAiJDA6IE5vIFBPU0lYIHRocmVhZHMgbGlicmFyeSAoLWxwdGhyZWFkKSBmb3VuZC4gICIg
XAoJCSAgICAgIllvdSBtYXkgd2FudCB0byBpbnN0YWxsIEdOVSBwdGguICBBYm9ydGluZy4iID4m
NAoJCWV4aXQgMQoJZmkKCXVuc2V0IGxwdGhyZWFkCgoJIyBzZXZlcmFsIHJlZW50cmFudCBmdW5j
dGlvbnMgYXJlIGVtYmVkZGVkIGluIGxpYmMsIGJ1dCBoYXZlbid0CgkjIGJlZW4gYWRkZWQgdG8g
dGhlIGhlYWRlciBmaWxlcyB5ZXQuICBMZXQncyBob2xkIG9mZiBvbiB1c2luZwoJIyB0aGVtIHVu
dGlsIHRoZXkgYXJlIGEgdmFsaWQgcGFydCBvZiB0aGUgQVBJCgljYXNlICIkb3N2ZXJzIiBpbgoJ
WzAxMl0uKnwzLlswLTFdKQoJCWRfZ2V0cHJvdG9ieW5hbWVfcj0kdW5kZWYKCQlkX2dldHByb3Rv
YnludW1iZXJfcj0kdW5kZWYKCQlkX2dldHByb3RvZW50X3I9JHVuZGVmCgkJZF9nZXRzZXJ2Ynlu
YW1lX3I9JHVuZGVmCgkJZF9nZXRzZXJ2Ynlwb3J0X3I9JHVuZGVmCgkJZF9nZXRzZXJ2ZW50X3I9
JHVuZGVmCgkJZF9zZXRwcm90b2VudF9yPSR1bmRlZgoJCWRfc2V0c2VydmVudF9yPSR1bmRlZgoJ
CWRfZW5kcHJvdG9lbnRfcj0kdW5kZWYKCQlkX2VuZHNlcnZlbnRfcj0kdW5kZWYgOzsKCWVzYWMK
CTs7Cgplc2FjCkVPQ0JVCgojIFNldCBzZW5zaWJsZSBkZWZhdWx0cyBmb3IgTmV0QlNEOiBsb29r
IGZvciBsb2NhbCBzb2Z0d2FyZSBpbgojIC91c3IvcGtnIChOZXRCU0QgUGFja2FnZXMgQ29sbGVj
dGlvbikgYW5kIGluIC91c3IvbG9jYWwuCiMKbG9jbGlicHRoPSIvdXNyL3BrZy9saWIgL3Vzci9s
b2NhbC9saWIiCmxvY2luY3B0aD0iL3Vzci9wa2cvaW5jbHVkZSAvdXNyL2xvY2FsL2luY2x1ZGUi
CmNhc2UgIiRycGF0aGZsYWciIGluCicnKQoJbGRmbGFncz0KCTs7CiopCglsZGZsYWdzPQoJZm9y
IHl5eSBpbiAkbG9jbGlicHRoOyBkbwoJCWxkZmxhZ3M9IiRsZGZsYWdzICRycGF0aGZsYWckeXl5
IgoJZG9uZQoJOzsKZXNhYwoKY2FzZSBgdW5hbWUgLW1gIGluCmFscGhhKQogICAgZWNobyAnaW50
IG1haW4oKSB7fScgPiB0cnkuYwogICAgZ2NjPWAke2NjOi1jY30gLXYgLWMgdHJ5LmMgMj4mMXxn
cmVwICdnY2MgdmVyc2lvbiBlZ2NzLTInYAogICAgY2FzZSAiJGdjYyIgaW4KICAgICcnIHwgImdj
YyB2ZXJzaW9uIGVnY3MtMi45NS4iWzMtOV0qKSA7OyAjIDIuOTUuMyBvciBiZXR0ZXIgb2theQog
ICAgKikJY2F0ID4mNCA8PEVPRgoqKioKKioqIFlvdXIgZ2NjICgkZ2NjKSBpcyBrbm93biB0byBi
ZQoqKiogdG9vIGJ1Z2d5IG9uIG5ldGJzZC9hbHBoYSB0byBjb21waWxlIFBlcmwgd2l0aCBvcHRp
bWl6YXRpb24uCioqKiBJdCBpcyBzdWdnZXN0ZWQgeW91IGluc3RhbGwgdGhlIGxhbmcvZ2NjIHBh
Y2thZ2Ugd2hpY2ggc2hvdWxkCioqKiBoYXZlIGF0IGxlYXN0IGdjYyAyLjk1LjMgd2hpY2ggc2hv
dWxkIHdvcmsgb2theTogdXNlIGZvciBleGFtcGxlCioqKiBDb25maWd1cmUgLURjYz0vdXNyL3Br
Zy9nY2MtMi45NS4zL2Jpbi9jYy4gIFlvdSBjb3VsZCBhbHNvCioqKiBDb25maWd1cmUgLURvcHRp
bWl6ZT0tTzAgdG8gY29tcGlsZSBQZXJsIHdpdGhvdXQgYW55IG9wdGltaXphdGlvbgoqKiogYnV0
IHRoYXQgaXMgbm90IHJlY29tbWVuZGVkLgoqKioKRU9GCglleGl0IDEKCTs7CiAgICBlc2FjCiAg
ICBybSAtZiB0cnkuKgogICAgOzsKZXNhYwoKIyBOZXRCU0Qvc3BhcmMgMS41LjMvMS42LjEgZHVt
cHMgY29yZSBpbiB0aGUgc2VtaWRfZHMgdGVzdCBvZiBDb25maWd1cmUuCmNhc2UgYHVuYW1lIC1t
YCBpbgpzcGFyYykgZF9zZW1jdGxfc2VtaWRfZHM9dW5kZWYgOzsKZXNhYwoKIyBtYWxsb2Mgd3Jh
cCB3b3JrcwpjYXNlICIkdXNlbWFsbG9jd3JhcCIgaW4KJycpIHVzZW1hbGxvY3dyYXA9J2RlZmlu
ZScgOzsKZXNhYwoKIyBkb24ndCB1c2UgcGVybCBtYWxsb2MgYnkgZGVmYXVsdApjYXNlICIkdXNl
bXltYWxsb2MiIGluCicnKSB1c2VteW1hbGxvYz1uIDs7CmVzYWMK',
'openbsd' =>
'IyBoaW50cy9vcGVuYnNkLnNoCiMKIyBoaW50cyBmaWxlIGZvciBPcGVuQlNEOyBUb2RkIE1pbGxl
ciA8bWlsbGVydEBvcGVuYnNkLm9yZz4KIyBFZGl0ZWQgdG8gYWxsb3cgQ29uZmlndXJlIGNvbW1h
bmQtbGluZSBvdmVycmlkZXMgYnkKIyAgQW5keSBEb3VnaGVydHkgPGRvdWdoZXJhQGxhZmF5ZXR0
ZS5lZHU+CiMKIyBUbyBidWlsZCB3aXRoIGRpc3RyaWJ1dGlvbiBwYXRocywgdXNlOgojCS4vQ29u
ZmlndXJlIC1kZXMgLURvcGVuYnNkX2Rpc3RyaWJ1dGlvbj1kZWZpbmVkCiMKCiMgSW4gT3BlbkJT
RCA+IDMuNywgdXNlIHBlcmwncyBtYWxsb2MgW3BlcmwgIzc1NzQyXQpjYXNlICIkb3N2ZXJzIiBp
bgozLls4OV0qfFs0LTldKikKICAgIHRlc3QgIiR1c2VteW1hbGxvYyIgfHwgdXNlbXltYWxsb2M9
eQogICAgOzsKZXNhYwoKIyBtYWxsb2Mgd3JhcCB3b3JrcwpjYXNlICIkdXNlbWFsbG9jd3JhcCIg
aW4KJycpIHVzZW1hbGxvY3dyYXA9J2RlZmluZScgOzsKZXNhYwoKIyBDdXJyZW50bHksIHZmb3Jr
KDIpIGlzIG5vdCBhIHJlYWwgd2luIG92ZXIgZm9yaygyKS4KdXNldmZvcms9IiR1bmRlZiIKCiMg
SW4gT3BlbkJTRCA8IDMuMywgdGhlIHNldHJlP1t1Z11pZCgpIGFyZSBlbXVsYXRlZCB1c2luZyB0
aGUKIyBfUE9TSVhfU0FWRURfSURTIGZ1bmN0aW9uYWxpdHkgd2hpY2ggZG9lcyBub3QgaGF2ZSB0
aGUgc2FtZQojIHNlbWFudGljcyBhcyA0LjNCU0QuICBTdGFydGluZyB3aXRoIE9wZW5CU0QgMy4z
LCB0aGUgb3JpZ2luYWwKIyBzZW1hbnRpY3MgaGF2ZSBiZWVuIHJlc3RvcmVkLgpjYXNlICIkb3N2
ZXJzIiBpbgpbMC0yXS4qfDMuWzAtMl0pCglkX3NldHJlZ2lkPSR1bmRlZgoJZF9zZXRyZXVpZD0k
dW5kZWYKCWRfc2V0cmdpZD0kdW5kZWYKCWRfc2V0cnVpZD0kdW5kZWYKZXNhYwoKIwojIE5vdCBh
bGwgcGxhdGZvcm1zIHN1cHBvcnQgZHluYW1pYyBsb2FkaW5nLi4uCiMgRm9yIHRoZSBjYXNlIG9m
ICIkb3BlbmJzZF9kaXN0cmlidXRpb24iLCB0aGUgaGludHMgZmlsZQojIG5lZWRzIHRvIGtub3cg
d2hldGhlciB3ZSBhcmUgdXNpbmcgZHluYW1pYyBsb2FkaW5nIHNvIHRoYXQKIyBpdCBjYW4gc2V0
IHRoZSBsaWJwZXJsIG5hbWUgYXBwcm9wcmlhdGVseS4KIyBBbGxvdyBjb21tYW5kIGxpbmUgb3Zl
cnJpZGVzLgojCkFSQ0g9YGFyY2ggfCBzZWQgJ3MvXk9wZW5CU0QuLy8nYApjYXNlICIke0FSQ0h9
LSR7b3N2ZXJzfSIgaW4KYWxwaGEtMi5bMC04XXxtaXBzLTIuWzAtOF18cG93ZXJwYy0yLlswLTdd
fG04OGstKnxocHBhLSp8dmF4LSopCgl0ZXN0IC16ICIkdXNlZGwiICYmIHVzZWRsPSR1bmRlZgoJ
OzsKKikKCXRlc3QgLXogIiR1c2VkbCIgJiYgdXNlZGw9JGRlZmluZQoJIyBXZSB1c2UgLWZQSUMg
aGVyZSBiZWNhdXNlIC1mcGljIGlzICpOT1QqIGVub3VnaCBmb3Igc29tZSBvZiB0aGUKCSMgZXh0
ZW5zaW9ucyBsaWtlIFRrIG9uIHNvbWUgT3BlbkJTRCBwbGF0Zm9ybXMgKGllOiBzcGFyYykKCWNj
Y2RsZmxhZ3M9Ii1EUElDIC1mUElDICRjY2NkbGZsYWdzIgoJY2FzZSAiJG9zdmVycyIgaW4KCVsw
MV0uKnwyLlswLTddfDIuWzAtN10uKikKCQlsZGRsZmxhZ3M9Ii1Cc2hhcmVhYmxlICRsZGRsZmxh
Z3MiCgkJOzsKCTIuWzgtOV18My4wKQoJCWxkPSR7Y2M6LWNjfQoJCWxkZGxmbGFncz0iLXNoYXJl
ZCAtZlBJQyAkbGRkbGZsYWdzIgoJCTs7CgkqKSAjIGZyb20gMy4xIG9ud2FyZHMKCQlsZD0ke2Nj
Oi1jY30KCQlsZGRsZmxhZ3M9Ii1zaGFyZWQgLWZQSUMgJGxkZGxmbGFncyIKCQlsaWJzd2FudGVk
PWBlY2hvICRsaWJzd2FudGVkIHwgc2VkICdzLyBkbCAvIC8nYAoJCTs7Cgllc2FjCgoJIyBXZSBu
ZWVkIHRvIGZvcmNlIGxkIHRvIGV4cG9ydCBzeW1ib2xzIG9uIEVMRiBwbGF0Zm9ybXMuCgkjIFdp
dGhvdXQgdGhpcywgZGxvcGVuKCkgaXMgY3JpcHBsZWQuCglFTEY9YCR7Y2M6LWNjfSAtZE0gLUUg
LSA8L2Rldi9udWxsIHwgZ3JlcCBfX0VMRl9fYAoJdGVzdCAtbiAiJEVMRiIgJiYgbGRmbGFncz0i
LVdsLC1FICRsZGZsYWdzIgoJOzsKZXNhYwoKIwojIFR3ZWFrcyBmb3IgdmFyaW91cyB2ZXJzaW9u
cyBvZiBPcGVuQlNECiMKY2FzZSAiJG9zdmVycyIgaW4KMi41KQoJIyBPcGVuQlNEIDIuNSBoYXMg
YnJva2VuIG9kYm0gc3VwcG9ydAoJaV9kYm09JHVuZGVmCgk7Owplc2FjCgojIE9wZW5CU0QgZG9l
c24ndCBuZWVkIGxpYmNyeXB0IGJ1dCBtYW55IGZvbGtzIGtlZXAgYSBzdHViIGxpYgojIGFyb3Vu
ZCBmb3Igb2xkIE5ldEJTRCBiaW5hcmllcy4KbGlic3dhbnRlZD1gZWNobyAkbGlic3dhbnRlZCB8
IHNlZCAncy8gY3J5cHQgLyAvJ2AKCiMgQ29uZmlndXJlIGNhbid0IGZpZ3VyZSB0aGlzIG91dCBu
b24taW50ZXJhY3RpdmVseQpkX3N1aWRzYWZlPSRkZWZpbmUKCiMgY2MgaXMgZ2NjIHNvIHdlIGNh
biBkbyBiZXR0ZXIgdGhhbiAtTwojIEFsbG93IGEgY29tbWFuZC1saW5lIG92ZXJyaWRlLCBzdWNo
IGFzIC1Eb3B0aW1pemU9LWcKY2FzZSAke0FSQ0h9IGluCm04OGspCiAgIG9wdGltaXplPSctTzAn
CiAgIDs7CmhwcGEpCiAgIG9wdGltaXplPSctTzAnCiAgIDs7CiopCiAgIHRlc3QgIiRvcHRpbWl6
ZSIgfHwgb3B0aW1pemU9Jy1PMicKICAgOzsKZXNhYwoKIyBUaGlzIHNjcmlwdCBVVS91c2V0aHJl
YWRzLmNidSB3aWxsIGdldCAnY2FsbGVkLWJhY2snIGJ5IENvbmZpZ3VyZSAKIyBhZnRlciBpdCBo
YXMgcHJvbXB0ZWQgdGhlIHVzZXIgZm9yIHdoZXRoZXIgdG8gdXNlIHRocmVhZHMuCmNhdCA+IFVV
L3VzZXRocmVhZHMuY2J1IDw8J0VPQ0JVJwpjYXNlICIkdXNldGhyZWFkcyIgaW4KJGRlZmluZXx0
cnVlfFt5WV0qKQoJIyBhbnkgb3BlbmJzZCB2ZXJzaW9uIGRlcGVuZGVuY2llcyB3aXRoIHB0aHJl
YWRzPwoJY2NmbGFncz0iLXB0aHJlYWQgJGNjZmxhZ3MiCglsZGZsYWdzPSItcHRocmVhZCAkbGRm
bGFncyIKCWNhc2UgIiRvc3ZlcnMiIGluCglbMC0yXS4qfDMuWzAtMl0pCgkJIyBDaGFuZ2UgZnJv
bSAtbGMgdG8gLWxjX3IKCQlzZXQgYGVjaG8gIlggJGxpYnN3YW50ZWQgIiB8IHNlZCAncy8gYyAv
IGNfciAvJ2AKCQlzaGlmdAoJCWxpYnN3YW50ZWQ9IiQqIgoJOzsKCWVzYWMKCWNhc2UgIiRvc3Zl
cnMiIGluCglbMDEyXS4qfDMuWzAtNl0pCiAgICAgICAgCSMgQnJva2VuIGF0IGxlYXN0IHVwIHRv
IE9wZW5CU0QgMy42LCB3ZSdsbCBzZWUgYWJvdXQgMy43CgkJZF9nZXRzZXJ2YnluYW1lX3I9JHVu
ZGVmIDs7Cgllc2FjCmVzYWMKRU9DQlUKCiMgVGhpcyBzY3JpcHQgVVUvdXNlNjRiaXRpbnQuY2J1
IHdpbGwgZ2V0ICdjYWxsZWQtYmFjaycgYnkgQ29uZmlndXJlIAojIGFmdGVyIGl0IGhhcyBwcm9t
cHRlZCB0aGUgdXNlciBmb3Igd2hldGhlciB0byB1c2UgNjQtYml0bmVzcy4KY2F0ID4gVVUvdXNl
NjRiaXRpbnQuY2J1IDw8J0VPQ0JVJwpjYXNlICIkdXNlNjRiaXRpbnQiIGluCiRkZWZpbmV8dHJ1
ZXxbeVldKikKCWVjaG8gIiAiCgllY2hvICJDaGVja2luZyBpZiB5b3VyIEMgbGlicmFyeSBoYXMg
YnJva2VuIDY0LWJpdCBmdW5jdGlvbnMuLi4iID4mNAoJJGNhdCA+Y2hlY2suYyA8PEVPQ1AKI2lu
Y2x1ZGUgPHN0ZGlvLmg+CnR5cGVkZWYgJHVxdWFkdHlwZSBteVVMTDsKaW50IG1haW4gKHZvaWQp
CnsKICAgIHN0cnVjdCB7Cglkb3VibGUgZDsKCW15VUxMICB1OwogICAgfSAqcCwgdGVzdFtdID0g
ewoJezQyOTQ5NjczMDMuMTUsIDQyOTQ5NjczMDNVTEx9LAoJezQyOTQ5NjcyOTQuMiwgIDQyOTQ5
NjcyOTRVTEx9LAoJezQyOTQ5NjcyOTUuNywgIDQyOTQ5NjcyOTVVTEx9LAoJezAuMCwgMFVMTH0K
ICAgIH07CiAgICBmb3IgKHAgPSB0ZXN0OyBwLT51OyBwKyspIHsKCW15VUxMIHggPSAobXlVTEwp
cC0+ZDsKCWlmICh4ICE9IHAtPnUpIHsKCSAgICBwcmludGYoImJ1Z2d5XG4iKTsKCSAgICByZXR1
cm4gMDsKCX0KICAgIH0KICAgIHByaW50Zigib2tcbiIpOwogICAgcmV0dXJuIDA7Cn0KRU9DUAoJ
c2V0IGNoZWNrCglpZiBldmFsICRjb21waWxlX29rOyB0aGVuCgkgICAgbGliY3F1YWQ9YC4vY2hl
Y2tgCgkgICAgZWNobyAiWW91ciBDIGxpYnJhcnkncyA2NC1iaXQgZnVuY3Rpb25zIGFyZSAkbGli
Y3F1YWQuIgoJZWxzZQoJICAgIGVjaG8gIihJIGNhbid0IHNlZW0gdG8gY29tcGlsZSB0aGUgdGVz
dCBwcm9ncmFtLikiCgkgICAgZWNobyAiQXNzdW1pbmcgdGhhdCB5b3VyIEMgbGlicmFyeSdzIDY0
LWJpdCBmdW5jdGlvbnMgYXJlIG9rLiIKCSAgICBsaWJjcXVhZD0ib2siCglmaQoJJHJtIC1mIGNo
ZWNrLmMgY2hlY2sKCgljYXNlICIkbGliY3F1YWQiIGluCgkgICAgYnVnZ3kqKQoJCWNhdCA+JjQg
PDxFT00KCioqKiBZb3UgaGF2ZSBhIEMgbGlicmFyeSB3aXRoIGJyb2tlbiA2NC1iaXQgZnVuY3Rp
b25zLgoqKiogNjQtYml0IHN1cHBvcnQgZG9lcyBub3Qgd29yayByZWxpYWJseSBpbiB0aGlzIGNv
bmZpZ3VyYXRpb24uCioqKiBQbGVhc2UgcmVydW4gQ29uZmlndXJlIHdpdGhvdXQgLUR1c2U2NGJp
dGludCBhbmQvb3IgLUR1c2Vtb3JlYml0cy4KKioqIENhbm5vdCBjb250aW51ZSwgYWJvcnRpbmcu
CgpFT00KCQlleGl0IDEKCQk7OwoJZXNhYwplc2FjCkVPQ0JVCgojIFdoZW4gYnVpbGRpbmcgaW4g
dGhlIE9wZW5CU0QgdHJlZSB3ZSB1c2UgZGlmZmVyZW50IHBhdGhzCiMgVGhpcyBpcyBvbmx5IHBh
cnQgb2YgdGhlIHN0b3J5LCB0aGUgcmVzdCBjb21lcyBmcm9tIGNvbmZpZy5vdmVyCmNhc2UgIiRv
cGVuYnNkX2Rpc3RyaWJ1dGlvbiIgaW4KJyd8JHVuZGVmfGZhbHNlKSA7OwoqKQoJIyBXZSBwdXQg
dGhpbmdzIGluIC91c3IsIG5vdCAvdXNyL2xvY2FsCglwcmVmaXg9Jy91c3InCglwcmVmaXhleHA9
Jy91c3InCglzeXNtYW49Jy91c3Ivc2hhcmUvbWFuL21hbjEnCglsaWJwdGg9Jy91c3IvbGliJwoJ
Z2xpYnB0aD0nL3Vzci9saWInCgkjIExvY2FsIHRoaW5ncywgaG93ZXZlciwgZG8gZ28gaW4gL3Vz
ci9sb2NhbAoJc2l0ZXByZWZpeD0nL3Vzci9sb2NhbCcKCXNpdGVwcmVmaXhleHA9Jy91c3IvbG9j
YWwnCgkjIFBvcnRzIGluc3RhbGxzIG5vbi1zdGQgbGlicyBpbiAvdXNyL2xvY2FsL2xpYiBzbyBs
b29rIHRoZXJlIHRvbwoJbG9jaW5jcHRoPScvdXNyL2xvY2FsL2luY2x1ZGUnCglsb2NsaWJwdGg9
Jy91c3IvbG9jYWwvbGliJwoJIyBMaW5rIHBlcmwgd2l0aCBzaGFyZWQgbGlicGVybAoJaWYgWyAi
JHVzZWRsIiA9ICIkZGVmaW5lIiAtYSAtciBzaGxpYl92ZXJzaW9uIF07IHRoZW4KCQl1c2VzaHJw
bGliPXRydWUKCQlsaWJwZXJsPWAuIC4vc2hsaWJfdmVyc2lvbjsgZWNobyBsaWJwZXJsLnNvLiR7
bWFqb3J9LiR7bWlub3J9YAoJZmkKCTs7CmVzYWMKCiMgZW5kCg==',
'cygwin' =>
'IyEgL2Jpbi9zaAojIGN5Z3dpbi5zaCAtIGhpbnRzIGZvciBidWlsZGluZyBwZXJsIHVzaW5nIHRo
ZSBDeWd3aW4gZW52aXJvbm1lbnQgZm9yIFdpbjMyCiMKCiMgbm90IG90aGVyd2lzZSBzZXR0YWJs
ZQpleGVfZXh0PScuZXhlJwpmaXJzdG1ha2VmaWxlPSdHTlVtYWtlZmlsZScKY2FzZSAiJGxkbGli
cHRobmFtZSIgaW4KJycpIGxkbGlicHRobmFtZT1QQVRIIDs7CmVzYWMKYXJjaG9ianM9J2N5Z3dp
bi5vJwoKIyBtYW5kYXRvcnkgKG92ZXJyaWRlcyBpbmNvcnJlY3QgZGVmYXVsdHMpCnRlc3QgLXog
IiRjYyIgJiYgY2M9J2djYycKaWYgdGVzdCAteiAiJHBsaWJwdGgiCnRoZW4KICAgIHBsaWJwdGg9
YGdjYyAtcHJpbnQtZmlsZS1uYW1lPWxpYmMuYWAKICAgIHBsaWJwdGg9YGRpcm5hbWUgJHBsaWJw
dGhgCiAgICBwbGlicHRoPWBjZCAkcGxpYnB0aCAmJiBwd2RgCmZpCnNvPSdkbGwnCiMgLSBlbGlt
aW5hdGUgLWxjLCBpbXBsaWVkIGJ5IGdjYyBhbmQgYSBzeW1saW5rIHRvIGxpYmN5Z3dpbi5hCmxp
YnN3YW50ZWQ9YGVjaG8gIiAkbGlic3dhbnRlZCAiIHwgc2VkIC1lICdzLyBjIC8gL2cnYAojIC0g
ZWxpbWluYXRlIC1sbSwgc3ltbGluayB0byBsaWJjeWd3aW4uYQpsaWJzd2FudGVkPWBlY2hvICIg
JGxpYnN3YW50ZWQgIiB8IHNlZCAtZSAncy8gbSAvIC9nJ2AKIyAtIGVsaW1pbmF0ZSAtbHV0aWws
IHN5bWJvbHMgYXJlIGFsbCBpbiBsaWJjeWd3aW4uYQpsaWJzd2FudGVkPWBlY2hvICIgJGxpYnN3
YW50ZWQgIiB8IHNlZCAtZSAncy8gdXRpbCAvIC9nJ2AKIyAtIGFkZCBsaWJnZGJtX2NvbXBhdCAk
bGlic3dhbnRlZApsaWJzd2FudGVkPSIkbGlic3dhbnRlZCBnZGJtX2NvbXBhdCIKdGVzdCAteiAi
JG9wdGltaXplIiAmJiBvcHRpbWl6ZT0nLU8zJwptYW4zZXh0PSczcG0nCnRlc3QgLXogIiR1c2U2
NGJpdGludCIgJiYgdXNlNjRiaXRpbnQ9J2RlZmluZScKdGVzdCAteiAiJHVzZWl0aHJlYWRzIiAm
JiB1c2VpdGhyZWFkcz0nZGVmaW5lJwpjY2ZsYWdzPSIkY2NmbGFncyAtRFBFUkxfVVNFX1NBRkVf
UFVURU5WIC1VX19TVFJJQ1RfQU5TSV9fIgojIC0gb3RoZXJ3aXNlIGk2ODYtY3lnd2luCmFyY2hu
YW1lPSdjeWd3aW4nCgojIGR5bmFtaWMgbG9hZGluZwojIC0gb3RoZXJ3aXNlIC1mcGljCmNjY2Rs
ZmxhZ3M9JyAnCmxkZGxmbGFncz0nIC0tc2hhcmVkJwp0ZXN0IC16ICIkbGQiICYmIGxkPSdnKysn
CgpjYXNlICIkb3N2ZXJzIiBpbgogICAgIyBDb25maWd1cmUgZ2V0cyB0aGVzZSB3cm9uZyBpZiB0
aGUgSVBDIHNlcnZlciBpc24ndCB5ZXQgcnVubmluZzoKICAgICMgb25seSB1c2UgZm9yIDEuNS43
IGFuZCBvbndhcmRzCiAgICBbMi05XSp8MS5bNi05XSp8MS5bMS01XVswLTldKnwxLjUuWzctOV0q
fDEuNS5bMS02XVswLTldKikKICAgICAgICBkX3NlbWN0bF9zZW1pZF9kcz0nZGVmaW5lJwogICAg
ICAgIGRfc2VtY3RsX3NlbXVuPSdkZWZpbmUnCiAgICAgICAgOzsKZXNhYwoKY2FzZSAiJG9zdmVy
cyIgaW4KICAgIFsyLTldKnwxLls2LTldKikKICAgICAgICAjIElQdjYgb25seSBzaW5jZSAxLjcK
ICAgICAgICBkX2luZXRudG9wPSdkZWZpbmUnCiAgICAgICAgZF9pbmV0cHRvbj0nZGVmaW5lJwog
ICAgICAgIDs7CiAgICAqKQogICAgICAgICMgSVB2NiBub3QgaW1wbGVtZW50ZWQgYmVmb3JlIGN5
Z3dpbi0xLjcKICAgICAgICBkX2luZXRudG9wPSd1bmRlZicKICAgICAgICBkX2luZXRwdG9uPSd1
bmRlZicKZXNhYwoKIyBjb21waWxlIFdpbjMyQ09SRSAibW9kdWxlIiBhcyBzdGF0aWMuIHRyeSB0
byBhdm9pZCB0aGUgc3BhY2UuCmlmIHRlc3QgLXogIiRzdGF0aWNfZXh0IjsgdGhlbgogIHN0YXRp
Y19leHQ9IldpbjMyQ09SRSIKZWxzZQogIHN0YXRpY19leHQ9IiRzdGF0aWNfZXh0IFdpbjMyQ09S
RSIKZmkKCiMgV2luOXggcHJvYmxlbSB3aXRoIG5vbi1ibG9ja2luZyByZWFkIGZyb20gYSBjbG9z
ZWQgcGlwZQpkX2VvZm5ibGs9J2RlZmluZScKCiMgc3VwcHJlc3MgYXV0by1pbXBvcnQgd2Fybmlu
Z3MKbGRmbGFncz0iJGxkZmxhZ3MgLVdsLC0tZW5hYmxlLWF1dG8taW1wb3J0IC1XbCwtLWV4cG9y
dC1hbGwtc3ltYm9scyAtV2wsLS1lbmFibGUtYXV0by1pbWFnZS1iYXNlIgpsZGRsZmxhZ3M9IiRs
ZGRsZmxhZ3MgJGxkZmxhZ3MiCgojIHN0cmlwIGV4ZSdzIGFuZCBkbGwncywgYmV0dGVyIGRvIGl0
IGFmdGVyd2FyZHMKI2xkZmxhZ3M9IiRsZGZsYWdzIC1zIgojY2NkbGZsYWdzPSIkY2NkbGZsYWdz
IC1zIgojbGRkbGZsYWdzPSIkbGRkbGZsYWdzIC1zIgo=',
'linux' =>
'IyBoaW50cy9saW51eC5zaAojIE9yaWdpbmFsIHZlcnNpb24gYnkgcnNhbmRlcnMKIyBBZGRpdGlv
bmFsIHN1cHBvcnQgYnkgS2VubmV0aCBBbGJhbm93c2tpIDxramFoZHNAa2phaGRzLmNvbT4KIwoj
IEVMRiBzdXBwb3J0IGJ5IEguSi4gTHUgPGhqbEBueW5leHN0LmNvbT4KIyBBZGRpdGlvbmFsIGlu
Zm8gZnJvbSBOaWdlbCBIZWFkIDxuaGVhZEBFU09DLmJpdG5ldD4KIyBhbmQgS2VubmV0aCBBbGJh
bm93c2tpIDxramFoZHNAa2phaGRzLmNvbT4KIwojIENvbnNvbGlkYXRlZCBieSBBbmR5IERvdWdo
ZXJ0eSA8ZG91Z2hlcmFAbGFmYXlldHRlLmVkdT4KIwojIFVwZGF0ZWQgVGh1IEZlYiAgOCAxMTo1
NjoxMCBFU1QgMTk5NgoKIyBVcGRhdGVkIFRodSBNYXkgMzAgMTA6NTA6MjIgRURUIDE5OTYgYnkg
PGRvdWdoZXJhQGxhZmF5ZXR0ZS5lZHU+CgojIFVwZGF0ZWQgRnJpIEp1biAyMSAxMTowNzo1NCBF
RFQgMTk5NgojIE5EQk0gc3VwcG9ydCBmb3IgRUxGIHJlLWVuYWJsZWQgYnkgPGtqYWhkc0BramFo
ZHMuY29tPgoKIyBObyB2ZXJzaW9uIG9mIExpbnV4IHN1cHBvcnRzIHNldHVpZCBzY3JpcHRzLgpk
X3N1aWRzYWZlPSd1bmRlZicKCiMgTm8gdmVyc2lvbiBvZiBMaW51eCBuZWVkcyBsaWJ1dGlsIGZv
ciBwZXJsLgppX2xpYnV0aWw9J3VuZGVmJwoKIyBEZWJpYW4gYW5kIFJlZCBIYXQsIGFuZCBwZXJo
YXBzIG90aGVyIHZlbmRvcnMsIHByb3ZpZGUgYm90aCBydW50aW1lIGFuZAojIGRldmVsb3BtZW50
IHBhY2thZ2VzIGZvciBzb21lIGxpYnJhcmllcy4gIFRoZSBydW50aW1lIHBhY2thZ2VzIGNvbnRh
aW4gc2hhcmVkCiMgbGlicmFyaWVzIHdpdGggdmVyc2lvbiBpbmZvcm1hdGlvbiBpbiB0aGVpciBu
YW1lcyAoZS5nLiwgbGliZ2RibS5zby4xLjcuMyk7CiMgdGhlIGRldmVsb3BtZW50IHBhY2thZ2Vz
IHN1cHBsZW1lbnQgdGhpcyB3aXRoIHZlcnNpb25sZXNzIHNoYXJlZCBsaWJyYXJpZXMKIyAoZS5n
LiwgbGliZ2RibS5zbykuCiMKIyBJZiB5b3Ugd2FudCB0byBsaW5rIGFnYWluc3Qgc3VjaCBhIGxp
YnJhcnksIHlvdSBtdXN0IGluc3RhbGwgdGhlIGRldmVsb3BtZW50CiMgdmVyc2lvbiBvZiB0aGUg
cGFja2FnZS4KIwojIFRoZXNlIHBhY2thZ2VzIHVzZSBhIC1kZXYgbmFtaW5nIGNvbnZlbnRpb24g
aW4gYm90aCBEZWJpYW4gYW5kIFJlZCBIYXQ6CiMgICBsaWJnZGJtZzEgIChub24tZGV2ZWxvcG1l
bnQgdmVyc2lvbiBvZiBHTlUgbGliYyAyLWxpbmtlZCBHREJNIGxpYnJhcnkpCiMgICBsaWJnZGJt
ZzEtZGV2IChkZXZlbG9wbWVudCB2ZXJzaW9uIG9mIEdOVSBsaWJjIDItbGlua2VkIEdEQk0gbGli
cmFyeSkKIyBTbyBtYWtlIHN1cmUgdGhhdCBmb3IgYW55IGxpYnJhcmllcyB5b3Ugd2lzaCB0byBs
aW5rIFBlcmwgd2l0aCB1bmRlcgojIERlYmlhbiBvciBSZWQgSGF0IHlvdSBoYXZlIHRoZSAtZGV2
IHBhY2thZ2VzIGluc3RhbGxlZC4KCiMgU3VTRSBMaW51eCBjYW4gYmUgdXNlZCBhcyBjcm9zcy1j
b21waWxhdGlvbiBob3N0IGZvciBDcmF5IFhUNCBDYXRhbW91bnQvUWsuCmlmIHRlc3QgLWQgL29w
dC94dC1wZQp0aGVuCiAgY2FzZSAiYGNjIC1WIDI+JjFgIiBpbgogICpjYXRhbW91bnQqKSAuIGhp
bnRzL2NhdGFtb3VudC5zaDsgcmV0dXJuIDs7CiAgZXNhYwpmaQoKIyBTb21lIG9wZXJhdGluZyBz
eXN0ZW1zIChlLmcuLCBTb2xhcmlzIDIuNikgd2lsbCBsaW5rIHRvIGEgdmVyc2lvbmVkIHNoYXJl
ZAojIGxpYnJhcnkgaW1wbGljaXRseS4gIEZvciBleGFtcGxlLCBvbiBTb2xhcmlzLCBgbGQgZm9v
Lm8gLWxnZGJtJyB3aWxsIGZpbmQgYW4KIyBhcHByb3ByaWF0ZSB2ZXJzaW9uIG9mIGxpYmdkYm0s
IGlmIG9uZSBpcyBhdmFpbGFibGU7IExpbnV4LCBob3dldmVyLCBkb2Vzbid0CiMgZG8gdGhlIGlt
cGxpY2l0IG1hcHBpbmcuCmlnbm9yZV92ZXJzaW9uZWRfc29saWJzPSd5JwoKIyBCU0QgY29tcGF0
aWJpbGl0eSBsaWJyYXJ5IG5vIGxvbmdlciBuZWVkZWQKIyAna2FmZmUnIGhhcyBhIC91c3IvbGli
L2xpYm5ldC5zbyB3aGljaCBpcyBub3QgYXQgYWxsIHJlbGV2YW50IGZvciBwZXJsLgojIGJpbmQg
Y2F1c2VzIGlzc3VlcyB3aXRoIHNldmVyYWwgcmVlbnRyYW50IGZ1bmN0aW9ucwpzZXQgYGVjaG8g
WCAiJGxpYnN3YW50ZWQgInwgc2VkIC1lICdzLyBic2QgLyAvJyAtZSAncy8gbmV0IC8gLycgLWUg
J3MvIGJpbmQgLyAvJ2AKc2hpZnQKbGlic3dhbnRlZD0iJCoiCgojIERlYmlhbiA0LjAgcHV0cyBu
ZGJtIGluIHRoZSAtbGdkYm1fY29tcGF0IGxpYnJhcnkuCmxpYnN3YW50ZWQ9IiRsaWJzd2FudGVk
IGdkYm1fY29tcGF0IgoKIyBJZiB5b3UgaGF2ZSBnbGliYywgdGhlbiByZXBvcnQgdGhlIHZlcnNp
b24gZm9yIC4vbXljb25maWcgYnVnIHJlcG9ydGluZy4KIyAoQ29uZmlndXJlIGRvZXNuJ3QgbmVl
ZCB0byBrbm93IHRoZSBzcGVjaWZpYyB2ZXJzaW9uIHNpbmNlIGl0IGp1c3QgdXNlcwojIGdjYyB0
byBsb2FkIHRoZSBsaWJyYXJ5IGZvciBhbGwgdGVzdHMuKQojIFdlIGRvbid0IHVzZSBfX0dMSUJD
X18gYW5kICBfX0dMSUJDX01JTk9SX18gYmVjYXVzZSB0aGV5CiMgYXJlIGluc3VmZmljaWVudGx5
IHByZWNpc2UgdG8gZGlzdGluZ3Vpc2ggdGhpbmdzIGxpa2UKIyBsaWJjLTIuMC42IGFuZCBsaWJj
LTIuMC43LgppZiB0ZXN0IC1MIC9saWIvbGliYy5zby42OyB0aGVuCiAgICBsaWJjPWBscyAtbCAv
bGliL2xpYmMuc28uNiB8IGF3ayAne3ByaW50ICRORn0nYAogICAgbGliYz0vbGliLyRsaWJjCmZp
CgojIENvbmZpZ3VyZSBtYXkgZmFpbCB0byBmaW5kIGxzdGF0KCkgc2luY2UgaXQncyBhIHN0YXRp
Yy9pbmxpbmUKIyBmdW5jdGlvbiBpbiA8c3lzL3N0YXQuaD4uCmRfbHN0YXQ9ZGVmaW5lCgojIG1h
bGxvYyB3cmFwIHdvcmtzCmNhc2UgIiR1c2VtYWxsb2N3cmFwIiBpbgonJykgdXNlbWFsbG9jd3Jh
cD0nZGVmaW5lJyA7Owplc2FjCgojIFRoZSBzeXN0ZW0gbWFsbG9jKCkgaXMgYWJvdXQgYXMgZmFz
dCBhbmQgYXMgZnJ1Z2FsIGFzIHBlcmwncy4KIyBTaW5jZSB0aGUgc3lzdGVtIG1hbGxvYygpIGhh
cyBiZWVuIHRoZSBkZWZhdWx0IHNpbmNlIGF0IGxlYXN0CiMgNS4wMDEsIHdlIG1pZ2h0IGFzIHdl
bGwgbGVhdmUgaXQgdGhhdCB3YXkuICAtLUFEICAxMCBKYW4gMjAwMgpjYXNlICIkdXNlbXltYWxs
b2MiIGluCicnKSB1c2VteW1hbGxvYz0nbicgOzsKZXNhYwoKIyBDaGVjayBpZiB3ZSdyZSBhYm91
dCB0byB1c2UgSW50ZWwncyBJQ0MgY29tcGlsZXIKY2FzZSAiYCR7Y2M6LWNjfSAtViAyPiYxYCIg
aW4KKiJJbnRlbChSKSBDKysgQ29tcGlsZXIiKnwqIkludGVsKFIpIEMgQ29tcGlsZXIiKikKICAg
ICMgcmVjb3JkIHRoZSB2ZXJzaW9uLCBmb3JtYXRzOgogICAgIyBpY2MgKElDQykgMTAuMSAyMDA4
MDgwMQogICAgIyBpY3BjIChJQ0MpIDEwLjEgMjAwODA4MDEKICAgICMgZm9sbG93ZWQgYnkgYSBj
b3B5cmlnaHQgb24gdGhlIHNlY29uZCBsaW5lCiAgICBjY3ZlcnNpb249YCR7Y2M6LWNjfSAtLXZl
cnNpb24gfCBzZWQgLW4gLWUgJ3MvXmljcFw/YyBcKChJQ0MpIFwpXD8vL3AnYAogICAgIyBUaGlz
IGlzIG5lZWRlZCBmb3IgQ29uZmlndXJlJ3MgcHJvdG90eXBlIGNoZWNrcyB0byB3b3JrIGNvcnJl
Y3RseQogICAgIyBUaGUgLW1wIGZsYWcgaXMgbmVlZGVkIHRvIHBhc3MgdmFyaW91cyBmbG9hdGlu
ZyBwb2ludCByZWxhdGVkIHRlc3RzCiAgICAjIFRoZSAtbm8tZ2NjIGZsYWcgaXMgbmVlZGVkIG90
aGVyd2lzZSwgaWNjIHByZXRlbmRzIChwb29ybHkpIHRvIGJlIGdjYwogICAgY2NmbGFncz0iLXdl
MTQ3IC1tcCAtbm8tZ2NjICRjY2ZsYWdzIgogICAgIyBQcmV2ZW50IHJlbG9jYXRpb24gZXJyb3Jz
IG9uIDY0Yml0cyBhcmNoCiAgICBjYXNlICJgdW5hbWUgLW1gIiBpbgoJKmlhNjQqfCp4ODZfNjQq
KQoJICAgIGNjY2RsZmxhZ3M9Jy1mUElDJwoJOzsKICAgIGVzYWMKICAgICMgSWYgd2UncmUgdXNp
bmcgSUNDLCB3ZSB1c3VhbGx5IHdhbnQgdGhlIGJlc3QgcGVyZm9ybWFuY2UKICAgIGNhc2UgIiRv
cHRpbWl6ZSIgaW4KICAgICcnKSBvcHRpbWl6ZT0nLU8zJyA7OwogICAgZXNhYwogICAgOzsKKiIg
U3VuICIqIkMiKikKICAgICMgU3VuJ3MgQyBjb21waWxlciwgd2hpY2ggbWlnaHQgaGF2ZSBhICd0
YWcnIG5hbWUgYmV0d2VlbgogICAgIyAnU3VuJyBhbmQgdGhlICdDJzogIEV4YW1wbGVzOgogICAg
IyBjYzogU3VuIEMgNS45IExpbnV4X2kzODYgUGF0Y2ggMTI0ODcxLTAxIDIwMDcvMDcvMzEKICAg
ICMgY2M6IFN1biBDZXJlcyBDIDUuMTAgTGludXhfaTM4NiAyMDA4LzA3LzEwCiAgICB0ZXN0ICIk
b3B0aW1pemUiIHx8IG9wdGltaXplPScteE8yJwogICAgY2NjZGxmbGFncz0nLUtQSUMnCiAgICBs
ZGRsZmxhZ3M9Jy1HIC1CZHluYW1pYycKICAgICMgU3VuIEMgZG9lc24ndCBzdXBwb3J0IGdjYyBh
dHRyaWJ1dGVzLCBidXQsIGluIG1hbnkgY2FzZXMsIGRvZXNuJ3QKICAgICMgY29tcGxhaW4gZWl0
aGVyLiAgTm90IGFsbCBjYXNlcywgdGhvdWdoLgogICAgZF9hdHRyaWJ1dGVfZm9ybWF0PSd1bmRl
ZicKICAgIGRfYXR0cmlidXRlX21hbGxvYz0ndW5kZWYnCiAgICBkX2F0dHJpYnV0ZV9ub25udWxs
PSd1bmRlZicKICAgIGRfYXR0cmlidXRlX25vcmV0dXJuPSd1bmRlZicKICAgIGRfYXR0cmlidXRl
X3B1cmU9J3VuZGVmJwogICAgZF9hdHRyaWJ1dGVfdW51c2VkPSd1bmRlZicKICAgIGRfYXR0cmli
dXRlX3dhcm5fdW51c2VkX3Jlc3VsdD0ndW5kZWYnCiAgICA7Owplc2FjCgpjYXNlICIkb3B0aW1p
emUiIGluCiMgdXNlIC1PMiBieSBkZWZhdWx0IDsgLU8zIGRvZXNuJ3Qgc2VlbSB0byBicmluZyBz
aWduaWZpY2FudCBiZW5lZml0cyB3aXRoIGdjYwonJykKICAgIG9wdGltaXplPSctTzInCiAgICBj
YXNlICJgdW5hbWUgLW1gIiBpbgogICAgICAgIHBwYyopCiAgICAgICAgICAgICMgb24gcHBjLCBp
dCBzZWVtcyB0aGF0IGdjYyAoYXQgbGVhc3QgZ2NjIDMuMy4yKSBpc24ndCBoYXBweQogICAgICAg
ICAgICAjIHdpdGggLU8yIDsgc28gZG93bmdyYWRlIHRvIC1PMS4KICAgICAgICAgICAgb3B0aW1p
emU9Jy1PMScKICAgICAgICA7OwogICAgICAgIGlhNjQqKQogICAgICAgICAgICAjIFRoaXMgYXJj
aGl0ZWN0dXJlIGhhcyBoYWQgdmFyaW91cyBwcm9ibGVtcyB3aXRoIGdjYydzCiAgICAgICAgICAg
ICMgaW4gdGhlIDMuMiwgMy4zLCBhbmQgMy40IHJlbGVhc2VzIHdoZW4gb3B0aW1pemVkIHRvIC1P
Mi4gIFNlZQogICAgICAgICAgICAjIFJUICMzNzE1NiBmb3IgYSBkaXNjdXNzaW9uIG9mIHRoZSBw
cm9ibGVtLgogICAgICAgICAgICBjYXNlICJgJHtjYzotZ2NjfSAtdiAyPiYxYCIgaW4KICAgICAg
ICAgICAgKiJ2ZXJzaW9uIDMuMiIqfCoidmVyc2lvbiAzLjMiKnwqInZlcnNpb24gMy40IiopCiAg
ICAgICAgICAgICAgICBjY2ZsYWdzPSItZm5vLWRlbGV0ZS1udWxsLXBvaW50ZXItY2hlY2tzICRj
Y2ZsYWdzIgogICAgICAgICAgICA7OwogICAgICAgICAgICBlc2FjCiAgICAgICAgOzsKICAgIGVz
YWMKICAgIDs7CmVzYWMKCiMgVWJ1bnR1IDExLjA0IChhbmQgbGF0ZXIsIHByZXN1bWFibHkpIGRv
ZXNuJ3Qga2VlcCBtb3N0IGxpYnJhcmllcwojIChzdWNoIGFzIC1sbSkgaW4gL2xpYiBvciAvdXNy
L2xpYi4gIFNvIHdlIGhhdmUgdG8gYXNrIGdjYyB0byB0ZWxsIHVzCiMgd2hlcmUgdG8gbG9vay4g
IFdlIGRvbid0IHdhbnQgZ2NjJ3Mgb3duIGxpYnJhcmllcywgaG93ZXZlciwgc28gd2UKIyBmaWx0
ZXIgdGhvc2Ugb3V0LgojIFRoaXMgY291bGQgYmUgY29uZGl0aW9uYWwgb24gVW5idW50dSwgYnV0
IG90aGVyIGRpc3RyaWJ1dGlvbnMgbWF5CiMgZm9sbG93IHN1aXQsIGFuZCB0aGlzIHNjaGVtZSBz
ZWVtcyB0byB3b3JrIGV2ZW4gb24gcmF0aGVyIG9sZCBnY2Mncy4KIyBUaGlzIHVuY29uZGl0aW9u
YWxseSB1c2VzIGdjYyBiZWNhdXNlIGV2ZW4gaWYgdGhlIHVzZXIgaXMgdXNpbmcgYW5vdGhlcgoj
IGNvbXBpbGVyLCB3ZSBzdGlsbCBuZWVkIHRvIGZpbmQgdGhlIG1hdGggbGlicmFyeSBhbmQgZnJp
ZW5kcywgYW5kIEkgZG9uJ3QKIyBrbm93IGhvdyBvdGhlciBjb21waWxlcnMgd2lsbCBjb3BlIHdp
dGggdGhhdCBzaXR1YXRpb24uCiMgTW9yZXZlciwgaWYgdGhlIHVzZXIgaGFzIHRoZWlyIG93biBn
Y2MgZWFybGllciBpbiAkUEFUSCB0aGFuIHRoZSBzeXN0ZW0gZ2NjLAojIHdlIGRvbid0IHdhbnQg
aXRzIGxpYnJhcmllcy4gU28gd2UgdHJ5IHRvIHByZWZlciB0aGUgc3lzdGVtIGdjYwojIFN0aWxs
LCBhcyBhbiBlc2NhcGUgaGF0Y2gsIGFsbG93IENvbmZpZ3VyZSBjb21tYW5kIGxpbmUgb3ZlcnJp
ZGVzIHRvCiMgcGxpYnB0aCB0byBieXBhc3MgdGhpcyBjaGVjay4KaWYgWyAteCAvdXNyL2Jpbi9n
Y2MgXSA7IHRoZW4KICAgIGdjYz0vdXNyL2Jpbi9nY2MKZWxzZQogICAgZ2NjPWdjYwpmaQoKY2Fz
ZSAiJHBsaWJwdGgiIGluCicnKSBwbGlicHRoPWBMQU5HPUMgTENfQUxMPUMgJGdjYyAtcHJpbnQt
c2VhcmNoLWRpcnMgfCBncmVwIGxpYnJhcmllcyB8CgljdXQgLWYyLSAtZD0gfCB0ciAnOicgJHRy
bmwgfCBncmVwIC12ICdnY2MnIHwgc2VkIC1lICdzOi8kOjonYAogICAgc2V0IFggJHBsaWJwdGgg
IyBDb2xsYXBzZSBhbGwgZW50cmllcyBvbiBvbmUgbGluZQogICAgc2hpZnQKICAgIHBsaWJwdGg9
IiQqIgogICAgOzsKZXNhYwoKIyBBcmUgd2UgdXNpbmcgRUxGPyAgVGhhbmtzIHRvIEtlbm5ldGgg
QWxiYW5vd3NraSA8a2phaGRzQGtqYWhkcy5jb20+CiMgZm9yIHRoaXMgdGVzdC4KY2F0ID50cnku
YyA8PCdFT00nCi8qIFRlc3QgZm9yIHdoZXRoZXIgRUxGIGJpbmFyaWVzIGFyZSBwcm9kdWNlZCAq
LwojaW5jbHVkZSA8ZmNudGwuaD4KI2luY2x1ZGUgPHN0ZGxpYi5oPgojaW5jbHVkZSA8dW5pc3Rk
Lmg+Cm1haW4oKSB7CgljaGFyIGJ1ZmZlcls0XTsKCWludCBpPW9wZW4oImEub3V0IixPX1JET05M
WSk7CglpZihpPT0tMSkKCQlleGl0KDEpOyAvKiBmYWlsICovCglpZihyZWFkKGksJmJ1ZmZlclsw
XSw0KTw0KQoJCWV4aXQoMSk7IC8qIGZhaWwgKi8KCWlmKGJ1ZmZlclswXSAhPSAxMjcgfHwgYnVm
ZmVyWzFdICE9ICdFJyB8fAogICAgICAgICAgIGJ1ZmZlclsyXSAhPSAnTCcgfHwgYnVmZmVyWzNd
ICE9ICdGJykKCQlleGl0KDEpOyAvKiBmYWlsICovCglleGl0KDApOyAvKiBzdWNjZWVkICh5ZXMs
IGl0J3MgRUxGKSAqLwp9CkVPTQppZiAke2NjOi1nY2N9IHRyeS5jID4vZGV2L251bGwgMj4mMSAm
JiAkcnVuIC4vYS5vdXQ7IHRoZW4KICAgIGNhdCA8PCdFT00nID4mNAoKWW91IGFwcGVhciB0byBo
YXZlIEVMRiBzdXBwb3J0LiAgSSdsbCB0cnkgdG8gdXNlIGl0IGZvciBkeW5hbWljIGxvYWRpbmcu
CklmIGR5bmFtaWMgbG9hZGluZyBkb2Vzbid0IHdvcmssIHJlYWQgaGludHMvbGludXguc2ggZm9y
IGZ1cnRoZXIgaW5mb3JtYXRpb24uCkVPTQoKZWxzZQogICAgY2F0IDw8J0VPTScgPiY0CgpZb3Ug
ZG9uJ3QgaGF2ZSBhbiBFTEYgZ2NjLiAgSSB3aWxsIHVzZSBkbGQgaWYgcG9zc2libGUuICBJZiB5
b3UgYXJlCnVzaW5nIGEgdmVyc2lvbiBvZiBETEQgZWFybGllciB0aGFuIDMuMi42LCBvciBkb24n
dCBoYXZlIGl0IGF0IGFsbCwgeW91CnNob3VsZCBwcm9iYWJseSB1cGdyYWRlLiBJZiB5b3UgYXJl
IGZvcmNlZCB0byB1c2UgMy4yLjQsIHlvdSBzaG91bGQKdW5jb21tZW50IGEgY291cGxlIG9mIGxp
bmVzIGluIGhpbnRzL2xpbnV4LnNoIGFuZCByZXN0YXJ0IENvbmZpZ3VyZSBzbwp0aGF0IHNoYXJl
ZCBsaWJyYXJpZXMgd2lsbCBiZSBkaXNhbGxvd2VkLgoKRU9NCiAgICBsZGRsZmxhZ3M9Ii1yICRs
ZGRsZmxhZ3MiCiAgICAjIFRoZXNlIGVtcHR5IHZhbHVlcyBhcmUgc28gdGhhdCBDb25maWd1cmUg
ZG9lc24ndCBwdXQgaW4gdGhlCiAgICAjIExpbnV4IEVMRiB2YWx1ZXMuCiAgICBjY2RsZmxhZ3M9
JyAnCiAgICBjY2NkbGZsYWdzPScgJwogICAgY2NmbGFncz0iLURPVlJfREJMX0RJRz0xNCAkY2Nm
bGFncyIKICAgIHNvPSdzYScKICAgIGRsZXh0PSdvJwogICAgbm1fc29fb3B0PScgJwogICAgIyMg
SWYgeW91IGFyZSB1c2luZyBETEQgMy4yLjQgd2hpY2ggZG9lcyBub3Qgc3VwcG9ydCBzaGFyZWQg
bGlicywKICAgICMjIHVuY29tbWVudCB0aGUgbmV4dCB0d28gbGluZXM6CiAgICAjbGRmbGFncz0i
LXN0YXRpYyIKICAgICNzbz0nbm9uZScKCgkjIEluIGFkZGl0aW9uLCBvbiBzb21lIHN5c3RlbXMg
dGhlcmUgaXMgYSBwcm9ibGVtIHdpdGggcGVybCBhbmQgTkRCTQoJIyB3aGljaCBjYXVzZXMgQW55
REJNIGFuZCBOREJNX0ZpbGUgdG8gbG9jayB1cC4gVGhpcyBpcyBldmlkZW5jZWQKCSMgaW4gdGhl
IHRlc3RzIGFzIEFueURCTSBqdXN0IGZyZWV6aW5nLiAgQXBwYXJlbnRseSwgdGhpcyBvbmx5Cgkj
IGhhcHBlbnMgb24gYS5vdXQgc3lzdGVtcywgc28gd2UgZGlzYWJsZSBOREJNIGZvciBhbGwgYS5v
dXQgbGludXgKCSMgc3lzdGVtcy4gIElmIHNvbWVvbmUgY2FuIHN1Z2dlc3QgYSBtb3JlIHJvYnVz
dCB0ZXN0CgkjICB0aGF0IHdvdWxkIGJlIGFwcHJlY2lhdGVkLgoJIwoJIyBNb3JlIGluZm86Cgkj
IERhdGU6IFdlZCwgNyBGZWIgMTk5NiAwMzoyMTowNCArMDkwMAoJIyBGcm9tOiBKZWZmcmV5IEZy
aWVkbCA8amZyaWVkbEBuZmYubmNsLm9tcm9uLmNvLmpwPgoJIwoJIyBJIHRyaWVkIGNvbXBpbGlu
ZyB3aXRoIERCTSBzdXBwb3J0IGFuZCBzdXJlIGVub3VnaCB0aGluZ3MgbG9ja2VkIHVwCgkjIGp1
c3QgYXMgYWR2ZXJ0aXNlZC4gQ2hlY2tpbmcgaW50byBpdCwgSSBmb3VuZCB0aGF0IHRoZSBsb2Nr
dXAgd2FzCgkjIGR1cmluZyB0aGUgY2FsbCB0byBkYm1fb3Blbi4gTm90ICppbiogZGJtX29wZW4g
LS0gYnV0IGJldHdlZW4gdGhlIGNhbGwKCSMgdG8gYW5kIHRoZSBqdW1wIGludG8uCgkjCgkjIFRv
IG1ha2UgYSBsb25nIHN0b3J5IHNob3J0LCBtYWtpbmcgc3VyZSB0aGF0IHRoZSAqLmEgYW5kICou
c2EgcGFpcnMgb2YKCSMgICAvdXNyL2xpYi9saWJ7bSxkYixnZGJtfS57YSxzYX0KCSMgd2VyZSBw
ZXJmZWN0bHkgaW4gc3luYyB0b29rIGNhcmUgb2YgaXQuCgkjCgkjIFRoaXMgd2lsbCBnZW5lcmF0
ZSBhIGhhcm1sZXNzIFdob2EgVGhlcmUhIG1lc3NhZ2UKCWNhc2UgIiRkX2RibV9vcGVuIiBpbgoJ
JycpCWNhdCA8PCdFT00nID4mNAoKRGlzYWJsaW5nIG5kYm0uICBUaGlzIHdpbGwgZ2VuZXJhdGUg
YSBXaG9hIFRoZXJlIG1lc3NhZ2UgaW4gQ29uZmlndXJlLgpSZWFkIGhpbnRzL2xpbnV4LnNoIGZv
ciBmdXJ0aGVyIGluZm9ybWF0aW9uLgpFT00KCQkjIFlvdSBjYW4gb3ZlcnJpZGUgdGhpcyB3aXRo
IENvbmZpZ3VyZSAtRGRfZGJtX29wZW4KCQlkX2RibV9vcGVuPXVuZGVmCgkJOzsKCWVzYWMKZmkK
CnJtIC1mIHRyeS5jIGEub3V0CgppZiAvYmluL3NoIC1jIGV4aXQ7IHRoZW4KICBlY2hvICcnCiAg
ZWNobyAnWW91IGFwcGVhciB0byBoYXZlIGEgd29ya2luZyBiYXNoLiAgR29vZC4nCmVsc2UKICBj
YXQgPDwgJ0VPTScgPiY0CgoqKioqKioqKioqKioqKioqKioqKioqKiBXYXJuaW5nISAqKioqKioq
KioqKioqKioqKioqKioKSXQgd291bGQgYXBwZWFyIHlvdSBoYXZlIGEgZGVmZWN0aXZlIGJhc2gg
c2hlbGwgaW5zdGFsbGVkLiBUaGlzIGlzIGxpa2VseSB0bwpnaXZlIHlvdSBhIGZhaWx1cmUgb2Yg
b3AvZXhlYyB0ZXN0ICM1IGR1cmluZyB0aGUgdGVzdCBwaGFzZSBvZiB0aGUgYnVpbGQsClVwZ3Jh
ZGluZyB0byBhIHJlY2VudCB2ZXJzaW9uICgxLjE0LjQgb3IgbGF0ZXIpIHNob3VsZCBmaXggdGhl
IHByb2JsZW0uCioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioq
KioqKioqKgpFT00KCmZpCgojIE9uIFNQQVJDbGludXgsCiMgVGhlIGZvbGxvd2luZyBjc2ggY29u
c2lzdGVudGx5IGNvcmVkdW1wZWQgaW4gdGhlIHRlc3QgZGlyZWN0b3J5CiMgIi9ob21lL21pa2Vk
bHIvcGVybDUuMDAzXzk0L3QiLCB0aG91Z2ggbm90IG1vc3Qgb3RoZXIgZGlyZWN0b3JpZXMuCgoj
TmFtZSAgICAgICAgOiBjc2ggICAgICAgICAgICAgICAgICAgIERpc3RyaWJ1dGlvbjogUmVkIEhh
dCBMaW51eCAoUmVtYnJhbmR0KQojVmVyc2lvbiAgICAgOiA1LjIuNiAgICAgICAgICAgICAgICAg
ICAgICAgIFZlbmRvcjogUmVkIEhhdCBTb2Z0d2FyZQojUmVsZWFzZSAgICAgOiAzICAgICAgICAg
ICAgICAgICAgICAgICAgQnVpbGQgRGF0ZTogRnJpIE1heSAyNCAxOTo0MjoxNCAxOTk2CiNJbnN0
YWxsIGRhdGU6IFRodSBKdWwgMTEgMTY6MjA6MTQgMTk5NiBCdWlsZCBIb3N0OiBpdGNoeS5yZWRo
YXQuY29tCiNHcm91cCAgICAgICA6IFNoZWxscyAgICAgICAgICAgICAgICAgICBTb3VyY2UgUlBN
OiBjc2gtNS4yLjYtMy5zcmMucnBtCiNTaXplICAgICAgICA6IDE4NDQxNwojRGVzY3JpcHRpb24g
OiBCU0QgYy1zaGVsbAoKIyBGb3IgdGhpcyByZWFzb24gSSBzdWdnZXN0IHVzaW5nIHRoZSBtdWNo
IGJ1Zy1maXhlZCB0Y3NoIGZvciBnbG9iYmluZwojIHdoZXJlIGF2YWlsYWJsZS4KCiMgTm92ZW1i
ZXIgMjAwMTogIFRoYXQgd2FybmluZydzIHByZXR0eSBvbGQgbm93IGFuZCBwcm9iYWJseSBub3Qg
c28KIyByZWxldmFudCwgZXNwZWNpYWxseSBzaW5jZSBwZXJsIG5vdyB1c2VzIEZpbGU6Okdsb2Ig
Zm9yIGdsb2JiaW5nLgojIFdlJ2xsIHN0aWxsIGxvb2sgZm9yIHRjc2gsIGJ1dCB0b25lIGRvd24g
dGhlIHdhcm5pbmdzLgojIEFuZHkgRG91Z2hlcnR5LCBOb3YuIDYsIDIwMDEKaWYgJGNzaCAtYyAn
ZWNobyAkdmVyc2lvbicgPi9kZXYvbnVsbCAyPiYxOyB0aGVuCiAgICBlY2hvICdZb3VyIGNzaCBp
cyByZWFsbHkgdGNzaC4gIEdvb2QuJwplbHNlCiAgICBpZiB4eHg9YC4vVVUvbG9jIHRjc2ggYmx1
cmZsICRwdGhgOyAkdGVzdCAtZiAiJHh4eCI7IHRoZW4KCWVjaG8gIkZvdW5kIHRjc2guICBJJ2xs
IHVzZSBpdCBmb3IgZ2xvYmJpbmcuIgoJIyBXZSBjYW4ndCBjaGFuZ2UgQ29uZmlndXJlJ3Mgc2V0
dGluZyBvZiAkY3NoLCBkdWUgdG8gdGhlIHdheQoJIyBDb25maWd1cmUgaGFuZGxlcyAkZF9wb3J0
YWJsZSBhbmQgY29tbWFuZHMgZm91bmQgaW4gJGxvY2xpc3QuCgkjIFdlIGNhbiBzZXQgdGhlIHZh
bHVlIGZvciBDU0ggaW4gY29uZmlnLmggYnkgc2V0dGluZyBmdWxsX2NzaC4KCWZ1bGxfY3NoPSR4
eHgKICAgIGVsaWYgWyAtZiAiJGNzaCIgXTsgdGhlbgoJZWNobyAiQ291bGRuJ3QgZmluZCB0Y3No
LiAgQ3NoLWJhc2VkIGdsb2JiaW5nIG1pZ2h0IGJlIGJyb2tlbi4iCiAgICBmaQpmaQoKIyBTaGlt
cGVpIFlhbWFzaGl0YSA8c2hpbXBlaUBzb2NyYXRlcy5wYXRuZXQuY2FsdGVjaC5lZHU+CiMgTWVz
c2FnZS1JZDogPDMzRUYxNjM0LkIzNkI2NTAwQHBvYm94LmNvbT4KIwojIFRoZSBEUjIgb2YgTWtM
aW51eCAob3NuYW1lPWxpbnV4LGFyY2huYW1lPXBwYy1saW51eCkgbWF5IG5lZWQKIyBzcGVjaWFs
IGZsYWdzIHBhc3NlZCBpbiBvcmRlciBmb3IgZHluYW1pYyBsb2FkaW5nIHRvIHdvcmsuCiMgaW5z
dGVhZCBvZiB0aGUgcmVjb21tZW5kZWQ6CiMKIyBjY2RsZmxhZ3M9Jy1yZHluYW1pYycKIwojIGl0
IHNob3VsZCBiZToKIyBjY2RsZmxhZ3M9Jy1XbCwtRScKIwojIFNvIGlmIHlvdXIgRFIyIChEUjMg
Y2FtZSBvdXQgc3VtbWVyIDE5OTgsIGNvbnNpZGVyIHVwZ3JhZGluZykKIyBoYXMgcHJvYmxlbXMg
d2l0aCBkeW5hbWljIGxvYWRpbmcsIHVuY29tbWVudCB0aGUKIyBmb2xsb3dpbmcgdGhyZWUgbGlu
ZXMsIG1ha2UgZGlzdGNsZWFuLCBhbmQgcmUtQ29uZmlndXJlOgojY2FzZSAiYHVuYW1lIC1yIHwg
c2VkICdzL15bMC05Li1dKi8vJ2BgYXJjaGAiIGluCiMnb3NmbWFjaDNwcGMnKSBjY2RsZmxhZ3M9
Jy1XbCwtRScgOzsKI2VzYWMKCmNhc2UgImB1bmFtZSAtbWAiIGluCnNwYXJjKikKCWNhc2UgIiRj
Y2NkbGZsYWdzIiBpbgoJKi1mcGljKikgY2NjZGxmbGFncz0iYGVjaG8gJGNjY2RsZmxhZ3N8c2Vk
ICdzLy1mcGljLy1mUElDLydgIiA7OwoJKi1mUElDKikgOzsKCSopCSBjY2NkbGZsYWdzPSIkY2Nj
ZGxmbGFncyAtZlBJQyIgOzsKCWVzYWMKCTs7CmVzYWMKCiMgU3VTRTguMiBoYXMgL3Vzci9saWIv
bGlibmRibSogd2hpY2ggYXJlIGxkIHNjcmlwdHMgcmF0aGVyIHRoYW4KIyB0cnVlIGxpYnJhcmll
cy4gVGhlIHNjcmlwdHMgY2F1c2UgYmluZGluZyBhZ2FpbnN0IHN0YXRpYwojIHZlcnNpb24gb2Yg
LWxnZGJtIHdoaWNoIGlzIGEgYmFkIGlkZWEuIFNvIGlmIHdlIGhhdmUgJ25tJwojIG1ha2Ugc3Vy
ZSBpdCBjYW4gcmVhZCB0aGUgZmlsZQojIE5JLVMgMjAwMy8wOC8wNwppZiBbIC1yIC91c3IvbGli
L2xpYm5kYm0uc28gIC1hICAteCAvdXNyL2Jpbi9ubSBdIDsgdGhlbgogICBpZiAvdXNyL2Jpbi9u
bSAvdXNyL2xpYi9saWJuZGJtLnNvID4vZGV2L251bGwgMj4mMSA7IHRoZW4KICAgIGVjaG8gJ1lv
dXIgc2hhcmVkIC1sbmRibSBzZWVtcyB0byBiZSBhIHJlYWwgbGlicmFyeS4nCiAgIGVsc2UKICAg
IGVjaG8gJ1lvdXIgc2hhcmVkIC1sbmRibSBpcyBub3QgYSByZWFsIGxpYnJhcnkuJwogICAgc2V0
IGBlY2hvIFggIiRsaWJzd2FudGVkICJ8IHNlZCAtZSAncy8gbmRibSAvIC8nYAogICAgc2hpZnQK
ICAgIGxpYnN3YW50ZWQ9IiQqIgogICBmaQpmaQoKCiMgVGhpcyBzY3JpcHQgVVUvdXNldGhyZWFk
cy5jYnUgd2lsbCBnZXQgJ2NhbGxlZC1iYWNrJyBieSBDb25maWd1cmUKIyBhZnRlciBpdCBoYXMg
cHJvbXB0ZWQgdGhlIHVzZXIgZm9yIHdoZXRoZXIgdG8gdXNlIHRocmVhZHMuCmNhdCA+IFVVL3Vz
ZXRocmVhZHMuY2J1IDw8J0VPQ0JVJwpjYXNlICIkdXNldGhyZWFkcyIgaW4KJGRlZmluZXx0cnVl
fFt5WV0qKQogICAgICAgIGNjZmxhZ3M9Ii1EX1JFRU5UUkFOVCAtRF9HTlVfU09VUkNFICRjY2Zs
YWdzIgogICAgICAgIGlmIGVjaG8gJGxpYnN3YW50ZWQgfCBncmVwIC12IHB0aHJlYWQgPi9kZXYv
bnVsbAogICAgICAgIHRoZW4KICAgICAgICAgICAgc2V0IGBlY2hvIFggIiRsaWJzd2FudGVkICJ8
IHNlZCAtZSAncy8gYyAvIHB0aHJlYWQgYyAvJ2AKICAgICAgICAgICAgc2hpZnQKICAgICAgICAg
ICAgbGlic3dhbnRlZD0iJCoiCiAgICAgICAgZmkKCgkjIFNvbWVob3cgYXQgbGVhc3QgaW4gRGVi
aWFuIDIuMiB0aGVzZSBtYW5hZ2UgdG8gZXNjYXBlCgkjIHRoZSAjZGVmaW5lIGZvcmVzdCBvZiA8
ZmVhdHVyZXMuaD4gYW5kIDx0aW1lLmg+IHNvIHRoYXQKCSMgdGhlIGhhc3Byb3RvIG1hY3JvIG9m
IENvbmZpZ3VyZSBkb2Vzbid0IHNlZSB0aGVzZSBwcm90b3MsCgkjIGV2ZW4gd2l0aCB0aGUgLURf
R05VX1NPVVJDRS4KCglkX2FzY3RpbWVfcl9wcm90bz0iJGRlZmluZSIKCWRfY3J5cHRfcl9wcm90
bz0iJGRlZmluZSIKCWRfY3RpbWVfcl9wcm90bz0iJGRlZmluZSIKCWRfZ210aW1lX3JfcHJvdG89
IiRkZWZpbmUiCglkX2xvY2FsdGltZV9yX3Byb3RvPSIkZGVmaW5lIgoJZF9yYW5kb21fcl9wcm90
bz0iJGRlZmluZSIKCgk7Owplc2FjCkVPQ0JVCgpjYXQgPiBVVS91c2VsYXJnZWZpbGVzLmNidSA8
PCdFT0NCVScKIyBUaGlzIHNjcmlwdCBVVS91c2VsYXJnZWZpbGVzLmNidSB3aWxsIGdldCAnY2Fs
bGVkLWJhY2snIGJ5IENvbmZpZ3VyZQojIGFmdGVyIGl0IGhhcyBwcm9tcHRlZCB0aGUgdXNlciBm
b3Igd2hldGhlciB0byB1c2UgbGFyZ2UgZmlsZXMuCmNhc2UgIiR1c2VsYXJnZWZpbGVzIiBpbgon
J3wkZGVmaW5lfHRydWV8W3lZXSopCiMgS2VlcCB0aGlzIGluIHRoZSBsZWZ0IG1hcmdpbi4KY2Nm
bGFnc191c2VsYXJnZWZpbGVzPSItRF9MQVJHRUZJTEVfU09VUkNFIC1EX0ZJTEVfT0ZGU0VUX0JJ
VFM9NjQiCgoJY2NmbGFncz0iJGNjZmxhZ3MgJGNjZmxhZ3NfdXNlbGFyZ2VmaWxlcyIKCTs7CmVz
YWMKRU9DQlUKCiMgUHVyaWZ5IGZhaWxzIHRvIGxpbmsgUGVybCBpZiBhICItbGMiIGlzIHBhc3Nl
ZCBpbnRvIGl0cyBsaW5rZXIKIyBkdWUgdG8gZHVwbGljYXRlIHN5bWJvbHMuCmNhc2UgIiRQVVJJ
RlkiIGluCiRkZWZpbmV8dHJ1ZXxbeVldKikKICAgIHNldCBgZWNobyBYICIkbGlic3dhbnRlZCAi
fCBzZWQgLWUgJ3MvIGMgLyAvJ2AKICAgIHNoaWZ0CiAgICBsaWJzd2FudGVkPSIkKiIKICAgIDs7
CmVzYWMKCiMgSWYgdXNpbmcgZysrLCB0aGUgQ29uZmlndXJlIHNjYW4gZm9yIGRsb3BlbigpIGFu
ZCAoZXNwZWNpYWxseSkKIyBkbGVycm9yKCkgbWlnaHQgZmFpbCwgZWFzaWVyIGp1c3QgdG8gZm9y
Y2libHkgaGludCB0aGVtIGluLgpjYXNlICIkY2MiIGluCipnKysqKQogIGRfZGxvcGVuPSdkZWZp
bmUnCiAgZF9kbGVycm9yPSdkZWZpbmUnCiAgOzsKZXNhYwoKIyBVbmRlciBzb21lIGNpcmN1bXN0
YW5jZXMgbGliZGIgY2FuIGdldCBidWlsdCBpbiBzdWNoIGEgd2F5IGFzIHRvCiMgbmVlZCBwdGhy
ZWFkIGV4cGxpY2l0bHkgbGlua2VkLgoKbGliZGJfbmVlZHNfcHRocmVhZD0iTiIKCmlmIGVjaG8g
IiAkbGlic3dhbnRlZCAiIHwgZ3JlcCAtdiAiIHB0aHJlYWQgIiA+L2Rldi9udWxsCnRoZW4KICAg
aWYgZWNobyAiICRsaWJzd2FudGVkICIgfCBncmVwICIgZGIgIiA+L2Rldi9udWxsCiAgIHRoZW4K
ICAgICBmb3IgREJESVIgaW4gJGdsaWJwdGgKICAgICBkbwogICAgICAgREJMSUI9IiREQkRJUi9s
aWJkYi5zbyIKICAgICAgIGlmIFsgLWYgJERCTElCIF0KICAgICAgIHRoZW4KICAgICAgICAgaWYg
bm0gLXUgJERCTElCIHwgZ3JlcCBwdGhyZWFkID4vZGV2L251bGwKICAgICAgICAgdGhlbgogICAg
ICAgICAgIGlmIGxkZCAkREJMSUIgfCBncmVwIHB0aHJlYWQgPi9kZXYvbnVsbAogICAgICAgICAg
IHRoZW4KICAgICAgICAgICAgIGxpYmRiX25lZWRzX3B0aHJlYWQ9Ik4iCiAgICAgICAgICAgZWxz
ZQogICAgICAgICAgICAgbGliZGJfbmVlZHNfcHRocmVhZD0iWSIKICAgICAgICAgICBmaQogICAg
ICAgICBmaQogICAgICAgZmkKICAgICBkb25lCiAgIGZpCmZpCgpjYXNlICIkbGliZGJfbmVlZHNf
cHRocmVhZCIgaW4KICAiWSIpCiAgICBsaWJzd2FudGVkPSIkbGlic3dhbnRlZCBwdGhyZWFkIgog
ICAgOzsKZXNhYwo=',
'freebsd' =>
'IyBPcmlnaW5hbCBiYXNlZCBvbiBpbmZvIGZyb20KIyBDYXJsIE0uIEZvbmdoZWlzZXIgPGNtZkBp
bnMuaW5mb25ldC5uZXQ+CiMgRGF0ZTogVGh1LCAyOCBKdWwgMTk5NCAxOToxNzowNSAtMDUwMCAo
Q0RUKQojCiMgQWRkaXRpb25hbCAxLjEuNSBkZWZpbmVzIGZyb20gCiMgT2xsaXZpZXIgUm9iZXJ0
IDxPbGxpdmllci5Sb2JlcnRAa2VsdGlhLmZybXVnLmZyLm5ldD4KIyBEYXRlOiBXZWQsIDI4IFNl
cCAxOTk0IDAwOjM3OjQ2ICswMTAwIChNRVQpCiMKIyBBZGRpdGlvbmFsIDIuKiBkZWZpbmVzIGZy
b20KIyBPbGxpdmllciBSb2JlcnQgPE9sbGl2aWVyLlJvYmVydEBrZWx0aWEuZnJtdWcuZnIubmV0
PgojIERhdGU6IFNhdCwgOCBBcHIgMTk5NSAyMDo1Mzo0MSArMDIwMCAoTUVUIERTVCkKIwojIEFk
ZGl0aW9uYWwgMi4wLjUgYW5kIDIuMSBkZWZpbmVkIGZyb20KIyBPbGxpdmllciBSb2JlcnQgPE9s
bGl2aWVyLlJvYmVydEBrZWx0aWEuZnJtdWcuZnIubmV0PgojIERhdGU6IEZyaSwgMTIgTWF5IDE5
OTUgMTQ6MzA6MzggKzAyMDAgKE1FVCBEU1QpCiMKIyBBZGRpdGlvbmFsIDIuMiBkZWZpbmVzIGZy
b20KIyBNYXJrIE11cnJheSA8bWFya0Bncm9uZGFyLnphPgojIERhdGU6IFdlZCwgNiBOb3YgMTk5
NiAwOTo0NDo1OCArMDIwMCAoTUVUKQojCiMgTW9kaWZpZWQgdG8gZW5zdXJlIHdlIHJlcGxhY2Ug
LWxjIHdpdGggLWxjX3IsIGFuZAojIHRvIHB1dCBpbiBwbGFjZS1ob2xkZXJzIGZvciB2YXJpb3Vz
IHNwZWNpZmljIGhpbnRzLgojIEFuZHkgRG91Z2hlcnR5IDxkb3VnaGVyYUBsYWZheWV0dGUuZWR1
PgojIERhdGU6IFR1ZSBNYXIgMTAgMTY6MDc6MDAgRVNUIDE5OTgKIwojIFN1cHBvcnQgZm9yIEZy
ZWVCU0QvRUxGCiMgT2xsaXZpZXIgUm9iZXJ0IDxyb2JlcnRvQGtlbHRpYS5mcmVlbml4LmZyPgoj
IERhdGU6IFdlZCBTZXAgIDIgMTY6MjI6MTIgQ0VTVCAxOTk4CiMKIyBUaGUgdHdvIGZsYWdzICIt
ZnBpYyAtRFBJQyIgYXJlIHVzZWQgdG8gaW5kaWNhdGUgYQojIHdpbGwtYmUtc2hhcmVkIG9iamVj
dC4gIENvbmZpZ3VyZSB3aWxsIGd1ZXNzIHRoZSAtZnBpYywgKGFuZCB0aGUKIyAtRFBJQyBpcyBu
b3QgdXNlZCBieSBwZXJsIHByb3BlcikgYnV0IHRoZSBmdWxsIGRlZmluZSBpcyBpbmNsdWRlZCB0
byAKIyBiZSBjb25zaXN0ZW50IHdpdGggdGhlIEZyZWVCU0QgZ2VuZXJhbCBzaGFyZWQgbGlicyBi
dWlsZGluZyBwcm9jZXNzLgojCiMgc2V0cmV1aWQgYW5kIGZyaWVuZHMgYXJlIGluaGVyZW50bHkg
YnJva2VuIGluIGFsbCB2ZXJzaW9ucyBvZiBGcmVlQlNECiMgYmVmb3JlIDIuMS1jdXJyZW50IChi
ZWZvcmUgYXBwcm94IGRhdGUgNC8xNS85NSkuIEl0IGlzIGZpeGVkIGluIDIuMC41CiMgYW5kIHdo
YXQtd2lsbC1iZS0yLjEKIwoKY2FzZSAiJG9zdmVycyIgaW4KMC4qfDEuMCopCgl1c2VkbD0iJHVu
ZGVmIgoJOzsKMS4xKikKCW1hbGxvY3R5cGU9J3ZvaWQgKicKCWdyb3Vwc3R5cGU9J2ludCcKCWRf
c2V0cmVnaWQ9J3VuZGVmJwoJZF9zZXRyZXVpZD0ndW5kZWYnCglkX3NldHJnaWQ9J3VuZGVmJwoJ
ZF9zZXRydWlkPSd1bmRlZicKCTs7CjIuMC1yZWxlYXNlKikKCWRfc2V0cmVnaWQ9J3VuZGVmJwoJ
ZF9zZXRyZXVpZD0ndW5kZWYnCglkX3NldHJnaWQ9J3VuZGVmJwoJZF9zZXRydWlkPSd1bmRlZicK
CTs7CiMKIyBUcnlpbmcgdG8gY292ZXIgMi4wLjUsIDIuMS1jdXJyZW50IGFuZCBmdXR1cmUgMi4x
LzIuMgojIEl0IGRvZXMgbm90IGNvdmVydCBhbGwgMi4xLWN1cnJlbnQgdmVyc2lvbnMgYXMgdGhl
IG91dHB1dCBvZiB1bmFtZQojIGNoYW5nZWQgYSBmZXcgdGltZXMuCiMKIyBFdmVuIHRob3VnaCBz
ZXRldWlkL3NldGVnaWQgYXJlIGF2YWlsYWJsZSwgdGhleSd2ZSBiZWVuIHR1cm5lZCBvZmYKIyBi
ZWNhdXNlIHBlcmwgaXNuJ3QgY29kZWQgd2l0aCBzYXZlZCBzZXRbdWddaWQgdmFyaWFibGVzIGlu
IG1pbmQuCiMgSW4gYWRkaXRpb24sIGEgc21hbGwgcGF0Y2ggaXMgcmVxdWlyZWQgdG8gc3VpZHBl
cmwgdG8gYXZvaWQgYSBzZWN1cml0eQojIHByb2JsZW0gd2l0aCBGcmVlQlNELgojCjIuMC41Knwy
LjAtYnVpbHQqfDIuMSopCiAJdXNldmZvcms9J3RydWUnCgljYXNlICIkdXNlbXltYWxsb2MiIGlu
CgkgICAgIiIpIHVzZW15bWFsbG9jPSduJwoJICAgICAgICA7OwoJZXNhYwoJZF9zZXRyZWdpZD0n
ZGVmaW5lJwoJZF9zZXRyZXVpZD0nZGVmaW5lJwoJZF9zZXRlZ2lkPSd1bmRlZicKCWRfc2V0ZXVp
ZD0ndW5kZWYnCgl0ZXN0IC1yIC4vYnJva2VuLWRiLm1zZyAmJiAuIC4vYnJva2VuLWRiLm1zZwoJ
OzsKIwojIDIuMiBhbmQgYWJvdmUgaGF2ZSBwaGttYWxsb2MoMykuCiMgZG9uJ3QgdXNlIC1sbWFs
bG9jIChtYXliZSB0aGVyZSdzIGFuIG9sZCBvbmUgZnJvbSAxLjEuNS4xIGZsb2F0aW5nIGFyb3Vu
ZCkKMi4yKikKIAl1c2V2Zm9yaz0ndHJ1ZScKCWNhc2UgIiR1c2VteW1hbGxvYyIgaW4KCSAgICAi
IikgdXNlbXltYWxsb2M9J24nCgkgICAgICAgIDs7Cgllc2FjCglsaWJzd2FudGVkPWBlY2hvICRs
aWJzd2FudGVkIHwgc2VkICdzLyBtYWxsb2MgLyAvJ2AKCWxpYnN3YW50ZWQ9YGVjaG8gJGxpYnN3
YW50ZWQgfCBzZWQgJ3MvIGJpbmQgLyAvJ2AKCSMgaWNvbnYgZ29uZSBpbiBQZXJsIDUuOC4xLCBi
dXQgaWYgc29tZW9uZSBjb21waWxlcyA1LjguMCBvciBlYXJsaWVyLgoJbGlic3dhbnRlZD1gZWNo
byAkbGlic3dhbnRlZCB8IHNlZCAncy8gaWNvbnYgLyAvJ2AKCWRfc2V0cmVnaWQ9J2RlZmluZScK
CWRfc2V0cmV1aWQ9J2RlZmluZScKCWRfc2V0ZWdpZD0nZGVmaW5lJwoJZF9zZXRldWlkPSdkZWZp
bmUnCgkjIGRfZG9zdWlkPSdkZWZpbmUnICMgT2Jzb2xldGUuCgk7OwoqKQl1c2V2Zm9yaz0ndHJ1
ZScKCWNhc2UgIiR1c2VteW1hbGxvYyIgaW4KCSAgICAiIikgdXNlbXltYWxsb2M9J24nCgkgICAg
ICAgIDs7Cgllc2FjCglsaWJzd2FudGVkPWBlY2hvICRsaWJzd2FudGVkIHwgc2VkICdzLyBtYWxs
b2MgLyAvJ2AKCTs7CmVzYWMKCiMgRHluYW1pYyBMb2FkaW5nIGZsYWdzIGhhdmUgbm90IGNoYW5n
ZWQgbXVjaCwgc28gdGhleSBhcmUgc2VwYXJhdGVkCiMgb3V0IGhlcmUgdG8gYXZvaWQgZHVwbGlj
YXRpbmcgdGhlbSBldmVyeXdoZXJlLgpjYXNlICIkb3N2ZXJzIiBpbgowLip8MS4wKikgOzsKCjEu
KnwyLiopCgljY2NkbGZsYWdzPSctRFBJQyAtZnBpYycKCWxkZGxmbGFncz0iLUJzaGFyZWFibGUg
JGxkZGxmbGFncyIKCTs7CgozKnw0Knw1Knw2KikKICAgICAgICBvYmpmb3JtYXQ9YC91c3IvYmlu
L29iamZvcm1hdGAKICAgICAgICBpZiBbIHgkb2JqZm9ybWF0ID0geGFvdXQgXTsgdGhlbgogICAg
ICAgICAgICBpZiBbIC1lIC91c3IvbGliL2FvdXQgXTsgdGhlbgogICAgICAgICAgICAgICAgbGli
cHRoPSIvdXNyL2xpYi9hb3V0IC91c3IvbG9jYWwvbGliIC91c3IvbGliIgogICAgICAgICAgICAg
ICAgZ2xpYnB0aD0iL3Vzci9saWIvYW91dCAvdXNyL2xvY2FsL2xpYiAvdXNyL2xpYiIKICAgICAg
ICAgICAgZmkKICAgICAgICAgICAgbGRkbGZsYWdzPSctQnNoYXJlYWJsZScKICAgICAgICBlbHNl
CiAgICAgICAgICAgIGxpYnB0aD0iL3Vzci9saWIgL3Vzci9sb2NhbC9saWIiCiAgICAgICAgICAg
IGdsaWJwdGg9Ii91c3IvbGliIC91c3IvbG9jYWwvbGliIgogICAgICAgICAgICBsZGZsYWdzPSIt
V2wsLUUgIgogICAgICAgICAgICBsZGRsZmxhZ3M9Ii1zaGFyZWQgIgogICAgICAgIGZpCiAgICAg
ICAgY2NjZGxmbGFncz0nLURQSUMgLWZQSUMnCiAgICAgICAgOzsKKikKICAgICAgIGxpYnB0aD0i
L3Vzci9saWIgL3Vzci9sb2NhbC9saWIiCiAgICAgICBnbGlicHRoPSIvdXNyL2xpYiAvdXNyL2xv
Y2FsL2xpYiIKICAgICAgIGxkZmxhZ3M9Ii1XbCwtRSAiCiAgICAgICAgbGRkbGZsYWdzPSItc2hh
cmVkICIKICAgICAgICBjY2NkbGZsYWdzPSctRFBJQyAtZlBJQycKICAgICAgIDs7CmVzYWMKCmNh
c2UgIiRvc3ZlcnMiIGluCjAuKnwxLip8Mi4qfDMuKikgOzsKCiopCgljY2ZsYWdzPSIke2NjZmxh
Z3N9IC1ESEFTX0ZQU0VUTUFTSyAtREhBU19GTE9BVElOR1BPSU5UX0giCglpZiAvdXNyL2Jpbi9m
aWxlIC1MIC91c3IvbGliL2xpYmMuc28gfCAvdXNyL2Jpbi9ncmVwIC12cSAibm90IHN0cmlwcGVk
IiA7IHRoZW4KCSAgICB1c2VubT1mYWxzZQoJZmkKICAgICAgICA7Owplc2FjCgpjYXQgPDwnRU9N
JyA+JjQKClNvbWUgdXNlcnMgaGF2ZSByZXBvcnRlZCB0aGF0IENvbmZpZ3VyZSBoYWx0cyB3aGVu
IHRlc3RpbmcgZm9yCnRoZSBPX05PTkJMT0NLIHN5bWJvbCB3aXRoIGEgc3ludGF4IGVycm9yLiAg
VGhpcyBpcyBhcHBhcmVudGx5IGEKc2ggZXJyb3IuICBSZXJ1bm5pbmcgQ29uZmlndXJlIHdpdGgg
a3NoIGFwcGFyZW50bHkgZml4ZXMgdGhlCnByb2JsZW0uICBUcnkKCWtzaCBDb25maWd1cmUgW3lv
dXIgb3B0aW9uc10KCkVPTQoKIyBGcm9tOiBBbnRvbiBCZXJlemluIDx0b2JlekBwbGFiLmt1LmRr
PgojIFRvOiBwZXJsNS1wb3J0ZXJzQHBlcmwub3JnCiMgU3ViamVjdDogW1BBVENIIDUuMDA1XzU0
XSBDb25maWd1cmUgLSBoaW50cy9mcmVlYnNkLnNoIHNpZ25hbCBoYW5kbGVyIHR5cGUKIyBEYXRl
OiAzMCBOb3YgMTk5OCAxOTo0NjoyNCArMDEwMAojIE1lc3NhZ2UtSUQ6IDw4NjRzcmhodmN2LmZz
ZkBsaW9uLnBsYWIua3UuZGs+CgpzaWduYWxfdD0ndm9pZCcKZF92b2lkc2lnPSdkZWZpbmUnCgoj
IHNldCBsaWJwZXJsLnNvLlguWCBmb3IgMi4yLlgKY2FzZSAiJG9zdmVycyIgaW4KMi4yKikKICAg
ICMgdW5mb3J0dW5hdGVseSB0aGlzIGNvZGUgZ2V0cyBleGVjdXRlZCBiZWZvcmUKICAgICMgdGhl
IGVxdWl2YWxlbnQgaW4gdGhlIG1haW4gQ29uZmlndXJlIHNvIHdlIGNvcHkgYSBsaXR0bGUKICAg
ICMgZnJvbSBDb25maWd1cmUgWFhYIENvbmZpZ3VyZSBzaG91bGQgYmUgZml4ZWQuCiAgICBpZiAk
dGVzdCAtciAkc3JjL3BhdGNobGV2ZWwuaDt0aGVuCiAgICAgICBwYXRjaGxldmVsPWBhd2sgJy9k
ZWZpbmVbIAldK1BFUkxfVkVSU0lPTi8ge3ByaW50ICQzfScgJHNyYy9wYXRjaGxldmVsLmhgCiAg
ICAgICBzdWJ2ZXJzaW9uPWBhd2sgJy9kZWZpbmVbIAldK1BFUkxfU1VCVkVSU0lPTi8ge3ByaW50
ICQzfScgJHNyYy9wYXRjaGxldmVsLmhgCiAgICBlbHNlCiAgICAgICBwYXRjaGxldmVsPTAKICAg
ICAgIHN1YnZlcnNpb249MAogICAgZmkKICAgIGxpYnBlcmw9ImxpYnBlcmwuc28uJHBhdGNobGV2
ZWwuJHN1YnZlcnNpb24iCiAgICB1bnNldCBwYXRjaGxldmVsCiAgICB1bnNldCBzdWJ2ZXJzaW9u
CiAgICA7Owplc2FjCgojIFRoaXMgc2NyaXB0IFVVL3VzZXRocmVhZHMuY2J1IHdpbGwgZ2V0ICdj
YWxsZWQtYmFjaycgYnkgQ29uZmlndXJlIAojIGFmdGVyIGl0IGhhcyBwcm9tcHRlZCB0aGUgdXNl
ciBmb3Igd2hldGhlciB0byB1c2UgdGhyZWFkcy4KY2F0ID4gVVUvdXNldGhyZWFkcy5jYnUgPDwn
RU9DQlUnCmNhc2UgIiR1c2V0aHJlYWRzIiBpbgokZGVmaW5lfHRydWV8W3lZXSopCiAgICAgICAg
bGNfcj1gL3NiaW4vbGRjb25maWcgLXJ8Z3JlcCAnOi1sY19yJ3xhd2sgJ3twcmludCAkTkZ9J3xz
ZWQgLW4gJyRwJ2AKICAgICAgICBjYXNlICIkb3N2ZXJzIiBpbiAgCgkwLip8MS4qfDIuMCp8Mi4x
KikgICBjYXQgPDxFT00gPiY0CkkgZGlkIG5vdCBrbm93IHRoYXQgRnJlZUJTRCAkb3N2ZXJzIHN1
cHBvcnRzIFBPU0lYIHRocmVhZHMuCgpGZWVsIGZyZWUgdG8gdGVsbCBwZXJsYnVnQHBlcmwub3Jn
IG90aGVyd2lzZS4KRU9NCgkgICAgICBleGl0IDEKCSAgICAgIDs7CgogICAgICAgIDIuMi5bMC03
XSopCiAgICAgICAgICAgICAgY2F0IDw8RU9NID4mNApQT1NJWCB0aHJlYWRzIGFyZSBub3Qgc3Vw
cG9ydGVkIHdlbGwgYnkgRnJlZUJTRCAkb3N2ZXJzLgoKUGxlYXNlIGNvbnNpZGVyIHVwZ3JhZGlu
ZyB0byBhdCBsZWFzdCBGcmVlQlNEIDIuMi44LApvciBwcmVmZXJhYmx5IHRvIHRoZSBtb3N0IHJl
Y2VudCAtUkVMRUFTRSBvciAtU1RBQkxFCnZlcnNpb24gKHNlZSBodHRwOi8vd3d3LmZyZWVic2Qu
b3JnL3JlbGVhc2VzLykuCgooV2hpbGUgMi4yLjcgZG9lcyBoYXZlIHB0aHJlYWRzLCBpdCBoYXMg
c29tZSBwcm9ibGVtcwogd2l0aCB0aGUgY29tYmluYXRpb24gb2YgdGhyZWFkcyBhbmQgcGlwZXMg
YW5kIHRoZXJlZm9yZQogbWFueSBQZXJsIHRlc3RzIHdpbGwgZWl0aGVyIGhhbmcgb3IgZmFpbC4p
CkVPTQoJICAgICAgZXhpdCAxCgkgICAgICA7OwoKCVszLTVdLiopCgkgICAgICBpZiBbICEgLXIg
IiRsY19yIiBdOyB0aGVuCgkgICAgICBjYXQgPDxFT00gPiY0ClBPU0lYIHRocmVhZHMgc2hvdWxk
IGJlIHN1cHBvcnRlZCBieSBGcmVlQlNEICRvc3ZlcnMgLS0KYnV0IHlvdXIgc3lzdGVtIGlzIG1p
c3NpbmcgdGhlIHNoYXJlZCBsaWJjX3IuCigvc2Jpbi9sZGNvbmZpZyAtciBkb2Vzbid0IGZpbmQg
YW55KS4KCkNvbnNpZGVyIHVzaW5nIHRoZSBsYXRlc3QgU1RBQkxFIHJlbGVhc2UuCkVPTQoJCSBl
eGl0IDEKCSAgICAgIGZpCgkgICAgICAjIDUwMDAxNiBpcyB0aGUgZmlyc3Qgb3NyZWxkYXRlIGlu
IHdoaWNoIG9uZSBjb3VsZAoJICAgICAgIyBqdXN0IGxpbmsgYWdhaW5zdCBsaWJjX3Igd2l0aG91
dCBkaXNwb3Npbmcgb2YgbGliYwoJICAgICAgIyBhdCB0aGUgc2FtZSB0aW1lLiAgNTAwMDE2IC4u
LiB1cCB0byB3aGF0ZXZlciBpdCB3YXMKCSAgICAgICMgb24gdGhlIDMxc3Qgb2YgQXVndXN0IDIw
MDMgY2FuIHN0aWxsIGJlIHVzZWQgd2l0aCAtcHRocmVhZCwKCSAgICAgICMgYnV0IGl0IGlzIG5v
dCBuZWNlc3NhcnkuCgoJICAgICAgIyBBbnRvbiBCZXJlemluIHNheXMgdGhhdCBwb3N0IDUwMHNv
bWV0aGluZyB3ZSdyZSB3cm9uZyB0byBiZQoJICAgICAgIyB0byBiZSB1c2luZyAtbGNfciwgYW5k
IHNob3VsZCBqdXN0IGJlIHVzaW5nIC1wdGhyZWFkIG9uIHRoZQoJICAgICAgIyBsaW5rZXIgbGlu
ZS4KCSAgICAgICMgU28gcHJlc3VtYWJseSByZWFsbHkgd2Ugc2hvdWxkIGJlIGNoZWNraW5nIHRo
YXQgJG9zdmVyIGlzIDUuKikKCSAgICAgICMgYW5kIHRoYXQgYC9zYmluL3N5c2N0bCAtbiBrZXJu
Lm9zcmVsZGF0ZWAgLWdlIDUwMDAxNgoJICAgICAgIyBvciAtbHQgNTAwc29tZXRoaW5nIGFuZCBv
bmx5IGluIHRoYXQgcmFuZ2Ugbm90IGRvaW5nIHRoaXM6CgkgICAgICBsZGZsYWdzPSItcHRocmVh
ZCAkbGRmbGFncyIKCgkgICAgICAjIEJvdGggaW4gNC54IGFuZCA1LnggZ2V0aG9zdGJ5YWRkcl9y
IGV4aXN0cyBidXQKCSAgICAgICMgaXQgaXMgIlRlbXBvcmFyeSBmdW5jdGlvbiwgbm90IHRocmVh
ZHNhZmUiLi4uCgkgICAgICAjIFByZXN1bWFibHkgZWFybGllciBpdCBkaWRuJ3QgZXZlbiBleGlz
dC4KCSAgICAgIGRfZ2V0aG9zdGJ5YWRkcl9yPSJ1bmRlZiIKCSAgICAgIGRfZ2V0aG9zdGJ5YWRk
cl9yX3Byb3RvPSIwIgoJICAgICAgOzsKCgkqKQoJICAgICAgIyA3LnggZG9lc24ndCBpbnN0YWxs
IGxpYmNfciBieSBkZWZhdWx0LCBhbmQgQ29uZmlndXJlCgkgICAgICAjIHdvdWxkIGZhaWwgaW4g
dGhlIGNvZGUgZm9sbG93aW5nCgkgICAgICAjCgkgICAgICAjIGdldGhvc3RieWFkZHJfcigpIGFw
cGVhcnMgdG8gaGF2ZSBiZWVuIGltcGxlbWVudGVkIGluIDYueCsKCSAgICAgIGxkZmxhZ3M9Ii1w
dGhyZWFkICRsZGZsYWdzIgoJICAgICAgOzsKCgllc2FjCgogICAgICAgIGNhc2UgIiRvc3ZlcnMi
IGluCiAgICAgICAgWzEtNF0qKQoJICAgIHNldCBgZWNobyBYICIkbGlic3dhbnRlZCAifCBzZWQg
LWUgJ3MvIGMgLyBjX3IgLydgCgkgICAgc2hpZnQKCSAgICBsaWJzd2FudGVkPSIkKiIKCSAgICA7
OwogICAgICAgICopCgkgICAgc2V0IGBlY2hvIFggIiRsaWJzd2FudGVkICJ8IHNlZCAtZSAncy8g
YyAvLydgCgkgICAgc2hpZnQKCSAgICBsaWJzd2FudGVkPSIkKiIKCSAgICA7OwoJZXNhYwoJICAg
IAoJIyBDb25maWd1cmUgd2lsbCBwcm9iYWJseSBwaWNrIHRoZSB3cm9uZyBsaWJjIHRvIHVzZSBm
b3Igbm0gc2Nhbi4KCSMgVGhlIHNhZmVzdCBxdWljay1maXggaXMganVzdCB0byBub3QgdXNlIG5t
IGF0IGFsbC4uLgoJdXNlbm09ZmFsc2UKCiAgICAgICAgY2FzZSAiJG9zdmVycyIgaW4KICAgICAg
ICAyLjIuOCopCiAgICAgICAgICAgICMgLi4uIGJ1dCB0aGlzIGRvZXMgbm90IGFwcGx5IGZvciAy
LjIuOCAtIHdlIGtub3cgaXQncyBzYWZlCiAgICAgICAgICAgIGxpYmM9IiRsY19yIgogICAgICAg
ICAgICB1c2VubT10cnVlCiAgICAgICAgICAgOzsKICAgICAgICBlc2FjCgogICAgICAgIHVuc2V0
IGxjX3IKCgkjIEV2ZW4gd2l0aCB0aGUgbWFsbG9jIG11dGV4ZXMgdGhlIFBlcmwgbWFsbG9jIGRv
ZXMgbm90CgkjIHNlZW0gdG8gYmUgdGhyZWFkc2FmZSBpbiBGcmVlQlNEPwoJY2FzZSAiJHVzZW15
bWFsbG9jIiBpbgoJJycpIHVzZW15bWFsbG9jPW4gOzsKCWVzYWMKZXNhYwpFT0NCVQoKIyBtYWxs
b2Mgd3JhcCB3b3JrcwpjYXNlICIkdXNlbWFsbG9jd3JhcCIgaW4KJycpIHVzZW1hbGxvY3dyYXA9
J2RlZmluZScgOzsKZXNhYwoKIyBYWFggVW5kZXIgRnJlZUJTRCA2LjAgKGFuZCBwcm9iYWJseSBt
b3N0IG90aGVyIHNpbWlsYXIgdmVyc2lvbnMpCiMgUGVybF9kaWUoTlVMTCkgZ2VuZXJhdGVzIGEg
d2FybmluZzoKIyAgICBwcF9zeXMuYzo0OTE6IHdhcm5pbmc6IG51bGwgZm9ybWF0IHN0cmluZwoj
IENvbmZpZ3VyZSBzdXBwb3NlZGVseSB0ZXN0cyBmb3IgdGhpcywgYnV0IGFwcGFyZW50bHkgdGhl
IHRlc3QgZG9lc24ndAojIHdvcmsuICBWb2x1bnRlZXJzIHdpdGggRnJlZUJTRCBhcmUgbmVlZGVk
IHRvIGltcHJvdmluZyB0aGUgQ29uZmlndXJlIHRlc3QuCiMgTWVhbndoaWxlLCB0aGUgZm9sbG93
aW5nIHdvcmthcm91bmQgc2hvdWxkIGJlIHNhZmUgb24gYWxsIHZlcnNpb25zCiMgb2YgRnJlZUJT
RC4KZF9wcmludGZfZm9ybWF0X251bGw9J3VuZGVmJwo=',
'midnightbsd' =>
'dXNldmZvcms9J3RydWUnCmNhc2UgIiR1c2VteW1hbGxvYyIgaW4KICAgICIiKSB1c2VteW1hbGxv
Yz0nbicKICAgICAgICA7Owplc2FjCmxpYnN3YW50ZWQ9YGVjaG8gJGxpYnN3YW50ZWQgfCBzZWQg
J3MvIG1hbGxvYyAvIC8nYAoKb2JqZm9ybWF0PWAvdXNyL2Jpbi9vYmpmb3JtYXRgCmlmIFsgeCRv
Ympmb3JtYXQgPSB4ZWxmIF07IHRoZW4KICAgIGxpYnB0aD0iL3Vzci9saWIgL3Vzci9sb2NhbC9s
aWIiCiAgICBnbGlicHRoPSIvdXNyL2xpYiAvdXNyL2xvY2FsL2xpYiIKICAgIGxkZmxhZ3M9Ii1X
bCwtRSAiCiAgICBsZGRsZmxhZ3M9Ii1zaGFyZWQgIgplbHNlCiAgICBpZiBbIC1lIC91c3IvbGli
L2FvdXQgXTsgdGhlbgogICAgICAgIGxpYnB0aD0iL3Vzci9saWIvYW91dCAvdXNyL2xvY2FsL2xp
YiAvdXNyL2xpYiIKICAgICAgICBnbGlicHRoPSIvdXNyL2xpYi9hb3V0IC91c3IvbG9jYWwvbGli
IC91c3IvbGliIgogICAgZmkKICAgIGxkZGxmbGFncz0nLUJzaGFyZWFibGUnCmZpCmNjY2RsZmxh
Z3M9Jy1EUElDIC1mUElDJwoKY2NmbGFncz0iJHtjY2ZsYWdzfSAtREhBU19GUFNFVE1BU0sgLURI
QVNfRkxPQVRJTkdQT0lOVF9IIgppZiAvdXNyL2Jpbi9maWxlIC1MIC91c3IvbGliL2xpYmMuc28g
fCAvdXNyL2Jpbi9ncmVwIC12cSAibm90IHN0cmlwcGVkIiA7IHRoZW4KICAgIHVzZW5tPWZhbHNl
CmZpCgpzaWduYWxfdD0ndm9pZCcKZF92b2lkc2lnPSdkZWZpbmUnCgojIFRoaXMgc2NyaXB0IFVV
L3VzZXRocmVhZHMuY2J1IHdpbGwgZ2V0ICdjYWxsZWQtYmFjaycgYnkgQ29uZmlndXJlIAojIGFm
dGVyIGl0IGhhcyBwcm9tcHRlZCB0aGUgdXNlciBmb3Igd2hldGhlciB0byB1c2UgdGhyZWFkcy4K
Y2F0ID4gVVUvdXNldGhyZWFkcy5jYnUgPDwnRU9DQlUnCmNhc2UgIiR1c2V0aHJlYWRzIiBpbgok
ZGVmaW5lfHRydWV8W3lZXSopCglsZGZsYWdzPSItcHRocmVhZCAkbGRmbGFncyIKCXNldCBgZWNo
byBYICIkbGlic3dhbnRlZCAifCBzZWQgLWUgJ3MvIGMgLy8nYAoJc2hpZnQKCWxpYnN3YW50ZWQ9
IiQqIgoJIyBDb25maWd1cmUgd2lsbCBwcm9iYWJseSBwaWNrIHRoZSB3cm9uZyBsaWJjIHRvIHVz
ZSBmb3Igbm0gc2Nhbi4KCSMgVGhlIHNhZmVzdCBxdWljay1maXggaXMganVzdCB0byBub3QgdXNl
IG5tIGF0IGFsbC4uLgoJdXNlbm09ZmFsc2UKCiAgICAgICAgdW5zZXQgbGNfcgoKCSMgRXZlbiB3
aXRoIHRoZSBtYWxsb2MgbXV0ZXhlcyB0aGUgUGVybCBtYWxsb2MgZG9lcyBub3QKCSMgc2VlbSB0
byBiZSB0aHJlYWRzYWZlIGluIE1pZG5pZ2h0QlNEPwoJY2FzZSAiJHVzZW15bWFsbG9jIiBpbgoJ
JycpIHVzZW15bWFsbG9jPW4gOzsKCWVzYWMKZXNhYwpFT0NCVQoKIyBtYWxsb2Mgd3JhcCB3b3Jr
cwpjYXNlICIkdXNlbWFsbG9jd3JhcCIgaW4KJycpIHVzZW1hbGxvY3dyYXA9J2RlZmluZScgOzsK
ZXNhYwo=',
'gnukfreebsd' =>
'IyEgL2Jpbi9zaAoKIyBTdXBwb3J0IGZvciBEZWJpYW4gR05VL2tGcmVlQlNEIChrZnJlZWJzZC1n
bnUpCiMgQSBwb3J0IG9mIHRoZSBEZWJpYW4gR05VIHN5c3RlbSB1c2luZyB0aGUgRnJlZUJTRCBr
ZXJuZWwuCgouIC4vaGludHMvbGludXguc2gKCg==',
);
my %files = (
'freebsd' => 'freebsd.sh',
'netbsd' => 'netbsd.sh',
'openbsd' => 'openbsd.sh',
'linux' => 'linux.sh',
'dragonfly' => 'dragonfly.sh',
'darwin' => 'darwin.sh',
'hpux' => 'hpux.sh',
'cygwin' => 'cygwin.sh',
'midnightbsd' => 'midnightbsd.sh',
'gnukfreebsd' => 'gnukfreebsd.sh',
);
sub hint_file {
my $os = shift;
$os = shift if eval { $os->isa(__PACKAGE__) };
$os = $^O unless $os;
return unless defined $hints{ $os };
my $content = decode_base64( $hints{ $os } );
return $content unless wantarray;
return ( $files{ $os }, $content );
}
qq'nudge nudge wink wink';
__END__
=pod
=head1 NAME
Devel::PatchPerl::Hints - replacement 'hints' files
=head1 VERSION
version 0.84
=head1 SYNOPSIS
use Devel::PatchPerl::Hints;
if ( my $content = Devel::PatchPerl::Hints->hint_file() ) {
chmod 0644, 'hints/netbsd.sh' or die "$!";
open my $hints, '>', 'hints/netbsd.sh' or die "$!";
print $hints $content;
close $hints;
}
=head1 DESCRIPTION
Sometimes there is a problem with Perls C<hints> file for a particular
perl port. This module provides fixed C<hints> files encoded using
C<MIME::Base64>.
=head1 FUNCTION
The function is exported, but has to implicitly imported into the
requesting package.
use Devel::PatchPerl::Hints qw[hint_file];
It may also be called as a class method:
use Devel::PatchPerl::Hints;
my $content = Devel::PatchPerl::Hints->hint_file();
=over
=item C<hint_file>
Takes an optional argument which is the OS name ( as would be returned by C<$^O> ).
By default it will use C<$^O>.
In a scalar context, Will return the decoded content of the C<hints> file suitable for writing straight to a
file handle or undef list if there isn't an applicable C<hints> file for the given or derived
OS.
If called in a list context, will return a list, the first item will be the name of the C<hints> file that
will need to be amended, the second item will be a string with the decoded content of the C<hints> file suitable
for writing straight to a file handle. Otherwise an empty list will be returned.
=back
=head1 AUTHOR
Chris Williams <chris@bingosnet.co.uk>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2013 by Chris Williams and Marcus Holland-Moritz.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
DEVEL_PATCHPERL_HINTS
$fatpacked{"Devel/PatchPerl/Plugin.pm"} = <<'DEVEL_PATCHPERL_PLUGIN';
package Devel::PatchPerl::Plugin;
{
$Devel::PatchPerl::Plugin::VERSION = '0.84';
}
#ABSTRACT: Devel::PatchPerl plugins explained
use strict;
use warnings;
qq[Plug it in];
__END__
=pod
=head1 NAME
Devel::PatchPerl::Plugin - Devel::PatchPerl plugins explained
=head1 VERSION
version 0.84
=head1 DESCRIPTION
This document explains the L<Devel::PatchPerl> plugin system.
Plugins are a mechanism for providing additional functionality to
L<Devel::PatchPerl>.
Plugins are searched for in the L<Devel::PatchPerl::Plugin> namespace.
=head1 INITIALISATION
The plugin constructor is C<patchperl>.
A plugin is specified using the C<PERL5_PATCHPERL_PLUGIN> environment
variable. It may either be specified in full (ie. C<Devel::PatchPerl::Plugin::Feegle>)
or as the short part (ie. C<Feegle>).
$ export PERL5_PATCHPERL_PLUGIN=Devel::PatchPerl::Plugin::Feegle
$ export PERL5_PATCHPERL_PLUGIN=Feegle
When L<Devel::PatchPerl> has identified the perl source patch and done its patching
it will attempt to load the plugin identified. It will then call the class method
C<patchperl> for the plugin package, with the following parameters:
'version', the Perl version of the source tree;
'source', the absolute path to the Perl source tree;
'patchexe', the 'patch' utility that can be used;
Plugins are called with the current working directory being the root of the
Perl source tree, ie. C<source>.
Summarised:
$ENV{PERL5_PATCHPERL_PLUGIN} = 'Devel::PatchPerl::Plugin::Feegle';
my $plugin = $ENV{PERL5_PATCHPERL_PLUGIN};
eval "require $plugin";
eval {
$plugin->patchperl( version => $vers, source => $srcdir, patchexe => $patch );
};
=head1 WHAT CAN PLUGINS DO?
Anything you desire to a Perl source tree.
=head1 WHY USE AN ENVIRONMENT VARIABLE TO SPECIFY PLUGINS?
So that indicating a plugin to use can be specified independently of whatever mechanism is
calling L<Devel::PatchPerl> to do its bidding.
Think L<perlbrew>.
=head1 AUTHOR
Chris Williams <chris@bingosnet.co.uk>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2013 by Chris Williams and Marcus Holland-Moritz.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
DEVEL_PATCHPERL_PLUGIN
$fatpacked{"Exporter.pm"} = <<'EXPORTER';
package Exporter;
require 5.006;
# Be lean.
#use strict;
#no strict 'refs';
our $Debug = 0;
our $ExportLevel = 0;
our $Verbose ||= 0;
our $VERSION = '5.67';
our (%Cache);
sub as_heavy {
require Exporter::Heavy;
# Unfortunately, this does not work if the caller is aliased as *name = \&foo
# Thus the need to create a lot of identical subroutines
my $c = (caller(1))[3];
$c =~ s/.*:://;
\&{"Exporter::Heavy::heavy_$c"};
}
sub export {
goto &{as_heavy()};
}
sub import {
my $pkg = shift;
my $callpkg = caller($ExportLevel);
if ($pkg eq "Exporter" and @_ and $_[0] eq "import") {
*{$callpkg."::import"} = \&import;
return;
}
# We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-(
my $exports = \@{"$pkg\::EXPORT"};
# But, avoid creating things if they don't exist, which saves a couple of
# hundred bytes per package processed.
my $fail = ${$pkg . '::'}{EXPORT_FAIL} && \@{"$pkg\::EXPORT_FAIL"};
return export $pkg, $callpkg, @_
if $Verbose or $Debug or $fail && @$fail > 1;
my $export_cache = ($Cache{$pkg} ||= {});
my $args = @_ or @_ = @$exports;
if ($args and not %$export_cache) {
s/^&//, $export_cache->{$_} = 1
foreach (@$exports, @{"$pkg\::EXPORT_OK"});
}
my $heavy;
# Try very hard not to use {} and hence have to enter scope on the foreach
# We bomb out of the loop with last as soon as heavy is set.
if ($args or $fail) {
($heavy = (/\W/ or $args and not exists $export_cache->{$_}
or $fail and @$fail and $_ eq $fail->[0])) and last
foreach (@_);
} else {
($heavy = /\W/) and last
foreach (@_);
}
return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy;
local $SIG{__WARN__} =
sub {require Carp; &Carp::carp} if not $SIG{__WARN__};
# shortcut for the common case of no type character
*{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_;
}
# Default methods
sub export_fail {
my $self = shift;
@_;
}
# Unfortunately, caller(1)[3] "does not work" if the caller is aliased as
# *name = \&foo. Thus the need to create a lot of identical subroutines
# Otherwise we could have aliased them to export().
sub export_to_level {
goto &{as_heavy()};
}
sub export_tags {
goto &{as_heavy()};
}
sub export_ok_tags {
goto &{as_heavy()};
}
sub require_version {
goto &{as_heavy()};
}
1;
__END__
=head1 NAME
Exporter - Implements default import method for modules
=head1 SYNOPSIS
In module F<YourModule.pm>:
package YourModule;
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(munge frobnicate); # symbols to export on request
or
package YourModule;
use Exporter 'import'; # gives you Exporter's import() method directly
@EXPORT_OK = qw(munge frobnicate); # symbols to export on request
In other files which wish to use C<YourModule>:
use YourModule qw(frobnicate); # import listed symbols
frobnicate ($left, $right) # calls YourModule::frobnicate
Take a look at L</Good Practices> for some variants
you will like to use in modern Perl code.
=head1 DESCRIPTION
The Exporter module implements an C<import> method which allows a module
to export functions and variables to its users' namespaces. Many modules
use Exporter rather than implementing their own C<import> method because
Exporter provides a highly flexible interface, with an implementation optimised
for the common case.
Perl automatically calls the C<import> method when processing a
C<use> statement for a module. Modules and C<use> are documented
in L<perlfunc> and L<perlmod>. Understanding the concept of
modules and how the C<use> statement operates is important to
understanding the Exporter.
=head2 How to Export
The arrays C<@EXPORT> and C<@EXPORT_OK> in a module hold lists of
symbols that are going to be exported into the users name space by
default, or which they can request to be exported, respectively. The
symbols can represent functions, scalars, arrays, hashes, or typeglobs.
The symbols must be given by full name with the exception that the
ampersand in front of a function is optional, e.g.
@EXPORT = qw(afunc $scalar @array); # afunc is a function
@EXPORT_OK = qw(&bfunc %hash *typeglob); # explicit prefix on &bfunc
If you are only exporting function names it is recommended to omit the
ampersand, as the implementation is faster this way.
=head2 Selecting What to Export
Do B<not> export method names!
Do B<not> export anything else by default without a good reason!
Exports pollute the namespace of the module user. If you must export
try to use C<@EXPORT_OK> in preference to C<@EXPORT> and avoid short or
common symbol names to reduce the risk of name clashes.
Generally anything not exported is still accessible from outside the
module using the C<YourModule::item_name> (or C<< $blessed_ref->method >>)
syntax. By convention you can use a leading underscore on names to
informally indicate that they are 'internal' and not for public use.
(It is actually possible to get private functions by saying:
my $subref = sub { ... };
$subref->(@args); # Call it as a function
$obj->$subref(@args); # Use it as a method
However if you use them for methods it is up to you to figure out
how to make inheritance work.)
As a general rule, if the module is trying to be object oriented
then export nothing. If it's just a collection of functions then
C<@EXPORT_OK> anything but use C<@EXPORT> with caution. For function and
method names use barewords in preference to names prefixed with
ampersands for the export lists.
Other module design guidelines can be found in L<perlmod>.
=head2 How to Import
In other files which wish to use your module there are three basic ways for
them to load your module and import its symbols:
=over 4
=item C<use YourModule;>
This imports all the symbols from YourModule's C<@EXPORT> into the namespace
of the C<use> statement.
=item C<use YourModule ();>
This causes perl to load your module but does not import any symbols.
=item C<use YourModule qw(...);>
This imports only the symbols listed by the caller into their namespace.
All listed symbols must be in your C<@EXPORT> or C<@EXPORT_OK>, else an error
occurs. The advanced export features of Exporter are accessed like this,
but with list entries that are syntactically distinct from symbol names.
=back
Unless you want to use its advanced features, this is probably all you
need to know to use Exporter.
=head1 Advanced Features
=head2 Specialised Import Lists
If any of the entries in an import list begins with !, : or / then
the list is treated as a series of specifications which either add to
or delete from the list of names to import. They are processed left to
right. Specifications are in the form:
[!]name This name only
[!]:DEFAULT All names in @EXPORT
[!]:tag All names in $EXPORT_TAGS{tag} anonymous list
[!]/pattern/ All names in @EXPORT and @EXPORT_OK which match
A leading ! indicates that matching names should be deleted from the
list of names to import. If the first specification is a deletion it
is treated as though preceded by :DEFAULT. If you just want to import
extra names in addition to the default set you will still need to
include :DEFAULT explicitly.
e.g., F<Module.pm> defines:
@EXPORT = qw(A1 A2 A3 A4 A5);
@EXPORT_OK = qw(B1 B2 B3 B4 B5);
%EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]);
Note that you cannot use tags in @EXPORT or @EXPORT_OK.
Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
An application using Module can say something like:
use Module qw(:DEFAULT :T2 !B3 A3);
Other examples include:
use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
use POSIX qw(:errno_h :termios_h !TCSADRAIN !/^EXIT/);
Remember that most patterns (using //) will need to be anchored
with a leading ^, e.g., C</^EXIT/> rather than C</EXIT/>.
You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the
specifications are being processed and what is actually being imported
into modules.
=head2 Exporting Without Using Exporter's import Method
Exporter has a special method, 'export_to_level' which is used in situations
where you can't directly call Exporter's
import method. The export_to_level
method looks like:
MyPackage->export_to_level(
$where_to_export, $package, @what_to_export
);
where C<$where_to_export> is an integer telling how far up the calling stack
to export your symbols, and C<@what_to_export> is an array telling what
symbols *to* export (usually this is C<@_>). The C<$package> argument is
currently unused.
For example, suppose that you have a module, A, which already has an
import function:
package A;
@ISA = qw(Exporter);
@EXPORT_OK = qw ($b);
sub import
{
$A::b = 1; # not a very useful import method
}
and you want to Export symbol C<$A::b> back to the module that called
package A. Since Exporter relies on the import method to work, via
inheritance, as it stands Exporter::import() will never get called.
Instead, say the following:
package A;
@ISA = qw(Exporter);
@EXPORT_OK = qw ($b);
sub import
{
$A::b = 1;
A->export_to_level(1, @_);
}
This will export the symbols one level 'above' the current package - ie: to
the program or module that used package A.
Note: Be careful not to modify C<@_> at all before you call export_to_level
- or people using your package will get very unexplained results!
=head2 Exporting Without Inheriting from Exporter
By including Exporter in your C<@ISA> you inherit an Exporter's import() method
but you also inherit several other helper methods which you probably don't
want. To avoid this you can do
package YourModule;
use Exporter qw( import );
which will export Exporter's own import() method into YourModule.
Everything will work as before but you won't need to include Exporter in
C<@YourModule::ISA>.
Note: This feature was introduced in version 5.57
of Exporter, released with perl 5.8.3.
=head2 Module Version Checking
The Exporter module will convert an attempt to import a number from a
module into a call to C<< $module_name->VERSION($value) >>. This can
be used to validate that the version of the module being used is
greater than or equal to the required version.
For historical reasons, Exporter supplies a C<require_version> method that
simply delegates to C<VERSION>. Originally, before C<UNIVERSAL::VERSION>
existed, Exporter would call C<require_version>.
Since the C<UNIVERSAL::VERSION> method treats the C<$VERSION> number as
a simple numeric value it will regard version 1.10 as lower than
1.9. For this reason it is strongly recommended that you use numbers
with at least two decimal places, e.g., 1.09.
=head2 Managing Unknown Symbols
In some situations you may want to prevent certain symbols from being
exported. Typically this applies to extensions which have functions
or constants that may not exist on some systems.
The names of any symbols that cannot be exported should be listed
in the C<@EXPORT_FAIL> array.
If a module attempts to import any of these symbols the Exporter
will give the module an opportunity to handle the situation before
generating an error. The Exporter will call an export_fail method
with a list of the failed symbols:
@failed_symbols = $module_name->export_fail(@failed_symbols);
If the C<export_fail> method returns an empty list then no error is
recorded and all the requested symbols are exported. If the returned
list is not empty then an error is generated for each symbol and the
export fails. The Exporter provides a default C<export_fail> method which
simply returns the list unchanged.
Uses for the C<export_fail> method include giving better error messages
for some symbols and performing lazy architectural checks (put more
symbols into C<@EXPORT_FAIL> by default and then take them out if someone
actually tries to use them and an expensive check shows that they are
usable on that platform).
=head2 Tag Handling Utility Functions
Since the symbols listed within C<%EXPORT_TAGS> must also appear in either
C<@EXPORT> or C<@EXPORT_OK>, two utility functions are provided which allow
you to easily add tagged sets of symbols to C<@EXPORT> or C<@EXPORT_OK>:
%EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
Exporter::export_tags('foo'); # add aa, bb and cc to @EXPORT
Exporter::export_ok_tags('bar'); # add aa, cc and dd to @EXPORT_OK
Any names which are not tags are added to C<@EXPORT> or C<@EXPORT_OK>
unchanged but will trigger a warning (with C<-w>) to avoid misspelt tags
names being silently added to C<@EXPORT> or C<@EXPORT_OK>. Future versions
may make this a fatal error.
=head2 Generating Combined Tags
If several symbol categories exist in C<%EXPORT_TAGS>, it's usually
useful to create the utility ":all" to simplify "use" statements.
The simplest way to do this is:
%EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
# add all the other ":class" tags to the ":all" class,
# deleting duplicates
{
my %seen;
push @{$EXPORT_TAGS{all}},
grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS;
}
F<CGI.pm> creates an ":all" tag which contains some (but not really
all) of its categories. That could be done with one small
change:
# add some of the other ":class" tags to the ":all" class,
# deleting duplicates
{
my %seen;
push @{$EXPORT_TAGS{all}},
grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}}
foreach qw/html2 html3 netscape form cgi internal/;
}
Note that the tag names in C<%EXPORT_TAGS> don't have the leading ':'.
=head2 C<AUTOLOAD>ed Constants
Many modules make use of C<AUTOLOAD>ing for constant subroutines to
avoid having to compile and waste memory on rarely used values (see
L<perlsub> for details on constant subroutines). Calls to such
constant subroutines are not optimized away at compile time because
they can't be checked at compile time for constancy.
Even if a prototype is available at compile time, the body of the
subroutine is not (it hasn't been C<AUTOLOAD>ed yet). perl needs to
examine both the C<()> prototype and the body of a subroutine at
compile time to detect that it can safely replace calls to that
subroutine with the constant value.
A workaround for this is to call the constants once in a C<BEGIN> block:
package My ;
use Socket ;
foo( SO_LINGER ); ## SO_LINGER NOT optimized away; called at runtime
BEGIN { SO_LINGER }
foo( SO_LINGER ); ## SO_LINGER optimized away at compile time.
This forces the C<AUTOLOAD> for C<SO_LINGER> to take place before
SO_LINGER is encountered later in C<My> package.
If you are writing a package that C<AUTOLOAD>s, consider forcing
an C<AUTOLOAD> for any constants explicitly imported by other packages
or which are usually used when your package is C<use>d.
=head1 Good Practices
=head2 Declaring C<@EXPORT_OK> and Friends
When using C<Exporter> with the standard C<strict> and C<warnings>
pragmas, the C<our> keyword is needed to declare the package
variables C<@EXPORT_OK>, C<@EXPORT>, C<@ISA>, etc.
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(munge frobnicate);
If backward compatibility for Perls under 5.6 is important,
one must write instead a C<use vars> statement.
use vars qw(@ISA @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT_OK = qw(munge frobnicate);
=head2 Playing Safe
There are some caveats with the use of runtime statements
like C<require Exporter> and the assignment to package
variables, which can very subtle for the unaware programmer.
This may happen for instance with mutually recursive
modules, which are affected by the time the relevant
constructions are executed.
The ideal (but a bit ugly) way to never have to think
about that is to use C<BEGIN> blocks. So the first part
of the L</SYNOPSIS> code could be rewritten as:
package YourModule;
use strict;
use warnings;
our (@ISA, @EXPORT_OK);
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(munge frobnicate); # symbols to export on request
}
The C<BEGIN> will assure that the loading of F<Exporter.pm>
and the assignments to C<@ISA> and C<@EXPORT_OK> happen
immediately, leaving no room for something to get awry
or just plain wrong.
With respect to loading C<Exporter> and inheriting, there
are alternatives with the use of modules like C<base> and C<parent>.
use base qw( Exporter );
# or
use parent qw( Exporter );
Any of these statements are nice replacements for
C<BEGIN { require Exporter; @ISA = qw(Exporter); }>
with the same compile-time effect. The basic difference
is that C<base> code interacts with declared C<fields>
while C<parent> is a streamlined version of the older
C<base> code to just establish the IS-A relationship.
For more details, see the documentation and code of
L<base> and L<parent>.
Another thorough remedy to that runtime
vs. compile-time trap is to use L<Exporter::Easy>,
which is a wrapper of Exporter that allows all
boilerplate code at a single gulp in the
use statement.
use Exporter::Easy (
OK => [ qw(munge frobnicate) ],
);
# @ISA setup is automatic
# all assignments happen at compile time
=head2 What Not to Export
You have been warned already in L</Selecting What to Export>
to not export:
=over 4
=item *
method names (because you don't need to
and that's likely to not do what you want),
=item *
anything by default (because you don't want to surprise your users...
badly)
=item *
anything you don't need to (because less is more)
=back
There's one more item to add to this list. Do B<not>
export variable names. Just because C<Exporter> lets you
do that, it does not mean you should.
@EXPORT_OK = qw( $svar @avar %hvar ); # DON'T!
Exporting variables is not a good idea. They can
change under the hood, provoking horrible
effects at-a-distance, that are too hard to track
and to fix. Trust me: they are not worth it.
To provide the capability to set/get class-wide
settings, it is best instead to provide accessors
as subroutines or class methods instead.
=head1 SEE ALSO
C<Exporter> is definitely not the only module with
symbol exporter capabilities. At CPAN, you may find
a bunch of them. Some are lighter. Some
provide improved APIs and features. Peek the one
that fits your needs. The following is
a sample list of such modules.
Exporter::Easy
Exporter::Lite
Exporter::Renaming
Exporter::Tidy
Sub::Exporter / Sub::Installer
Perl6::Export / Perl6::Export::Attrs
=head1 LICENSE
This library is free software. You can redistribute it
and/or modify it under the same terms as Perl itself.
=cut
EXPORTER
$fatpacked{"Exporter/Heavy.pm"} = <<'EXPORTER_HEAVY';
package Exporter::Heavy;
use strict;
no strict 'refs';
# On one line so MakeMaker will see it.
require Exporter; our $VERSION = $Exporter::VERSION;
=head1 NAME
Exporter::Heavy - Exporter guts
=head1 SYNOPSIS
(internal use only)
=head1 DESCRIPTION
No user-serviceable parts inside.
=cut
#
# We go to a lot of trouble not to 'require Carp' at file scope,
# because Carp requires Exporter, and something has to give.
#
sub _rebuild_cache {
my ($pkg, $exports, $cache) = @_;
s/^&// foreach @$exports;
@{$cache}{@$exports} = (1) x @$exports;
my $ok = \@{"${pkg}::EXPORT_OK"};
if (@$ok) {
s/^&// foreach @$ok;
@{$cache}{@$ok} = (1) x @$ok;
}
}
sub heavy_export {
# First make import warnings look like they're coming from the "use".
local $SIG{__WARN__} = sub {
my $text = shift;
if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) {
require Carp;
local $Carp::CarpLevel = 1; # ignore package calling us too.
Carp::carp($text);
}
else {
warn $text;
}
};
local $SIG{__DIE__} = sub {
require Carp;
local $Carp::CarpLevel = 1; # ignore package calling us too.
Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
};
my($pkg, $callpkg, @imports) = @_;
my($type, $sym, $cache_is_current, $oops);
my($exports, $export_cache) = (\@{"${pkg}::EXPORT"},
$Exporter::Cache{$pkg} ||= {});
if (@imports) {
if (!%$export_cache) {
_rebuild_cache ($pkg, $exports, $export_cache);
$cache_is_current = 1;
}
if (grep m{^[/!:]}, @imports) {
my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
my $tagdata;
my %imports;
my($remove, $spec, @names, @allexports);
# negated first item implies starting with default set:
unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
foreach $spec (@imports){
$remove = $spec =~ s/^!//;
if ($spec =~ s/^://){
if ($spec eq 'DEFAULT'){
@names = @$exports;
}
elsif ($tagdata = $tagsref->{$spec}) {
@names = @$tagdata;
}
else {
warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];
++$oops;
next;
}
}
elsif ($spec =~ m:^/(.*)/$:){
my $patn = $1;
@allexports = keys %$export_cache unless @allexports; # only do keys once
@names = grep(/$patn/, @allexports); # not anchored by default
}
else {
@names = ($spec); # is a normal symbol name
}
warn "Import ".($remove ? "del":"add").": @names "
if $Exporter::Verbose;
if ($remove) {
foreach $sym (@names) { delete $imports{$sym} }
}
else {
@imports{@names} = (1) x @names;
}
}
@imports = keys %imports;
}
my @carp;
foreach $sym (@imports) {
if (!$export_cache->{$sym}) {
if ($sym =~ m/^\d/) {
$pkg->VERSION($sym); # inherit from UNIVERSAL
# If the version number was the only thing specified
# then we should act as if nothing was specified:
if (@imports == 1) {
@imports = @$exports;
last;
}
# We need a way to emulate 'use Foo ()' but still
# allow an easy version check: "use Foo 1.23, ''";
if (@imports == 2 and !$imports[1]) {
@imports = ();
last;
}
} elsif ($sym !~ s/^&// || !$export_cache->{$sym}) {
# Last chance - see if they've updated EXPORT_OK since we
# cached it.
unless ($cache_is_current) {
%$export_cache = ();
_rebuild_cache ($pkg, $exports, $export_cache);
$cache_is_current = 1;
}
if (!$export_cache->{$sym}) {
# accumulate the non-exports
push @carp,
qq["$sym" is not exported by the $pkg module\n];
$oops++;
}
}
}
}
if ($oops) {
require Carp;
Carp::croak("@{carp}Can't continue after import errors");
}
}
else {
@imports = @$exports;
}
my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"},
$Exporter::FailCache{$pkg} ||= {});
if (@$fail) {
if (!%$fail_cache) {
# Build cache of symbols. Optimise the lookup by adding
# barewords twice... both with and without a leading &.
# (Technique could be applied to $export_cache at cost of memory)
my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail;
warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Exporter::Verbose;
@{$fail_cache}{@expanded} = (1) x @expanded;
}
my @failed;
foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} }
if (@failed) {
@failed = $pkg->export_fail(@failed);
foreach $sym (@failed) {
require Carp;
Carp::carp(qq["$sym" is not implemented by the $pkg module ],
"on this architecture");
}
if (@failed) {
require Carp;
Carp::croak("Can't continue after import errors");
}
}
}
warn "Importing into $callpkg from $pkg: ",
join(", ",sort @imports) if $Exporter::Verbose;
foreach $sym (@imports) {
# shortcut for the common case of no type character
(*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next)
unless $sym =~ s/^(\W)//;
$type = $1;
no warnings 'once';
*{"${callpkg}::$sym"} =
$type eq '&' ? \&{"${pkg}::$sym"} :
$type eq '$' ? \${"${pkg}::$sym"} :
$type eq '@' ? \@{"${pkg}::$sym"} :
$type eq '%' ? \%{"${pkg}::$sym"} :
$type eq '*' ? *{"${pkg}::$sym"} :
do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
}
}
sub heavy_export_to_level
{
my $pkg = shift;
my $level = shift;
(undef) = shift; # XXX redundant arg
my $callpkg = caller($level);
$pkg->export($callpkg, @_);
}
# Utility functions
sub _push_tags {
my($pkg, $var, $syms) = @_;
my @nontag = ();
my $export_tags = \%{"${pkg}::EXPORT_TAGS"};
push(@{"${pkg}::$var"},
map { $export_tags->{$_} ? @{$export_tags->{$_}}
: scalar(push(@nontag,$_),$_) }
(@$syms) ? @$syms : keys %$export_tags);
if (@nontag and $^W) {
# This may change to a die one day
require Carp;
Carp::carp(join(", ", @nontag)." are not tags of $pkg");
}
}
sub heavy_require_version {
my($self, $wanted) = @_;
my $pkg = ref $self || $self;
return ${pkg}->VERSION($wanted);
}
sub heavy_export_tags {
_push_tags((caller)[0], "EXPORT", \@_);
}
sub heavy_export_ok_tags {
_push_tags((caller)[0], "EXPORT_OK", \@_);
}
1;
EXPORTER_HEAVY
$fatpacked{"ExtUtils/Command/MM.pm"} = <<'EXTUTILS_COMMAND_MM';
package ExtUtils::Command::MM;
require 5.006;
use strict;
use warnings;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(test_harness pod2man perllocal_install uninstall
warn_if_old_packlist);
our $VERSION = '6.64';
my $Is_VMS = $^O eq 'VMS';
=head1 NAME
ExtUtils::Command::MM - Commands for the MM's to use in Makefiles
=head1 SYNOPSIS
perl "-MExtUtils::Command::MM" -e "function" "--" arguments...
=head1 DESCRIPTION
B<FOR INTERNAL USE ONLY!> The interface is not stable.
ExtUtils::Command::MM encapsulates code which would otherwise have to
be done with large "one" liners.
Any $(FOO) used in the examples are make variables, not Perl.
=over 4
=item B<test_harness>
test_harness($verbose, @test_libs);
Runs the tests on @ARGV via Test::Harness passing through the $verbose
flag. Any @test_libs will be unshifted onto the test's @INC.
@test_libs are run in alphabetical order.
=cut
sub test_harness {
require Test::Harness;
require File::Spec;
$Test::Harness::verbose = shift;
# Because Windows doesn't do this for us and listing all the *.t files
# out on the command line can blow over its exec limit.
require ExtUtils::Command;
my @argv = ExtUtils::Command::expand_wildcards(@ARGV);
local @INC = @INC;
unshift @INC, map { File::Spec->rel2abs($_) } @_;
Test::Harness::runtests(sort { lc $a cmp lc $b } @argv);
}
=item B<pod2man>
pod2man( '--option=value',
$podfile1 => $manpage1,
$podfile2 => $manpage2,
...
);
# or args on @ARGV
pod2man() is a function performing most of the duties of the pod2man
program. Its arguments are exactly the same as pod2man as of 5.8.0
with the addition of:
--perm_rw octal permission to set the resulting manpage to
And the removal of:
--verbose/-v
--help/-h
If no arguments are given to pod2man it will read from @ARGV.
If Pod::Man is unavailable, this function will warn and return undef.
=cut
sub pod2man {
local @ARGV = @_ ? @_ : @ARGV;
{
local $@;
if( !eval { require Pod::Man } ) {
warn "Pod::Man is not available: $@".
"Man pages will not be generated during this install.\n";
return undef;
}
}
require Getopt::Long;
# We will cheat and just use Getopt::Long. We fool it by putting
# our arguments into @ARGV. Should be safe.
my %options = ();
Getopt::Long::config ('bundling_override');
Getopt::Long::GetOptions (\%options,
'section|s=s', 'release|r=s', 'center|c=s',
'date|d=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s',
'fixedbolditalic=s', 'official|o', 'quotes|q=s', 'lax|l',
'name|n=s', 'perm_rw=i'
);
# If there's no files, don't bother going further.
return 0 unless @ARGV;
# Official sets --center, but don't override things explicitly set.
if ($options{official} && !defined $options{center}) {
$options{center} = q[Perl Programmer's Reference Guide];
}
# This isn't a valid Pod::Man option and is only accepted for backwards
# compatibility.
delete $options{lax};
do {{ # so 'next' works
my ($pod, $man) = splice(@ARGV, 0, 2);
next if ((-e $man) &&
(-M $man < -M $pod) &&
(-M $man < -M "Makefile"));
print "Manifying $man\n";
my $parser = Pod::Man->new(%options);
$parser->parse_from_file($pod, $man)
or do { warn("Could not install $man\n"); next };
if (exists $options{perm_rw}) {
chmod(oct($options{perm_rw}), $man)
or do { warn("chmod $options{perm_rw} $man: $!\n"); next };
}
}} while @ARGV;
return 1;
}
=item B<warn_if_old_packlist>
perl "-MExtUtils::Command::MM" -e warn_if_old_packlist <somefile>
Displays a warning that an old packlist file was found. Reads the
filename from @ARGV.
=cut
sub warn_if_old_packlist {
my $packlist = $ARGV[0];
return unless -f $packlist;
print <<"PACKLIST_WARNING";
WARNING: I have found an old package in
$packlist.
Please make sure the two installations are not conflicting
PACKLIST_WARNING
}
=item B<perllocal_install>
perl "-MExtUtils::Command::MM" -e perllocal_install
<type> <module name> <key> <value> ...
# VMS only, key|value pairs come on STDIN
perl "-MExtUtils::Command::MM" -e perllocal_install
<type> <module name> < <key>|<value> ...
Prints a fragment of POD suitable for appending to perllocal.pod.
Arguments are read from @ARGV.
'type' is the type of what you're installing. Usually 'Module'.
'module name' is simply the name of your module. (Foo::Bar)
Key/value pairs are extra information about the module. Fields include:
installed into which directory your module was out into
LINKTYPE dynamic or static linking
VERSION module version number
EXE_FILES any executables installed in a space seperated
list
=cut
sub perllocal_install {
my($type, $name) = splice(@ARGV, 0, 2);
# VMS feeds args as a piped file on STDIN since it usually can't
# fit all the args on a single command line.
my @mod_info = $Is_VMS ? split /\|/, <STDIN>
: @ARGV;
my $pod;
$pod = sprintf <<POD, scalar localtime;
=head2 %s: C<$type> L<$name|$name>
=over 4
POD
do {
my($key, $val) = splice(@mod_info, 0, 2);
$pod .= <<POD
=item *
C<$key: $val>
POD
} while(@mod_info);
$pod .= "=back\n\n";
$pod =~ s/^ //mg;
print $pod;
return 1;
}
=item B<uninstall>
perl "-MExtUtils::Command::MM" -e uninstall <packlist>
A wrapper around ExtUtils::Install::uninstall(). Warns that
uninstallation is deprecated and doesn't actually perform the
uninstallation.
=cut
sub uninstall {
my($packlist) = shift @ARGV;
require ExtUtils::Install;
print <<'WARNING';
Uninstall is unsafe and deprecated, the uninstallation was not performed.
We will show what would have been done.
WARNING
ExtUtils::Install::uninstall($packlist, 1, 1);
print <<'WARNING';
Uninstall is unsafe and deprecated, the uninstallation was not performed.
Please check the list above carefully, there may be errors.
Remove the appropriate files manually.
Sorry for the inconvenience.
WARNING
}
=back
=cut
1;
EXTUTILS_COMMAND_MM
$fatpacked{"ExtUtils/Liblist.pm"} = <<'EXTUTILS_LIBLIST';
package ExtUtils::Liblist;
use strict;
our $VERSION = '6.64';
use File::Spec;
require ExtUtils::Liblist::Kid;
our @ISA = qw(ExtUtils::Liblist::Kid File::Spec);
# Backwards compatibility with old interface.
sub ext {
goto &ExtUtils::Liblist::Kid::ext;
}
sub lsdir {
shift;
my $rex = qr/$_[1]/;
opendir DIR, $_[0];
my @out = grep /$rex/, readdir DIR;
closedir DIR;
return @out;
}
__END__
=head1 NAME
ExtUtils::Liblist - determine libraries to use and how to use them
=head1 SYNOPSIS
require ExtUtils::Liblist;
$MM->ext($potential_libs, $verbose, $need_names);
# Usually you can get away with:
ExtUtils::Liblist->ext($potential_libs, $verbose, $need_names)
=head1 DESCRIPTION
This utility takes a list of libraries in the form C<-llib1 -llib2
-llib3> and returns lines suitable for inclusion in an extension
Makefile. Extra library paths may be included with the form
C<-L/another/path> this will affect the searches for all subsequent
libraries.
It returns an array of four or five scalar values: EXTRALIBS,
BSLOADLIBS, LDLOADLIBS, LD_RUN_PATH, and, optionally, a reference to
the array of the filenames of actual libraries. Some of these don't
mean anything unless on Unix. See the details about those platform
specifics below. The list of the filenames is returned only if
$need_names argument is true.
Dependent libraries can be linked in one of three ways:
=over 2
=item * For static extensions
by the ld command when the perl binary is linked with the extension
library. See EXTRALIBS below.
=item * For dynamic extensions at build/link time
by the ld command when the shared object is built/linked. See
LDLOADLIBS below.
=item * For dynamic extensions at load time
by the DynaLoader when the shared object is loaded. See BSLOADLIBS
below.
=back
=head2 EXTRALIBS
List of libraries that need to be linked with when linking a perl
binary which includes this extension. Only those libraries that
actually exist are included. These are written to a file and used
when linking perl.
=head2 LDLOADLIBS and LD_RUN_PATH
List of those libraries which can or must be linked into the shared
library when created using ld. These may be static or dynamic
libraries. LD_RUN_PATH is a colon separated list of the directories
in LDLOADLIBS. It is passed as an environment variable to the process
that links the shared library.
=head2 BSLOADLIBS
List of those libraries that are needed but can be linked in
dynamically at run time on this platform. SunOS/Solaris does not need
this because ld records the information (from LDLOADLIBS) into the
object file. This list is used to create a .bs (bootstrap) file.
=head1 PORTABILITY
This module deals with a lot of system dependencies and has quite a
few architecture specific C<if>s in the code.
=head2 VMS implementation
The version of ext() which is executed under VMS differs from the
Unix-OS/2 version in several respects:
=over 2
=item *
Input library and path specifications are accepted with or without the
C<-l> and C<-L> prefixes used by Unix linkers. If neither prefix is
present, a token is considered a directory to search if it is in fact
a directory, and a library to search for otherwise. Authors who wish
their extensions to be portable to Unix or OS/2 should use the Unix
prefixes, since the Unix-OS/2 version of ext() requires them.
=item *
Wherever possible, shareable images are preferred to object libraries,
and object libraries to plain object files. In accordance with VMS
naming conventions, ext() looks for files named I<lib>shr and I<lib>rtl;
it also looks for I<lib>lib and libI<lib> to accommodate Unix conventions
used in some ported software.
=item *
For each library that is found, an appropriate directive for a linker options
file is generated. The return values are space-separated strings of
these directives, rather than elements used on the linker command line.
=item *
LDLOADLIBS contains both the libraries found based on C<$potential_libs> and
the CRTLs, if any, specified in Config.pm. EXTRALIBS contains just those
libraries found based on C<$potential_libs>. BSLOADLIBS and LD_RUN_PATH
are always empty.
=back
In addition, an attempt is made to recognize several common Unix library
names, and filter them out or convert them to their VMS equivalents, as
appropriate.
In general, the VMS version of ext() should properly handle input from
extensions originally designed for a Unix or VMS environment. If you
encounter problems, or discover cases where the search could be improved,
please let us know.
=head2 Win32 implementation
The version of ext() which is executed under Win32 differs from the
Unix-OS/2 version in several respects:
=over 2
=item *
If C<$potential_libs> is empty, the return value will be empty.
Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
will be appended to the list of C<$potential_libs>. The libraries
will be searched for in the directories specified in C<$potential_libs>,
C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>.
For each library that is found, a space-separated list of fully qualified
library pathnames is generated.
=item *
Input library and path specifications are accepted with or without the
C<-l> and C<-L> prefixes used by Unix linkers.
An entry of the form C<-La:\foo> specifies the C<a:\foo> directory to look
for the libraries that follow.
An entry of the form C<-lfoo> specifies the library C<foo>, which may be
spelled differently depending on what kind of compiler you are using. If
you are using GCC, it gets translated to C<libfoo.a>, but for other win32
compilers, it becomes C<foo.lib>. If no files are found by those translated
names, one more attempt is made to find them using either C<foo.a> or
C<libfoo.lib>, depending on whether GCC or some other win32 compiler is
being used, respectively.
If neither the C<-L> or C<-l> prefix is present in an entry, the entry is
considered a directory to search if it is in fact a directory, and a
library to search for otherwise. The C<$Config{lib_ext}> suffix will
be appended to any entries that are not directories and don't already have
the suffix.
Note that the C<-L> and C<-l> prefixes are B<not required>, but authors
who wish their extensions to be portable to Unix or OS/2 should use the
prefixes, since the Unix-OS/2 version of ext() requires them.
=item *
Entries cannot be plain object files, as many Win32 compilers will
not handle object files in the place of libraries.
=item *
Entries in C<$potential_libs> beginning with a colon and followed by
alphanumeric characters are treated as flags. Unknown flags will be ignored.
An entry that matches C</:nodefault/i> disables the appending of default
libraries found in C<$Config{perllibs}> (this should be only needed very rarely).
An entry that matches C</:nosearch/i> disables all searching for
the libraries specified after it. Translation of C<-Lfoo> and
C<-lfoo> still happens as appropriate (depending on compiler being used,
as reflected by C<$Config{cc}>), but the entries are not verified to be
valid files or directories.
An entry that matches C</:search/i> reenables searching for
the libraries specified after it. You can put it at the end to
enable searching for default libraries specified by C<$Config{perllibs}>.
=item *
The libraries specified may be a mixture of static libraries and
import libraries (to link with DLLs). Since both kinds are used
pretty transparently on the Win32 platform, we do not attempt to
distinguish between them.
=item *
LDLOADLIBS and EXTRALIBS are always identical under Win32, and BSLOADLIBS
and LD_RUN_PATH are always empty (this may change in future).
=item *
You must make sure that any paths and path components are properly
surrounded with double-quotes if they contain spaces. For example,
C<$potential_libs> could be (literally):
"-Lc:\Program Files\vc\lib" msvcrt.lib "la test\foo bar.lib"
Note how the first and last entries are protected by quotes in order
to protect the spaces.
=item *
Since this module is most often used only indirectly from extension
C<Makefile.PL> files, here is an example C<Makefile.PL> entry to add
a library to the build process for an extension:
LIBS => ['-lgl']
When using GCC, that entry specifies that MakeMaker should first look
for C<libgl.a> (followed by C<gl.a>) in all the locations specified by
C<$Config{libpth}>.
When using a compiler other than GCC, the above entry will search for
C<gl.lib> (followed by C<libgl.lib>).
If the library happens to be in a location not in C<$Config{libpth}>,
you need:
LIBS => ['-Lc:\gllibs -lgl']
Here is a less often used example:
LIBS => ['-lgl', ':nosearch -Ld:\mesalibs -lmesa -luser32']
This specifies a search for library C<gl> as before. If that search
fails to find the library, it looks at the next item in the list. The
C<:nosearch> flag will prevent searching for the libraries that follow,
so it simply returns the value as C<-Ld:\mesalibs -lmesa -luser32>,
since GCC can use that value as is with its linker.
When using the Visual C compiler, the second item is returned as
C<-libpath:d:\mesalibs mesa.lib user32.lib>.
When using the Borland compiler, the second item is returned as
C<-Ld:\mesalibs mesa.lib user32.lib>, and MakeMaker takes care of
moving the C<-Ld:\mesalibs> to the correct place in the linker
command line.
=back
=head1 SEE ALSO
L<ExtUtils::MakeMaker>
=cut
EXTUTILS_LIBLIST
$fatpacked{"ExtUtils/Liblist/Kid.pm"} = <<'EXTUTILS_LIBLIST_KID';
package ExtUtils::Liblist::Kid;
# XXX Splitting this out into its own .pm is a temporary solution.
# This kid package is to be used by MakeMaker. It will not work if
# $self is not a Makemaker.
use 5.006;
# Broken out of MakeMaker from version 4.11
use strict;
use warnings;
our $VERSION = '6.64';
use ExtUtils::MakeMaker::Config;
use Cwd 'cwd';
use File::Basename;
use File::Spec;
sub ext {
if ( $^O eq 'VMS' ) { return &_vms_ext; }
elsif ( $^O eq 'MSWin32' ) { return &_win32_ext; }
else { return &_unix_os2_ext; }
}
sub _unix_os2_ext {
my ( $self, $potential_libs, $verbose, $give_libs ) = @_;
$verbose ||= 0;
if ( $^O =~ 'os2' and $Config{perllibs} ) {
# Dynamic libraries are not transitive, so we may need including
# the libraries linked against perl.dll again.
$potential_libs .= " " if $potential_libs;
$potential_libs .= $Config{perllibs};
}
return ( "", "", "", "", ( $give_libs ? [] : () ) ) unless $potential_libs;
warn "Potential libraries are '$potential_libs':\n" if $verbose;
my ( $so ) = $Config{so};
my ( $libs ) = defined $Config{perllibs} ? $Config{perllibs} : $Config{libs};
my $Config_libext = $Config{lib_ext} || ".a";
my $Config_dlext = $Config{dlext};
# compute $extralibs, $bsloadlibs and $ldloadlibs from
# $potential_libs
# this is a rewrite of Andy Dougherty's extliblist in perl
my ( @searchpath ); # from "-L/path" entries in $potential_libs
my ( @libpath ) = split " ", $Config{'libpth'};
my ( @ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen );
my ( @libs, %libs_seen );
my ( $fullname, @fullname );
my ( $pwd ) = cwd(); # from Cwd.pm
my ( $found ) = 0;
foreach my $thislib ( split ' ', $potential_libs ) {
# Handle possible linker path arguments.
if ( $thislib =~ s/^(-[LR]|-Wl,-R)// ) { # save path flag type
my ( $ptype ) = $1;
unless ( -d $thislib ) {
warn "$ptype$thislib ignored, directory does not exist\n"
if $verbose;
next;
}
my ( $rtype ) = $ptype;
if ( ( $ptype eq '-R' ) or ( $ptype eq '-Wl,-R' ) ) {
if ( $Config{'lddlflags'} =~ /-Wl,-R/ ) {
$rtype = '-Wl,-R';
}
elsif ( $Config{'lddlflags'} =~ /-R/ ) {
$rtype = '-R';
}
}
unless ( File::Spec->file_name_is_absolute( $thislib ) ) {
warn "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n";
$thislib = $self->catdir( $pwd, $thislib );
}
push( @searchpath, $thislib );
push( @extralibs, "$ptype$thislib" );
push( @ldloadlibs, "$rtype$thislib" );
next;
}
# Handle possible library arguments.
unless ( $thislib =~ s/^-l// ) {
warn "Unrecognized argument in LIBS ignored: '$thislib'\n";
next;
}
my ( $found_lib ) = 0;
foreach my $thispth ( @searchpath, @libpath ) {
# Try to find the full name of the library. We need this to
# determine whether it's a dynamically-loadable library or not.
# This tends to be subject to various os-specific quirks.
# For gcc-2.6.2 on linux (March 1995), DLD can not load
# .sa libraries, with the exception of libm.sa, so we
# deliberately skip them.
if ( @fullname = $self->lsdir( $thispth, "^\Qlib$thislib.$so.\E[0-9]+" ) ) {
# Take care that libfoo.so.10 wins against libfoo.so.9.
# Compare two libraries to find the most recent version
# number. E.g. if you have libfoo.so.9.0.7 and
# libfoo.so.10.1, first convert all digits into two
# decimal places. Then we'll add ".00" to the shorter
# strings so that we're comparing strings of equal length
# Thus we'll compare libfoo.so.09.07.00 with
# libfoo.so.10.01.00. Some libraries might have letters
# in the version. We don't know what they mean, but will
# try to skip them gracefully -- we'll set any letter to
# '0'. Finally, sort in reverse so we can take the
# first element.
#TODO: iterate through the directory instead of sorting
$fullname = "$thispth/" . (
sort {
my ( $ma ) = $a;
my ( $mb ) = $b;
$ma =~ tr/A-Za-z/0/s;
$ma =~ s/\b(\d)\b/0$1/g;
$mb =~ tr/A-Za-z/0/s;
$mb =~ s/\b(\d)\b/0$1/g;
while ( length( $ma ) < length( $mb ) ) { $ma .= ".00"; }
while ( length( $mb ) < length( $ma ) ) { $mb .= ".00"; }
# Comparison deliberately backwards
$mb cmp $ma;
} @fullname
)[0];
}
elsif ( -f ( $fullname = "$thispth/lib$thislib.$so" )
&& ( ( $Config{'dlsrc'} ne "dl_dld.xs" ) || ( $thislib eq "m" ) ) )
{
}
elsif (-f ( $fullname = "$thispth/lib${thislib}_s$Config_libext" )
&& ( $Config{'archname'} !~ /RM\d\d\d-svr4/ )
&& ( $thislib .= "_s" ) )
{ # we must explicitly use _s version
}
elsif ( -f ( $fullname = "$thispth/lib$thislib$Config_libext" ) ) {
}
elsif ( defined( $Config_dlext )
&& -f ( $fullname = "$thispth/lib$thislib.$Config_dlext" ) )
{
}
elsif ( -f ( $fullname = "$thispth/$thislib$Config_libext" ) ) {
}
elsif ( -f ( $fullname = "$thispth/lib$thislib.dll$Config_libext" ) ) {
}
elsif ( -f ( $fullname = "$thispth/Slib$thislib$Config_libext" ) ) {
}
elsif ($^O eq 'dgux'
&& -l ( $fullname = "$thispth/lib$thislib$Config_libext" )
&& readlink( $fullname ) =~ /^elink:/s )
{
# Some of DG's libraries look like misconnected symbolic
# links, but development tools can follow them. (They
# look like this:
#
# libm.a -> elink:${SDE_PATH:-/usr}/sde/\
# ${TARGET_BINARY_INTERFACE:-m88kdgux}/usr/lib/libm.a
#
# , the compilation tools expand the environment variables.)
}
else {
warn "$thislib not found in $thispth\n" if $verbose;
next;
}
warn "'-l$thislib' found at $fullname\n" if $verbose;
push @libs, $fullname unless $libs_seen{$fullname}++;
$found++;
$found_lib++;
# Now update library lists
# what do we know about this library...
my $is_dyna = ( $fullname !~ /\Q$Config_libext\E\z/ );
my $in_perl = ( $libs =~ /\B-l\Q${thislib}\E\b/s );
# include the path to the lib once in the dynamic linker path
# but only if it is a dynamic lib and not in Perl itself
my ( $fullnamedir ) = dirname( $fullname );
push @ld_run_path, $fullnamedir
if $is_dyna
&& !$in_perl
&& !$ld_run_path_seen{$fullnamedir}++;
# Do not add it into the list if it is already linked in
# with the main perl executable.
# We have to special-case the NeXT, because math and ndbm
# are both in libsys_s
unless (
$in_perl
|| ( $Config{'osname'} eq 'next'
&& ( $thislib eq 'm' || $thislib eq 'ndbm' ) )
)
{
push( @extralibs, "-l$thislib" );
}
# We might be able to load this archive file dynamically
if ( ( $Config{'dlsrc'} =~ /dl_next/ && $Config{'osvers'} lt '4_0' )
|| ( $Config{'dlsrc'} =~ /dl_dld/ ) )
{
# We push -l$thislib instead of $fullname because
# it avoids hardwiring a fixed path into the .bs file.
# Mkbootstrap will automatically add dl_findfile() to
# the .bs file if it sees a name in the -l format.
# USE THIS, when dl_findfile() is fixed:
# push(@bsloadlibs, "-l$thislib");
# OLD USE WAS while checking results against old_extliblist
push( @bsloadlibs, "$fullname" );
}
else {
if ( $is_dyna ) {
# For SunOS4, do not add in this shared library if
# it is already linked in the main perl executable
push( @ldloadlibs, "-l$thislib" )
unless ( $in_perl and $^O eq 'sunos' );
}
else {
push( @ldloadlibs, "-l$thislib" );
}
}
last; # found one here so don't bother looking further
}
warn "Warning (mostly harmless): " . "No library found for -l$thislib\n"
unless $found_lib > 0;
}
unless ( $found ) {
return ( '', '', '', '', ( $give_libs ? \@libs : () ) );
}
else {
return ( "@extralibs", "@bsloadlibs", "@ldloadlibs", join( ":", @ld_run_path ), ( $give_libs ? \@libs : () ) );
}
}
sub _win32_ext {
require Text::ParseWords;
my ( $self, $potential_libs, $verbose, $give_libs ) = @_;
$verbose ||= 0;
# If user did not supply a list, we punt.
# (caller should probably use the list in $Config{libs})
return ( "", "", "", "", ( $give_libs ? [] : () ) ) unless $potential_libs;
# TODO: make this use MM_Win32.pm's compiler detection
my %libs_seen;
my @extralibs;
my $cc = $Config{cc} || '';
my $VC = $cc =~ /\bcl\b/i;
my $GC = $cc =~ /\bgcc\b/i;
my $libext = _win32_lib_extensions();
my @searchpath = ( '' ); # from "-L/path" entries in $potential_libs
my @libpath = _win32_default_search_paths( $VC, $GC );
my $pwd = cwd(); # from Cwd.pm
my $search = 1;
# compute @extralibs from $potential_libs
my @lib_search_list = _win32_make_lib_search_list( $potential_libs, $verbose );
for ( @lib_search_list ) {
my $thislib = $_;
# see if entry is a flag
if ( /^:\w+$/ ) {
$search = 0 if lc eq ':nosearch';
$search = 1 if lc eq ':search';
_debug( "Ignoring unknown flag '$thislib'\n", $verbose ) if !/^:(no)?(search|default)$/i;
next;
}
# if searching is disabled, do compiler-specific translations
unless ( $search ) {
s/^-l(.+)$/$1.lib/ unless $GC;
s/^-L/-libpath:/ if $VC;
push( @extralibs, $_ );
next;
}
# handle possible linker path arguments
if ( s/^-L// and not -d ) {
_debug( "$thislib ignored, directory does not exist\n", $verbose );
next;
}
elsif ( -d ) {
unless ( File::Spec->file_name_is_absolute( $_ ) ) {
warn "Warning: '$thislib' changed to '-L$pwd/$_'\n";
$_ = $self->catdir( $pwd, $_ );
}
push( @searchpath, $_ );
next;
}
my @paths = ( @searchpath, @libpath );
my ( $fullname, $path ) = _win32_search_file( $thislib, $libext, \@paths, $verbose, $GC );
if ( !$fullname ) {
warn "Warning (mostly harmless): No library found for $thislib\n";
next;
}
_debug( "'$thislib' found as '$fullname'\n", $verbose );
push( @extralibs, $fullname );
$libs_seen{$fullname} = 1 if $path; # why is this a special case?
}
my @libs = keys %libs_seen;
return ( '', '', '', '', ( $give_libs ? \@libs : () ) ) unless @extralibs;
# make sure paths with spaces are properly quoted
@extralibs = map { /\s/ ? qq["$_"] : $_ } @extralibs;
@libs = map { /\s/ ? qq["$_"] : $_ } @libs;
my $lib = join( ' ', @extralibs );
# normalize back to backward slashes (to help braindead tools)
# XXX this may break equally braindead GNU tools that don't understand
# backslashes, either. Seems like one can't win here. Cursed be CP/M.
$lib =~ s,/,\\,g;
_debug( "Result: $lib\n", $verbose );
wantarray ? ( $lib, '', $lib, '', ( $give_libs ? \@libs : () ) ) : $lib;
}
sub _win32_make_lib_search_list {
my ( $potential_libs, $verbose ) = @_;
# If Config.pm defines a set of default libs, we always
# tack them on to the user-supplied list, unless the user
# specified :nodefault
my $libs = $Config{'perllibs'};
$potential_libs = join( ' ', $potential_libs, $libs ) if $libs and $potential_libs !~ /:nodefault/i;
_debug( "Potential libraries are '$potential_libs':\n", $verbose );
$potential_libs =~ s,\\,/,g; # normalize to forward slashes
my @list = Text::ParseWords::quotewords( '\s+', 0, $potential_libs );
return @list;
}
sub _win32_default_search_paths {
my ( $VC, $GC ) = @_;
my $libpth = $Config{'libpth'} || '';
$libpth =~ s,\\,/,g; # normalize to forward slashes
my @libpath = Text::ParseWords::quotewords( '\s+', 0, $libpth );
push @libpath, "$Config{installarchlib}/CORE"; # add "$Config{installarchlib}/CORE" to default search path
push @libpath, split /;/, $ENV{LIB} if $VC and $ENV{LIB};
push @libpath, split /;/, $ENV{LIBRARY_PATH} if $GC and $ENV{LIBRARY_PATH};
return @libpath;
}
sub _win32_search_file {
my ( $thislib, $libext, $paths, $verbose, $GC ) = @_;
my @file_list = _win32_build_file_list( $thislib, $GC, $libext );
for my $lib_file ( @file_list ) {
for my $path ( @{$paths} ) {
my $fullname = $lib_file;
$fullname = "$path\\$fullname" if $path;
return ( $fullname, $path ) if -f $fullname;
_debug( "'$thislib' not found as '$fullname'\n", $verbose );
}
}
return;
}
sub _win32_build_file_list {
my ( $lib, $GC, $extensions ) = @_;
my @pre_fixed = _win32_build_prefixed_list( $lib, $GC );
return map _win32_attach_extensions( $_, $extensions ), @pre_fixed;
}
sub _win32_build_prefixed_list {
my ( $lib, $GC ) = @_;
return $lib if $lib !~ s/^-l//;
return $lib if $lib =~ /^lib/ and !$GC;
( my $no_prefix = $lib ) =~ s/^lib//i;
$lib = "lib$lib" if $no_prefix eq $lib;
return ( $lib, $no_prefix ) if $GC;
return ( $no_prefix, $lib );
}
sub _win32_attach_extensions {
my ( $lib, $extensions ) = @_;
return map _win32_try_attach_extension( $lib, $_ ), @{$extensions};
}
sub _win32_try_attach_extension {
my ( $lib, $extension ) = @_;
return $lib if $lib =~ /\Q$extension\E$/i;
return "$lib$extension";
}
sub _win32_lib_extensions {
my %extensions;
$extensions{ $Config{'lib_ext'} } = 1 if $Config{'lib_ext'};
$extensions{".lib"} = 1;
return [ keys %extensions ];
}
sub _debug {
my ( $message, $verbose ) = @_;
return if !$verbose;
warn $message;
return;
}
sub _vms_ext {
my ( $self, $potential_libs, $verbose, $give_libs ) = @_;
$verbose ||= 0;
my ( @crtls, $crtlstr );
@crtls = ( ( $Config{'ldflags'} =~ m-/Debug-i ? $Config{'dbgprefix'} : '' ) . 'PerlShr/Share' );
push( @crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'} );
push( @crtls, grep { not /\(/ } split /\s+/, $Config{'libc'} );
# In general, we pass through the basic libraries from %Config unchanged.
# The one exception is that if we're building in the Perl source tree, and
# a library spec could be resolved via a logical name, we go to some trouble
# to insure that the copy in the local tree is used, rather than one to
# which a system-wide logical may point.
if ( $self->{PERL_SRC} ) {
my ( $locspec, $type );
foreach my $lib ( @crtls ) {
if ( ( $locspec, $type ) = $lib =~ m{^([\w\$-]+)(/\w+)?} and $locspec =~ /perl/i ) {
if ( lc $type eq '/share' ) { $locspec .= $Config{'exe_ext'}; }
elsif ( lc $type eq '/library' ) { $locspec .= $Config{'lib_ext'}; }
else { $locspec .= $Config{'obj_ext'}; }
$locspec = $self->catfile( $self->{PERL_SRC}, $locspec );
$lib = "$locspec$type" if -e $locspec;
}
}
}
$crtlstr = @crtls ? join( ' ', @crtls ) : '';
unless ( $potential_libs ) {
warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose;
return ( '', '', $crtlstr, '', ( $give_libs ? [] : () ) );
}
my ( %found, @fndlibs, $ldlib );
my $cwd = cwd();
my ( $so, $lib_ext, $obj_ext ) = @Config{ 'so', 'lib_ext', 'obj_ext' };
# List of common Unix library names and their VMS equivalents
# (VMS equivalent of '' indicates that the library is automatically
# searched by the linker, and should be skipped here.)
my ( @flibs, %libs_seen );
my %libmap = (
'm' => '',
'f77' => '',
'F77' => '',
'V77' => '',
'c' => '',
'malloc' => '',
'crypt' => '',
'resolv' => '',
'c_s' => '',
'socket' => '',
'X11' => 'DECW$XLIBSHR',
'Xt' => 'DECW$XTSHR',
'Xm' => 'DECW$XMLIBSHR',
'Xmu' => 'DECW$XMULIBSHR'
);
if ( $Config{'vms_cc_type'} ne 'decc' ) { $libmap{'curses'} = 'VAXCCURSE'; }
warn "Potential libraries are '$potential_libs'\n" if $verbose;
# First, sort out directories and library names in the input
my ( @dirs, @libs );
foreach my $lib ( split ' ', $potential_libs ) {
push( @dirs, $1 ), next if $lib =~ /^-L(.*)/;
push( @dirs, $lib ), next if $lib =~ /[:>\]]$/;
push( @dirs, $lib ), next if -d $lib;
push( @libs, $1 ), next if $lib =~ /^-l(.*)/;
push( @libs, $lib );
}
push( @dirs, split( ' ', $Config{'libpth'} ) );
# Now make sure we've got VMS-syntax absolute directory specs
# (We don't, however, check whether someone's hidden a relative
# path in a logical name.)
foreach my $dir ( @dirs ) {
unless ( -d $dir ) {
warn "Skipping nonexistent Directory $dir\n" if $verbose > 1;
$dir = '';
next;
}
warn "Resolving directory $dir\n" if $verbose;
if ( File::Spec->file_name_is_absolute( $dir ) ) {
$dir = $self->fixpath( $dir, 1 );
}
else {
$dir = $self->catdir( $cwd, $dir );
}
}
@dirs = grep { length( $_ ) } @dirs;
unshift( @dirs, '' ); # Check each $lib without additions first
LIB: foreach my $lib ( @libs ) {
if ( exists $libmap{$lib} ) {
next unless length $libmap{$lib};
$lib = $libmap{$lib};
}
my ( @variants, $cand );
my ( $ctype ) = '';
# If we don't have a file type, consider it a possibly abbreviated name and
# check for common variants. We try these first to grab libraries before
# a like-named executable image (e.g. -lperl resolves to perlshr.exe
# before perl.exe).
if ( $lib !~ /\.[^:>\]]*$/ ) {
push( @variants, "${lib}shr", "${lib}rtl", "${lib}lib" );
push( @variants, "lib$lib" ) if $lib !~ /[:>\]]/;
}
push( @variants, $lib );
warn "Looking for $lib\n" if $verbose;
foreach my $variant ( @variants ) {
my ( $fullname, $name );
foreach my $dir ( @dirs ) {
my ( $type );
$name = "$dir$variant";
warn "\tChecking $name\n" if $verbose > 2;
$fullname = VMS::Filespec::rmsexpand( $name );
if ( defined $fullname and -f $fullname ) {
# It's got its own suffix, so we'll have to figure out the type
if ( $fullname =~ /(?:$so|exe)$/i ) { $type = 'SHR'; }
elsif ( $fullname =~ /(?:$lib_ext|olb)$/i ) { $type = 'OLB'; }
elsif ( $fullname =~ /(?:$obj_ext|obj)$/i ) {
warn "Warning (mostly harmless): " . "Plain object file $fullname found in library list\n";
$type = 'OBJ';
}
else {
warn "Warning (mostly harmless): " . "Unknown library type for $fullname; assuming shared\n";
$type = 'SHR';
}
}
elsif (-f ( $fullname = VMS::Filespec::rmsexpand( $name, $so ) )
or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.exe' ) ) )
{
$type = 'SHR';
$name = $fullname unless $fullname =~ /exe;?\d*$/i;
}
elsif (
not length( $ctype ) and # If we've got a lib already,
# don't bother
( -f ( $fullname = VMS::Filespec::rmsexpand( $name, $lib_ext ) ) or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.olb' ) ) )
)
{
$type = 'OLB';
$name = $fullname unless $fullname =~ /olb;?\d*$/i;
}
elsif (
not length( $ctype ) and # If we've got a lib already,
# don't bother
( -f ( $fullname = VMS::Filespec::rmsexpand( $name, $obj_ext ) ) or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.obj' ) ) )
)
{
warn "Warning (mostly harmless): " . "Plain object file $fullname found in library list\n";
$type = 'OBJ';
$name = $fullname unless $fullname =~ /obj;?\d*$/i;
}
if ( defined $type ) {
$ctype = $type;
$cand = $name;
last if $ctype eq 'SHR';
}
}
if ( $ctype ) {
# This has to precede any other CRTLs, so just make it first
if ( $cand eq 'VAXCCURSE' ) { unshift @{ $found{$ctype} }, $cand; }
else { push @{ $found{$ctype} }, $cand; }
warn "\tFound as $cand (really $fullname), type $ctype\n"
if $verbose > 1;
push @flibs, $name unless $libs_seen{$fullname}++;
next LIB;
}
}
warn "Warning (mostly harmless): " . "No library found for $lib\n";
}
push @fndlibs, @{ $found{OBJ} } if exists $found{OBJ};
push @fndlibs, map { "$_/Library" } @{ $found{OLB} } if exists $found{OLB};
push @fndlibs, map { "$_/Share" } @{ $found{SHR} } if exists $found{SHR};
my $lib = join( ' ', @fndlibs );
$ldlib = $crtlstr ? "$lib $crtlstr" : $lib;
warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose;
wantarray ? ( $lib, '', $ldlib, '', ( $give_libs ? \@flibs : () ) ) : $lib;
}
1;
EXTUTILS_LIBLIST_KID
$fatpacked{"ExtUtils/MM.pm"} = <<'EXTUTILS_MM';
package ExtUtils::MM;
use strict;
use ExtUtils::MakeMaker::Config;
our $VERSION = '6.64';
require ExtUtils::Liblist;
require ExtUtils::MakeMaker;
our @ISA = qw(ExtUtils::Liblist ExtUtils::MakeMaker);
=head1 NAME
ExtUtils::MM - OS adjusted ExtUtils::MakeMaker subclass
=head1 SYNOPSIS
require ExtUtils::MM;
my $mm = MM->new(...);
=head1 DESCRIPTION
B<FOR INTERNAL USE ONLY>
ExtUtils::MM is a subclass of ExtUtils::MakeMaker which automatically
chooses the appropriate OS specific subclass for you
(ie. ExtUils::MM_Unix, etc...).
It also provides a convenient alias via the MM class (I didn't want
MakeMaker modules outside of ExtUtils/).
This class might turn out to be a temporary solution, but MM won't go
away.
=cut
{
# Convenient alias.
package MM;
our @ISA = qw(ExtUtils::MM);
sub DESTROY {}
}
sub _is_win95 {
# miniperl might not have the Win32 functions available and we need
# to run in miniperl.
my $have_win32 = eval { require Win32 };
return $have_win32 && defined &Win32::IsWin95 ? Win32::IsWin95()
: ! defined $ENV{SYSTEMROOT};
}
my %Is = ();
$Is{VMS} = $^O eq 'VMS';
$Is{OS2} = $^O eq 'os2';
$Is{MacOS} = $^O eq 'MacOS';
if( $^O eq 'MSWin32' ) {
_is_win95() ? $Is{Win95} = 1 : $Is{Win32} = 1;
}
$Is{UWIN} = $^O =~ /^uwin(-nt)?$/;
$Is{Cygwin} = $^O eq 'cygwin';
$Is{NW5} = $Config{osname} eq 'NetWare'; # intentional
$Is{BeOS} = ($^O =~ /beos/i or $^O eq 'haiku');
$Is{DOS} = $^O eq 'dos';
if( $Is{NW5} ) {
$^O = 'NetWare';
delete $Is{Win32};
}
$Is{VOS} = $^O eq 'vos';
$Is{QNX} = $^O eq 'qnx';
$Is{AIX} = $^O eq 'aix';
$Is{Darwin} = $^O eq 'darwin';
$Is{Unix} = !grep { $_ } values %Is;
map { delete $Is{$_} unless $Is{$_} } keys %Is;
_assert( keys %Is == 1 );
my($OS) = keys %Is;
my $class = "ExtUtils::MM_$OS";
eval "require $class" unless $INC{"ExtUtils/MM_$OS.pm"}; ## no critic
die $@ if $@;
unshift @ISA, $class;
sub _assert {
my $sanity = shift;
die sprintf "Assert failed at %s line %d\n", (caller)[1,2] unless $sanity;
return;
}
EXTUTILS_MM
$fatpacked{"ExtUtils/MM_AIX.pm"} = <<'EXTUTILS_MM_AIX';
package ExtUtils::MM_AIX;
use strict;
our $VERSION = '6.64';
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
use ExtUtils::MakeMaker qw(neatvalue);
=head1 NAME
ExtUtils::MM_AIX - AIX specific subclass of ExtUtils::MM_Unix
=head1 SYNOPSIS
Don't use this module directly.
Use ExtUtils::MM and let it choose.
=head1 DESCRIPTION
This is a subclass of ExtUtils::MM_Unix which contains functionality for
AIX.
Unless otherwise stated it works just like ExtUtils::MM_Unix
=head2 Overridden methods
=head3 dlsyms
Define DL_FUNCS and DL_VARS and write the *.exp files.
=cut
sub dlsyms {
my($self,%attribs) = @_;
return '' unless $self->needs_linking();
my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
my(@m);
push(@m,"
dynamic :: $self->{BASEEXT}.exp
") unless $self->{SKIPHASH}{'dynamic'}; # dynamic and static are subs, so...
push(@m,"
static :: $self->{BASEEXT}.exp
") unless $self->{SKIPHASH}{'static'}; # we avoid a warning if we tick them
push(@m,"
$self->{BASEEXT}.exp: Makefile.PL
",' $(PERLRUN) -e \'use ExtUtils::Mksymlists; \\
Mksymlists("NAME" => "',$self->{NAME},'", "DL_FUNCS" => ',
neatvalue($funcs), ', "FUNCLIST" => ', neatvalue($funclist),
', "DL_VARS" => ', neatvalue($vars), ');\'
');
join('',@m);
}
=head1 AUTHOR
Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix
=head1 SEE ALSO
L<ExtUtils::MakeMaker>
=cut
1;
EXTUTILS_MM_AIX
$fatpacked{"ExtUtils/MM_Any.pm"} = <<'EXTUTILS_MM_ANY';
package ExtUtils::MM_Any;
use strict;
our $VERSION = '6.64';
use Carp;
use File::Spec;
use File::Basename;
BEGIN { our @ISA = qw(File::Spec); }
# We need $Verbose
use ExtUtils::MakeMaker qw($Verbose);
use ExtUtils::MakeMaker::Config;
# So we don't have to keep calling the methods over and over again,
# we have these globals to cache the values. Faster and shrtr.
my $Curdir = __PACKAGE__->curdir;
my $Rootdir = __PACKAGE__->rootdir;
my $Updir = __PACKAGE__->updir;
=head1 NAME
ExtUtils::MM_Any - Platform-agnostic MM methods
=head1 SYNOPSIS
FOR INTERNAL USE ONLY!
package ExtUtils::MM_SomeOS;
# Temporarily, you have to subclass both. Put MM_Any first.
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
@ISA = qw(ExtUtils::MM_Any ExtUtils::Unix);
=head1 DESCRIPTION
B<FOR INTERNAL USE ONLY!>
ExtUtils::MM_Any is a superclass for the ExtUtils::MM_* set of
modules. It contains methods which are either inherently
cross-platform or are written in a cross-platform manner.
Subclass off of ExtUtils::MM_Any I<and> ExtUtils::MM_Unix. This is a
temporary solution.
B<THIS MAY BE TEMPORARY!>
=head1 METHODS
Any methods marked I<Abstract> must be implemented by subclasses.
=head2 Cross-platform helper methods
These are methods which help writing cross-platform code.
=head3 os_flavor I<Abstract>
my @os_flavor = $mm->os_flavor;
@os_flavor is the style of operating system this is, usually
corresponding to the MM_*.pm file we're using.
The first element of @os_flavor is the major family (ie. Unix,
Windows, VMS, OS/2, etc...) and the rest are sub families.
Some examples:
Cygwin98 ('Unix', 'Cygwin', 'Cygwin9x')
Windows ('Win32')
Win98 ('Win32', 'Win9x')
Linux ('Unix', 'Linux')
MacOS X ('Unix', 'Darwin', 'MacOS', 'MacOS X')
OS/2 ('OS/2')
This is used to write code for styles of operating system.
See os_flavor_is() for use.
=head3 os_flavor_is
my $is_this_flavor = $mm->os_flavor_is($this_flavor);
my $is_this_flavor = $mm->os_flavor_is(@one_of_these_flavors);
Checks to see if the current operating system is one of the given flavors.
This is useful for code like:
if( $mm->os_flavor_is('Unix') ) {
$out = `foo 2>&1`;
}
else {
$out = `foo`;
}
=cut
sub os_flavor_is {
my $self = shift;
my %flavors = map { ($_ => 1) } $self->os_flavor;
return (grep { $flavors{$_} } @_) ? 1 : 0;
}
=head3 can_load_xs
my $can_load_xs = $self->can_load_xs;
Returns true if we have the ability to load XS.
This is important because miniperl, used to build XS modules in the
core, can not load XS.
=cut
sub can_load_xs {
return defined &DynaLoader::boot_DynaLoader ? 1 : 0;
}
=head3 split_command
my @cmds = $MM->split_command($cmd, @args);
Most OS have a maximum command length they can execute at once. Large
modules can easily generate commands well past that limit. Its
necessary to split long commands up into a series of shorter commands.
C<split_command> will return a series of @cmds each processing part of
the args. Collectively they will process all the arguments. Each
individual line in @cmds will not be longer than the
$self->max_exec_len being careful to take into account macro expansion.
$cmd should include any switches and repeated initial arguments.
If no @args are given, no @cmds will be returned.
Pairs of arguments will always be preserved in a single command, this
is a heuristic for things like pm_to_blib and pod2man which work on
pairs of arguments. This makes things like this safe:
$self->split_command($cmd, %pod2man);
=cut
sub split_command {
my($self, $cmd, @args) = @_;
my @cmds = ();
return(@cmds) unless @args;
# If the command was given as a here-doc, there's probably a trailing
# newline.
chomp $cmd;
# set aside 30% for macro expansion.
my $len_left = int($self->max_exec_len * 0.70);
$len_left -= length $self->_expand_macros($cmd);
do {
my $arg_str = '';
my @next_args;
while( @next_args = splice(@args, 0, 2) ) {
# Two at a time to preserve pairs.
my $next_arg_str = "\t ". join ' ', @next_args, "\n";
if( !length $arg_str ) {
$arg_str .= $next_arg_str
}
elsif( length($arg_str) + length($next_arg_str) > $len_left ) {
unshift @args, @next_args;
last;
}
else {
$arg_str .= $next_arg_str;
}
}
chop $arg_str;
push @cmds, $self->escape_newlines("$cmd \n$arg_str");
} while @args;
return @cmds;
}
sub _expand_macros {
my($self, $cmd) = @_;
$cmd =~ s{\$\((\w+)\)}{
defined $self->{$1} ? $self->{$1} : "\$($1)"
}e;
return $cmd;
}
=head3 echo
my @commands = $MM->echo($text);
my @commands = $MM->echo($text, $file);
my @commands = $MM->echo($text, $file, \%opts);
Generates a set of @commands which print the $text to a $file.
If $file is not given, output goes to STDOUT.
If $opts{append} is true the $file will be appended to rather than
overwritten. Default is to overwrite.
If $opts{allow_variables} is true, make variables of the form
C<$(...)> will not be escaped. Other C<$> will. Default is to escape
all C<$>.
Example of use:
my $make = map "\t$_\n", $MM->echo($text, $file);
=cut
sub echo {
my($self, $text, $file, $opts) = @_;
# Compatibility with old options
if( !ref $opts ) {
my $append = $opts;
$opts = { append => $append || 0 };
}
$opts->{allow_variables} = 0 unless defined $opts->{allow_variables};
my $ql_opts = { allow_variables => $opts->{allow_variables} };
my @cmds = map { '$(NOECHO) $(ECHO) '.$self->quote_literal($_, $ql_opts) }
split /\n/, $text;
if( $file ) {
my $redirect = $opts->{append} ? '>>' : '>';
$cmds[0] .= " $redirect $file";
$_ .= " >> $file" foreach @cmds[1..$#cmds];
}
return @cmds;
}
=head3 wraplist
my $args = $mm->wraplist(@list);
Takes an array of items and turns them into a well-formatted list of
arguments. In most cases this is simply something like:
FOO \
BAR \
BAZ
=cut
sub wraplist {
my $self = shift;
return join " \\\n\t", @_;
}
=head3 maketext_filter
my $filter_make_text = $mm->maketext_filter($make_text);
The text of the Makefile is run through this method before writing to
disk. It allows systems a chance to make portability fixes to the
Makefile.
By default it does nothing.
This method is protected and not intended to be called outside of
MakeMaker.
=cut
sub maketext_filter { return $_[1] }
=head3 cd I<Abstract>
my $subdir_cmd = $MM->cd($subdir, @cmds);
This will generate a make fragment which runs the @cmds in the given
$dir. The rough equivalent to this, except cross platform.
cd $subdir && $cmd
Currently $dir can only go down one level. "foo" is fine. "foo/bar" is
not. "../foo" is right out.
The resulting $subdir_cmd has no leading tab nor trailing newline. This
makes it easier to embed in a make string. For example.
my $make = sprintf <<'CODE', $subdir_cmd;
foo :
$(ECHO) what
%s
$(ECHO) mouche
CODE
=head3 oneliner I<Abstract>
my $oneliner = $MM->oneliner($perl_code);
my $oneliner = $MM->oneliner($perl_code, \@switches);
This will generate a perl one-liner safe for the particular platform
you're on based on the given $perl_code and @switches (a -e is
assumed) suitable for using in a make target. It will use the proper
shell quoting and escapes.
$(PERLRUN) will be used as perl.
Any newlines in $perl_code will be escaped. Leading and trailing
newlines will be stripped. Makes this idiom much easier:
my $code = $MM->oneliner(<<'CODE', [...switches...]);
some code here
another line here
CODE
Usage might be something like:
# an echo emulation
$oneliner = $MM->oneliner('print "Foo\n"');
$make = '$oneliner > somefile';
All dollar signs must be doubled in the $perl_code if you expect them
to be interpreted normally, otherwise it will be considered a make
macro. Also remember to quote make macros else it might be used as a
bareword. For example:
# Assign the value of the $(VERSION_FROM) make macro to $vf.
$oneliner = $MM->oneliner('$$vf = "$(VERSION_FROM)"');
Its currently very simple and may be expanded sometime in the figure
to include more flexible code and switches.
=head3 quote_literal I<Abstract>
my $safe_text = $MM->quote_literal($text);
my $safe_text = $MM->quote_literal($text, \%options);
This will quote $text so it is interpreted literally in the shell.
For example, on Unix this would escape any single-quotes in $text and
put single-quotes around the whole thing.
If $options{allow_variables} is true it will leave C<'$(FOO)'> make
variables untouched. If false they will be escaped like any other
C<$>. Defaults to true.
=head3 escape_dollarsigns
my $escaped_text = $MM->escape_dollarsigns($text);
Escapes stray C<$> so they are not interpreted as make variables.
It lets by C<$(...)>.
=cut
sub escape_dollarsigns {
my($self, $text) = @_;
# Escape dollar signs which are not starting a variable
$text =~ s{\$ (?!\() }{\$\$}gx;
return $text;
}
=head3 escape_all_dollarsigns
my $escaped_text = $MM->escape_all_dollarsigns($text);
Escapes all C<$> so they are not interpreted as make variables.
=cut
sub escape_all_dollarsigns {
my($self, $text) = @_;
# Escape dollar signs
$text =~ s{\$}{\$\$}gx;
return $text;
}
=head3 escape_newlines I<Abstract>
my $escaped_text = $MM->escape_newlines($text);
Shell escapes newlines in $text.
=head3 max_exec_len I<Abstract>
my $max_exec_len = $MM->max_exec_len;
Calculates the maximum command size the OS can exec. Effectively,
this is the max size of a shell command line.
=for _private
$self->{_MAX_EXEC_LEN} is set by this method, but only for testing purposes.
=head3 make
my $make = $MM->make;
Returns the make variant we're generating the Makefile for. This attempts
to do some normalization on the information from %Config or the user.
=cut
sub make {
my $self = shift;
my $make = lc $self->{MAKE};
# Truncate anything like foomake6 to just foomake.
$make =~ s/^(\w+make).*/$1/;
# Turn gnumake into gmake.
$make =~ s/^gnu/g/;
return $make;
}
=head2 Targets
These are methods which produce make targets.
=head3 all_target
Generate the default target 'all'.
=cut
sub all_target {
my $self = shift;
return <<'MAKE_EXT';
all :: pure_all
$(NOECHO) $(NOOP)
MAKE_EXT
}
=head3 blibdirs_target
my $make_frag = $mm->blibdirs_target;
Creates the blibdirs target which creates all the directories we use
in blib/.
The blibdirs.ts target is deprecated. Depend on blibdirs instead.
=cut
sub blibdirs_target {
my $self = shift;
my @dirs = map { uc "\$(INST_$_)" } qw(libdir archlib
autodir archautodir
bin script
man1dir man3dir
);
my @exists = map { $_.'$(DFSEP).exists' } @dirs;
my $make = sprintf <<'MAKE', join(' ', @exists);
blibdirs : %s
$(NOECHO) $(NOOP)
# Backwards compat with 6.18 through 6.25
blibdirs.ts : blibdirs
$(NOECHO) $(NOOP)
MAKE
$make .= $self->dir_target(@dirs);
return $make;
}
=head3 clean (o)
Defines the clean target.
=cut
sub clean {
# --- Cleanup and Distribution Sections ---
my($self, %attribs) = @_;
my @m;
push(@m, '
# Delete temporary files but do not touch installed files. We don\'t delete
# the Makefile here so a later make realclean still has a makefile to use.
clean :: clean_subdirs
');
my @files = values %{$self->{XS}}; # .c files from *.xs files
my @dirs = qw(blib);
# Normally these are all under blib but they might have been
# redefined.
# XXX normally this would be a good idea, but the Perl core sets
# INST_LIB = ../../lib rather than actually installing the files.
# So a "make clean" in an ext/ directory would blow away lib.
# Until the core is adjusted let's leave this out.
# push @dirs, qw($(INST_ARCHLIB) $(INST_LIB)
# $(INST_BIN) $(INST_SCRIPT)
# $(INST_MAN1DIR) $(INST_MAN3DIR)
# $(INST_LIBDIR) $(INST_ARCHLIBDIR) $(INST_AUTODIR)
# $(INST_STATIC) $(INST_DYNAMIC) $(INST_BOOT)
# );
if( $attribs{FILES} ) {
# Use @dirs because we don't know what's in here.
push @dirs, ref $attribs{FILES} ?
@{$attribs{FILES}} :
split /\s+/, $attribs{FILES} ;
}
push(@files, qw[$(MAKE_APERL_FILE)
MYMETA.json MYMETA.yml perlmain.c tmon.out mon.out so_locations
blibdirs.ts pm_to_blib pm_to_blib.ts
*$(OBJ_EXT) *$(LIB_EXT) perl.exe perl perl$(EXE_EXT)
$(BOOTSTRAP) $(BASEEXT).bso
$(BASEEXT).def lib$(BASEEXT).def
$(BASEEXT).exp $(BASEEXT).x
]);
push(@files, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'));
push(@files, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.ld'));
# core files
push(@files, qw[core core.*perl.*.? *perl.core]);
push(@files, map { "core." . "[0-9]"x$_ } (1..5));
# OS specific things to clean up. Use @dirs since we don't know
# what might be in here.
push @dirs, $self->extra_clean_files;
# Occasionally files are repeated several times from different sources
{ my(%f) = map { ($_ => 1) } @files; @files = keys %f; }
{ my(%d) = map { ($_ => 1) } @dirs; @dirs = keys %d; }
push @m, map "\t$_\n", $self->split_command('- $(RM_F)', @files);
push @m, map "\t$_\n", $self->split_command('- $(RM_RF)', @dirs);
# Leave Makefile.old around for realclean
push @m, <<'MAKE';
- $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) $(DEV_NULL)
MAKE
push(@m, "\t$attribs{POSTOP}\n") if $attribs{POSTOP};
join("", @m);
}
=head3 clean_subdirs_target
my $make_frag = $MM->clean_subdirs_target;
Returns the clean_subdirs target. This is used by the clean target to
call clean on any subdirectories which contain Makefiles.
=cut
sub clean_subdirs_target {
my($self) = shift;
# No subdirectories, no cleaning.
return <<'NOOP_FRAG' unless @{$self->{DIR}};
clean_subdirs :
$(NOECHO) $(NOOP)
NOOP_FRAG
my $clean = "clean_subdirs :\n";
for my $dir (@{$self->{DIR}}) {
my $subclean = $self->oneliner(sprintf <<'CODE', $dir);
chdir '%s'; system '$(MAKE) clean' if -f '$(FIRST_MAKEFILE)';
CODE
$clean .= "\t$subclean\n";
}
return $clean;
}
=head3 dir_target
my $make_frag = $mm->dir_target(@directories);
Generates targets to create the specified directories and set its
permission to PERM_DIR.
Because depending on a directory to just ensure it exists doesn't work
too well (the modified time changes too often) dir_target() creates a
.exists file in the created directory. It is this you should depend on.
For portability purposes you should use the $(DIRFILESEP) macro rather
than a '/' to seperate the directory from the file.
yourdirectory$(DIRFILESEP).exists
=cut
sub dir_target {
my($self, @dirs) = @_;
my $make = '';
foreach my $dir (@dirs) {
$make .= sprintf <<'MAKE', ($dir) x 7;
%s$(DFSEP).exists :: Makefile.PL
$(NOECHO) $(MKPATH) %s
$(NOECHO) $(CHMOD) $(PERM_DIR) %s
$(NOECHO) $(TOUCH) %s$(DFSEP).exists
MAKE
}
return $make;
}
=head3 distdir
Defines the scratch directory target that will hold the distribution
before tar-ing (or shar-ing).
=cut
# For backwards compatibility.
*dist_dir = *distdir;
sub distdir {
my($self) = shift;
my $meta_target = $self->{NO_META} ? '' : 'distmeta';
my $sign_target = !$self->{SIGN} ? '' : 'distsignature';
return sprintf <<'MAKE_FRAG', $meta_target, $sign_target;
create_distdir :
$(RM_RF) $(DISTVNAME)
$(PERLRUN) "-MExtUtils::Manifest=manicopy,maniread" \
-e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');"
distdir : create_distdir %s %s
$(NOECHO) $(NOOP)
MAKE_FRAG
}
=head3 dist_test
Defines a target that produces the distribution in the
scratchdirectory, and runs 'perl Makefile.PL; make ;make test' in that
subdirectory.
=cut
sub dist_test {
my($self) = shift;
my $mpl_args = join " ", map qq["$_"], @ARGV;
my $test = $self->cd('$(DISTVNAME)',
'$(ABSPERLRUN) Makefile.PL '.$mpl_args,
'$(MAKE) $(PASTHRU)',
'$(MAKE) test $(PASTHRU)'
);
return sprintf <<'MAKE_FRAG', $test;
disttest : distdir
%s
MAKE_FRAG
}
=head3 dynamic (o)
Defines the dynamic target.
=cut
sub dynamic {
# --- Dynamic Loading Sections ---
my($self) = shift;
'
dynamic :: $(FIRST_MAKEFILE) $(INST_DYNAMIC) $(INST_BOOT)
$(NOECHO) $(NOOP)
';
}
=head3 makemakerdflt_target
my $make_frag = $mm->makemakerdflt_target
Returns a make fragment with the makemakerdeflt_target specified.
This target is the first target in the Makefile, is the default target
and simply points off to 'all' just in case any make variant gets
confused or something gets snuck in before the real 'all' target.
=cut
sub makemakerdflt_target {
return <<'MAKE_FRAG';
makemakerdflt : all
$(NOECHO) $(NOOP)
MAKE_FRAG
}
=head3 manifypods_target
my $manifypods_target = $self->manifypods_target;
Generates the manifypods target. This target generates man pages from
all POD files in MAN1PODS and MAN3PODS.
=cut
sub manifypods_target {
my($self) = shift;
my $man1pods = '';
my $man3pods = '';
my $dependencies = '';
# populate manXpods & dependencies:
foreach my $name (keys %{$self->{MAN1PODS}}, keys %{$self->{MAN3PODS}}) {
$dependencies .= " \\\n\t$name";
}
my $manify = <<END;
manifypods : pure_all $dependencies
END
my @man_cmds;
foreach my $section (qw(1 3)) {
my $pods = $self->{"MAN${section}PODS"};
push @man_cmds, $self->split_command(<<CMD, %$pods);
\$(NOECHO) \$(POD2MAN) --section=$section --perm_rw=\$(PERM_RW)
CMD
}
$manify .= "\t\$(NOECHO) \$(NOOP)\n" unless @man_cmds;
$manify .= join '', map { "$_\n" } @man_cmds;
return $manify;
}
sub _has_cpan_meta {
return eval {
require CPAN::Meta;
CPAN::Meta->VERSION(2.112150);
1;
};
}
=head3 metafile_target
my $target = $mm->metafile_target;
Generate the metafile target.
Writes the file META.yml YAML encoded meta-data about the module in
the distdir. The format follows Module::Build's as closely as
possible.
=cut
sub metafile_target {
my $self = shift;
return <<'MAKE_FRAG' if $self->{NO_META} or ! _has_cpan_meta();
metafile :
$(NOECHO) $(NOOP)
MAKE_FRAG
my %metadata = $self->metafile_data(
$self->{META_ADD} || {},
$self->{META_MERGE} || {},
);
_fix_metadata_before_conversion( \%metadata );
# paper over validation issues, but still complain, necessary because
# there's no guarantee that the above will fix ALL errors
my $meta = eval { CPAN::Meta->create( \%metadata, { lazy_validation => 1 } ) };
warn $@ if $@ and
$@ !~ /encountered CODE.*, but JSON can only represent references to arrays or hashes/;
# use the original metadata straight if the conversion failed
# or if it can't be stringified.
if( !$meta ||
!eval { $meta->as_string( { version => "1.4" } ) } ||
!eval { $meta->as_string }
)
{
$meta = bless \%metadata, 'CPAN::Meta';
}
my @write_metayml = $self->echo(
$meta->as_string({version => "1.4"}), 'META_new.yml'
);
my @write_metajson = $self->echo(
$meta->as_string(), 'META_new.json'
);
my $metayml = join("\n\t", @write_metayml);
my $metajson = join("\n\t", @write_metajson);
return sprintf <<'MAKE_FRAG', $metayml, $metajson;
metafile : create_distdir
$(NOECHO) $(ECHO) Generating META.yml
%s
-$(NOECHO) $(MV) META_new.yml $(DISTVNAME)/META.yml
$(NOECHO) $(ECHO) Generating META.json
%s
-$(NOECHO) $(MV) META_new.json $(DISTVNAME)/META.json
MAKE_FRAG
}
=begin private
=head3 _fix_metadata_before_conversion
_fix_metadata_before_conversion( \%metadata );
Fixes errors in the metadata before it's handed off to CPAN::Meta for
conversion. This hopefully results in something that can be used further
on, no guarantee is made though.
=end private
=cut
sub _fix_metadata_before_conversion {
my ( $metadata ) = @_;
# we should never be called unless this already passed but
# prefer to be defensive in case somebody else calls this
return unless _has_cpan_meta;
my $bad_version = $metadata->{version} &&
!CPAN::Meta::Validator->new->version( 'version', $metadata->{version} );
# just delete all invalid versions
if( $bad_version ) {
warn "Can't parse version '$metadata->{version}'\n";
$metadata->{version} = '';
}
my $validator = CPAN::Meta::Validator->new( $metadata );
return if $validator->is_valid;
# fix non-camelcase custom resource keys (only other trick we know)
for my $error ( $validator->errors ) {
my ( $key ) = ( $error =~ /Custom resource '(.*)' must be in CamelCase./ );
next if !$key;
# first try to remove all non-alphabetic chars
( my $new_key = $key ) =~ s/[^_a-zA-Z]//g;
# if that doesn't work, uppercase first one
$new_key = ucfirst $new_key if !$validator->custom_1( $new_key );
# copy to new key if that worked
$metadata->{resources}{$new_key} = $metadata->{resources}{$key}
if $validator->custom_1( $new_key );
# and delete old one in any case
delete $metadata->{resources}{$key};
}
return;
}
=begin private
=head3 _sort_pairs
my @pairs = _sort_pairs($sort_sub, \%hash);
Sorts the pairs of a hash based on keys ordered according
to C<$sort_sub>.
=end private
=cut
sub _sort_pairs {
my $sort = shift;
my $pairs = shift;
return map { $_ => $pairs->{$_} }
sort $sort
keys %$pairs;
}
# Taken from Module::Build::Base
sub _hash_merge {
my ($self, $h, $k, $v) = @_;
if (ref $h->{$k} eq 'ARRAY') {
push @{$h->{$k}}, ref $v ? @$v : $v;
} elsif (ref $h->{$k} eq 'HASH') {
$self->_hash_merge($h->{$k}, $_, $v->{$_}) foreach keys %$v;
} else {
$h->{$k} = $v;
}
}
=head3 metafile_data
my @metadata_pairs = $mm->metafile_data(\%meta_add, \%meta_merge);
Returns the data which MakeMaker turns into the META.yml file.
Values of %meta_add will overwrite any existing metadata in those
keys. %meta_merge will be merged with them.
=cut
sub metafile_data {
my $self = shift;
my($meta_add, $meta_merge) = @_;
my %meta = (
# required
name => $self->{DISTNAME},
version => _normalize_version($self->{VERSION}),
abstract => $self->{ABSTRACT} || 'unknown',
license => $self->{LICENSE} || 'unknown',
dynamic_config => 1,
# optional
distribution_type => $self->{PM} ? 'module' : 'script',
no_index => {
directory => [qw(t inc)]
},
generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
'meta-spec' => {
url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
version => 1.4
},
);
# The author key is required and it takes a list.
$meta{author} = defined $self->{AUTHOR} ? $self->{AUTHOR} : [];
# Check the original args so we can tell between the user setting it
# to an empty hash and it just being initialized.
if( $self->{ARGS}{CONFIGURE_REQUIRES} ) {
$meta{configure_requires}
= _normalize_prereqs($self->{CONFIGURE_REQUIRES});
} else {
$meta{configure_requires} = {
'ExtUtils::MakeMaker' => 0,
};
}
%meta = $self->_add_requirements_to_meta_v1_4( %meta );
while( my($key, $val) = each %$meta_add ) {
$meta{$key} = $val;
}
while( my($key, $val) = each %$meta_merge ) {
$self->_hash_merge(\%meta, $key, $val);
}
return %meta;
}
=begin private
=cut
sub _add_requirements_to_meta_v1_4 {
my ( $self, %meta ) = @_;
# Check the original args so we can tell between the user setting it
# to an empty hash and it just being initialized.
if( $self->{ARGS}{BUILD_REQUIRES} ) {
$meta{build_requires} = _normalize_prereqs($self->{BUILD_REQUIRES});
} else {
$meta{build_requires} = {
'ExtUtils::MakeMaker' => 0,
};
}
if( $self->{ARGS}{TEST_REQUIRES} ) {
$meta{build_requires} = {
%{ $meta{build_requires} },
%{ _normalize_prereqs($self->{TEST_REQUIRES}) },
};
}
$meta{requires} = _normalize_prereqs($self->{PREREQ_PM})
if defined $self->{PREREQ_PM};
$meta{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION})
if $self->{MIN_PERL_VERSION};
return %meta;
}
sub _add_requirements_to_meta_v2 {
my ( $self, %meta ) = @_;
# Check the original args so we can tell between the user setting it
# to an empty hash and it just being initialized.
if( $self->{ARGS}{BUILD_REQUIRES} ) {
$meta{prereqs}{build}{requires} = _normalize_prereqs($self->{BUILD_REQUIRES});
} else {
$meta{prereqs}{build}{requires} = {
'ExtUtils::MakeMaker' => 0,
};
}
if( $self->{ARGS}{TEST_REQUIRES} ) {
$meta{prereqs}{test}{requires} = _normalize_prereqs($self->{TEST_REQUIRES});
}
$meta{prereqs}{runtime}{requires} = _normalize_prereqs($self->{PREREQ_PM})
if defined $self->{PREREQ_PM};
$meta{prereqs}{runtime}{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION})
if $self->{MIN_PERL_VERSION};
return %meta;
}
sub _normalize_prereqs {
my ($hash) = @_;
my %prereqs;
while ( my ($k,$v) = each %$hash ) {
$prereqs{$k} = _normalize_version($v);
}
return \%prereqs;
}
# Adapted from Module::Build::Base
sub _normalize_version {
my ($version) = @_;
$version = 0 unless defined $version;
if ( ref $version eq 'version' ) { # version objects
$version = $version->is_qv ? $version->normal : $version->stringify;
}
elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
# normalize string tuples without "v": "1.2.3" -> "v1.2.3"
$version = "v$version";
}
else {
# leave alone
}
return $version;
}
=head3 _dump_hash
$yaml = _dump_hash(\%options, %hash);
Implements a fake YAML dumper for a hash given
as a list of pairs. No quoting/escaping is done. Keys
are supposed to be strings. Values are undef, strings,
hash refs or array refs of strings.
Supported options are:
delta => STR - indentation delta
use_header => BOOL - whether to include a YAML header
indent => STR - a string of spaces
default: ''
max_key_length => INT - maximum key length used to align
keys and values of the same hash
default: 20
key_sort => CODE - a sort sub
It may be undef, which means no sorting by keys
default: sub { lc $a cmp lc $b }
customs => HASH - special options for certain keys
(whose values are hashes themselves)
may contain: max_key_length, key_sort, customs
=end private
=cut
sub _dump_hash {
croak "first argument should be a hash ref" unless ref $_[0] eq 'HASH';
my $options = shift;
my %hash = @_;
# Use a list to preserve order.
my @pairs;
my $k_sort
= exists $options->{key_sort} ? $options->{key_sort}
: sub { lc $a cmp lc $b };
if ($k_sort) {
croak "'key_sort' should be a coderef" unless ref $k_sort eq 'CODE';
@pairs = _sort_pairs($k_sort, \%hash);
} else { # list of pairs, no sorting
@pairs = @_;
}
my $yaml = $options->{use_header} ? "--- #YAML:1.0\n" : '';
my $indent = $options->{indent} || '';
my $k_length = min(
($options->{max_key_length} || 20),
max(map { length($_) + 1 } grep { !ref $hash{$_} } keys %hash)
);
my $customs = $options->{customs} || {};
# printf format for key
my $k_format = "%-${k_length}s";
while( @pairs ) {
my($key, $val) = splice @pairs, 0, 2;
$val = '~' unless defined $val;
if(ref $val eq 'HASH') {
if ( keys %$val ) {
my %k_options = ( # options for recursive call
delta => $options->{delta},
use_header => 0,
indent => $indent . $options->{delta},
);
if (exists $customs->{$key}) {
my %k_custom = %{$customs->{$key}};
foreach my $k (qw(key_sort max_key_length customs)) {
$k_options{$k} = $k_custom{$k} if exists $k_custom{$k};
}
}
$yaml .= $indent . "$key:\n"
. _dump_hash(\%k_options, %$val);
}
else {
$yaml .= $indent . "$key: {}\n";
}
}
elsif (ref $val eq 'ARRAY') {
if( @$val ) {
$yaml .= $indent . "$key:\n";
for (@$val) {
croak "only nested arrays of non-refs are supported" if ref $_;
$yaml .= $indent . $options->{delta} . "- $_\n";
}
}
else {
$yaml .= $indent . "$key: []\n";
}
}
elsif( ref $val and !blessed($val) ) {
croak "only nested hashes, arrays and objects are supported";
}
else { # if it's an object, just stringify it
$yaml .= $indent . sprintf "$k_format %s\n", "$key:", $val;
}
};
return $yaml;
}
sub blessed {
return eval { $_[0]->isa("UNIVERSAL"); };
}
sub max {
return (sort { $b <=> $a } @_)[0];
}
sub min {
return (sort { $a <=> $b } @_)[0];
}
=head3 metafile_file
my $meta_yml = $mm->metafile_file(@metadata_pairs);
Turns the @metadata_pairs into YAML.
This method does not implement a complete YAML dumper, being limited
to dump a hash with values which are strings, undef's or nested hashes
and arrays of strings. No quoting/escaping is done.
=cut
sub metafile_file {
my $self = shift;
my %dump_options = (
use_header => 1,
delta => ' ' x 4,
key_sort => undef,
);
return _dump_hash(\%dump_options, @_);
}
=head3 distmeta_target
my $make_frag = $mm->distmeta_target;
Generates the distmeta target to add META.yml to the MANIFEST in the
distdir.
=cut
sub distmeta_target {
my $self = shift;
my @add_meta = (
$self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']),
exit unless -e q{META.yml};
eval { maniadd({q{META.yml} => q{Module YAML meta-data (added by MakeMaker)}}) }
or print "Could not add META.yml to MANIFEST: $${'@'}\n"
CODE
$self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd'])
exit unless -f q{META.json};
eval { maniadd({q{META.json} => q{Module JSON meta-data (added by MakeMaker)}}) }
or print "Could not add META.json to MANIFEST: $${'@'}\n"
CODE
);
my @add_meta_to_distdir = map { $self->cd('$(DISTVNAME)', $_) } @add_meta;
return sprintf <<'MAKE', @add_meta_to_distdir;
distmeta : create_distdir metafile
$(NOECHO) %s
$(NOECHO) %s
MAKE
}
=head3 mymeta
my $mymeta = $mm->mymeta;
Generate MYMETA information as a hash either from an existing META.yml
or from internal data.
=cut
sub mymeta {
my $self = shift;
my $file = shift || ''; # for testing
my $mymeta = $self->_mymeta_from_meta($file);
my $v2 = 1;
unless ( $mymeta ) {
my @metadata = $self->metafile_data(
$self->{META_ADD} || {},
$self->{META_MERGE} || {},
);
$mymeta = {@metadata};
$v2 = 0;
}
# Overwrite the non-configure dependency hashes
my $method = $v2
? '_add_requirements_to_meta_v2'
: '_add_requirements_to_meta_v1_4';
$mymeta = { $self->$method( %$mymeta ) };
$mymeta->{dynamic_config} = 0;
return $mymeta;
}
sub _mymeta_from_meta {
my $self = shift;
my $metafile = shift || ''; # for testing
return unless _has_cpan_meta();
my $meta;
for my $file ( $metafile, "META.json", "META.yml" ) {
next unless -e $file;
eval {
$meta = CPAN::Meta->load_file($file)->as_struct( { version => 2 } );
};
last if $meta;
}
return undef unless $meta;
# META.yml before 6.25_01 cannot be trusted. META.yml lived in the source directory.
# There was a good chance the author accidentally uploaded a stale META.yml if they
# rolled their own tarball rather than using "make dist".
if ($meta->{generated_by} &&
$meta->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
my $eummv = do { local $^W = 0; $1+0; };
if ($eummv < 6.2501) {
return undef;
}
}
return $meta;
}
=head3 write_mymeta
$self->write_mymeta( $mymeta );
Write MYMETA information to MYMETA.yml.
This will probably be refactored into a more generic YAML dumping method.
=cut
sub write_mymeta {
my $self = shift;
my $mymeta = shift;
return unless _has_cpan_meta();
_fix_metadata_before_conversion( $mymeta );
# this can still blow up
# not sure if i should just eval this and skip file creation if it
# blows up
my $meta_obj = CPAN::Meta->new( $mymeta, { lazy_validation => 1 } );
$meta_obj->save( 'MYMETA.json' );
$meta_obj->save( 'MYMETA.yml', { version => "1.4" } );
return 1;
}
=head3 realclean (o)
Defines the realclean target.
=cut
sub realclean {
my($self, %attribs) = @_;
my @dirs = qw($(DISTVNAME));
my @files = qw($(FIRST_MAKEFILE) $(MAKEFILE_OLD));
# Special exception for the perl core where INST_* is not in blib.
# This cleans up the files built from the ext/ directory (all XS).
if( $self->{PERL_CORE} ) {
push @dirs, qw($(INST_AUTODIR) $(INST_ARCHAUTODIR));
push @files, values %{$self->{PM}};
}
if( $self->has_link_code ){
push @files, qw($(OBJECT));
}
if( $attribs{FILES} ) {
if( ref $attribs{FILES} ) {
push @dirs, @{ $attribs{FILES} };
}
else {
push @dirs, split /\s+/, $attribs{FILES};
}
}
# Occasionally files are repeated several times from different sources
{ my(%f) = map { ($_ => 1) } @files; @files = keys %f; }
{ my(%d) = map { ($_ => 1) } @dirs; @dirs = keys %d; }
my $rm_cmd = join "\n\t", map { "$_" }
$self->split_command('- $(RM_F)', @files);
my $rmf_cmd = join "\n\t", map { "$_" }
$self->split_command('- $(RM_RF)', @dirs);
my $m = sprintf <<'MAKE', $rm_cmd, $rmf_cmd;
# Delete temporary files (via clean) and also delete dist files
realclean purge :: clean realclean_subdirs
%s
%s
MAKE
$m .= "\t$attribs{POSTOP}\n" if $attribs{POSTOP};
return $m;
}
=head3 realclean_subdirs_target
my $make_frag = $MM->realclean_subdirs_target;
Returns the realclean_subdirs target. This is used by the realclean
target to call realclean on any subdirectories which contain Makefiles.
=cut
sub realclean_subdirs_target {
my $self = shift;
return <<'NOOP_FRAG' unless @{$self->{DIR}};
realclean_subdirs :
$(NOECHO) $(NOOP)
NOOP_FRAG
my $rclean = "realclean_subdirs :\n";
foreach my $dir (@{$self->{DIR}}) {
foreach my $makefile ('$(MAKEFILE_OLD)', '$(FIRST_MAKEFILE)' ) {
my $subrclean .= $self->oneliner(sprintf <<'CODE', $dir, ($makefile) x 2);
chdir '%s'; system '$(MAKE) $(USEMAKEFILE) %s realclean' if -f '%s';
CODE
$rclean .= sprintf <<'RCLEAN', $subrclean;
- %s
RCLEAN
}
}
return $rclean;
}
=head3 signature_target
my $target = $mm->signature_target;
Generate the signature target.
Writes the file SIGNATURE with "cpansign -s".
=cut
sub signature_target {
my $self = shift;
return <<'MAKE_FRAG';
signature :
cpansign -s
MAKE_FRAG
}
=head3 distsignature_target
my $make_frag = $mm->distsignature_target;
Generates the distsignature target to add SIGNATURE to the MANIFEST in the
distdir.
=cut
sub distsignature_target {
my $self = shift;
my $add_sign = $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']);
eval { maniadd({q{SIGNATURE} => q{Public-key signature (added by MakeMaker)}}) }
or print "Could not add SIGNATURE to MANIFEST: $${'@'}\n"
CODE
my $sign_dist = $self->cd('$(DISTVNAME)' => 'cpansign -s');
# cpansign -s complains if SIGNATURE is in the MANIFEST yet does not
# exist
my $touch_sig = $self->cd('$(DISTVNAME)' => '$(TOUCH) SIGNATURE');
my $add_sign_to_dist = $self->cd('$(DISTVNAME)' => $add_sign );
return sprintf <<'MAKE', $add_sign_to_dist, $touch_sig, $sign_dist
distsignature : create_distdir
$(NOECHO) %s
$(NOECHO) %s
%s
MAKE
}
=head3 special_targets
my $make_frag = $mm->special_targets
Returns a make fragment containing any targets which have special
meaning to make. For example, .SUFFIXES and .PHONY.
=cut
sub special_targets {
my $make_frag = <<'MAKE_FRAG';
.SUFFIXES : .xs .c .C .cpp .i .s .cxx .cc $(OBJ_EXT)
.PHONY: all config static dynamic test linkext manifest blibdirs clean realclean disttest distdir
MAKE_FRAG
$make_frag .= <<'MAKE_FRAG' if $ENV{CLEARCASE_ROOT};
.NO_CONFIG_REC: Makefile
MAKE_FRAG
return $make_frag;
}
=head2 Init methods
Methods which help initialize the MakeMaker object and macros.
=head3 init_ABSTRACT
$mm->init_ABSTRACT
=cut
sub init_ABSTRACT {
my $self = shift;
if( $self->{ABSTRACT_FROM} and $self->{ABSTRACT} ) {
warn "Both ABSTRACT_FROM and ABSTRACT are set. ".
"Ignoring ABSTRACT_FROM.\n";
return;
}
if ($self->{ABSTRACT_FROM}){
$self->{ABSTRACT} = $self->parse_abstract($self->{ABSTRACT_FROM}) or
carp "WARNING: Setting ABSTRACT via file ".
"'$self->{ABSTRACT_FROM}' failed\n";
}
}
=head3 init_INST
$mm->init_INST;
Called by init_main. Sets up all INST_* variables except those related
to XS code. Those are handled in init_xs.
=cut
sub init_INST {
my($self) = shift;
$self->{INST_ARCHLIB} ||= $self->catdir($Curdir,"blib","arch");
$self->{INST_BIN} ||= $self->catdir($Curdir,'blib','bin');
# INST_LIB typically pre-set if building an extension after
# perl has been built and installed. Setting INST_LIB allows
# you to build directly into, say $Config{privlibexp}.
unless ($self->{INST_LIB}){
if ($self->{PERL_CORE}) {
if (defined $Cross::platform) {
$self->{INST_LIB} = $self->{INST_ARCHLIB} =
$self->catdir($self->{PERL_LIB},"..","xlib",
$Cross::platform);
}
else {
$self->{INST_LIB} = $self->{INST_ARCHLIB} = $self->{PERL_LIB};
}
} else {
$self->{INST_LIB} = $self->catdir($Curdir,"blib","lib");
}
}
my @parentdir = split(/::/, $self->{PARENT_NAME});
$self->{INST_LIBDIR} = $self->catdir('$(INST_LIB)', @parentdir);
$self->{INST_ARCHLIBDIR} = $self->catdir('$(INST_ARCHLIB)', @parentdir);
$self->{INST_AUTODIR} = $self->catdir('$(INST_LIB)', 'auto',
'$(FULLEXT)');
$self->{INST_ARCHAUTODIR} = $self->catdir('$(INST_ARCHLIB)', 'auto',
'$(FULLEXT)');
$self->{INST_SCRIPT} ||= $self->catdir($Curdir,'blib','script');
$self->{INST_MAN1DIR} ||= $self->catdir($Curdir,'blib','man1');
$self->{INST_MAN3DIR} ||= $self->catdir($Curdir,'blib','man3');
return 1;
}
=head3 init_INSTALL
$mm->init_INSTALL;
Called by init_main. Sets up all INSTALL_* variables (except
INSTALLDIRS) and *PREFIX.
=cut
sub init_INSTALL {
my($self) = shift;
if( $self->{ARGS}{INSTALL_BASE} and $self->{ARGS}{PREFIX} ) {
die "Only one of PREFIX or INSTALL_BASE can be given. Not both.\n";
}
if( $self->{ARGS}{INSTALL_BASE} ) {
$self->init_INSTALL_from_INSTALL_BASE;
}
else {
$self->init_INSTALL_from_PREFIX;
}
}
=head3 init_INSTALL_from_PREFIX
$mm->init_INSTALL_from_PREFIX;
=cut
sub init_INSTALL_from_PREFIX {
my $self = shift;
$self->init_lib2arch;
# There are often no Config.pm defaults for these new man variables so
# we fall back to the old behavior which is to use installman*dir
foreach my $num (1, 3) {
my $k = 'installsiteman'.$num.'dir';
$self->{uc $k} ||= uc "\$(installman${num}dir)"
unless $Config{$k};
}
foreach my $num (1, 3) {
my $k = 'installvendorman'.$num.'dir';
unless( $Config{$k} ) {
$self->{uc $k} ||= $Config{usevendorprefix}
? uc "\$(installman${num}dir)"
: '';
}
}
$self->{INSTALLSITEBIN} ||= '$(INSTALLBIN)'
unless $Config{installsitebin};
$self->{INSTALLSITESCRIPT} ||= '$(INSTALLSCRIPT)'
unless $Config{installsitescript};
unless( $Config{installvendorbin} ) {
$self->{INSTALLVENDORBIN} ||= $Config{usevendorprefix}
? $Config{installbin}
: '';
}
unless( $Config{installvendorscript} ) {
$self->{INSTALLVENDORSCRIPT} ||= $Config{usevendorprefix}
? $Config{installscript}
: '';
}
my $iprefix = $Config{installprefixexp} || $Config{installprefix} ||
$Config{prefixexp} || $Config{prefix} || '';
my $vprefix = $Config{usevendorprefix} ? $Config{vendorprefixexp} : '';
my $sprefix = $Config{siteprefixexp} || '';
# 5.005_03 doesn't have a siteprefix.
$sprefix = $iprefix unless $sprefix;
$self->{PREFIX} ||= '';
if( $self->{PREFIX} ) {
@{$self}{qw(PERLPREFIX SITEPREFIX VENDORPREFIX)} =
('$(PREFIX)') x 3;
}
else {
$self->{PERLPREFIX} ||= $iprefix;
$self->{SITEPREFIX} ||= $sprefix;
$self->{VENDORPREFIX} ||= $vprefix;
# Lots of MM extension authors like to use $(PREFIX) so we
# put something sensible in there no matter what.
$self->{PREFIX} = '$('.uc $self->{INSTALLDIRS}.'PREFIX)';
}
my $arch = $Config{archname};
my $version = $Config{version};
# default style
my $libstyle = $Config{installstyle} || 'lib/perl5';
my $manstyle = '';
if( $self->{LIBSTYLE} ) {
$libstyle = $self->{LIBSTYLE};
$manstyle = $self->{LIBSTYLE} eq 'lib/perl5' ? 'lib/perl5' : '';
}
# Some systems, like VOS, set installman*dir to '' if they can't
# read man pages.
for my $num (1, 3) {
$self->{'INSTALLMAN'.$num.'DIR'} ||= 'none'
unless $Config{'installman'.$num.'dir'};
}
my %bin_layouts =
(
bin => { s => $iprefix,
t => 'perl',
d => 'bin' },
vendorbin => { s => $vprefix,
t => 'vendor',
d => 'bin' },
sitebin => { s => $sprefix,
t => 'site',
d => 'bin' },
script => { s => $iprefix,
t => 'perl',
d => 'bin' },
vendorscript=> { s => $vprefix,
t => 'vendor',
d => 'bin' },
sitescript => { s => $sprefix,
t => 'site',
d => 'bin' },
);
my %man_layouts =
(
man1dir => { s => $iprefix,
t => 'perl',
d => 'man/man1',
style => $manstyle, },
siteman1dir => { s => $sprefix,
t => 'site',
d => 'man/man1',
style => $manstyle, },
vendorman1dir => { s => $vprefix,
t => 'vendor',
d => 'man/man1',
style => $manstyle, },
man3dir => { s => $iprefix,
t => 'perl',
d => 'man/man3',
style => $manstyle, },
siteman3dir => { s => $sprefix,
t => 'site',
d => 'man/man3',
style => $manstyle, },
vendorman3dir => { s => $vprefix,
t => 'vendor',
d => 'man/man3',
style => $manstyle, },
);
my %lib_layouts =
(
privlib => { s => $iprefix,
t => 'perl',
d => '',
style => $libstyle, },
vendorlib => { s => $vprefix,
t => 'vendor',
d => '',
style => $libstyle, },
sitelib => { s => $sprefix,
t => 'site',
d => 'site_perl',
style => $libstyle, },
archlib => { s => $iprefix,
t => 'perl',
d => "$version/$arch",
style => $libstyle },
vendorarch => { s => $vprefix,
t => 'vendor',
d => "$version/$arch",
style => $libstyle },
sitearch => { s => $sprefix,
t => 'site',
d => "site_perl/$version/$arch",
style => $libstyle },
);
# Special case for LIB.
if( $self->{LIB} ) {
foreach my $var (keys %lib_layouts) {
my $Installvar = uc "install$var";
if( $var =~ /arch/ ) {
$self->{$Installvar} ||=
$self->catdir($self->{LIB}, $Config{archname});
}
else {
$self->{$Installvar} ||= $self->{LIB};
}
}
}
my %type2prefix = ( perl => 'PERLPREFIX',
site => 'SITEPREFIX',
vendor => 'VENDORPREFIX'
);
my %layouts = (%bin_layouts, %man_layouts, %lib_layouts);
while( my($var, $layout) = each(%layouts) ) {
my($s, $t, $d, $style) = @{$layout}{qw(s t d style)};
my $r = '$('.$type2prefix{$t}.')';
warn "Prefixing $var\n" if $Verbose >= 2;
my $installvar = "install$var";
my $Installvar = uc $installvar;
next if $self->{$Installvar};
$d = "$style/$d" if $style;
$self->prefixify($installvar, $s, $r, $d);
warn " $Installvar == $self->{$Installvar}\n"
if $Verbose >= 2;
}
# Generate these if they weren't figured out.
$self->{VENDORARCHEXP} ||= $self->{INSTALLVENDORARCH};
$self->{VENDORLIBEXP} ||= $self->{INSTALLVENDORLIB};
return 1;
}
=head3 init_from_INSTALL_BASE
$mm->init_from_INSTALL_BASE
=cut
my %map = (
lib => [qw(lib perl5)],
arch => [('lib', 'perl5', $Config{archname})],
bin => [qw(bin)],
man1dir => [qw(man man1)],
man3dir => [qw(man man3)]
);
$map{script} = $map{bin};
sub init_INSTALL_from_INSTALL_BASE {
my $self = shift;
@{$self}{qw(PREFIX VENDORPREFIX SITEPREFIX PERLPREFIX)} =
'$(INSTALL_BASE)';
my %install;
foreach my $thing (keys %map) {
foreach my $dir (('', 'SITE', 'VENDOR')) {
my $uc_thing = uc $thing;
my $key = "INSTALL".$dir.$uc_thing;
$install{$key} ||=
$self->catdir('$(INSTALL_BASE)', @{$map{$thing}});
}
}
# Adjust for variable quirks.
$install{INSTALLARCHLIB} ||= delete $install{INSTALLARCH};
$install{INSTALLPRIVLIB} ||= delete $install{INSTALLLIB};
foreach my $key (keys %install) {
$self->{$key} ||= $install{$key};
}
return 1;
}
=head3 init_VERSION I<Abstract>
$mm->init_VERSION
Initialize macros representing versions of MakeMaker and other tools
MAKEMAKER: path to the MakeMaker module.
MM_VERSION: ExtUtils::MakeMaker Version
MM_REVISION: ExtUtils::MakeMaker version control revision (for backwards
compat)
VERSION: version of your module
VERSION_MACRO: which macro represents the version (usually 'VERSION')
VERSION_SYM: like version but safe for use as an RCS revision number
DEFINE_VERSION: -D line to set the module version when compiling
XS_VERSION: version in your .xs file. Defaults to $(VERSION)
XS_VERSION_MACRO: which macro represents the XS version.
XS_DEFINE_VERSION: -D line to set the xs version when compiling.
Called by init_main.
=cut
sub init_VERSION {
my($self) = shift;
$self->{MAKEMAKER} = $ExtUtils::MakeMaker::Filename;
$self->{MM_VERSION} = $ExtUtils::MakeMaker::VERSION;
$self->{MM_REVISION}= $ExtUtils::MakeMaker::Revision;
$self->{VERSION_FROM} ||= '';
if ($self->{VERSION_FROM}){
$self->{VERSION} = $self->parse_version($self->{VERSION_FROM});
if( $self->{VERSION} eq 'undef' ) {
carp("WARNING: Setting VERSION via file ".
"'$self->{VERSION_FROM}' failed\n");
}
}
# strip blanks
if (defined $self->{VERSION}) {
$self->{VERSION} =~ s/^\s+//;
$self->{VERSION} =~ s/\s+$//;
}
else {
$self->{VERSION} = '';
}
$self->{VERSION_MACRO} = 'VERSION';
($self->{VERSION_SYM} = $self->{VERSION}) =~ s/\W/_/g;
$self->{DEFINE_VERSION} = '-D$(VERSION_MACRO)=\"$(VERSION)\"';
# Graham Barr and Paul Marquess had some ideas how to ensure
# version compatibility between the *.pm file and the
# corresponding *.xs file. The bottomline was, that we need an
# XS_VERSION macro that defaults to VERSION:
$self->{XS_VERSION} ||= $self->{VERSION};
$self->{XS_VERSION_MACRO} = 'XS_VERSION';
$self->{XS_DEFINE_VERSION} = '-D$(XS_VERSION_MACRO)=\"$(XS_VERSION)\"';
}
=head3 init_tools
$MM->init_tools();
Initializes the simple macro definitions used by tools_other() and
places them in the $MM object. These use conservative cross platform
versions and should be overridden with platform specific versions for
performance.
Defines at least these macros.
Macro Description
NOOP Do nothing
NOECHO Tell make not to display the command itself
SHELL Program used to run shell commands
ECHO Print text adding a newline on the end
RM_F Remove a file
RM_RF Remove a directory
TOUCH Update a file's timestamp
TEST_F Test for a file's existence
CP Copy a file
MV Move a file
CHMOD Change permissions on a file
FALSE Exit with non-zero
TRUE Exit with zero
UMASK_NULL Nullify umask
DEV_NULL Suppress all command output
=cut
sub init_tools {
my $self = shift;
$self->{ECHO} ||= $self->oneliner('print qq{@ARGV}', ['-l']);
$self->{ECHO_N} ||= $self->oneliner('print qq{@ARGV}');
$self->{TOUCH} ||= $self->oneliner('touch', ["-MExtUtils::Command"]);
$self->{CHMOD} ||= $self->oneliner('chmod', ["-MExtUtils::Command"]);
$self->{RM_F} ||= $self->oneliner('rm_f', ["-MExtUtils::Command"]);
$self->{RM_RF} ||= $self->oneliner('rm_rf', ["-MExtUtils::Command"]);
$self->{TEST_F} ||= $self->oneliner('test_f', ["-MExtUtils::Command"]);
$self->{FALSE} ||= $self->oneliner('exit 1');
$self->{TRUE} ||= $self->oneliner('exit 0');
$self->{MKPATH} ||= $self->oneliner('mkpath', ["-MExtUtils::Command"]);
$self->{CP} ||= $self->oneliner('cp', ["-MExtUtils::Command"]);
$self->{MV} ||= $self->oneliner('mv', ["-MExtUtils::Command"]);
$self->{MOD_INSTALL} ||=
$self->oneliner(<<'CODE', ['-MExtUtils::Install']);
install([ from_to => {@ARGV}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]);
CODE
$self->{DOC_INSTALL} ||= $self->oneliner('perllocal_install', ["-MExtUtils::Command::MM"]);
$self->{UNINSTALL} ||= $self->oneliner('uninstall', ["-MExtUtils::Command::MM"]);
$self->{WARN_IF_OLD_PACKLIST} ||=
$self->oneliner('warn_if_old_packlist', ["-MExtUtils::Command::MM"]);
$self->{FIXIN} ||= $self->oneliner('MY->fixin(shift)', ["-MExtUtils::MY"]);
$self->{EQUALIZE_TIMESTAMP} ||= $self->oneliner('eqtime', ["-MExtUtils::Command"]);
$self->{UNINST} ||= 0;
$self->{VERBINST} ||= 0;
$self->{SHELL} ||= $Config{sh};
# UMASK_NULL is not used by MakeMaker but some CPAN modules
# make use of it.
$self->{UMASK_NULL} ||= "umask 0";
# Not the greatest default, but its something.
$self->{DEV_NULL} ||= "> /dev/null 2>&1";
$self->{NOOP} ||= '$(TRUE)';
$self->{NOECHO} = '@' unless defined $self->{NOECHO};
$self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE} || 'Makefile';
$self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE};
$self->{MAKEFILE_OLD} ||= $self->{MAKEFILE}.'.old';
$self->{MAKE_APERL_FILE} ||= $self->{MAKEFILE}.'.aperl';
# Not everybody uses -f to indicate "use this Makefile instead"
$self->{USEMAKEFILE} ||= '-f';
# Some makes require a wrapper around macros passed in on the command
# line.
$self->{MACROSTART} ||= '';
$self->{MACROEND} ||= '';
return;
}
=head3 init_others
$MM->init_others();
Initializes the macro definitions having to do with compiling and
linking used by tools_other() and places them in the $MM object.
If there is no description, its the same as the parameter to
WriteMakefile() documented in ExtUtils::MakeMaker.
=cut
sub init_others {
my $self = shift;
$self->{LD_RUN_PATH} = "";
$self->{LIBS} = $self->_fix_libs($self->{LIBS});
# Compute EXTRALIBS, BSLOADLIBS and LDLOADLIBS from $self->{LIBS}
foreach my $libs ( @{$self->{LIBS}} ){
$libs =~ s/^\s*(.*\S)\s*$/$1/; # remove leading and trailing whitespace
my(@libs) = $self->extliblist($libs);
if ($libs[0] or $libs[1] or $libs[2]){
# LD_RUN_PATH now computed by ExtUtils::Liblist
($self->{EXTRALIBS}, $self->{BSLOADLIBS},
$self->{LDLOADLIBS}, $self->{LD_RUN_PATH}) = @libs;
last;
}
}
if ( $self->{OBJECT} ) {
$self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g;
} else {
# init_dirscan should have found out, if we have C files
$self->{OBJECT} = "";
$self->{OBJECT} = '$(BASEEXT)$(OBJ_EXT)' if @{$self->{C}||[]};
}
$self->{OBJECT} =~ s/\n+/ \\\n\t/g;
$self->{BOOTDEP} = (-f "$self->{BASEEXT}_BS") ? "$self->{BASEEXT}_BS" : "";
$self->{PERLMAINCC} ||= '$(CC)';
$self->{LDFROM} = '$(OBJECT)' unless $self->{LDFROM};
# Sanity check: don't define LINKTYPE = dynamic if we're skipping
# the 'dynamic' section of MM. We don't have this problem with
# 'static', since we either must use it (%Config says we can't
# use dynamic loading) or the caller asked for it explicitly.
if (!$self->{LINKTYPE}) {
$self->{LINKTYPE} = $self->{SKIPHASH}{'dynamic'}
? 'static'
: ($Config{usedl} ? 'dynamic' : 'static');
}
return;
}
# Lets look at $self->{LIBS} carefully: It may be an anon array, a string or
# undefined. In any case we turn it into an anon array
sub _fix_libs {
my($self, $libs) = @_;
return !defined $libs ? [''] :
!ref $libs ? [$libs] :
!defined $libs->[0] ? [''] :
$libs ;
}
=head3 tools_other
my $make_frag = $MM->tools_other;
Returns a make fragment containing definitions for the macros init_others()
initializes.
=cut
sub tools_other {
my($self) = shift;
my @m;
# We set PM_FILTER as late as possible so it can see all the earlier
# on macro-order sensitive makes such as nmake.
for my $tool (qw{ SHELL CHMOD CP MV NOOP NOECHO RM_F RM_RF TEST_F TOUCH
UMASK_NULL DEV_NULL MKPATH EQUALIZE_TIMESTAMP
FALSE TRUE
ECHO ECHO_N
UNINST VERBINST
MOD_INSTALL DOC_INSTALL UNINSTALL
WARN_IF_OLD_PACKLIST
MACROSTART MACROEND
USEMAKEFILE
PM_FILTER
FIXIN
} )
{
next unless defined $self->{$tool};
push @m, "$tool = $self->{$tool}\n";
}
return join "", @m;
}
=head3 init_DIRFILESEP I<Abstract>
$MM->init_DIRFILESEP;
my $dirfilesep = $MM->{DIRFILESEP};
Initializes the DIRFILESEP macro which is the seperator between the
directory and filename in a filepath. ie. / on Unix, \ on Win32 and
nothing on VMS.
For example:
# instead of $(INST_ARCHAUTODIR)/extralibs.ld
$(INST_ARCHAUTODIR)$(DIRFILESEP)extralibs.ld
Something of a hack but it prevents a lot of code duplication between
MM_* variants.
Do not use this as a seperator between directories. Some operating
systems use different seperators between subdirectories as between
directories and filenames (for example: VOLUME:[dir1.dir2]file on VMS).
=head3 init_linker I<Abstract>
$mm->init_linker;
Initialize macros which have to do with linking.
PERL_ARCHIVE: path to libperl.a equivalent to be linked to dynamic
extensions.
PERL_ARCHIVE_AFTER: path to a library which should be put on the
linker command line I<after> the external libraries to be linked to
dynamic extensions. This may be needed if the linker is one-pass, and
Perl includes some overrides for C RTL functions, such as malloc().
EXPORT_LIST: name of a file that is passed to linker to define symbols
to be exported.
Some OSes do not need these in which case leave it blank.
=head3 init_platform
$mm->init_platform
Initialize any macros which are for platform specific use only.
A typical one is the version number of your OS specific mocule.
(ie. MM_Unix_VERSION or MM_VMS_VERSION).
=cut
sub init_platform {
return '';
}
=head3 init_MAKE
$mm->init_MAKE
Initialize MAKE from either a MAKE environment variable or $Config{make}.
=cut
sub init_MAKE {
my $self = shift;
$self->{MAKE} ||= $ENV{MAKE} || $Config{make};
}
=head2 Tools
A grab bag of methods to generate specific macros and commands.
=head3 manifypods
Defines targets and routines to translate the pods into manpages and
put them into the INST_* directories.
=cut
sub manifypods {
my $self = shift;
my $POD2MAN_macro = $self->POD2MAN_macro();
my $manifypods_target = $self->manifypods_target();
return <<END_OF_TARGET;
$POD2MAN_macro
$manifypods_target
END_OF_TARGET
}
=head3 POD2MAN_macro
my $pod2man_macro = $self->POD2MAN_macro
Returns a definition for the POD2MAN macro. This is a program
which emulates the pod2man utility. You can add more switches to the
command by simply appending them on the macro.
Typical usage:
$(POD2MAN) --section=3 --perm_rw=$(PERM_RW) podfile1 man_page1 ...
=cut
sub POD2MAN_macro {
my $self = shift;
# Need the trailing '--' so perl stops gobbling arguments and - happens
# to be an alternative end of line seperator on VMS so we quote it
return <<'END_OF_DEF';
POD2MAN_EXE = $(PERLRUN) "-MExtUtils::Command::MM" -e pod2man "--"
POD2MAN = $(POD2MAN_EXE)
END_OF_DEF
}
=head3 test_via_harness
my $command = $mm->test_via_harness($perl, $tests);
Returns a $command line which runs the given set of $tests with
Test::Harness and the given $perl.
Used on the t/*.t files.
=cut
sub test_via_harness {
my($self, $perl, $tests) = @_;
return qq{\t$perl "-MExtUtils::Command::MM" }.
qq{"-e" "test_harness(\$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n};
}
=head3 test_via_script
my $command = $mm->test_via_script($perl, $script);
Returns a $command line which just runs a single test without
Test::Harness. No checks are done on the results, they're just
printed.
Used for test.pl, since they don't always follow Test::Harness
formatting.
=cut
sub test_via_script {
my($self, $perl, $script) = @_;
return qq{\t$perl "-I\$(INST_LIB)" "-I\$(INST_ARCHLIB)" $script\n};
}
=head3 tool_autosplit
Defines a simple perl call that runs autosplit. May be deprecated by
pm_to_blib soon.
=cut
sub tool_autosplit {
my($self, %attribs) = @_;
my $maxlen = $attribs{MAXLEN} ? '$$AutoSplit::Maxlen=$attribs{MAXLEN};'
: '';
my $asplit = $self->oneliner(sprintf <<'PERL_CODE', $maxlen);
use AutoSplit; %s autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1)
PERL_CODE
return sprintf <<'MAKE_FRAG', $asplit;
# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto
AUTOSPLITFILE = %s
MAKE_FRAG
}
=head3 arch_check
my $arch_ok = $mm->arch_check(
$INC{"Config.pm"},
File::Spec->catfile($Config{archlibexp}, "Config.pm")
);
A sanity check that what Perl thinks the architecture is and what
Config thinks the architecture is are the same. If they're not it
will return false and show a diagnostic message.
When building Perl it will always return true, as nothing is installed
yet.
The interface is a bit odd because this is the result of a
quick refactoring. Don't rely on it.
=cut
sub arch_check {
my $self = shift;
my($pconfig, $cconfig) = @_;
return 1 if $self->{PERL_SRC};
my($pvol, $pthinks) = $self->splitpath($pconfig);
my($cvol, $cthinks) = $self->splitpath($cconfig);
$pthinks = $self->canonpath($pthinks);
$cthinks = $self->canonpath($cthinks);
my $ret = 1;
if ($pthinks ne $cthinks) {
print "Have $pthinks\n";
print "Want $cthinks\n";
$ret = 0;
my $arch = (grep length, $self->splitdir($pthinks))[-1];
print <<END unless $self->{UNINSTALLED_PERL};
Your perl and your Config.pm seem to have different ideas about the
architecture they are running on.
Perl thinks: [$arch]
Config says: [$Config{archname}]
This may or may not cause problems. Please check your installation of perl
if you have problems building this extension.
END
}
return $ret;
}
=head2 File::Spec wrappers
ExtUtils::MM_Any is a subclass of File::Spec. The methods noted here
override File::Spec.
=head3 catfile
File::Spec <= 0.83 has a bug where the file part of catfile is not
canonicalized. This override fixes that bug.
=cut
sub catfile {
my $self = shift;
return $self->canonpath($self->SUPER::catfile(@_));
}
=head2 Misc
Methods I can't really figure out where they should go yet.
=head3 find_tests
my $test = $mm->find_tests;
Returns a string suitable for feeding to the shell to return all
tests in t/*.t.
=cut
sub find_tests {
my($self) = shift;
return -d 't' ? 't/*.t' : '';
}
=head3 extra_clean_files
my @files_to_clean = $MM->extra_clean_files;
Returns a list of OS specific files to be removed in the clean target in
addition to the usual set.
=cut
# An empty method here tickled a perl 5.8.1 bug and would return its object.
sub extra_clean_files {
return;
}
=head3 installvars
my @installvars = $mm->installvars;
A list of all the INSTALL* variables without the INSTALL prefix. Useful
for iteration or building related variable sets.
=cut
sub installvars {
return qw(PRIVLIB SITELIB VENDORLIB
ARCHLIB SITEARCH VENDORARCH
BIN SITEBIN VENDORBIN
SCRIPT SITESCRIPT VENDORSCRIPT
MAN1DIR SITEMAN1DIR VENDORMAN1DIR
MAN3DIR SITEMAN3DIR VENDORMAN3DIR
);
}
=head3 libscan
my $wanted = $self->libscan($path);
Takes a path to a file or dir and returns an empty string if we don't
want to include this file in the library. Otherwise it returns the
the $path unchanged.
Mainly used to exclude version control administrative directories from
installation.
=cut
sub libscan {
my($self,$path) = @_;
my($dirs,$file) = ($self->splitpath($path))[1,2];
return '' if grep /^(?:RCS|CVS|SCCS|\.svn|_darcs)$/,
$self->splitdir($dirs), $file;
return $path;
}
=head3 platform_constants
my $make_frag = $mm->platform_constants
Returns a make fragment defining all the macros initialized in
init_platform() rather than put them in constants().
=cut
sub platform_constants {
return '';
}
=begin private
=head3 _PREREQ_PRINT
$self->_PREREQ_PRINT;
Implements PREREQ_PRINT.
Refactored out of MakeMaker->new().
=end private
=cut
sub _PREREQ_PRINT {
my $self = shift;
require Data::Dumper;
my @what = ('PREREQ_PM');
push @what, 'MIN_PERL_VERSION' if $self->{MIN_PERL_VERSION};
push @what, 'BUILD_REQUIRES' if $self->{BUILD_REQUIRES};
print Data::Dumper->Dump([@{$self}{@what}], \@what);
exit 0;
}
=begin private
=head3 _PRINT_PREREQ
$mm->_PRINT_PREREQ;
Implements PRINT_PREREQ, a slightly different version of PREREQ_PRINT
added by Redhat to, I think, support generating RPMs from Perl modules.
Should not include BUILD_REQUIRES as RPMs do not incluide them.
Refactored out of MakeMaker->new().
=end private
=cut
sub _PRINT_PREREQ {
my $self = shift;
my $prereqs= $self->{PREREQ_PM};
my @prereq = map { [$_, $prereqs->{$_}] } keys %$prereqs;
if ( $self->{MIN_PERL_VERSION} ) {
push @prereq, ['perl' => $self->{MIN_PERL_VERSION}];
}
print join(" ", map { "perl($_->[0])>=$_->[1] " }
sort { $a->[0] cmp $b->[0] } @prereq), "\n";
exit 0;
}
=begin private
=head3 _all_prereqs
my $prereqs = $self->_all_prereqs;
Returns a hash ref of both PREREQ_PM and BUILD_REQUIRES.
=end private
=cut
sub _all_prereqs {
my $self = shift;
return { %{$self->{PREREQ_PM}}, %{$self->{BUILD_REQUIRES}} };
}
=head1 AUTHOR
Michael G Schwern <schwern@pobox.com> and the denizens of
makemaker@perl.org with code from ExtUtils::MM_Unix and
ExtUtils::MM_Win32.
=cut
1;
EXTUTILS_MM_ANY
$fatpacked{"ExtUtils/MM_BeOS.pm"} = <<'EXTUTILS_MM_BEOS';
package ExtUtils::MM_BeOS;
use strict;
=head1 NAME
ExtUtils::MM_BeOS - methods to override UN*X behaviour in ExtUtils::MakeMaker
=head1 SYNOPSIS
use ExtUtils::MM_BeOS; # Done internally by ExtUtils::MakeMaker if needed
=head1 DESCRIPTION
See ExtUtils::MM_Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
=over 4
=cut
use ExtUtils::MakeMaker::Config;
use File::Spec;
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
our $VERSION = '6.64';
=item os_flavor
BeOS is BeOS.
=cut
sub os_flavor {
return('BeOS');
}
=item init_linker
libperl.a equivalent to be linked to dynamic extensions.
=cut
sub init_linker {
my($self) = shift;
$self->{PERL_ARCHIVE} ||=
File::Spec->catdir('$(PERL_INC)',$Config{libperl});
$self->{PERL_ARCHIVE_AFTER} ||= '';
$self->{EXPORT_LIST} ||= '';
}
=back
1;
__END__
EXTUTILS_MM_BEOS
$fatpacked{"ExtUtils/MM_Cygwin.pm"} = <<'EXTUTILS_MM_CYGWIN';
package ExtUtils::MM_Cygwin;
use strict;
use ExtUtils::MakeMaker::Config;
use File::Spec;
require ExtUtils::MM_Unix;
require ExtUtils::MM_Win32;
our @ISA = qw( ExtUtils::MM_Unix );
our $VERSION = '6.64';
=head1 NAME
ExtUtils::MM_Cygwin - methods to override UN*X behaviour in ExtUtils::MakeMaker
=head1 SYNOPSIS
use ExtUtils::MM_Cygwin; # Done internally by ExtUtils::MakeMaker if needed
=head1 DESCRIPTION
See ExtUtils::MM_Unix for a documentation of the methods provided there.
=over 4
=item os_flavor
We're Unix and Cygwin.
=cut
sub os_flavor {
return('Unix', 'Cygwin');
}
=item cflags
if configured for dynamic loading, triggers #define EXT in EXTERN.h
=cut
sub cflags {
my($self,$libperl)=@_;
return $self->{CFLAGS} if $self->{CFLAGS};
return '' unless $self->needs_linking();
my $base = $self->SUPER::cflags($libperl);
foreach (split /\n/, $base) {
/^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2;
};
$self->{CCFLAGS} .= " -DUSEIMPORTLIB" if ($Config{useshrplib} eq 'true');
return $self->{CFLAGS} = qq{
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
PERLTYPE = $self->{PERLTYPE}
};
}
=item replace_manpage_separator
replaces strings '::' with '.' in MAN*POD man page names
=cut
sub replace_manpage_separator {
my($self, $man) = @_;
$man =~ s{/+}{.}g;
return $man;
}
=item init_linker
points to libperl.a
=cut
sub init_linker {
my $self = shift;
if ($Config{useshrplib} eq 'true') {
my $libperl = '$(PERL_INC)' .'/'. "$Config{libperl}";
if( $] >= 5.006002 ) {
$libperl =~ s/a$/dll.a/;
}
$self->{PERL_ARCHIVE} = $libperl;
} else {
$self->{PERL_ARCHIVE} =
'$(PERL_INC)' .'/'. ("$Config{libperl}" or "libperl.a");
}
$self->{PERL_ARCHIVE_AFTER} ||= '';
$self->{EXPORT_LIST} ||= '';
}
=item maybe_command
If our path begins with F</cygdrive/> then we use C<ExtUtils::MM_Win32>
to determine if it may be a command. Otherwise we use the tests
from C<ExtUtils::MM_Unix>.
=cut
sub maybe_command {
my ($self, $file) = @_;
if ($file =~ m{^/cygdrive/}i) {
return ExtUtils::MM_Win32->maybe_command($file);
}
return $self->SUPER::maybe_command($file);
}
=item dynamic_lib
Use the default to produce the *.dll's.
But for new archdir dll's use the same rebase address if the old exists.
=cut
sub dynamic_lib {
my($self, %attribs) = @_;
my $s = ExtUtils::MM_Unix::dynamic_lib($self, %attribs);
my $ori = "$self->{INSTALLARCHLIB}/auto/$self->{FULLEXT}/$self->{BASEEXT}.$self->{DLEXT}";
if (-e $ori) {
my $imagebase = `/bin/objdump -p $ori | /bin/grep ImageBase | /bin/cut -c12-`;
chomp $imagebase;
if ($imagebase gt "40000000") {
my $LDDLFLAGS = $self->{LDDLFLAGS};
$LDDLFLAGS =~ s/-Wl,--enable-auto-image-base/-Wl,--image-base=0x$imagebase/;
$s =~ s/ \$\(LDDLFLAGS\) / $LDDLFLAGS /m;
}
}
$s;
}
=item all_target
Build man pages, too
=cut
sub all_target {
ExtUtils::MM_Unix::all_target(shift);
}
=back
=cut
1;
EXTUTILS_MM_CYGWIN
$fatpacked{"ExtUtils/MM_DOS.pm"} = <<'EXTUTILS_MM_DOS';
package ExtUtils::MM_DOS;
use strict;
our $VERSION = '6.64';
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
=head1 NAME
ExtUtils::MM_DOS - DOS specific subclass of ExtUtils::MM_Unix
=head1 SYNOPSIS
Don't use this module directly.
Use ExtUtils::MM and let it choose.
=head1 DESCRIPTION
This is a subclass of ExtUtils::MM_Unix which contains functionality
for DOS.
Unless otherwise stated, it works just like ExtUtils::MM_Unix
=head2 Overridden methods
=over 4
=item os_flavor
=cut
sub os_flavor {
return('DOS');
}
=item B<replace_manpage_separator>
Generates Foo__Bar.3 style man page names
=cut
sub replace_manpage_separator {
my($self, $man) = @_;
$man =~ s,/+,__,g;
return $man;
}
=back
=head1 AUTHOR
Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix
=head1 SEE ALSO
L<ExtUtils::MM_Unix>, L<ExtUtils::MakeMaker>
=cut
1;
EXTUTILS_MM_DOS
$fatpacked{"ExtUtils/MM_Darwin.pm"} = <<'EXTUTILS_MM_DARWIN';
package ExtUtils::MM_Darwin;
use strict;
BEGIN {
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Unix );
}
our $VERSION = '6.64';
=head1 NAME
ExtUtils::MM_Darwin - special behaviors for OS X
=head1 SYNOPSIS
For internal MakeMaker use only
=head1 DESCRIPTION
See L<ExtUtils::MM_Unix> for L<ExtUtils::MM_Any> for documention on the
methods overridden here.
=head2 Overriden Methods
=head3 init_dist
Turn off Apple tar's tendency to copy resource forks as "._foo" files.
=cut
sub init_dist {
my $self = shift;
# Thank you, Apple, for breaking tar and then breaking the work around.
# 10.4 wants COPY_EXTENDED_ATTRIBUTES_DISABLE while 10.5 wants
# COPYFILE_DISABLE. I'm not going to push my luck and instead just
# set both.
$self->{TAR} ||=
'COPY_EXTENDED_ATTRIBUTES_DISABLE=1 COPYFILE_DISABLE=1 tar';
$self->SUPER::init_dist(@_);
}
1;
EXTUTILS_MM_DARWIN
$fatpacked{"ExtUtils/MM_MacOS.pm"} = <<'EXTUTILS_MM_MACOS';
package ExtUtils::MM_MacOS;
use strict;
our $VERSION = '6.64';
sub new {
die <<'UNSUPPORTED';
MacOS Classic (MacPerl) is no longer supported by MakeMaker.
Please use Module::Build instead.
UNSUPPORTED
}
=head1 NAME
ExtUtils::MM_MacOS - once produced Makefiles for MacOS Classic
=head1 SYNOPSIS
# MM_MacOS no longer contains any code. This is just a stub.
=head1 DESCRIPTION
Once upon a time, MakeMaker could produce an approximation of a correct
Makefile on MacOS Classic (MacPerl). Due to a lack of maintainers, this
fell out of sync with the rest of MakeMaker and hadn't worked in years.
Since there's little chance of it being repaired, MacOS Classic is fading
away, and the code was icky to begin with, the code has been deleted to
make maintenance easier.
Those interested in writing modules for MacPerl should use Module::Build
which works better than MakeMaker ever did.
Anyone interested in resurrecting this file should pull the old version
from the MakeMaker CVS repository and contact makemaker@perl.org, but we
really encourage you to work on Module::Build instead.
=cut
1;
EXTUTILS_MM_MACOS
$fatpacked{"ExtUtils/MM_NW5.pm"} = <<'EXTUTILS_MM_NW5';
package ExtUtils::MM_NW5;
=head1 NAME
ExtUtils::MM_NW5 - methods to override UN*X behaviour in ExtUtils::MakeMaker
=head1 SYNOPSIS
use ExtUtils::MM_NW5; # Done internally by ExtUtils::MakeMaker if needed
=head1 DESCRIPTION
See ExtUtils::MM_Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
=over
=cut
use strict;
use ExtUtils::MakeMaker::Config;
use File::Basename;
our $VERSION = '6.64';
require ExtUtils::MM_Win32;
our @ISA = qw(ExtUtils::MM_Win32);
use ExtUtils::MakeMaker qw( &neatvalue );
$ENV{EMXSHELL} = 'sh'; # to run `commands`
my $BORLAND = $Config{'cc'} =~ /^bcc/i;
my $GCC = $Config{'cc'} =~ /^gcc/i;
=item os_flavor
We're Netware in addition to being Windows.
=cut
sub os_flavor {
my $self = shift;
return ($self->SUPER::os_flavor, 'Netware');
}
=item init_platform
Add Netware macros.
LIBPTH, BASE_IMPORT, NLM_VERSION, MPKTOOL, TOOLPATH, BOOT_SYMBOL,
NLM_SHORT_NAME, INCLUDE, PATH, MM_NW5_REVISION
=item platform_constants
Add Netware macros initialized above to the Makefile.
=cut
sub init_platform {
my($self) = shift;
# To get Win32's setup.
$self->SUPER::init_platform;
# incpath is copied to makefile var INCLUDE in constants sub, here just
# make it empty
my $libpth = $Config{'libpth'};
$libpth =~ s( )(;);
$self->{'LIBPTH'} = $libpth;
$self->{'BASE_IMPORT'} = $Config{'base_import'};
# Additional import file specified from Makefile.pl
if($self->{'base_import'}) {
$self->{'BASE_IMPORT'} .= ', ' . $self->{'base_import'};
}
$self->{'NLM_VERSION'} = $Config{'nlm_version'};
$self->{'MPKTOOL'} = $Config{'mpktool'};
$self->{'TOOLPATH'} = $Config{'toolpath'};
(my $boot = $self->{'NAME'}) =~ s/:/_/g;
$self->{'BOOT_SYMBOL'}=$boot;
# If the final binary name is greater than 8 chars,
# truncate it here.
if(length($self->{'BASEEXT'}) > 8) {
$self->{'NLM_SHORT_NAME'} = substr($self->{'BASEEXT'},0,8);
}
# Get the include path and replace the spaces with ;
# Copy this to makefile as INCLUDE = d:\...;d:\;
($self->{INCLUDE} = $Config{'incpath'}) =~ s/([ ]*)-I/;/g;
# Set the path to CodeWarrior binaries which might not have been set in
# any other place
$self->{PATH} = '$(PATH);$(TOOLPATH)';
$self->{MM_NW5_VERSION} = $VERSION;
}
sub platform_constants {
my($self) = shift;
my $make_frag = '';
# Setup Win32's constants.
$make_frag .= $self->SUPER::platform_constants;
foreach my $macro (qw(LIBPTH BASE_IMPORT NLM_VERSION MPKTOOL
TOOLPATH BOOT_SYMBOL NLM_SHORT_NAME INCLUDE PATH
MM_NW5_VERSION
))
{
next unless defined $self->{$macro};
$make_frag .= "$macro = $self->{$macro}\n";
}
return $make_frag;
}
=item const_cccmd
=cut
sub const_cccmd {
my($self,$libperl)=@_;
return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
return '' unless $self->needs_linking();
return $self->{CONST_CCCMD} = <<'MAKE_FRAG';
CCCMD = $(CC) $(CCFLAGS) $(INC) $(OPTIMIZE) \
$(PERLTYPE) $(MPOLLUTE) -o $@ \
-DVERSION=\"$(VERSION)\" -DXS_VERSION=\"$(XS_VERSION)\"
MAKE_FRAG
}
=item static_lib
=cut
sub static_lib {
my($self) = @_;
return '' unless $self->has_link_code;
my $m = <<'END';
$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists
$(RM_RF) $@
END
# If this extension has it's own library (eg SDBM_File)
# then copy that to $(INST_STATIC) and add $(OBJECT) into it.
$m .= <<'END' if $self->{MYEXTLIB};
$self->{CP} $(MYEXTLIB) $@
END
my $ar_arg;
if( $BORLAND ) {
$ar_arg = '$@ $(OBJECT:^"+")';
}
elsif( $GCC ) {
$ar_arg = '-ru $@ $(OBJECT)';
}
else {
$ar_arg = '-type library -o $@ $(OBJECT)';
}
$m .= sprintf <<'END', $ar_arg;
$(AR) %s
$(NOECHO) $(ECHO) "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)\extralibs.ld
$(CHMOD) 755 $@
END
$m .= <<'END' if $self->{PERL_SRC};
$(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)\ext.libs
END
return $m;
}
=item dynamic_lib
Defines how to produce the *.so (or equivalent) files.
=cut
sub dynamic_lib {
my($self, %attribs) = @_;
return '' unless $self->needs_linking(); #might be because of a subdir
return '' unless $self->has_link_code;
my($otherldflags) = $attribs{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': '');
my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
my($ldfrom) = '$(LDFROM)';
(my $boot = $self->{NAME}) =~ s/:/_/g;
my $m = <<'MAKE_FRAG';
# This section creates the dynamically loadable $(INST_DYNAMIC)
# from $(OBJECT) and possibly $(MYEXTLIB).
OTHERLDFLAGS = '.$otherldflags.'
INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
# Create xdc data for an MT safe NLM in case of mpk build
$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists
$(NOECHO) $(ECHO) Export boot_$(BOOT_SYMBOL) > $(BASEEXT).def
$(NOECHO) $(ECHO) $(BASE_IMPORT) >> $(BASEEXT).def
$(NOECHO) $(ECHO) Import @$(PERL_INC)\perl.imp >> $(BASEEXT).def
MAKE_FRAG
if ( $self->{CCFLAGS} =~ m/ -DMPK_ON /) {
$m .= <<'MAKE_FRAG';
$(MPKTOOL) $(XDCFLAGS) $(BASEEXT).xdc
$(NOECHO) $(ECHO) xdcdata $(BASEEXT).xdc >> $(BASEEXT).def
MAKE_FRAG
}
# Reconstruct the X.Y.Z version.
my $version = join '.', map { sprintf "%d", $_ }
$] =~ /(\d)\.(\d{3})(\d{2})/;
$m .= sprintf ' $(LD) $(LDFLAGS) $(OBJECT:.obj=.obj) -desc "Perl %s Extension ($(BASEEXT)) XS_VERSION: $(XS_VERSION)" -nlmversion $(NLM_VERSION)', $version;
# Taking care of long names like FileHandle, ByteLoader, SDBM_File etc
if($self->{NLM_SHORT_NAME}) {
# In case of nlms with names exceeding 8 chars, build nlm in the
# current dir, rename and move to auto\lib.
$m .= q{ -o $(NLM_SHORT_NAME).$(DLEXT)}
} else {
$m .= q{ -o $(INST_AUTODIR)\\$(BASEEXT).$(DLEXT)}
}
# Add additional lib files if any (SDBM_File)
$m .= q{ $(MYEXTLIB) } if $self->{MYEXTLIB};
$m .= q{ $(PERL_INC)\Main.lib -commandfile $(BASEEXT).def}."\n";
if($self->{NLM_SHORT_NAME}) {
$m .= <<'MAKE_FRAG';
if exist $(INST_AUTODIR)\$(NLM_SHORT_NAME).$(DLEXT) del $(INST_AUTODIR)\$(NLM_SHORT_NAME).$(DLEXT)
move $(NLM_SHORT_NAME).$(DLEXT) $(INST_AUTODIR)
MAKE_FRAG
}
$m .= <<'MAKE_FRAG';
$(CHMOD) 755 $@
MAKE_FRAG
return $m;
}
1;
__END__
=back
=cut
EXTUTILS_MM_NW5
$fatpacked{"ExtUtils/MM_OS2.pm"} = <<'EXTUTILS_MM_OS2';
package ExtUtils::MM_OS2;
use strict;
use ExtUtils::MakeMaker qw(neatvalue);
use File::Spec;
our $VERSION = '6.64';
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Any ExtUtils::MM_Unix);
=pod
=head1 NAME
ExtUtils::MM_OS2 - methods to override UN*X behaviour in ExtUtils::MakeMaker
=head1 SYNOPSIS
use ExtUtils::MM_OS2; # Done internally by ExtUtils::MakeMaker if needed
=head1 DESCRIPTION
See ExtUtils::MM_Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
=head1 METHODS
=over 4
=item init_dist
Define TO_UNIX to convert OS2 linefeeds to Unix style.
=cut
sub init_dist {
my($self) = @_;
$self->{TO_UNIX} ||= <<'MAKE_TEXT';
$(NOECHO) $(TEST_F) tmp.zip && $(RM_F) tmp.zip; $(ZIP) -ll -mr tmp.zip $(DISTVNAME) && unzip -o tmp.zip && $(RM_F) tmp.zip
MAKE_TEXT
$self->SUPER::init_dist;
}
sub dlsyms {
my($self,%attribs) = @_;
my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {};
my(@m);
(my $boot = $self->{NAME}) =~ s/:/_/g;
if (not $self->{SKIPHASH}{'dynamic'}) {
push(@m,"
$self->{BASEEXT}.def: Makefile.PL
",
' $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e \'use ExtUtils::Mksymlists; \\
Mksymlists("NAME" => "$(NAME)", "DLBASE" => "$(DLBASE)", ',
'"VERSION" => "$(VERSION)", "DISTNAME" => "$(DISTNAME)", ',
'"INSTALLDIRS" => "$(INSTALLDIRS)", ',
'"DL_FUNCS" => ',neatvalue($funcs),
', "FUNCLIST" => ',neatvalue($funclist),
', "IMPORTS" => ',neatvalue($imports),
', "DL_VARS" => ', neatvalue($vars), ');\'
');
}
if ($self->{IMPORTS} && %{$self->{IMPORTS}}) {
# Make import files (needed for static build)
-d 'tmp_imp' or mkdir 'tmp_imp', 0777 or die "Can't mkdir tmp_imp";
open my $imp, '>', 'tmpimp.imp' or die "Can't open tmpimp.imp";
while (my($name, $exp) = each %{$self->{IMPORTS}}) {
my ($lib, $id) = ($exp =~ /(.*)\.(.*)/) or die "Malformed IMPORT `$exp'";
print $imp "$name $lib $id ?\n";
}
close $imp or die "Can't close tmpimp.imp";
# print "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp\n";
system "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp"
and die "Cannot make import library: $!, \$?=$?";
# May be running under miniperl, so have no glob...
eval "unlink <tmp_imp/*>; 1" or system "rm tmp_imp/*";
system "cd tmp_imp; $Config::Config{ar} x ../tmpimp$Config::Config{lib_ext}"
and die "Cannot extract import objects: $!, \$?=$?";
}
join('',@m);
}
sub static_lib {
my($self) = @_;
my $old = $self->ExtUtils::MM_Unix::static_lib();
return $old unless $self->{IMPORTS} && %{$self->{IMPORTS}};
my @chunks = split /\n{2,}/, $old;
shift @chunks unless length $chunks[0]; # Empty lines at the start
$chunks[0] .= <<'EOC';
$(AR) $(AR_STATIC_ARGS) $@ tmp_imp/* && $(RANLIB) $@
EOC
return join "\n\n". '', @chunks;
}
sub replace_manpage_separator {
my($self,$man) = @_;
$man =~ s,/+,.,g;
$man;
}
sub maybe_command {
my($self,$file) = @_;
$file =~ s,[/\\]+,/,g;
return $file if -x $file && ! -d _;
return "$file.exe" if -x "$file.exe" && ! -d _;
return "$file.cmd" if -x "$file.cmd" && ! -d _;
return;
}
=item init_linker
=cut
sub init_linker {
my $self = shift;
$self->{PERL_ARCHIVE} = "\$(PERL_INC)/libperl\$(LIB_EXT)";
$self->{PERL_ARCHIVE_AFTER} = $OS2::is_aout
? ''
: '$(PERL_INC)/libperl_override$(LIB_EXT)';
$self->{EXPORT_LIST} = '$(BASEEXT).def';
}
=item os_flavor
OS/2 is OS/2
=cut
sub os_flavor {
return('OS/2');
}
=back
=cut
1;
EXTUTILS_MM_OS2
$fatpacked{"ExtUtils/MM_QNX.pm"} = <<'EXTUTILS_MM_QNX';
package ExtUtils::MM_QNX;
use strict;
our $VERSION = '6.64';
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
=head1 NAME
ExtUtils::MM_QNX - QNX specific subclass of ExtUtils::MM_Unix
=head1 SYNOPSIS
Don't use this module directly.
Use ExtUtils::MM and let it choose.
=head1 DESCRIPTION
This is a subclass of ExtUtils::MM_Unix which contains functionality for
QNX.
Unless otherwise stated it works just like ExtUtils::MM_Unix
=head2 Overridden methods
=head3 extra_clean_files
Add .err files corresponding to each .c file.
=cut
sub extra_clean_files {
my $self = shift;
my @errfiles = @{$self->{C}};
for ( @errfiles ) {
s/.c$/.err/;
}
return( @errfiles, 'perlmain.err' );
}
=head1 AUTHOR
Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix
=head1 SEE ALSO
L<ExtUtils::MakeMaker>
=cut
1;
EXTUTILS_MM_QNX
$fatpacked{"ExtUtils/MM_UWIN.pm"} = <<'EXTUTILS_MM_UWIN';
package ExtUtils::MM_UWIN;
use strict;
our $VERSION = '6.64';
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
=head1 NAME
ExtUtils::MM_UWIN - U/WIN specific subclass of ExtUtils::MM_Unix
=head1 SYNOPSIS
Don't use this module directly.
Use ExtUtils::MM and let it choose.
=head1 DESCRIPTION
This is a subclass of ExtUtils::MM_Unix which contains functionality for
the AT&T U/WIN UNIX on Windows environment.
Unless otherwise stated it works just like ExtUtils::MM_Unix
=head2 Overridden methods
=over 4
=item os_flavor
In addition to being Unix, we're U/WIN.
=cut
sub os_flavor {
return('Unix', 'U/WIN');
}
=item B<replace_manpage_separator>
=cut
sub replace_manpage_separator {
my($self, $man) = @_;
$man =~ s,/+,.,g;
return $man;
}
=back
=head1 AUTHOR
Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix
=head1 SEE ALSO
L<ExtUtils::MM_Win32>, L<ExtUtils::MakeMaker>
=cut
1;
EXTUTILS_MM_UWIN
$fatpacked{"ExtUtils/MM_Unix.pm"} = <<'EXTUTILS_MM_UNIX';
package ExtUtils::MM_Unix;
require 5.006;
use strict;
use Carp;
use ExtUtils::MakeMaker::Config;
use File::Basename qw(basename dirname);
use DirHandle;
our %Config_Override;
use ExtUtils::MakeMaker qw($Verbose neatvalue);
# If we make $VERSION an our variable parse_version() breaks
use vars qw($VERSION);
$VERSION = '6.64';
$VERSION = eval $VERSION;
require ExtUtils::MM_Any;
our @ISA = qw(ExtUtils::MM_Any);
my %Is;
BEGIN {
$Is{OS2} = $^O eq 'os2';
$Is{Win32} = $^O eq 'MSWin32' || $Config{osname} eq 'NetWare';
$Is{Dos} = $^O eq 'dos';
$Is{VMS} = $^O eq 'VMS';
$Is{OSF} = $^O eq 'dec_osf';
$Is{IRIX} = $^O eq 'irix';
$Is{NetBSD} = $^O eq 'netbsd';
$Is{Interix} = $^O eq 'interix';
$Is{SunOS4} = $^O eq 'sunos';
$Is{Solaris} = $^O eq 'solaris';
$Is{SunOS} = $Is{SunOS4} || $Is{Solaris};
$Is{BSD} = ($^O =~ /^(?:free|net|open)bsd$/ or
grep( $^O eq $_, qw(bsdos interix dragonfly) )
);
}
BEGIN {
if( $Is{VMS} ) {
# For things like vmsify()
require VMS::Filespec;
VMS::Filespec->import;
}
}
=head1 NAME
ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker
=head1 SYNOPSIS
C<require ExtUtils::MM_Unix;>
=head1 DESCRIPTION
The methods provided by this package are designed to be used in
conjunction with ExtUtils::MakeMaker. When MakeMaker writes a
Makefile, it creates one or more objects that inherit their methods
from a package C<MM>. MM itself doesn't provide any methods, but it
ISA ExtUtils::MM_Unix class. The inheritance tree of MM lets operating
specific packages take the responsibility for all the methods provided
by MM_Unix. We are trying to reduce the number of the necessary
overrides by defining rather primitive operations within
ExtUtils::MM_Unix.
If you are going to write a platform specific MM package, please try
to limit the necessary overrides to primitive methods, and if it is not
possible to do so, let's work out how to achieve that gain.
If you are overriding any of these methods in your Makefile.PL (in the
MY class), please report that to the makemaker mailing list. We are
trying to minimize the necessary method overrides and switch to data
driven Makefile.PLs wherever possible. In the long run less methods
will be overridable via the MY class.
=head1 METHODS
The following description of methods is still under
development. Please refer to the code for not suitably documented
sections and complain loudly to the makemaker@perl.org mailing list.
Better yet, provide a patch.
Not all of the methods below are overridable in a
Makefile.PL. Overridable methods are marked as (o). All methods are
overridable by a platform specific MM_*.pm file.
Cross-platform methods are being moved into MM_Any. If you can't find
something that used to be in here, look in MM_Any.
=cut
# So we don't have to keep calling the methods over and over again,
# we have these globals to cache the values. Faster and shrtr.
my $Curdir = __PACKAGE__->curdir;
my $Rootdir = __PACKAGE__->rootdir;
my $Updir = __PACKAGE__->updir;
=head2 Methods
=over 4
=item os_flavor
Simply says that we're Unix.
=cut
sub os_flavor {
return('Unix');
}
=item c_o (o)
Defines the suffix rules to compile different flavors of C files to
object files.
=cut
sub c_o {
# --- Translation Sections ---
my($self) = shift;
return '' unless $self->needs_linking();
my(@m);
my $command = '$(CCCMD)';
my $flags = '$(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE)';
if (my $cpp = $Config{cpprun}) {
my $cpp_cmd = $self->const_cccmd;
$cpp_cmd =~ s/^CCCMD\s*=\s*\$\(CC\)/$cpp/;
push @m, qq{
.c.i:
$cpp_cmd $flags \$*.c > \$*.i
};
}
push @m, qq{
.c.s:
$command -S $flags \$*.c
.c\$(OBJ_EXT):
$command $flags \$*.c
.cpp\$(OBJ_EXT):
$command $flags \$*.cpp
.cxx\$(OBJ_EXT):
$command $flags \$*.cxx
.cc\$(OBJ_EXT):
$command $flags \$*.cc
};
push @m, qq{
.C\$(OBJ_EXT):
$command $flags \$*.C
} if !$Is{OS2} and !$Is{Win32} and !$Is{Dos}; #Case-specific
return join "", @m;
}
=item cflags (o)
Does very much the same as the cflags script in the perl
distribution. It doesn't return the whole compiler command line, but
initializes all of its parts. The const_cccmd method then actually
returns the definition of the CCCMD macro which uses these parts.
=cut
#'
sub cflags {
my($self,$libperl)=@_;
return $self->{CFLAGS} if $self->{CFLAGS};
return '' unless $self->needs_linking();
my($prog, $uc, $perltype, %cflags);
$libperl ||= $self->{LIBPERL_A} || "libperl$self->{LIB_EXT}" ;
$libperl =~ s/\.\$\(A\)$/$self->{LIB_EXT}/;
@cflags{qw(cc ccflags optimize shellflags)}
= @Config{qw(cc ccflags optimize shellflags)};
my($optdebug) = "";
$cflags{shellflags} ||= '';
my(%map) = (
D => '-DDEBUGGING',
E => '-DEMBED',
DE => '-DDEBUGGING -DEMBED',
M => '-DEMBED -DMULTIPLICITY',
DM => '-DDEBUGGING -DEMBED -DMULTIPLICITY',
);
if ($libperl =~ /libperl(\w*)\Q$self->{LIB_EXT}/){
$uc = uc($1);
} else {
$uc = ""; # avoid warning
}
$perltype = $map{$uc} ? $map{$uc} : "";
if ($uc =~ /^D/) {
$optdebug = "-g";
}
my($name);
( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ;
if ($prog = $Config{$name}) {
# Expand hints for this extension via the shell
print "Processing $name hint:\n" if $Verbose;
my(@o)=`cc=\"$cflags{cc}\"
ccflags=\"$cflags{ccflags}\"
optimize=\"$cflags{optimize}\"
perltype=\"$cflags{perltype}\"
optdebug=\"$cflags{optdebug}\"
eval '$prog'
echo cc=\$cc
echo ccflags=\$ccflags
echo optimize=\$optimize
echo perltype=\$perltype
echo optdebug=\$optdebug
`;
foreach my $line (@o){
chomp $line;
if ($line =~ /(.*?)=\s*(.*)\s*$/){
$cflags{$1} = $2;
print " $1 = $2\n" if $Verbose;
} else {
print "Unrecognised result from hint: '$line'\n";
}
}
}
if ($optdebug) {
$cflags{optimize} = $optdebug;
}
for (qw(ccflags optimize perltype)) {
$cflags{$_} ||= '';
$cflags{$_} =~ s/^\s+//;
$cflags{$_} =~ s/\s+/ /g;
$cflags{$_} =~ s/\s+$//;
$self->{uc $_} ||= $cflags{$_};
}
if ($self->{POLLUTE}) {
$self->{CCFLAGS} .= ' -DPERL_POLLUTE ';
}
my $pollute = '';
if ($Config{usemymalloc} and not $Config{bincompat5005}
and not $Config{ccflags} =~ /-DPERL_POLLUTE_MALLOC\b/
and $self->{PERL_MALLOC_OK}) {
$pollute = '$(PERL_MALLOC_DEF)';
}
$self->{CCFLAGS} = quote_paren($self->{CCFLAGS});
$self->{OPTIMIZE} = quote_paren($self->{OPTIMIZE});
return $self->{CFLAGS} = qq{
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
PERLTYPE = $self->{PERLTYPE}
MPOLLUTE = $pollute
};
}
=item const_cccmd (o)
Returns the full compiler call for C programs and stores the
definition in CONST_CCCMD.
=cut
sub const_cccmd {
my($self,$libperl)=@_;
return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
return '' unless $self->needs_linking();
return $self->{CONST_CCCMD} =
q{CCCMD = $(CC) -c $(PASTHRU_INC) $(INC) \\
$(CCFLAGS) $(OPTIMIZE) \\
$(PERLTYPE) $(MPOLLUTE) $(DEFINE_VERSION) \\
$(XS_DEFINE_VERSION)};
}
=item const_config (o)
Defines a couple of constants in the Makefile that are imported from
%Config.
=cut
sub const_config {
# --- Constants Sections ---
my($self) = shift;
my @m = <<"END";
# These definitions are from config.sh (via $INC{'Config.pm'}).
# They may have been overridden via Makefile.PL or on the command line.
END
my(%once_only);
foreach my $key (@{$self->{CONFIG}}){
# SITE*EXP macros are defined in &constants; avoid duplicates here
next if $once_only{$key};
$self->{uc $key} = quote_paren($self->{uc $key});
push @m, uc($key) , ' = ' , $self->{uc $key}, "\n";
$once_only{$key} = 1;
}
join('', @m);
}
=item const_loadlibs (o)
Defines EXTRALIBS, LDLOADLIBS, BSLOADLIBS, LD_RUN_PATH. See
L<ExtUtils::Liblist> for details.
=cut
sub const_loadlibs {
my($self) = shift;
return "" unless $self->needs_linking;
my @m;
push @m, qq{
# $self->{NAME} might depend on some other libraries:
# See ExtUtils::Liblist for details
#
};
for my $tmp (qw/
EXTRALIBS LDLOADLIBS BSLOADLIBS
/) {
next unless defined $self->{$tmp};
push @m, "$tmp = $self->{$tmp}\n";
}
# don't set LD_RUN_PATH if empty
for my $tmp (qw/
LD_RUN_PATH
/) {
next unless $self->{$tmp};
push @m, "$tmp = $self->{$tmp}\n";
}
return join "", @m;
}
=item constants (o)
my $make_frag = $mm->constants;
Prints out macros for lots of constants.
=cut
sub constants {
my($self) = @_;
my @m = ();
$self->{DFSEP} = '$(DIRFILESEP)'; # alias for internal use
for my $macro (qw(
AR_STATIC_ARGS DIRFILESEP DFSEP
NAME NAME_SYM
VERSION VERSION_MACRO VERSION_SYM DEFINE_VERSION
XS_VERSION XS_VERSION_MACRO XS_DEFINE_VERSION
INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB
INST_MAN1DIR INST_MAN3DIR
MAN1EXT MAN3EXT
INSTALLDIRS INSTALL_BASE DESTDIR PREFIX
PERLPREFIX SITEPREFIX VENDORPREFIX
),
(map { ("INSTALL".$_,
"DESTINSTALL".$_)
} $self->installvars),
qw(
PERL_LIB
PERL_ARCHLIB
LIBPERL_A MYEXTLIB
FIRST_MAKEFILE MAKEFILE_OLD MAKE_APERL_FILE
PERLMAINCC PERL_SRC PERL_INC
PERL FULLPERL ABSPERL
PERLRUN FULLPERLRUN ABSPERLRUN
PERLRUNINST FULLPERLRUNINST ABSPERLRUNINST
PERL_CORE
PERM_DIR PERM_RW PERM_RWX
) )
{
next unless defined $self->{$macro};
# pathnames can have sharp signs in them; escape them so
# make doesn't think it is a comment-start character.
$self->{$macro} =~ s/#/\\#/g;
push @m, "$macro = $self->{$macro}\n";
}
push @m, qq{
MAKEMAKER = $self->{MAKEMAKER}
MM_VERSION = $self->{MM_VERSION}
MM_REVISION = $self->{MM_REVISION}
};
push @m, q{
# FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle).
# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle)
# PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar)
# DLBASE = Basename part of dynamic library. May be just equal BASEEXT.
};
for my $macro (qw/
MAKE
FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT
LDFROM LINKTYPE BOOTDEP
/ )
{
next unless defined $self->{$macro};
push @m, "$macro = $self->{$macro}\n";
}
push @m, "
# Handy lists of source code files:
XS_FILES = ".$self->wraplist(sort keys %{$self->{XS}})."
C_FILES = ".$self->wraplist(@{$self->{C}})."
O_FILES = ".$self->wraplist(@{$self->{O_FILES}})."
H_FILES = ".$self->wraplist(@{$self->{H}})."
MAN1PODS = ".$self->wraplist(sort keys %{$self->{MAN1PODS}})."
MAN3PODS = ".$self->wraplist(sort keys %{$self->{MAN3PODS}})."
";
push @m, q{
# Where is the Config information that we are using/depend on
CONFIGDEP = $(PERL_ARCHLIB)$(DFSEP)Config.pm $(PERL_INC)$(DFSEP)config.h
};
push @m, qq{
# Where to build things
INST_LIBDIR = $self->{INST_LIBDIR}
INST_ARCHLIBDIR = $self->{INST_ARCHLIBDIR}
INST_AUTODIR = $self->{INST_AUTODIR}
INST_ARCHAUTODIR = $self->{INST_ARCHAUTODIR}
INST_STATIC = $self->{INST_STATIC}
INST_DYNAMIC = $self->{INST_DYNAMIC}
INST_BOOT = $self->{INST_BOOT}
};
push @m, qq{
# Extra linker info
EXPORT_LIST = $self->{EXPORT_LIST}
PERL_ARCHIVE = $self->{PERL_ARCHIVE}
PERL_ARCHIVE_AFTER = $self->{PERL_ARCHIVE_AFTER}
};
push @m, "
TO_INST_PM = ".$self->wraplist(sort keys %{$self->{PM}})."
PM_TO_BLIB = ".$self->wraplist(%{$self->{PM}})."
";
join('',@m);
}
=item depend (o)
Same as macro for the depend attribute.
=cut
sub depend {
my($self,%attribs) = @_;
my(@m,$key,$val);
while (($key,$val) = each %attribs){
last unless defined $key;
push @m, "$key : $val\n";
}
join "", @m;
}
=item init_DEST
$mm->init_DEST
Defines the DESTDIR and DEST* variables paralleling the INSTALL*.
=cut
sub init_DEST {
my $self = shift;
# Initialize DESTDIR
$self->{DESTDIR} ||= '';
# Make DEST variables.
foreach my $var ($self->installvars) {
my $destvar = 'DESTINSTALL'.$var;
$self->{$destvar} ||= '$(DESTDIR)$(INSTALL'.$var.')';
}
}
=item init_dist
$mm->init_dist;
Defines a lot of macros for distribution support.
macro description default
TAR tar command to use tar
TARFLAGS flags to pass to TAR cvf
ZIP zip command to use zip
ZIPFLAGS flags to pass to ZIP -r
COMPRESS compression command to gzip --best
use for tarfiles
SUFFIX suffix to put on .gz
compressed files
SHAR shar command to use shar
PREOP extra commands to run before
making the archive
POSTOP extra commands to run after
making the archive
TO_UNIX a command to convert linefeeds
to Unix style in your archive
CI command to checkin your ci -u
sources to version control
RCS_LABEL command to label your sources rcs -Nv$(VERSION_SYM): -q
just after CI is run
DIST_CP $how argument to manicopy() best
when the distdir is created
DIST_DEFAULT default target to use to tardist
create a distribution
DISTVNAME name of the resulting archive $(DISTNAME)-$(VERSION)
(minus suffixes)
=cut
sub init_dist {
my $self = shift;
$self->{TAR} ||= 'tar';
$self->{TARFLAGS} ||= 'cvf';
$self->{ZIP} ||= 'zip';
$self->{ZIPFLAGS} ||= '-r';
$self->{COMPRESS} ||= 'gzip --best';
$self->{SUFFIX} ||= '.gz';
$self->{SHAR} ||= 'shar';
$self->{PREOP} ||= '$(NOECHO) $(NOOP)'; # eg update MANIFEST
$self->{POSTOP} ||= '$(NOECHO) $(NOOP)'; # eg remove the distdir
$self->{TO_UNIX} ||= '$(NOECHO) $(NOOP)';
$self->{CI} ||= 'ci -u';
$self->{RCS_LABEL}||= 'rcs -Nv$(VERSION_SYM): -q';
$self->{DIST_CP} ||= 'best';
$self->{DIST_DEFAULT} ||= 'tardist';
($self->{DISTNAME} = $self->{NAME}) =~ s{::}{-}g unless $self->{DISTNAME};
$self->{DISTVNAME} ||= $self->{DISTNAME}.'-'.$self->{VERSION};
}
=item dist (o)
my $dist_macros = $mm->dist(%overrides);
Generates a make fragment defining all the macros initialized in
init_dist.
%overrides can be used to override any of the above.
=cut
sub dist {
my($self, %attribs) = @_;
my $make = '';
foreach my $key (qw(
TAR TARFLAGS ZIP ZIPFLAGS COMPRESS SUFFIX SHAR
PREOP POSTOP TO_UNIX
CI RCS_LABEL DIST_CP DIST_DEFAULT
DISTNAME DISTVNAME
))
{
my $value = $attribs{$key} || $self->{$key};
$make .= "$key = $value\n";
}
return $make;
}
=item dist_basics (o)
Defines the targets distclean, distcheck, skipcheck, manifest, veryclean.
=cut
sub dist_basics {
my($self) = shift;
return <<'MAKE_FRAG';
distclean :: realclean distcheck
$(NOECHO) $(NOOP)
distcheck :
$(PERLRUN) "-MExtUtils::Manifest=fullcheck" -e fullcheck
skipcheck :
$(PERLRUN) "-MExtUtils::Manifest=skipcheck" -e skipcheck
manifest :
$(PERLRUN) "-MExtUtils::Manifest=mkmanifest" -e mkmanifest
veryclean : realclean
$(RM_F) *~ */*~ *.orig */*.orig *.bak */*.bak *.old */*.old
MAKE_FRAG
}
=item dist_ci (o)
Defines a check in target for RCS.
=cut
sub dist_ci {
my($self) = shift;
return q{
ci :
$(PERLRUN) "-MExtUtils::Manifest=maniread" \\
-e "@all = keys %{ maniread() };" \\
-e "print(qq{Executing $(CI) @all\n}); system(qq{$(CI) @all});" \\
-e "print(qq{Executing $(RCS_LABEL) ...\n}); system(qq{$(RCS_LABEL) @all});"
};
}
=item dist_core (o)
my $dist_make_fragment = $MM->dist_core;
Puts the targets necessary for 'make dist' together into one make
fragment.
=cut
sub dist_core {
my($self) = shift;
my $make_frag = '';
foreach my $target (qw(dist tardist uutardist tarfile zipdist zipfile
shdist))
{
my $method = $target.'_target';
$make_frag .= "\n";
$make_frag .= $self->$method();
}
return $make_frag;
}
=item B<dist_target>
my $make_frag = $MM->dist_target;
Returns the 'dist' target to make an archive for distribution. This
target simply checks to make sure the Makefile is up-to-date and
depends on $(DIST_DEFAULT).
=cut
sub dist_target {
my($self) = shift;
my $date_check = $self->oneliner(<<'CODE', ['-l']);
print 'Warning: Makefile possibly out of date with $(VERSION_FROM)'
if -e '$(VERSION_FROM)' and -M '$(VERSION_FROM)' < -M '$(FIRST_MAKEFILE)';
CODE
return sprintf <<'MAKE_FRAG', $date_check;
dist : $(DIST_DEFAULT) $(FIRST_MAKEFILE)
$(NOECHO) %s
MAKE_FRAG
}
=item B<tardist_target>
my $make_frag = $MM->tardist_target;
Returns the 'tardist' target which is simply so 'make tardist' works.
The real work is done by the dynamically named tardistfile_target()
method, tardist should have that as a dependency.
=cut
sub tardist_target {
my($self) = shift;
return <<'MAKE_FRAG';
tardist : $(DISTVNAME).tar$(SUFFIX)
$(NOECHO) $(NOOP)
MAKE_FRAG
}
=item B<zipdist_target>
my $make_frag = $MM->zipdist_target;
Returns the 'zipdist' target which is simply so 'make zipdist' works.
The real work is done by the dynamically named zipdistfile_target()
method, zipdist should have that as a dependency.
=cut
sub zipdist_target {
my($self) = shift;
return <<'MAKE_FRAG';
zipdist : $(DISTVNAME).zip
$(NOECHO) $(NOOP)
MAKE_FRAG
}
=item B<tarfile_target>
my $make_frag = $MM->tarfile_target;
The name of this target is the name of the tarball generated by
tardist. This target does the actual work of turning the distdir into
a tarball.
=cut
sub tarfile_target {
my($self) = shift;
return <<'MAKE_FRAG';
$(DISTVNAME).tar$(SUFFIX) : distdir
$(PREOP)
$(TO_UNIX)
$(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME)
$(RM_RF) $(DISTVNAME)
$(COMPRESS) $(DISTVNAME).tar
$(POSTOP)
MAKE_FRAG
}
=item zipfile_target
my $make_frag = $MM->zipfile_target;
The name of this target is the name of the zip file generated by
zipdist. This target does the actual work of turning the distdir into
a zip file.
=cut
sub zipfile_target {
my($self) = shift;
return <<'MAKE_FRAG';
$(DISTVNAME).zip : distdir
$(PREOP)
$(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME)
$(RM_RF) $(DISTVNAME)
$(POSTOP)
MAKE_FRAG
}
=item uutardist_target
my $make_frag = $MM->uutardist_target;
Converts the tarfile into a uuencoded file
=cut
sub uutardist_target {
my($self) = shift;
return <<'MAKE_FRAG';
uutardist : $(DISTVNAME).tar$(SUFFIX)
uuencode $(DISTVNAME).tar$(SUFFIX) $(DISTVNAME).tar$(SUFFIX) > $(DISTVNAME).tar$(SUFFIX)_uu
MAKE_FRAG
}
=item shdist_target
my $make_frag = $MM->shdist_target;
Converts the distdir into a shell archive.
=cut
sub shdist_target {
my($self) = shift;
return <<'MAKE_FRAG';
shdist : distdir
$(PREOP)
$(SHAR) $(DISTVNAME) > $(DISTVNAME).shar
$(RM_RF) $(DISTVNAME)
$(POSTOP)
MAKE_FRAG
}
=item dlsyms (o)
Used by some OS' to define DL_FUNCS and DL_VARS and write the *.exp files.
Normally just returns an empty string.
=cut
sub dlsyms {
return '';
}
=item dynamic_bs (o)
Defines targets for bootstrap files.
=cut
sub dynamic_bs {
my($self, %attribs) = @_;
return '
BOOTSTRAP =
' unless $self->has_link_code();
my $target = $Is{VMS} ? '$(MMS$TARGET)' : '$@';
return sprintf <<'MAKE_FRAG', ($target) x 5;
BOOTSTRAP = $(BASEEXT).bs
# As Mkbootstrap might not write a file (if none is required)
# we use touch to prevent make continually trying to remake it.
# The DynaLoader only reads a non-empty file.
$(BOOTSTRAP) : $(FIRST_MAKEFILE) $(BOOTDEP) $(INST_ARCHAUTODIR)$(DFSEP).exists
$(NOECHO) $(ECHO) "Running Mkbootstrap for $(NAME) ($(BSLOADLIBS))"
$(NOECHO) $(PERLRUN) \
"-MExtUtils::Mkbootstrap" \
-e "Mkbootstrap('$(BASEEXT)','$(BSLOADLIBS)');"
$(NOECHO) $(TOUCH) %s
$(CHMOD) $(PERM_RW) %s
$(INST_BOOT) : $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists
$(NOECHO) $(RM_RF) %s
- $(CP) $(BOOTSTRAP) %s
$(CHMOD) $(PERM_RW) %s
MAKE_FRAG
}
=item dynamic_lib (o)
Defines how to produce the *.so (or equivalent) files.
=cut
sub dynamic_lib {
my($self, %attribs) = @_;
return '' unless $self->needs_linking(); #might be because of a subdir
return '' unless $self->has_link_code;
my($otherldflags) = $attribs{OTHERLDFLAGS} || "";
my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
my($armaybe) = $attribs{ARMAYBE} || $self->{ARMAYBE} || ":";
my($ldfrom) = '$(LDFROM)';
$armaybe = 'ar' if ($Is{OSF} and $armaybe eq ':');
my(@m);
my $ld_opt = $Is{OS2} ? '$(OPTIMIZE) ' : ''; # Useful on other systems too?
my $ld_fix = $Is{OS2} ? '|| ( $(RM_F) $@ && sh -c false )' : '';
push(@m,'
# This section creates the dynamically loadable $(INST_DYNAMIC)
# from $(OBJECT) and possibly $(MYEXTLIB).
ARMAYBE = '.$armaybe.'
OTHERLDFLAGS = '.$ld_opt.$otherldflags.'
INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
INST_DYNAMIC_FIX = '.$ld_fix.'
$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP)
');
if ($armaybe ne ':'){
$ldfrom = 'tmp$(LIB_EXT)';
push(@m,' $(ARMAYBE) cr '.$ldfrom.' $(OBJECT)'."\n");
push(@m,' $(RANLIB) '."$ldfrom\n");
}
$ldfrom = "-all $ldfrom -none" if $Is{OSF};
# The IRIX linker doesn't use LD_RUN_PATH
my $ldrun = $Is{IRIX} && $self->{LD_RUN_PATH} ?
qq{-rpath "$self->{LD_RUN_PATH}"} : '';
# For example in AIX the shared objects/libraries from previous builds
# linger quite a while in the shared dynalinker cache even when nobody
# is using them. This is painful if one for instance tries to restart
# a failed build because the link command will fail unnecessarily 'cos
# the shared object/library is 'busy'.
push(@m,' $(RM_F) $@
');
my $libs = '$(LDLOADLIBS)';
if (($Is{NetBSD} || $Is{Interix}) && $Config{'useshrplib'} eq 'true') {
# Use nothing on static perl platforms, and to the flags needed
# to link against the shared libperl library on shared perl
# platforms. We peek at lddlflags to see if we need -Wl,-R
# or -R to add paths to the run-time library search path.
if ($Config{'lddlflags'} =~ /-Wl,-R/) {
$libs .= ' -L$(PERL_INC) -Wl,-R$(INSTALLARCHLIB)/CORE -Wl,-R$(PERL_ARCHLIB)/CORE -lperl';
} elsif ($Config{'lddlflags'} =~ /-R/) {
$libs .= ' -L$(PERL_INC) -R$(INSTALLARCHLIB)/CORE -R$(PERL_ARCHLIB)/CORE -lperl';
}
}
my $ld_run_path_shell = "";
if ($self->{LD_RUN_PATH} ne "") {
$ld_run_path_shell = 'LD_RUN_PATH="$(LD_RUN_PATH)" ';
}
push @m, sprintf <<'MAKE', $ld_run_path_shell, $ldrun, $ldfrom, $libs;
%s$(LD) %s $(LDDLFLAGS) %s $(OTHERLDFLAGS) -o $@ $(MYEXTLIB) \
$(PERL_ARCHIVE) %s $(PERL_ARCHIVE_AFTER) $(EXPORT_LIST) \
$(INST_DYNAMIC_FIX)
MAKE
push @m, <<'MAKE';
$(CHMOD) $(PERM_RWX) $@
MAKE
return join('',@m);
}
=item exescan
Deprecated method. Use libscan instead.
=cut
sub exescan {
my($self,$path) = @_;
$path;
}
=item extliblist
Called by init_others, and calls ext ExtUtils::Liblist. See
L<ExtUtils::Liblist> for details.
=cut
sub extliblist {
my($self,$libs) = @_;
require ExtUtils::Liblist;
$self->ext($libs, $Verbose);
}
=item find_perl
Finds the executables PERL and FULLPERL
=cut
sub find_perl {
my($self, $ver, $names, $dirs, $trace) = @_;
if ($trace >= 2){
print "Looking for perl $ver by these names:
@$names
in these dirs:
@$dirs
";
}
my $stderr_duped = 0;
local *STDERR_COPY;
unless ($Is{BSD}) {
# >& and lexical filehandles together give 5.6.2 indigestion
if( open(STDERR_COPY, '>&STDERR') ) { ## no critic
$stderr_duped = 1;
}
else {
warn <<WARNING;
find_perl() can't dup STDERR: $!
You might see some garbage while we search for Perl
WARNING
}
}
foreach my $name (@$names){
foreach my $dir (@$dirs){
next unless defined $dir; # $self->{PERL_SRC} may be undefined
my ($abs, $val);
if ($self->file_name_is_absolute($name)) { # /foo/bar
$abs = $name;
} elsif ($self->canonpath($name) eq
$self->canonpath(basename($name))) { # foo
$abs = $self->catfile($dir, $name);
} else { # foo/bar
$abs = $self->catfile($Curdir, $name);
}
print "Checking $abs\n" if ($trace >= 2);
next unless $self->maybe_command($abs);
print "Executing $abs\n" if ($trace >= 2);
my $version_check = qq{$abs -le "require $ver; print qq{VER_OK}"};
$version_check = "$Config{run} $version_check"
if defined $Config{run} and length $Config{run};
# To avoid using the unportable 2>&1 to suppress STDERR,
# we close it before running the command.
# However, thanks to a thread library bug in many BSDs
# ( http://www.freebsd.org/cgi/query-pr.cgi?pr=51535 )
# we cannot use the fancier more portable way in here
# but instead need to use the traditional 2>&1 construct.
if ($Is{BSD}) {
$val = `$version_check 2>&1`;
} else {
close STDERR if $stderr_duped;
$val = `$version_check`;
# 5.6.2's 3-arg open doesn't work with >&
open STDERR, ">&STDERR_COPY" ## no critic
if $stderr_duped;
}
if ($val =~ /^VER_OK/m) {
print "Using PERL=$abs\n" if $trace;
return $abs;
} elsif ($trace >= 2) {
print "Result: '$val' ".($? >> 8)."\n";
}
}
}
print "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
0; # false and not empty
}
=item fixin
$mm->fixin(@files);
Inserts the sharpbang or equivalent magic number to a set of @files.
=cut
sub fixin { # stolen from the pink Camel book, more or less
my ( $self, @files ) = @_;
for my $file (@files) {
my $file_new = "$file.new";
my $file_bak = "$file.bak";
open( my $fixin, '<', $file ) or croak "Can't process '$file': $!";
local $/ = "\n";
chomp( my $line = <$fixin> );
next unless $line =~ s/^\s*\#!\s*//; # Not a shbang file.
my $shb = $self->_fixin_replace_shebang( $file, $line );
next unless defined $shb;
open( my $fixout, ">", "$file_new" ) or do {
warn "Can't create new $file: $!\n";
next;
};
# Print out the new #! line (or equivalent).
local $\;
local $/;
print $fixout $shb, <$fixin>;
close $fixin;
close $fixout;
chmod 0666, $file_bak;
unlink $file_bak;
unless ( _rename( $file, $file_bak ) ) {
warn "Can't rename $file to $file_bak: $!";
next;
}
unless ( _rename( $file_new, $file ) ) {
warn "Can't rename $file_new to $file: $!";
unless ( _rename( $file_bak, $file ) ) {
warn "Can't rename $file_bak back to $file either: $!";
warn "Leaving $file renamed as $file_bak\n";
}
next;
}
unlink $file_bak;
}
continue {
system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
}
}
sub _rename {
my($old, $new) = @_;
foreach my $file ($old, $new) {
if( $Is{VMS} and basename($file) !~ /\./ ) {
# rename() in 5.8.0 on VMS will not rename a file if it
# does not contain a dot yet it returns success.
$file = "$file.";
}
}
return rename($old, $new);
}
sub _fixin_replace_shebang {
my ( $self, $file, $line ) = @_;
# Now figure out the interpreter name.
my ( $cmd, $arg ) = split ' ', $line, 2;
$cmd =~ s!^.*/!!;
# Now look (in reverse) for interpreter in absolute PATH (unless perl).
my $interpreter;
if ( $cmd =~ m{^perl(?:\z|[^a-z])} ) {
if ( $Config{startperl} =~ m,^\#!.*/perl, ) {
$interpreter = $Config{startperl};
$interpreter =~ s,^\#!,,;
}
else {
$interpreter = $Config{perlpath};
}
}
else {
my (@absdirs)
= reverse grep { $self->file_name_is_absolute($_) } $self->path;
$interpreter = '';
foreach my $dir (@absdirs) {
if ( $self->maybe_command($cmd) ) {
warn "Ignoring $interpreter in $file\n"
if $Verbose && $interpreter;
$interpreter = $self->catfile( $dir, $cmd );
}
}
}
# Figure out how to invoke interpreter on this machine.
my ($does_shbang) = $Config{'sharpbang'} =~ /^\s*\#\!/;
my ($shb) = "";
if ($interpreter) {
print "Changing sharpbang in $file to $interpreter"
if $Verbose;
# this is probably value-free on DOSISH platforms
if ($does_shbang) {
$shb .= "$Config{'sharpbang'}$interpreter";
$shb .= ' ' . $arg if defined $arg;
$shb .= "\n";
}
$shb .= qq{
eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}'
if 0; # not running under some shell
} unless $Is{Win32}; # this won't work on win32, so don't
}
else {
warn "Can't find $cmd in PATH, $file unchanged"
if $Verbose;
return undef;
}
return $shb
}
=item force (o)
Writes an empty FORCE: target.
=cut
sub force {
my($self) = shift;
'# Phony target to force checking subdirectories.
FORCE :
$(NOECHO) $(NOOP)
';
}
=item guess_name
Guess the name of this package by examining the working directory's
name. MakeMaker calls this only if the developer has not supplied a
NAME attribute.
=cut
# ';
sub guess_name {
my($self) = @_;
use Cwd 'cwd';
my $name = basename(cwd());
$name =~ s|[\-_][\d\.\-]+\z||; # this is new with MM 5.00, we
# strip minus or underline
# followed by a float or some such
print "Warning: Guessing NAME [$name] from current directory name.\n";
$name;
}
=item has_link_code
Returns true if C, XS, MYEXTLIB or similar objects exist within this
object that need a compiler. Does not descend into subdirectories as
needs_linking() does.
=cut
sub has_link_code {
my($self) = shift;
return $self->{HAS_LINK_CODE} if defined $self->{HAS_LINK_CODE};
if ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}){
$self->{HAS_LINK_CODE} = 1;
return 1;
}
return $self->{HAS_LINK_CODE} = 0;
}
=item init_dirscan
Scans the directory structure and initializes DIR, XS, XS_FILES,
C, C_FILES, O_FILES, H, H_FILES, PL_FILES, EXE_FILES.
Called by init_main.
=cut
sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc)
my($self) = @_;
my(%dir, %xs, %c, %h, %pl_files, %pm);
my %ignore = map {( $_ => 1 )} qw(Makefile.PL Build.PL test.pl t);
# ignore the distdir
$Is{VMS} ? $ignore{"$self->{DISTVNAME}.dir"} = 1
: $ignore{$self->{DISTVNAME}} = 1;
@ignore{map lc, keys %ignore} = values %ignore if $Is{VMS};
foreach my $name ($self->lsdir($Curdir)){
next if $name =~ /\#/;
$name = lc($name) if $Is{VMS};
next if $name eq $Curdir or $name eq $Updir or $ignore{$name};
next unless $self->libscan($name);
if (-d $name){
next if -l $name; # We do not support symlinks at all
next if $self->{NORECURS};
$dir{$name} = $name if (-f $self->catfile($name,"Makefile.PL"));
} elsif ($name =~ /\.xs\z/){
my($c); ($c = $name) =~ s/\.xs\z/.c/;
$xs{$name} = $c;
$c{$c} = 1;
} elsif ($name =~ /\.c(pp|xx|c)?\z/i){ # .c .C .cpp .cxx .cc
$c{$name} = 1
unless $name =~ m/perlmain\.c/; # See MAP_TARGET
} elsif ($name =~ /\.h\z/i){
$h{$name} = 1;
} elsif ($name =~ /\.PL\z/) {
($pl_files{$name} = $name) =~ s/\.PL\z// ;
} elsif (($Is{VMS} || $Is{Dos}) && $name =~ /[._]pl$/i) {
# case-insensitive filesystem, one dot per name, so foo.h.PL
# under Unix appears as foo.h_pl under VMS or fooh.pl on Dos
local($/); open(my $pl, '<', $name); my $txt = <$pl>; close $pl;
if ($txt =~ /Extracting \S+ \(with variable substitutions/) {
($pl_files{$name} = $name) =~ s/[._]pl\z//i ;
}
else {
$pm{$name} = $self->catfile($self->{INST_LIBDIR},$name);
}
} elsif ($name =~ /\.(p[ml]|pod)\z/){
$pm{$name} = $self->catfile($self->{INST_LIBDIR},$name);
}
}
$self->{PL_FILES} ||= \%pl_files;
$self->{DIR} ||= [sort keys %dir];
$self->{XS} ||= \%xs;
$self->{C} ||= [sort keys %c];
$self->{H} ||= [sort keys %h];
$self->{PM} ||= \%pm;
my @o_files = @{$self->{C}};
$self->{O_FILES} = [grep s/\.c(pp|xx|c)?\z/$self->{OBJ_EXT}/i, @o_files];
}
=item init_MANPODS
Determines if man pages should be generated and initializes MAN1PODS
and MAN3PODS as appropriate.
=cut
sub init_MANPODS {
my $self = shift;
# Set up names of manual pages to generate from pods
foreach my $man (qw(MAN1 MAN3)) {
if ( $self->{"${man}PODS"}
or $self->{"INSTALL${man}DIR"} =~ /^(none|\s*)$/
) {
$self->{"${man}PODS"} ||= {};
}
else {
my $init_method = "init_${man}PODS";
$self->$init_method();
}
}
}
sub _has_pod {
my($self, $file) = @_;
my($ispod)=0;
if (open( my $fh, '<', $file )) {
while (<$fh>) {
if (/^=(?:head\d+|item|pod)\b/) {
$ispod=1;
last;
}
}
close $fh;
} else {
# If it doesn't exist yet, we assume, it has pods in it
$ispod = 1;
}
return $ispod;
}
=item init_MAN1PODS
Initializes MAN1PODS from the list of EXE_FILES.
=cut
sub init_MAN1PODS {
my($self) = @_;
if ( exists $self->{EXE_FILES} ) {
foreach my $name (@{$self->{EXE_FILES}}) {
next unless $self->_has_pod($name);
$self->{MAN1PODS}->{$name} =
$self->catfile("\$(INST_MAN1DIR)",
basename($name).".\$(MAN1EXT)");
}
}
}
=item init_MAN3PODS
Initializes MAN3PODS from the list of PM files.
=cut
sub init_MAN3PODS {
my $self = shift;
my %manifypods = (); # we collect the keys first, i.e. the files
# we have to convert to pod
foreach my $name (keys %{$self->{PM}}) {
if ($name =~ /\.pod\z/ ) {
$manifypods{$name} = $self->{PM}{$name};
} elsif ($name =~ /\.p[ml]\z/ ) {
if( $self->_has_pod($name) ) {
$manifypods{$name} = $self->{PM}{$name};
}
}
}
my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}};
# Remove "Configure.pm" and similar, if it's not the only pod listed
# To force inclusion, just name it "Configure.pod", or override
# MAN3PODS
foreach my $name (keys %manifypods) {
if ($self->{PERL_CORE} and $name =~ /(config|setup).*\.pm/is) {
delete $manifypods{$name};
next;
}
my($manpagename) = $name;
$manpagename =~ s/\.p(od|m|l)\z//;
# everything below lib is ok
unless($manpagename =~ s!^\W*($parentlibs_re)\W+!!s) {
$manpagename = $self->catfile(
split(/::/,$self->{PARENT_NAME}),$manpagename
);
}
$manpagename = $self->replace_manpage_separator($manpagename);
$self->{MAN3PODS}->{$name} =
$self->catfile("\$(INST_MAN3DIR)", "$manpagename.\$(MAN3EXT)");
}
}
=item init_PM
Initializes PMLIBDIRS and PM from PMLIBDIRS.
=cut
sub init_PM {
my $self = shift;
# Some larger extensions often wish to install a number of *.pm/pl
# files into the library in various locations.
# The attribute PMLIBDIRS holds an array reference which lists
# subdirectories which we should search for library files to
# install. PMLIBDIRS defaults to [ 'lib', $self->{BASEEXT} ]. We
# recursively search through the named directories (skipping any
# which don't exist or contain Makefile.PL files).
# For each *.pm or *.pl file found $self->libscan() is called with
# the default installation path in $_[1]. The return value of
# libscan defines the actual installation location. The default
# libscan function simply returns the path. The file is skipped
# if libscan returns false.
# The default installation location passed to libscan in $_[1] is:
#
# ./*.pm => $(INST_LIBDIR)/*.pm
# ./xyz/... => $(INST_LIBDIR)/xyz/...
# ./lib/... => $(INST_LIB)/...
#
# In this way the 'lib' directory is seen as the root of the actual
# perl library whereas the others are relative to INST_LIBDIR
# (which includes PARENT_NAME). This is a subtle distinction but one
# that's important for nested modules.
unless( $self->{PMLIBDIRS} ) {
if( $Is{VMS} ) {
# Avoid logical name vs directory collisions
$self->{PMLIBDIRS} = ['./lib', "./$self->{BASEEXT}"];
}
else {
$self->{PMLIBDIRS} = ['lib', $self->{BASEEXT}];
}
}
#only existing directories that aren't in $dir are allowed
# Avoid $_ wherever possible:
# @{$self->{PMLIBDIRS}} = grep -d && !$dir{$_}, @{$self->{PMLIBDIRS}};
my (@pmlibdirs) = @{$self->{PMLIBDIRS}};
@{$self->{PMLIBDIRS}} = ();
my %dir = map { ($_ => $_) } @{$self->{DIR}};
foreach my $pmlibdir (@pmlibdirs) {
-d $pmlibdir && !$dir{$pmlibdir} && push @{$self->{PMLIBDIRS}}, $pmlibdir;
}
unless( $self->{PMLIBPARENTDIRS} ) {
@{$self->{PMLIBPARENTDIRS}} = ('lib');
}
return if $self->{PM} and $self->{ARGS}{PM};
if (@{$self->{PMLIBDIRS}}){
print "Searching PMLIBDIRS: @{$self->{PMLIBDIRS}}\n"
if ($Verbose >= 2);
require File::Find;
File::Find::find(sub {
if (-d $_){
unless ($self->libscan($_)){
$File::Find::prune = 1;
}
return;
}
return if /\#/;
return if /~$/; # emacs temp files
return if /,v$/; # RCS files
return if m{\.swp$}; # vim swap files
my $path = $File::Find::name;
my $prefix = $self->{INST_LIBDIR};
my $striplibpath;
my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}};
$prefix = $self->{INST_LIB}
if ($striplibpath = $path) =~ s{^(\W*)($parentlibs_re)\W}
{$1}i;
my($inst) = $self->catfile($prefix,$striplibpath);
local($_) = $inst; # for backwards compatibility
$inst = $self->libscan($inst);
print "libscan($path) => '$inst'\n" if ($Verbose >= 2);
return unless $inst;
$self->{PM}{$path} = $inst;
}, @{$self->{PMLIBDIRS}});
}
}
=item init_DIRFILESEP
Using / for Unix. Called by init_main.
=cut
sub init_DIRFILESEP {
my($self) = shift;
$self->{DIRFILESEP} = '/';
}
=item init_main
Initializes AR, AR_STATIC_ARGS, BASEEXT, CONFIG, DISTNAME, DLBASE,
EXE_EXT, FULLEXT, FULLPERL, FULLPERLRUN, FULLPERLRUNINST, INST_*,
INSTALL*, INSTALLDIRS, LIB_EXT, LIBPERL_A, MAP_TARGET, NAME,
OBJ_EXT, PARENT_NAME, PERL, PERL_ARCHLIB, PERL_INC, PERL_LIB,
PERL_SRC, PERLRUN, PERLRUNINST, PREFIX, VERSION,
VERSION_SYM, XS_VERSION.
=cut
sub init_main {
my($self) = @_;
# --- Initialize Module Name and Paths
# NAME = Foo::Bar::Oracle
# FULLEXT = Foo/Bar/Oracle
# BASEEXT = Oracle
# PARENT_NAME = Foo::Bar
### Only UNIX:
### ($self->{FULLEXT} =
### $self->{NAME}) =~ s!::!/!g ; #eg. BSD/Foo/Socket
$self->{FULLEXT} = $self->catdir(split /::/, $self->{NAME});
# Copied from DynaLoader:
my(@modparts) = split(/::/,$self->{NAME});
my($modfname) = $modparts[-1];
# Some systems have restrictions on files names for DLL's etc.
# mod2fname returns appropriate file base name (typically truncated)
# It may also edit @modparts if required.
if (defined &DynaLoader::mod2fname) {
$modfname = &DynaLoader::mod2fname(\@modparts);
}
($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!(?:([\w:]+)::)?(\w+)\z! ;
$self->{PARENT_NAME} ||= '';
if (defined &DynaLoader::mod2fname) {
# As of 5.001m, dl_os2 appends '_'
$self->{DLBASE} = $modfname;
} else {
$self->{DLBASE} = '$(BASEEXT)';
}
# --- Initialize PERL_LIB, PERL_SRC
# *Real* information: where did we get these two from? ...
my $inc_config_dir = dirname($INC{'Config.pm'});
my $inc_carp_dir = dirname($INC{'Carp.pm'});
unless ($self->{PERL_SRC}){
foreach my $dir_count (1..8) { # 8 is the VMS limit for nesting
my $dir = $self->catdir(($Updir) x $dir_count);
if (-f $self->catfile($dir,"config_h.SH") &&
-f $self->catfile($dir,"perl.h") &&
-f $self->catfile($dir,"lib","strict.pm")
) {
$self->{PERL_SRC}=$dir ;
last;
}
}
}
warn "PERL_CORE is set but I can't find your PERL_SRC!\n" if
$self->{PERL_CORE} and !$self->{PERL_SRC};
if ($self->{PERL_SRC}){
$self->{PERL_LIB} ||= $self->catdir("$self->{PERL_SRC}","lib");
if (defined $Cross::platform) {
$self->{PERL_ARCHLIB} =
$self->catdir("$self->{PERL_SRC}","xlib",$Cross::platform);
$self->{PERL_INC} =
$self->catdir("$self->{PERL_SRC}","xlib",$Cross::platform,
$Is{Win32}?("CORE"):());
}
else {
$self->{PERL_ARCHLIB} = $self->{PERL_LIB};
$self->{PERL_INC} = ($Is{Win32}) ?
$self->catdir($self->{PERL_LIB},"CORE") : $self->{PERL_SRC};
}
# catch a situation that has occurred a few times in the past:
unless (
-s $self->catfile($self->{PERL_SRC},'cflags')
or
$Is{VMS}
&&
-s $self->catfile($self->{PERL_SRC},'vmsish.h')
or
$Is{Win32}
){
warn qq{
You cannot build extensions below the perl source tree after executing
a 'make clean' in the perl source tree.
To rebuild extensions distributed with the perl source you should
simply Configure (to include those extensions) and then build perl as
normal. After installing perl the source tree can be deleted. It is
not needed for building extensions by running 'perl Makefile.PL'
usually without extra arguments.
It is recommended that you unpack and build additional extensions away
from the perl source tree.
};
}
} else {
# we should also consider $ENV{PERL5LIB} here
my $old = $self->{PERL_LIB} || $self->{PERL_ARCHLIB} || $self->{PERL_INC};
$self->{PERL_LIB} ||= $Config{privlibexp};
$self->{PERL_ARCHLIB} ||= $Config{archlibexp};
$self->{PERL_INC} = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now
my $perl_h;
if (not -f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h"))
and not $old){
# Maybe somebody tries to build an extension with an
# uninstalled Perl outside of Perl build tree
my $lib;
for my $dir (@INC) {
$lib = $dir, last if -e $self->catfile($dir, "Config.pm");
}
if ($lib) {
# Win32 puts its header files in /perl/src/lib/CORE.
# Unix leaves them in /perl/src.
my $inc = $Is{Win32} ? $self->catdir($lib, "CORE" )
: dirname $lib;
if (-e $self->catfile($inc, "perl.h")) {
$self->{PERL_LIB} = $lib;
$self->{PERL_ARCHLIB} = $lib;
$self->{PERL_INC} = $inc;
$self->{UNINSTALLED_PERL} = 1;
print <<EOP;
... Detected uninstalled Perl. Trying to continue.
EOP
}
}
}
}
# We get SITELIBEXP and SITEARCHEXP directly via
# Get_from_Config. When we are running standard modules, these
# won't matter, we will set INSTALLDIRS to "perl". Otherwise we
# set it to "site". I prefer that INSTALLDIRS be set from outside
# MakeMaker.
$self->{INSTALLDIRS} ||= "site";
$self->{MAN1EXT} ||= $Config{man1ext};
$self->{MAN3EXT} ||= $Config{man3ext};
# Get some stuff out of %Config if we haven't yet done so
print "CONFIG must be an array ref\n"
if ($self->{CONFIG} and ref $self->{CONFIG} ne 'ARRAY');
$self->{CONFIG} = [] unless (ref $self->{CONFIG});
push(@{$self->{CONFIG}}, @ExtUtils::MakeMaker::Get_from_Config);
push(@{$self->{CONFIG}}, 'shellflags') if $Config{shellflags};
my(%once_only);
foreach my $m (@{$self->{CONFIG}}){
next if $once_only{$m};
print "CONFIG key '$m' does not exist in Config.pm\n"
unless exists $Config{$m};
$self->{uc $m} ||= $Config{$m};
$once_only{$m} = 1;
}
# This is too dangerous:
# if ($^O eq "next") {
# $self->{AR} = "libtool";
# $self->{AR_STATIC_ARGS} = "-o";
# }
# But I leave it as a placeholder
$self->{AR_STATIC_ARGS} ||= "cr";
# These should never be needed
$self->{OBJ_EXT} ||= '.o';
$self->{LIB_EXT} ||= '.a';
$self->{MAP_TARGET} ||= "perl";
$self->{LIBPERL_A} ||= "libperl$self->{LIB_EXT}";
# make a simple check if we find strict
warn "Warning: PERL_LIB ($self->{PERL_LIB}) seems not to be a perl library directory
(strict.pm not found)"
unless -f $self->catfile("$self->{PERL_LIB}","strict.pm") ||
$self->{NAME} eq "ExtUtils::MakeMaker";
}
=item init_tools
Initializes tools to use their common (and faster) Unix commands.
=cut
sub init_tools {
my $self = shift;
$self->{ECHO} ||= 'echo';
$self->{ECHO_N} ||= 'echo -n';
$self->{RM_F} ||= "rm -f";
$self->{RM_RF} ||= "rm -rf";
$self->{TOUCH} ||= "touch";
$self->{TEST_F} ||= "test -f";
$self->{CP} ||= "cp";
$self->{MV} ||= "mv";
$self->{CHMOD} ||= "chmod";
$self->{FALSE} ||= 'false';
$self->{TRUE} ||= 'true';
$self->{LD} ||= 'ld';
return $self->SUPER::init_tools(@_);
# After SUPER::init_tools so $Config{shell} has a
# chance to get set.
$self->{SHELL} ||= '/bin/sh';
return;
}
=item init_linker
Unix has no need of special linker flags.
=cut
sub init_linker {
my($self) = shift;
$self->{PERL_ARCHIVE} ||= '';
$self->{PERL_ARCHIVE_AFTER} ||= '';
$self->{EXPORT_LIST} ||= '';
}
=begin _protected
=item init_lib2arch
$mm->init_lib2arch
=end _protected
=cut
sub init_lib2arch {
my($self) = shift;
# The user who requests an installation directory explicitly
# should not have to tell us an architecture installation directory
# as well. We look if a directory exists that is named after the
# architecture. If not we take it as a sign that it should be the
# same as the requested installation directory. Otherwise we take
# the found one.
for my $libpair ({l=>"privlib", a=>"archlib"},
{l=>"sitelib", a=>"sitearch"},
{l=>"vendorlib", a=>"vendorarch"},
)
{
my $lib = "install$libpair->{l}";
my $Lib = uc $lib;
my $Arch = uc "install$libpair->{a}";
if( $self->{$Lib} && ! $self->{$Arch} ){
my($ilib) = $Config{$lib};
$self->prefixify($Arch,$ilib,$self->{$Lib});
unless (-d $self->{$Arch}) {
print "Directory $self->{$Arch} not found\n"
if $Verbose;
$self->{$Arch} = $self->{$Lib};
}
print "Defaulting $Arch to $self->{$Arch}\n" if $Verbose;
}
}
}
=item init_PERL
$mm->init_PERL;
Called by init_main. Sets up ABSPERL, PERL, FULLPERL and all the
*PERLRUN* permutations.
PERL is allowed to be miniperl
FULLPERL must be a complete perl
ABSPERL is PERL converted to an absolute path
*PERLRUN contains everything necessary to run perl, find it's
libraries, etc...
*PERLRUNINST is *PERLRUN + everything necessary to find the
modules being built.
=cut
sub init_PERL {
my($self) = shift;
my @defpath = ();
foreach my $component ($self->{PERL_SRC}, $self->path(),
$Config{binexp})
{
push @defpath, $component if defined $component;
}
# Build up a set of file names (not command names).
my $thisperl = $self->canonpath($^X);
$thisperl .= $Config{exe_ext} unless
# VMS might have a file version # at the end
$Is{VMS} ? $thisperl =~ m/$Config{exe_ext}(;\d+)?$/i
: $thisperl =~ m/$Config{exe_ext}$/i;
# We need a relative path to perl when in the core.
$thisperl = $self->abs2rel($thisperl) if $self->{PERL_CORE};
my @perls = ($thisperl);
push @perls, map { "$_$Config{exe_ext}" }
('perl', 'perl5', "perl$Config{version}");
# miniperl has priority over all but the cannonical perl when in the
# core. Otherwise its a last resort.
my $miniperl = "miniperl$Config{exe_ext}";
if( $self->{PERL_CORE} ) {
splice @perls, 1, 0, $miniperl;
}
else {
push @perls, $miniperl;
}
$self->{PERL} ||=
$self->find_perl(5.0, \@perls, \@defpath, $Verbose );
# don't check if perl is executable, maybe they have decided to
# supply switches with perl
# When built for debugging, VMS doesn't create perl.exe but ndbgperl.exe.
my $perl_name = 'perl';
$perl_name = 'ndbgperl' if $Is{VMS} &&
defined $Config{usevmsdebug} && $Config{usevmsdebug} eq 'define';
# XXX This logic is flawed. If "miniperl" is anywhere in the path
# it will get confused. It should be fixed to work only on the filename.
# Define 'FULLPERL' to be a non-miniperl (used in test: target)
($self->{FULLPERL} = $self->{PERL}) =~ s/miniperl/$perl_name/i
unless $self->{FULLPERL};
# Little hack to get around VMS's find_perl putting "MCR" in front
# sometimes.
$self->{ABSPERL} = $self->{PERL};
my $has_mcr = $self->{ABSPERL} =~ s/^MCR\s*//;
if( $self->file_name_is_absolute($self->{ABSPERL}) ) {
$self->{ABSPERL} = '$(PERL)';
}
else {
$self->{ABSPERL} = $self->rel2abs($self->{ABSPERL});
# Quote the perl command if it contains whitespace
$self->{ABSPERL} = $self->quote_literal($self->{ABSPERL})
if $self->{ABSPERL} =~ /\s/;
$self->{ABSPERL} = 'MCR '.$self->{ABSPERL} if $has_mcr;
}
# Are we building the core?
$self->{PERL_CORE} = $ENV{PERL_CORE} unless exists $self->{PERL_CORE};
$self->{PERL_CORE} = 0 unless defined $self->{PERL_CORE};
# How do we run perl?
foreach my $perl (qw(PERL FULLPERL ABSPERL)) {
my $run = $perl.'RUN';
$self->{$run} = "\$($perl)";
# Make sure perl can find itself before it's installed.
$self->{$run} .= q{ "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)"}
if $self->{UNINSTALLED_PERL} || $self->{PERL_CORE};
$self->{$perl.'RUNINST'} =
sprintf q{$(%sRUN) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)"}, $perl;
}
return 1;
}
=item init_platform
=item platform_constants
Add MM_Unix_VERSION.
=cut
sub init_platform {
my($self) = shift;
$self->{MM_Unix_VERSION} = $VERSION;
$self->{PERL_MALLOC_DEF} = '-DPERL_EXTMALLOC_DEF -Dmalloc=Perl_malloc '.
'-Dfree=Perl_mfree -Drealloc=Perl_realloc '.
'-Dcalloc=Perl_calloc';
}
sub platform_constants {
my($self) = shift;
my $make_frag = '';
foreach my $macro (qw(MM_Unix_VERSION PERL_MALLOC_DEF))
{
next unless defined $self->{$macro};
$make_frag .= "$macro = $self->{$macro}\n";
}
return $make_frag;
}
=item init_PERM
$mm->init_PERM
Called by init_main. Initializes PERL_*
=cut
sub init_PERM {
my($self) = shift;
$self->{PERM_DIR} = 755 unless defined $self->{PERM_DIR};
$self->{PERM_RW} = 644 unless defined $self->{PERM_RW};
$self->{PERM_RWX} = 755 unless defined $self->{PERM_RWX};
return 1;
}
=item init_xs
$mm->init_xs
Sets up macros having to do with XS code. Currently just INST_STATIC,
INST_DYNAMIC and INST_BOOT.
=cut
sub init_xs {
my $self = shift;
if ($self->has_link_code()) {
$self->{INST_STATIC} =
$self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT)$(LIB_EXT)');
$self->{INST_DYNAMIC} =
$self->catfile('$(INST_ARCHAUTODIR)', '$(DLBASE).$(DLEXT)');
$self->{INST_BOOT} =
$self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT).bs');
} else {
$self->{INST_STATIC} = '';
$self->{INST_DYNAMIC} = '';
$self->{INST_BOOT} = '';
}
}
=item install (o)
Defines the install target.
=cut
sub install {
my($self, %attribs) = @_;
my(@m);
push @m, q{
install :: pure_install doc_install
$(NOECHO) $(NOOP)
install_perl :: pure_perl_install doc_perl_install
$(NOECHO) $(NOOP)
install_site :: pure_site_install doc_site_install
$(NOECHO) $(NOOP)
install_vendor :: pure_vendor_install doc_vendor_install
$(NOECHO) $(NOOP)
pure_install :: pure_$(INSTALLDIRS)_install
$(NOECHO) $(NOOP)
doc_install :: doc_$(INSTALLDIRS)_install
$(NOECHO) $(NOOP)
pure__install : pure_site_install
$(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site
doc__install : doc_site_install
$(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site
pure_perl_install :: all
$(NOECHO) $(MOD_INSTALL) \
read }.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{ \
write }.$self->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q{ \
$(INST_LIB) $(DESTINSTALLPRIVLIB) \
$(INST_ARCHLIB) $(DESTINSTALLARCHLIB) \
$(INST_BIN) $(DESTINSTALLBIN) \
$(INST_SCRIPT) $(DESTINSTALLSCRIPT) \
$(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) \
$(INST_MAN3DIR) $(DESTINSTALLMAN3DIR)
$(NOECHO) $(WARN_IF_OLD_PACKLIST) \
}.$self->catdir('$(SITEARCHEXP)','auto','$(FULLEXT)').q{
pure_site_install :: all
$(NOECHO) $(MOD_INSTALL) \
read }.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{ \
write }.$self->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{ \
$(INST_LIB) $(DESTINSTALLSITELIB) \
$(INST_ARCHLIB) $(DESTINSTALLSITEARCH) \
$(INST_BIN) $(DESTINSTALLSITEBIN) \
$(INST_SCRIPT) $(DESTINSTALLSITESCRIPT) \
$(INST_MAN1DIR) $(DESTINSTALLSITEMAN1DIR) \
$(INST_MAN3DIR) $(DESTINSTALLSITEMAN3DIR)
$(NOECHO) $(WARN_IF_OLD_PACKLIST) \
}.$self->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{
pure_vendor_install :: all
$(NOECHO) $(MOD_INSTALL) \
read }.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{ \
write }.$self->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').q{ \
$(INST_LIB) $(DESTINSTALLVENDORLIB) \
$(INST_ARCHLIB) $(DESTINSTALLVENDORARCH) \
$(INST_BIN) $(DESTINSTALLVENDORBIN) \
$(INST_SCRIPT) $(DESTINSTALLVENDORSCRIPT) \
$(INST_MAN1DIR) $(DESTINSTALLVENDORMAN1DIR) \
$(INST_MAN3DIR) $(DESTINSTALLVENDORMAN3DIR)
doc_perl_install :: all
$(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod
-$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
-$(NOECHO) $(DOC_INSTALL) \
"Module" "$(NAME)" \
"installed into" "$(INSTALLPRIVLIB)" \
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
EXE_FILES "$(EXE_FILES)" \
>> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{
doc_site_install :: all
$(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod
-$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
-$(NOECHO) $(DOC_INSTALL) \
"Module" "$(NAME)" \
"installed into" "$(INSTALLSITELIB)" \
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
EXE_FILES "$(EXE_FILES)" \
>> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{
doc_vendor_install :: all
$(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod
-$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
-$(NOECHO) $(DOC_INSTALL) \
"Module" "$(NAME)" \
"installed into" "$(INSTALLVENDORLIB)" \
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
EXE_FILES "$(EXE_FILES)" \
>> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{
};
push @m, q{
uninstall :: uninstall_from_$(INSTALLDIRS)dirs
$(NOECHO) $(NOOP)
uninstall_from_perldirs ::
$(NOECHO) $(UNINSTALL) }.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{
uninstall_from_sitedirs ::
$(NOECHO) $(UNINSTALL) }.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{
uninstall_from_vendordirs ::
$(NOECHO) $(UNINSTALL) }.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{
};
join("",@m);
}
=item installbin (o)
Defines targets to make and to install EXE_FILES.
=cut
sub installbin {
my($self) = shift;
return "" unless $self->{EXE_FILES} && ref $self->{EXE_FILES} eq "ARRAY";
my @exefiles = @{$self->{EXE_FILES}};
return "" unless @exefiles;
@exefiles = map vmsify($_), @exefiles if $Is{VMS};
my %fromto;
for my $from (@exefiles) {
my($path)= $self->catfile('$(INST_SCRIPT)', basename($from));
local($_) = $path; # for backwards compatibility
my $to = $self->libscan($path);
print "libscan($from) => '$to'\n" if ($Verbose >=2);
$to = vmsify($to) if $Is{VMS};
$fromto{$from} = $to;
}
my @to = values %fromto;
my @m;
push(@m, qq{
EXE_FILES = @exefiles
pure_all :: @to
\$(NOECHO) \$(NOOP)
realclean ::
});
# realclean can get rather large.
push @m, map "\t$_\n", $self->split_command('$(RM_F)', @to);
push @m, "\n";
# A target for each exe file.
while (my($from,$to) = each %fromto) {
last unless defined $from;
push @m, sprintf <<'MAKE', $to, $from, $to, $from, $to, $to, $to;
%s : %s $(FIRST_MAKEFILE) $(INST_SCRIPT)$(DFSEP).exists $(INST_BIN)$(DFSEP).exists
$(NOECHO) $(RM_F) %s
$(CP) %s %s
$(FIXIN) %s
-$(NOECHO) $(CHMOD) $(PERM_RWX) %s
MAKE
}
join "", @m;
}
=item linkext (o)
Defines the linkext target which in turn defines the LINKTYPE.
=cut
sub linkext {
my($self, %attribs) = @_;
# LINKTYPE => static or dynamic or ''
my($linktype) = defined $attribs{LINKTYPE} ?
$attribs{LINKTYPE} : '$(LINKTYPE)';
"
linkext :: $linktype
\$(NOECHO) \$(NOOP)
";
}
=item lsdir
Takes as arguments a directory name and a regular expression. Returns
all entries in the directory that match the regular expression.
=cut
sub lsdir {
my($self) = shift;
my($dir, $regex) = @_;
my(@ls);
my $dh = new DirHandle;
$dh->open($dir || ".") or return ();
@ls = $dh->read;
$dh->close;
@ls = grep(/$regex/, @ls) if $regex;
@ls;
}
=item macro (o)
Simple subroutine to insert the macros defined by the macro attribute
into the Makefile.
=cut
sub macro {
my($self,%attribs) = @_;
my(@m,$key,$val);
while (($key,$val) = each %attribs){
last unless defined $key;
push @m, "$key = $val\n";
}
join "", @m;
}
=item makeaperl (o)
Called by staticmake. Defines how to write the Makefile to produce a
static new perl.
By default the Makefile produced includes all the static extensions in
the perl library. (Purified versions of library files, e.g.,
DynaLoader_pure_p1_c0_032.a are automatically ignored to avoid link errors.)
=cut
sub makeaperl {
my($self, %attribs) = @_;
my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) =
@attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
my(@m);
push @m, "
# --- MakeMaker makeaperl section ---
MAP_TARGET = $target
FULLPERL = $self->{FULLPERL}
";
return join '', @m if $self->{PARENT};
my($dir) = join ":", @{$self->{DIR}};
unless ($self->{MAKEAPERL}) {
push @m, q{
$(MAP_TARGET) :: static $(MAKE_APERL_FILE)
$(MAKE) $(USEMAKEFILE) $(MAKE_APERL_FILE) $@
$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) pm_to_blib
$(NOECHO) $(ECHO) Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET)
$(NOECHO) $(PERLRUNINST) \
Makefile.PL DIR=}, $dir, q{ \
MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=};
foreach (@ARGV){
if( /\s/ ){
s/=(.*)/='$1'/;
}
push @m, " \\\n\t\t$_";
}
# push @m, map( " \\\n\t\t$_", @ARGV );
push @m, "\n";
return join '', @m;
}
my($cccmd, $linkcmd, $lperl);
$cccmd = $self->const_cccmd($libperl);
$cccmd =~ s/^CCCMD\s*=\s*//;
$cccmd =~ s/\$\(INC\)/ "-I$self->{PERL_INC}" /;
$cccmd .= " $Config{cccdlflags}"
if ($Config{useshrplib} eq 'true');
$cccmd =~ s/\(CC\)/\(PERLMAINCC\)/;
# The front matter of the linkcommand...
$linkcmd = join ' ', "\$(CC)",
grep($_, @Config{qw(ldflags ccdlflags)});
$linkcmd =~ s/\s+/ /g;
$linkcmd =~ s,(perl\.exp),\$(PERL_INC)/$1,;
# Which *.a files could we make use of...
my %static;
require File::Find;
File::Find::find(sub {
return unless m/\Q$self->{LIB_EXT}\E$/;
# Skip perl's libraries.
return if m/^libperl/ or m/^perl\Q$self->{LIB_EXT}\E$/;
# Skip purified versions of libraries
# (e.g., DynaLoader_pure_p1_c0_032.a)
return if m/_pure_\w+_\w+_\w+\.\w+$/ and -f "$File::Find::dir/.pure";
if( exists $self->{INCLUDE_EXT} ){
my $found = 0;
(my $xx = $File::Find::name) =~ s,.*?/auto/,,s;
$xx =~ s,/?$_,,;
$xx =~ s,/,::,g;
# Throw away anything not explicitly marked for inclusion.
# DynaLoader is implied.
foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){
if( $xx eq $incl ){
$found++;
last;
}
}
return unless $found;
}
elsif( exists $self->{EXCLUDE_EXT} ){
(my $xx = $File::Find::name) =~ s,.*?/auto/,,s;
$xx =~ s,/?$_,,;
$xx =~ s,/,::,g;
# Throw away anything explicitly marked for exclusion
foreach my $excl (@{$self->{EXCLUDE_EXT}}){
return if( $xx eq $excl );
}
}
# don't include the installed version of this extension. I
# leave this line here, although it is not necessary anymore:
# I patched minimod.PL instead, so that Miniperl.pm won't
# enclude duplicates
# Once the patch to minimod.PL is in the distribution, I can
# drop it
return if $File::Find::name =~ m:auto/$self->{FULLEXT}/$self->{BASEEXT}$self->{LIB_EXT}\z:;
use Cwd 'cwd';
$static{cwd() . "/" . $_}++;
}, grep( -d $_, @{$searchdirs || []}) );
# We trust that what has been handed in as argument, will be buildable
$static = [] unless $static;
@static{@{$static}} = (1) x @{$static};
$extra = [] unless $extra && ref $extra eq 'ARRAY';
for (sort keys %static) {
next unless /\Q$self->{LIB_EXT}\E\z/;
$_ = dirname($_) . "/extralibs.ld";
push @$extra, $_;
}
s/^(.*)/"-I$1"/ for @{$perlinc || []};
$target ||= "perl";
$tmp ||= ".";
# MAP_STATIC doesn't look into subdirs yet. Once "all" is made and we
# regenerate the Makefiles, MAP_STATIC and the dependencies for
# extralibs.all are computed correctly
push @m, "
MAP_LINKCMD = $linkcmd
MAP_PERLINC = @{$perlinc || []}
MAP_STATIC = ",
join(" \\\n\t", reverse sort keys %static), "
MAP_PRELIBS = $Config{perllibs} $Config{cryptlib}
";
if (defined $libperl) {
($lperl = $libperl) =~ s/\$\(A\)/$self->{LIB_EXT}/;
}
unless ($libperl && -f $lperl) { # Ilya's code...
my $dir = $self->{PERL_SRC} || "$self->{PERL_ARCHLIB}/CORE";
$dir = "$self->{PERL_ARCHLIB}/.." if $self->{UNINSTALLED_PERL};
$libperl ||= "libperl$self->{LIB_EXT}";
$libperl = "$dir/$libperl";
$lperl ||= "libperl$self->{LIB_EXT}";
$lperl = "$dir/$lperl";
if (! -f $libperl and ! -f $lperl) {
# We did not find a static libperl. Maybe there is a shared one?
if ($Is{SunOS}) {
$lperl = $libperl = "$dir/$Config{libperl}";
# SUNOS ld does not take the full path to a shared library
$libperl = '' if $Is{SunOS4};
}
}
print "Warning: $libperl not found
If you're going to build a static perl binary, make sure perl is installed
otherwise ignore this warning\n"
unless (-f $lperl || defined($self->{PERL_SRC}));
}
# SUNOS ld does not take the full path to a shared library
my $llibperl = $libperl ? '$(MAP_LIBPERL)' : '-lperl';
push @m, "
MAP_LIBPERL = $libperl
LLIBPERL = $llibperl
";
push @m, '
$(INST_ARCHAUTODIR)/extralibs.all : $(INST_ARCHAUTODIR)$(DFSEP).exists '.join(" \\\n\t", @$extra).'
$(NOECHO) $(RM_F) $@
$(NOECHO) $(TOUCH) $@
';
foreach my $catfile (@$extra){
push @m, "\tcat $catfile >> \$\@\n";
}
push @m, "
\$(MAP_TARGET) :: $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) \$(INST_ARCHAUTODIR)/extralibs.all
\$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) \$(LDFROM) \$(MAP_STATIC) \$(LLIBPERL) `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS)
\$(NOECHO) \$(ECHO) 'To install the new \"\$(MAP_TARGET)\" binary, call'
\$(NOECHO) \$(ECHO) ' \$(MAKE) \$(USEMAKEFILE) $makefilename inst_perl MAP_TARGET=\$(MAP_TARGET)'
\$(NOECHO) \$(ECHO) 'To remove the intermediate files say'
\$(NOECHO) \$(ECHO) ' \$(MAKE) \$(USEMAKEFILE) $makefilename map_clean'
$tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c
";
push @m, "\t".$self->cd($tmp, qq[$cccmd "-I\$(PERL_INC)" perlmain.c])."\n";
push @m, qq{
$tmp/perlmain.c: $makefilename}, q{
$(NOECHO) $(ECHO) Writing $@
$(NOECHO) $(PERL) $(MAP_PERLINC) "-MExtUtils::Miniperl" \\
-e "writemain(grep s#.*/auto/##s, split(q| |, q|$(MAP_STATIC)|))" > $@t && $(MV) $@t $@
};
push @m, "\t", q{$(NOECHO) $(PERL) $(INSTALLSCRIPT)/fixpmain
} if (defined (&Dos::UseLFN) && Dos::UseLFN()==0);
push @m, q{
doc_inst_perl :
$(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod
-$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
-$(NOECHO) $(DOC_INSTALL) \
"Perl binary" "$(MAP_TARGET)" \
MAP_STATIC "$(MAP_STATIC)" \
MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \
MAP_LIBPERL "$(MAP_LIBPERL)" \
>> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{
};
push @m, q{
inst_perl : pure_inst_perl doc_inst_perl
pure_inst_perl : $(MAP_TARGET)
}.$self->{CP}.q{ $(MAP_TARGET) }.$self->catfile('$(DESTINSTALLBIN)','$(MAP_TARGET)').q{
clean :: map_clean
map_clean :
}.$self->{RM_F}.qq{ $tmp/perlmain\$(OBJ_EXT) $tmp/perlmain.c \$(MAP_TARGET) $makefilename \$(INST_ARCHAUTODIR)/extralibs.all
};
join '', @m;
}
=item makefile (o)
Defines how to rewrite the Makefile.
=cut
sub makefile {
my($self) = shift;
my $m;
# We do not know what target was originally specified so we
# must force a manual rerun to be sure. But as it should only
# happen very rarely it is not a significant problem.
$m = '
$(OBJECT) : $(FIRST_MAKEFILE)
' if $self->{OBJECT};
my $newer_than_target = $Is{VMS} ? '$(MMS$SOURCE_LIST)' : '$?';
my $mpl_args = join " ", map qq["$_"], @ARGV;
$m .= sprintf <<'MAKE_FRAG', $newer_than_target, $mpl_args;
# We take a very conservative approach here, but it's worth it.
# We move Makefile to Makefile.old here to avoid gnu make looping.
$(FIRST_MAKEFILE) : Makefile.PL $(CONFIGDEP)
$(NOECHO) $(ECHO) "Makefile out-of-date with respect to %s"
$(NOECHO) $(ECHO) "Cleaning current config before rebuilding Makefile..."
-$(NOECHO) $(RM_F) $(MAKEFILE_OLD)
-$(NOECHO) $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD)
- $(MAKE) $(USEMAKEFILE) $(MAKEFILE_OLD) clean $(DEV_NULL)
$(PERLRUN) Makefile.PL %s
$(NOECHO) $(ECHO) "==> Your Makefile has been rebuilt. <=="
$(NOECHO) $(ECHO) "==> Please rerun the $(MAKE) command. <=="
$(FALSE)
MAKE_FRAG
return $m;
}
=item maybe_command
Returns true, if the argument is likely to be a command.
=cut
sub maybe_command {
my($self,$file) = @_;
return $file if -x $file && ! -d $file;
return;
}
=item needs_linking (o)
Does this module need linking? Looks into subdirectory objects (see
also has_link_code())
=cut
sub needs_linking {
my($self) = shift;
my $caller = (caller(0))[3];
confess("needs_linking called too early") if
$caller =~ /^ExtUtils::MakeMaker::/;
return $self->{NEEDS_LINKING} if defined $self->{NEEDS_LINKING};
if ($self->has_link_code or $self->{MAKEAPERL}){
$self->{NEEDS_LINKING} = 1;
return 1;
}
foreach my $child (keys %{$self->{CHILDREN}}) {
if ($self->{CHILDREN}->{$child}->needs_linking) {
$self->{NEEDS_LINKING} = 1;
return 1;
}
}
return $self->{NEEDS_LINKING} = 0;
}
=item parse_abstract
parse a file and return what you think is the ABSTRACT
=cut
sub parse_abstract {
my($self,$parsefile) = @_;
my $result;
local $/ = "\n";
open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!";
my $inpod = 0;
my $package = $self->{DISTNAME};
$package =~ s/-/::/g;
while (<$fh>) {
$inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
next if !$inpod;
chop;
next unless /^($package(?:\.pm)? \s+ -+ \s+)(.*)/x;
$result = $2;
last;
}
close $fh;
return $result;
}
=item parse_version
my $version = MM->parse_version($file);
Parse a $file and return what $VERSION is set to by the first assignment.
It will return the string "undef" if it can't figure out what $VERSION
is. $VERSION should be for all to see, so C<our $VERSION> or plain $VERSION
are okay, but C<my $VERSION> is not.
C<<package Foo VERSION>> is also checked for. The first version
declaration found is used, but this may change as it differs from how
Perl does it.
parse_version() will try to C<use version> before checking for
C<$VERSION> so the following will work.
$VERSION = qv(1.2.3);
=cut
sub parse_version {
my($self,$parsefile) = @_;
my $result;
local $/ = "\n";
local $_;
open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!";
my $inpod = 0;
while (<$fh>) {
$inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
next if $inpod || /^\s*#/;
chop;
next if /^\s*(if|unless|elsif)/;
if ( m{^ \s* package \s+ \w[\w\:\']* \s+ (v?[0-9._]+) \s* ; }x ) {
local $^W = 0;
$result = $1;
}
elsif ( m{(?<!\\) ([\$*]) (([\w\:\']*) \bVERSION)\b .* =}x ) {
my $eval = qq{
package ExtUtils::MakeMaker::_version;
no strict;
BEGIN { eval {
# Ensure any version() routine which might have leaked
# into this package has been deleted. Interferes with
# version->import()
undef *version;
require version;
"version"->import;
} }
local $1$2;
\$$2=undef;
do {
$_
};
\$$2;
};
local $^W = 0;
$result = eval($eval); ## no critic
warn "Could not eval '$eval' in $parsefile: $@" if $@;
}
else {
next;
}
last if defined $result;
}
close $fh;
$result = "undef" unless defined $result;
return $result;
}
=item pasthru (o)
Defines the string that is passed to recursive make calls in
subdirectories.
=cut
sub pasthru {
my($self) = shift;
my(@m);
my(@pasthru);
my($sep) = $Is{VMS} ? ',' : '';
$sep .= "\\\n\t";
foreach my $key (qw(LIB LIBPERL_A LINKTYPE OPTIMIZE
PREFIX INSTALL_BASE)
)
{
next unless defined $self->{$key};
push @pasthru, "$key=\"\$($key)\"";
}
foreach my $key (qw(DEFINE INC)) {
next unless defined $self->{$key};
push @pasthru, "PASTHRU_$key=\"\$(PASTHRU_$key)\"";
}
push @m, "\nPASTHRU = ", join ($sep, @pasthru), "\n";
join "", @m;
}
=item perl_script
Takes one argument, a file name, and returns the file name, if the
argument is likely to be a perl script. On MM_Unix this is true for
any ordinary, readable file.
=cut
sub perl_script {
my($self,$file) = @_;
return $file if -r $file && -f _;
return;
}
=item perldepend (o)
Defines the dependency from all *.h files that come with the perl
distribution.
=cut
sub perldepend {
my($self) = shift;
my(@m);
my $make_config = $self->cd('$(PERL_SRC)', '$(MAKE) lib/Config.pm');
push @m, sprintf <<'MAKE_FRAG', $make_config if $self->{PERL_SRC};
# Check for unpropogated config.sh changes. Should never happen.
# We do NOT just update config.h because that is not sufficient.
# An out of date config.h is not fatal but complains loudly!
$(PERL_INC)/config.h: $(PERL_SRC)/config.sh
-$(NOECHO) $(ECHO) "Warning: $(PERL_INC)/config.h out of date with $(PERL_SRC)/config.sh"; $(FALSE)
$(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh
$(NOECHO) $(ECHO) "Warning: $(PERL_ARCHLIB)/Config.pm may be out of date with $(PERL_SRC)/config.sh"
%s
MAKE_FRAG
return join "", @m unless $self->needs_linking;
push @m, q{
PERL_HDRS = \
$(PERL_INC)/EXTERN.h \
$(PERL_INC)/INTERN.h \
$(PERL_INC)/XSUB.h \
$(PERL_INC)/av.h \
$(PERL_INC)/config.h \
$(PERL_INC)/cop.h \
$(PERL_INC)/cv.h \
$(PERL_INC)/dosish.h \
$(PERL_INC)/embed.h \
$(PERL_INC)/embedvar.h \
$(PERL_INC)/fakethr.h \
$(PERL_INC)/form.h \
$(PERL_INC)/gv.h \
$(PERL_INC)/handy.h \
$(PERL_INC)/hv.h \
$(PERL_INC)/intrpvar.h \
$(PERL_INC)/iperlsys.h \
$(PERL_INC)/keywords.h \
$(PERL_INC)/mg.h \
$(PERL_INC)/nostdio.h \
$(PERL_INC)/op.h \
$(PERL_INC)/opcode.h \
$(PERL_INC)/patchlevel.h \
$(PERL_INC)/perl.h \
$(PERL_INC)/perlio.h \
$(PERL_INC)/perlsdio.h \
$(PERL_INC)/perlsfio.h \
$(PERL_INC)/perlvars.h \
$(PERL_INC)/perly.h \
$(PERL_INC)/pp.h \
$(PERL_INC)/pp_proto.h \
$(PERL_INC)/proto.h \
$(PERL_INC)/regcomp.h \
$(PERL_INC)/regexp.h \
$(PERL_INC)/regnodes.h \
$(PERL_INC)/scope.h \
$(PERL_INC)/sv.h \
$(PERL_INC)/thread.h \
$(PERL_INC)/unixish.h \
$(PERL_INC)/util.h
$(OBJECT) : $(PERL_HDRS)
} if $self->{OBJECT};
push @m, join(" ", values %{$self->{XS}})." : \$(XSUBPPDEPS)\n" if %{$self->{XS}};
join "\n", @m;
}
=item pm_to_blib
Defines target that copies all files in the hash PM to their
destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION>
=cut
sub pm_to_blib {
my $self = shift;
my($autodir) = $self->catdir('$(INST_LIB)','auto');
my $r = q{
pm_to_blib : $(FIRST_MAKEFILE) $(TO_INST_PM)
};
# VMS will swallow '' and PM_FILTER is often empty. So use q[]
my $pm_to_blib = $self->oneliner(<<CODE, ['-MExtUtils::Install']);
pm_to_blib({\@ARGV}, '$autodir', q[\$(PM_FILTER)], '\$(PERM_DIR)')
CODE
my @cmds = $self->split_command($pm_to_blib, %{$self->{PM}});
$r .= join '', map { "\t\$(NOECHO) $_\n" } @cmds;
$r .= qq{\t\$(NOECHO) \$(TOUCH) pm_to_blib\n};
return $r;
}
=item post_constants (o)
Returns an empty string per default. Dedicated to overrides from
within Makefile.PL after all constants have been defined.
=cut
sub post_constants{
"";
}
=item post_initialize (o)
Returns an empty string per default. Used in Makefile.PLs to add some
chunk of text to the Makefile after the object is initialized.
=cut
sub post_initialize {
"";
}
=item postamble (o)
Returns an empty string. Can be used in Makefile.PLs to write some
text to the Makefile at the end.
=cut
sub postamble {
"";
}
# transform dot-separated version string into comma-separated quadruple
# examples: '1.2.3.4.5' => '1,2,3,4'
# '1.2.3' => '1,2,3,0'
sub _ppd_version {
my ($self, $string) = @_;
return join ',', ((split /\./, $string), (0) x 4)[0..3];
}
=item ppd
Defines target that creates a PPD (Perl Package Description) file
for a binary distribution.
=cut
sub ppd {
my($self) = @_;
my $abstract = $self->{ABSTRACT} || '';
$abstract =~ s/\n/\\n/sg;
$abstract =~ s/</</g;
$abstract =~ s/>/>/g;
my $author = join(', ',@{$self->{AUTHOR} || []});
$author =~ s/</</g;
$author =~ s/>/>/g;
my $ppd_file = '$(DISTNAME).ppd';
my @ppd_cmds = $self->echo(<<'PPD_HTML', $ppd_file, { append => 0, allow_variables => 1 });
<SOFTPKG NAME="$(DISTNAME)" VERSION="$(VERSION)">
PPD_HTML
my $ppd_xml = sprintf <<'PPD_HTML', $abstract, $author;
<ABSTRACT>%s</ABSTRACT>
<AUTHOR>%s</AUTHOR>
PPD_HTML
$ppd_xml .= " <IMPLEMENTATION>\n";
if ( $self->{MIN_PERL_VERSION} ) {
my $min_perl_version = $self->_ppd_version($self->{MIN_PERL_VERSION});
$ppd_xml .= sprintf <<'PPD_PERLVERS', $min_perl_version;
<PERLCORE VERSION="%s" />
PPD_PERLVERS
}
# Don't add "perl" to requires. perl dependencies are
# handles by ARCHITECTURE.
my %prereqs = %{$self->{PREREQ_PM}};
delete $prereqs{perl};
# Build up REQUIRE
foreach my $prereq (sort keys %prereqs) {
my $name = $prereq;
$name .= '::' unless $name =~ /::/;
my $version = $prereqs{$prereq}+0; # force numification
my %attrs = ( NAME => $name );
$attrs{VERSION} = $version if $version;
my $attrs = join " ", map { qq[$_="$attrs{$_}"] } keys %attrs;
$ppd_xml .= qq( <REQUIRE $attrs />\n);
}
my $archname = $Config{archname};
if ($] >= 5.008) {
# archname did not change from 5.6 to 5.8, but those versions may
# not be not binary compatible so now we append the part of the
# version that changes when binary compatibility may change
$archname .= "-$Config{PERL_REVISION}.$Config{PERL_VERSION}";
}
$ppd_xml .= sprintf <<'PPD_OUT', $archname;
<ARCHITECTURE NAME="%s" />
PPD_OUT
if ($self->{PPM_INSTALL_SCRIPT}) {
if ($self->{PPM_INSTALL_EXEC}) {
$ppd_xml .= sprintf qq{ <INSTALL EXEC="%s">%s</INSTALL>\n},
$self->{PPM_INSTALL_EXEC}, $self->{PPM_INSTALL_SCRIPT};
}
else {
$ppd_xml .= sprintf qq{ <INSTALL>%s</INSTALL>\n},
$self->{PPM_INSTALL_SCRIPT};
}
}
my ($bin_location) = $self->{BINARY_LOCATION} || '';
$bin_location =~ s/\\/\\\\/g;
$ppd_xml .= sprintf <<'PPD_XML', $bin_location;
<CODEBASE HREF="%s" />
</IMPLEMENTATION>
</SOFTPKG>
PPD_XML
push @ppd_cmds, $self->echo($ppd_xml, $ppd_file, { append => 1 });
return sprintf <<'PPD_OUT', join "\n\t", @ppd_cmds;
# Creates a PPD (Perl Package Description) for a binary distribution.
ppd :
%s
PPD_OUT
}
=item prefixify
$MM->prefixify($var, $prefix, $new_prefix, $default);
Using either $MM->{uc $var} || $Config{lc $var}, it will attempt to
replace it's $prefix with a $new_prefix.
Should the $prefix fail to match I<AND> a PREFIX was given as an
argument to WriteMakefile() it will set it to the $new_prefix +
$default. This is for systems whose file layouts don't neatly fit into
our ideas of prefixes.
This is for heuristics which attempt to create directory structures
that mirror those of the installed perl.
For example:
$MM->prefixify('installman1dir', '/usr', '/home/foo', 'man/man1');
this will attempt to remove '/usr' from the front of the
$MM->{INSTALLMAN1DIR} path (initializing it to $Config{installman1dir}
if necessary) and replace it with '/home/foo'. If this fails it will
simply use '/home/foo/man/man1'.
=cut
sub prefixify {
my($self,$var,$sprefix,$rprefix,$default) = @_;
my $path = $self->{uc $var} ||
$Config_Override{lc $var} || $Config{lc $var} || '';
$rprefix .= '/' if $sprefix =~ m|/$|;
warn " prefixify $var => $path\n" if $Verbose >= 2;
warn " from $sprefix to $rprefix\n" if $Verbose >= 2;
if( $self->{ARGS}{PREFIX} &&
$path !~ s{^\Q$sprefix\E\b}{$rprefix}s )
{
warn " cannot prefix, using default.\n" if $Verbose >= 2;
warn " no default!\n" if !$default && $Verbose >= 2;
$path = $self->catdir($rprefix, $default) if $default;
}
print " now $path\n" if $Verbose >= 2;
return $self->{uc $var} = $path;
}
=item processPL (o)
Defines targets to run *.PL files.
=cut
sub processPL {
my $self = shift;
my $pl_files = $self->{PL_FILES};
return "" unless $pl_files;
my $m = '';
foreach my $plfile (sort keys %$pl_files) {
my $list = ref($pl_files->{$plfile})
? $pl_files->{$plfile}
: [$pl_files->{$plfile}];
foreach my $target (@$list) {
if( $Is{VMS} ) {
$plfile = vmsify($self->eliminate_macros($plfile));
$target = vmsify($self->eliminate_macros($target));
}
# Normally a .PL file runs AFTER pm_to_blib so it can have
# blib in its @INC and load the just built modules. BUT if
# the generated module is something in $(TO_INST_PM) which
# pm_to_blib depends on then it can't depend on pm_to_blib
# else we have a dependency loop.
my $pm_dep;
my $perlrun;
if( defined $self->{PM}{$target} ) {
$pm_dep = '';
$perlrun = 'PERLRUN';
}
else {
$pm_dep = 'pm_to_blib';
$perlrun = 'PERLRUNINST';
}
$m .= <<MAKE_FRAG;
all :: $target
\$(NOECHO) \$(NOOP)
$target :: $plfile $pm_dep
\$($perlrun) $plfile $target
MAKE_FRAG
}
}
return $m;
}
=item quote_paren
Backslashes parentheses C<()> in command line arguments.
Doesn't handle recursive Makefile C<$(...)> constructs,
but handles simple ones.
=cut
sub quote_paren {
my $arg = shift;
$arg =~ s{\$\((.+?)\)}{\$\\\\($1\\\\)}g; # protect $(...)
$arg =~ s{(?<!\\)([()])}{\\$1}g; # quote unprotected
$arg =~ s{\$\\\\\((.+?)\\\\\)}{\$($1)}g; # unprotect $(...)
return $arg;
}
=item replace_manpage_separator
my $man_name = $MM->replace_manpage_separator($file_path);
Takes the name of a package, which may be a nested package, in the
form 'Foo/Bar.pm' and replaces the slash with C<::> or something else
safe for a man page file name. Returns the replacement.
=cut
sub replace_manpage_separator {
my($self,$man) = @_;
$man =~ s,/+,::,g;
return $man;
}
=item cd
=cut
sub cd {
my($self, $dir, @cmds) = @_;
# No leading tab and no trailing newline makes for easier embedding
my $make_frag = join "\n\t", map { "cd $dir && $_" } @cmds;
return $make_frag;
}
=item oneliner
=cut
sub oneliner {
my($self, $cmd, $switches) = @_;
$switches = [] unless defined $switches;
# Strip leading and trailing newlines
$cmd =~ s{^\n+}{};
$cmd =~ s{\n+$}{};
my @cmds = split /\n/, $cmd;
$cmd = join " \n\t -e ", map $self->quote_literal($_), @cmds;
$cmd = $self->escape_newlines($cmd);
$switches = join ' ', @$switches;
return qq{\$(ABSPERLRUN) $switches -e $cmd --};
}
=item quote_literal
=cut
sub quote_literal {
my($self, $text, $opts) = @_;
$opts->{allow_variables} = 1 unless defined $opts->{allow_variables};
# Quote single quotes
$text =~ s{'}{'\\''}g;
$text = $opts->{allow_variables}
? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text);
return "'$text'";
}
=item escape_newlines
=cut
sub escape_newlines {
my($self, $text) = @_;
$text =~ s{\n}{\\\n}g;
return $text;
}
=item max_exec_len
Using POSIX::ARG_MAX. Otherwise falling back to 4096.
=cut
sub max_exec_len {
my $self = shift;
if (!defined $self->{_MAX_EXEC_LEN}) {
if (my $arg_max = eval { require POSIX; &POSIX::ARG_MAX }) {
$self->{_MAX_EXEC_LEN} = $arg_max;
}
else { # POSIX minimum exec size
$self->{_MAX_EXEC_LEN} = 4096;
}
}
return $self->{_MAX_EXEC_LEN};
}
=item static (o)
Defines the static target.
=cut
sub static {
# --- Static Loading Sections ---
my($self) = shift;
'
## $(INST_PM) has been moved to the all: target.
## It remains here for awhile to allow for old usage: "make static"
static :: $(FIRST_MAKEFILE) $(INST_STATIC)
$(NOECHO) $(NOOP)
';
}
=item static_lib (o)
Defines how to produce the *.a (or equivalent) files.
=cut
sub static_lib {
my($self) = @_;
return '' unless $self->has_link_code;
my(@m);
push(@m, <<'END');
$(INST_STATIC) : $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists
$(RM_RF) $@
END
# If this extension has its own library (eg SDBM_File)
# then copy that to $(INST_STATIC) and add $(OBJECT) into it.
push(@m, <<'MAKE_FRAG') if $self->{MYEXTLIB};
$(CP) $(MYEXTLIB) $@
MAKE_FRAG
my $ar;
if (exists $self->{FULL_AR} && -x $self->{FULL_AR}) {
# Prefer the absolute pathed ar if available so that PATH
# doesn't confuse us. Perl itself is built with the full_ar.
$ar = 'FULL_AR';
} else {
$ar = 'AR';
}
push @m, sprintf <<'MAKE_FRAG', $ar;
$(%s) $(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@
$(CHMOD) $(PERM_RWX) $@
$(NOECHO) $(ECHO) "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld
MAKE_FRAG
# Old mechanism - still available:
push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS};
$(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)/ext.libs
MAKE_FRAG
join('', @m);
}
=item staticmake (o)
Calls makeaperl.
=cut
sub staticmake {
my($self, %attribs) = @_;
my(@static);
my(@searchdirs)=($self->{PERL_ARCHLIB}, $self->{SITEARCHEXP}, $self->{INST_ARCHLIB});
# And as it's not yet built, we add the current extension
# but only if it has some C code (or XS code, which implies C code)
if (@{$self->{C}}) {
@static = $self->catfile($self->{INST_ARCHLIB},
"auto",
$self->{FULLEXT},
"$self->{BASEEXT}$self->{LIB_EXT}"
);
}
# Either we determine now, which libraries we will produce in the
# subdirectories or we do it at runtime of the make.
# We could ask all subdir objects, but I cannot imagine, why it
# would be necessary.
# Instead we determine all libraries for the new perl at
# runtime.
my(@perlinc) = ($self->{INST_ARCHLIB}, $self->{INST_LIB}, $self->{PERL_ARCHLIB}, $self->{PERL_LIB});
$self->makeaperl(MAKE => $self->{MAKEFILE},
DIRS => \@searchdirs,
STAT => \@static,
INCL => \@perlinc,
TARGET => $self->{MAP_TARGET},
TMP => "",
LIBPERL => $self->{LIBPERL_A}
);
}
=item subdir_x (o)
Helper subroutine for subdirs
=cut
sub subdir_x {
my($self, $subdir) = @_;
my $subdir_cmd = $self->cd($subdir,
'$(MAKE) $(USEMAKEFILE) $(FIRST_MAKEFILE) all $(PASTHRU)'
);
return sprintf <<'EOT', $subdir_cmd;
subdirs ::
$(NOECHO) %s
EOT
}
=item subdirs (o)
Defines targets to process subdirectories.
=cut
sub subdirs {
# --- Sub-directory Sections ---
my($self) = shift;
my(@m);
# This method provides a mechanism to automatically deal with
# subdirectories containing further Makefile.PL scripts.
# It calls the subdir_x() method for each subdirectory.
foreach my $dir (@{$self->{DIR}}){
push(@m, $self->subdir_x($dir));
#### print "Including $dir subdirectory\n";
}
if (@m){
unshift(@m, "
# The default clean, realclean and test targets in this Makefile
# have automatically been given entries for each subdir.
");
} else {
push(@m, "\n# none")
}
join('',@m);
}
=item test (o)
Defines the test targets.
=cut
sub test {
# --- Test and Installation Sections ---
my($self, %attribs) = @_;
my $tests = $attribs{TESTS} || '';
if (!$tests && -d 't') {
$tests = $self->find_tests;
}
# note: 'test.pl' name is also hardcoded in init_dirscan()
my(@m);
push(@m,"
TEST_VERBOSE=0
TEST_TYPE=test_\$(LINKTYPE)
TEST_FILE = test.pl
TEST_FILES = $tests
TESTDB_SW = -d
testdb :: testdb_\$(LINKTYPE)
test :: \$(TEST_TYPE) subdirs-test
subdirs-test ::
\$(NOECHO) \$(NOOP)
");
foreach my $dir (@{ $self->{DIR} }) {
my $test = $self->cd($dir, '$(MAKE) test $(PASTHRU)');
push @m, <<END
subdirs-test ::
\$(NOECHO) $test
END
}
push(@m, "\t\$(NOECHO) \$(ECHO) 'No tests defined for \$(NAME) extension.'\n")
unless $tests or -f "test.pl" or @{$self->{DIR}};
push(@m, "\n");
push(@m, "test_dynamic :: pure_all\n");
push(@m, $self->test_via_harness('$(FULLPERLRUN)', '$(TEST_FILES)'))
if $tests;
push(@m, $self->test_via_script('$(FULLPERLRUN)', '$(TEST_FILE)'))
if -f "test.pl";
push(@m, "\n");
push(@m, "testdb_dynamic :: pure_all\n");
push(@m, $self->test_via_script('$(FULLPERLRUN) $(TESTDB_SW)',
'$(TEST_FILE)'));
push(@m, "\n");
# Occasionally we may face this degenerate target:
push @m, "test_ : test_dynamic\n\n";
if ($self->needs_linking()) {
push(@m, "test_static :: pure_all \$(MAP_TARGET)\n");
push(@m, $self->test_via_harness('./$(MAP_TARGET)', '$(TEST_FILES)')) if $tests;
push(@m, $self->test_via_script('./$(MAP_TARGET)', '$(TEST_FILE)')) if -f "test.pl";
push(@m, "\n");
push(@m, "testdb_static :: pure_all \$(MAP_TARGET)\n");
push(@m, $self->test_via_script('./$(MAP_TARGET) $(TESTDB_SW)', '$(TEST_FILE)'));
push(@m, "\n");
} else {
push @m, "test_static :: test_dynamic\n";
push @m, "testdb_static :: testdb_dynamic\n";
}
join("", @m);
}
=item test_via_harness (override)
For some reason which I forget, Unix machines like to have
PERL_DL_NONLAZY set for tests.
=cut
sub test_via_harness {
my($self, $perl, $tests) = @_;
return $self->SUPER::test_via_harness("PERL_DL_NONLAZY=1 $perl", $tests);
}
=item test_via_script (override)
Again, the PERL_DL_NONLAZY thing.
=cut
sub test_via_script {
my($self, $perl, $script) = @_;
return $self->SUPER::test_via_script("PERL_DL_NONLAZY=1 $perl", $script);
}
=item tool_xsubpp (o)
Determines typemaps, xsubpp version, prototype behaviour.
=cut
sub tool_xsubpp {
my($self) = shift;
return "" unless $self->needs_linking;
my $xsdir;
my @xsubpp_dirs = @INC;
# Make sure we pick up the new xsubpp if we're building perl.
unshift @xsubpp_dirs, $self->{PERL_LIB} if $self->{PERL_CORE};
foreach my $dir (@xsubpp_dirs) {
$xsdir = $self->catdir($dir, 'ExtUtils');
if( -r $self->catfile($xsdir, "xsubpp") ) {
last;
}
}
my $tmdir = File::Spec->catdir($self->{PERL_LIB},"ExtUtils");
my(@tmdeps) = $self->catfile($tmdir,'typemap');
if( $self->{TYPEMAPS} ){
foreach my $typemap (@{$self->{TYPEMAPS}}){
if( ! -f $typemap ) {
warn "Typemap $typemap not found.\n";
}
else {
push(@tmdeps, $typemap);
}
}
}
push(@tmdeps, "typemap") if -f "typemap";
my(@tmargs) = map("-typemap $_", @tmdeps);
if( exists $self->{XSOPT} ){
unshift( @tmargs, $self->{XSOPT} );
}
if ($Is{VMS} &&
$Config{'ldflags'} &&
$Config{'ldflags'} =~ m!/Debug!i &&
(!exists($self->{XSOPT}) || $self->{XSOPT} !~ /linenumbers/)
)
{
unshift(@tmargs,'-nolinenumbers');
}
$self->{XSPROTOARG} = "" unless defined $self->{XSPROTOARG};
return qq{
XSUBPPDIR = $xsdir
XSUBPP = \$(XSUBPPDIR)\$(DFSEP)xsubpp
XSUBPPRUN = \$(PERLRUN) \$(XSUBPP)
XSPROTOARG = $self->{XSPROTOARG}
XSUBPPDEPS = @tmdeps \$(XSUBPP)
XSUBPPARGS = @tmargs
XSUBPP_EXTRA_ARGS =
};
};
=item all_target
Build man pages, too
=cut
sub all_target {
my $self = shift;
return <<'MAKE_EXT';
all :: pure_all manifypods
$(NOECHO) $(NOOP)
MAKE_EXT
}
=item top_targets (o)
Defines the targets all, subdirs, config, and O_FILES
=cut
sub top_targets {
# --- Target Sections ---
my($self) = shift;
my(@m);
push @m, $self->all_target, "\n" unless $self->{SKIPHASH}{'all'};
push @m, '
pure_all :: config pm_to_blib subdirs linkext
$(NOECHO) $(NOOP)
subdirs :: $(MYEXTLIB)
$(NOECHO) $(NOOP)
config :: $(FIRST_MAKEFILE) blibdirs
$(NOECHO) $(NOOP)
';
push @m, '
$(O_FILES): $(H_FILES)
' if @{$self->{O_FILES} || []} && @{$self->{H} || []};
push @m, q{
help :
perldoc ExtUtils::MakeMaker
};
join('',@m);
}
=item writedoc
Obsolete, deprecated method. Not used since Version 5.21.
=cut
sub writedoc {
# --- perllocal.pod section ---
my($self,$what,$name,@attribs)=@_;
my $time = localtime;
print "=head2 $time: $what C<$name>\n\n=over 4\n\n=item *\n\n";
print join "\n\n=item *\n\n", map("C<$_>",@attribs);
print "\n\n=back\n\n";
}
=item xs_c (o)
Defines the suffix rules to compile XS files to C.
=cut
sub xs_c {
my($self) = shift;
return '' unless $self->needs_linking();
'
.xs.c:
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(XSUBPP_EXTRA_ARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.c
';
}
=item xs_cpp (o)
Defines the suffix rules to compile XS files to C++.
=cut
sub xs_cpp {
my($self) = shift;
return '' unless $self->needs_linking();
'
.xs.cpp:
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.cpp
';
}
=item xs_o (o)
Defines suffix rules to go from XS to object files directly. This is
only intended for broken make implementations.
=cut
sub xs_o { # many makes are too dumb to use xs_c then c_o
my($self) = shift;
return '' unless $self->needs_linking();
'
.xs$(OBJ_EXT):
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.c
$(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) $*.c
';
}
1;
=back
=head1 SEE ALSO
L<ExtUtils::MakeMaker>
=cut
__END__
EXTUTILS_MM_UNIX
$fatpacked{"ExtUtils/MM_VMS.pm"} = <<'EXTUTILS_MM_VMS';
package ExtUtils::MM_VMS;
use strict;
use ExtUtils::MakeMaker::Config;
require Exporter;
BEGIN {
# so we can compile the thing on non-VMS platforms.
if( $^O eq 'VMS' ) {
require VMS::Filespec;
VMS::Filespec->import;
}
}
use File::Basename;
our $VERSION = '6.64';
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
use ExtUtils::MakeMaker qw($Verbose neatvalue);
our $Revision = $ExtUtils::MakeMaker::Revision;
=head1 NAME
ExtUtils::MM_VMS - methods to override UN*X behaviour in ExtUtils::MakeMaker
=head1 SYNOPSIS
Do not use this directly.
Instead, use ExtUtils::MM and it will figure out which MM_*
class to use for you.
=head1 DESCRIPTION
See ExtUtils::MM_Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
=head2 Methods always loaded
=over 4
=item wraplist
Converts a list into a string wrapped at approximately 80 columns.
=cut
sub wraplist {
my($self) = shift;
my($line,$hlen) = ('',0);
foreach my $word (@_) {
# Perl bug -- seems to occasionally insert extra elements when
# traversing array (scalar(@array) doesn't show them, but
# foreach(@array) does) (5.00307)
next unless $word =~ /\w/;
$line .= ' ' if length($line);
if ($hlen > 80) { $line .= "\\\n\t"; $hlen = 0; }
$line .= $word;
$hlen += length($word) + 2;
}
$line;
}
# This isn't really an override. It's just here because ExtUtils::MM_VMS
# appears in @MM::ISA before ExtUtils::Liblist::Kid, so if there isn't an ext()
# in MM_VMS, then AUTOLOAD is called, and bad things happen. So, we just
# mimic inheritance here and hand off to ExtUtils::Liblist::Kid.
# XXX This hackery will die soon. --Schwern
sub ext {
require ExtUtils::Liblist::Kid;
goto &ExtUtils::Liblist::Kid::ext;
}
=back
=head2 Methods
Those methods which override default MM_Unix methods are marked
"(override)", while methods unique to MM_VMS are marked "(specific)".
For overridden methods, documentation is limited to an explanation
of why this method overrides the MM_Unix method; see the ExtUtils::MM_Unix
documentation for more details.
=over 4
=item guess_name (override)
Try to determine name of extension being built. We begin with the name
of the current directory. Since VMS filenames are case-insensitive,
however, we look for a F<.pm> file whose name matches that of the current
directory (presumably the 'main' F<.pm> file for this extension), and try
to find a C<package> statement from which to obtain the Mixed::Case
package name.
=cut
sub guess_name {
my($self) = @_;
my($defname,$defpm,@pm,%xs);
local *PM;
$defname = basename(fileify($ENV{'DEFAULT'}));
$defname =~ s![\d\-_]*\.dir.*$!!; # Clip off .dir;1 suffix, and package version
$defpm = $defname;
# Fallback in case for some reason a user has copied the files for an
# extension into a working directory whose name doesn't reflect the
# extension's name. We'll use the name of a unique .pm file, or the
# first .pm file with a matching .xs file.
if (not -e "${defpm}.pm") {
@pm = glob('*.pm');
s/.pm$// for @pm;
if (@pm == 1) { ($defpm = $pm[0]) =~ s/.pm$//; }
elsif (@pm) {
%xs = map { s/.xs$//; ($_,1) } glob('*.xs'); ## no critic
if (keys %xs) {
foreach my $pm (@pm) {
$defpm = $pm, last if exists $xs{$pm};
}
}
}
}
if (open(my $pm, '<', "${defpm}.pm")){
while (<$pm>) {
if (/^\s*package\s+([^;]+)/i) {
$defname = $1;
last;
}
}
print "Warning (non-fatal): Couldn't find package name in ${defpm}.pm;\n\t",
"defaulting package name to $defname\n"
if eof($pm);
close $pm;
}
else {
print "Warning (non-fatal): Couldn't find ${defpm}.pm;\n\t",
"defaulting package name to $defname\n";
}
$defname =~ s#[\d.\-_]+$##;
$defname;
}
=item find_perl (override)
Use VMS file specification syntax and CLI commands to find and
invoke Perl images.
=cut
sub find_perl {
my($self, $ver, $names, $dirs, $trace) = @_;
my($vmsfile,@sdirs,@snames,@cand);
my($rslt);
my($inabs) = 0;
local *TCF;
if( $self->{PERL_CORE} ) {
# Check in relative directories first, so we pick up the current
# version of Perl if we're running MakeMaker as part of the main build.
@sdirs = sort { my($absa) = $self->file_name_is_absolute($a);
my($absb) = $self->file_name_is_absolute($b);
if ($absa && $absb) { return $a cmp $b }
else { return $absa ? 1 : ($absb ? -1 : ($a cmp $b)); }
} @$dirs;
# Check miniperl before perl, and check names likely to contain
# version numbers before "generic" names, so we pick up an
# executable that's less likely to be from an old installation.
@snames = sort { my($ba) = $a =~ m!([^:>\]/]+)$!; # basename
my($bb) = $b =~ m!([^:>\]/]+)$!;
my($ahasdir) = (length($a) - length($ba) > 0);
my($bhasdir) = (length($b) - length($bb) > 0);
if ($ahasdir and not $bhasdir) { return 1; }
elsif ($bhasdir and not $ahasdir) { return -1; }
else { $bb =~ /\d/ <=> $ba =~ /\d/
or substr($ba,0,1) cmp substr($bb,0,1)
or length($bb) <=> length($ba) } } @$names;
}
else {
@sdirs = @$dirs;
@snames = @$names;
}
# Image names containing Perl version use '_' instead of '.' under VMS
s/\.(\d+)$/_$1/ for @snames;
if ($trace >= 2){
print "Looking for perl $ver by these names:\n";
print "\t@snames,\n";
print "in these dirs:\n";
print "\t@sdirs\n";
}
foreach my $dir (@sdirs){
next unless defined $dir; # $self->{PERL_SRC} may be undefined
$inabs++ if $self->file_name_is_absolute($dir);
if ($inabs == 1) {
# We've covered relative dirs; everything else is an absolute
# dir (probably an installed location). First, we'll try
# potential command names, to see whether we can avoid a long
# MCR expression.
foreach my $name (@snames) {
push(@cand,$name) if $name =~ /^[\w\-\$]+$/;
}
$inabs++; # Should happen above in next $dir, but just in case...
}
foreach my $name (@snames){
push @cand, ($name !~ m![/:>\]]!) ? $self->catfile($dir,$name)
: $self->fixpath($name,0);
}
}
foreach my $name (@cand) {
print "Checking $name\n" if $trace >= 2;
# If it looks like a potential command, try it without the MCR
if ($name =~ /^[\w\-\$]+$/) {
open(my $tcf, ">", "temp_mmvms.com")
or die('unable to open temp file');
print $tcf "\$ set message/nofacil/nosever/noident/notext\n";
print $tcf "\$ $name -e \"require $ver; print \"\"VER_OK\\n\"\"\"\n";
close $tcf;
$rslt = `\@temp_mmvms.com` ;
unlink('temp_mmvms.com');
if ($rslt =~ /VER_OK/) {
print "Using PERL=$name\n" if $trace;
return $name;
}
}
next unless $vmsfile = $self->maybe_command($name);
$vmsfile =~ s/;[\d\-]*$//; # Clip off version number; we can use a newer version as well
print "Executing $vmsfile\n" if ($trace >= 2);
open(my $tcf, '>', "temp_mmvms.com")
or die('unable to open temp file');
print $tcf "\$ set message/nofacil/nosever/noident/notext\n";
print $tcf "\$ mcr $vmsfile -e \"require $ver; print \"\"VER_OK\\n\"\"\" \n";
close $tcf;
$rslt = `\@temp_mmvms.com`;
unlink('temp_mmvms.com');
if ($rslt =~ /VER_OK/) {
print "Using PERL=MCR $vmsfile\n" if $trace;
return "MCR $vmsfile";
}
}
print "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
0; # false and not empty
}
=item _fixin_replace_shebang (override)
Helper routine for MM->fixin(), overridden because there's no such thing as an
actual shebang line that will be intepreted by the shell, so we just prepend
$Config{startperl} and preserve the shebang line argument for any switches it
may contain.
=cut
sub _fixin_replace_shebang {
my ( $self, $file, $line ) = @_;
my ( undef, $arg ) = split ' ', $line, 2;
return $Config{startperl} . "\n" . $Config{sharpbang} . "perl $arg\n";
}
=item maybe_command (override)
Follows VMS naming conventions for executable files.
If the name passed in doesn't exactly match an executable file,
appends F<.Exe> (or equivalent) to check for executable image, and F<.Com>
to check for DCL procedure. If this fails, checks directories in DCL$PATH
and finally F<Sys$System:> for an executable file having the name specified,
with or without the F<.Exe>-equivalent suffix.
=cut
sub maybe_command {
my($self,$file) = @_;
return $file if -x $file && ! -d _;
my(@dirs) = ('');
my(@exts) = ('',$Config{'exe_ext'},'.exe','.com');
if ($file !~ m![/:>\]]!) {
for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) {
my $dir = $ENV{"DCL\$PATH;$i"};
$dir .= ':' unless $dir =~ m%[\]:]$%;
push(@dirs,$dir);
}
push(@dirs,'Sys$System:');
foreach my $dir (@dirs) {
my $sysfile = "$dir$file";
foreach my $ext (@exts) {
return $file if -x "$sysfile$ext" && ! -d _;
}
}
}
return 0;
}
=item pasthru (override)
VMS has $(MMSQUALIFIERS) which is a listing of all the original command line
options. This is used in every invocation of make in the VMS Makefile so
PASTHRU should not be necessary. Using PASTHRU tends to blow commands past
the 256 character limit.
=cut
sub pasthru {
return "PASTHRU=\n";
}
=item pm_to_blib (override)
VMS wants a dot in every file so we can't have one called 'pm_to_blib',
it becomes 'pm_to_blib.' and MMS/K isn't smart enough to know that when
you have a target called 'pm_to_blib' it should look for 'pm_to_blib.'.
So in VMS its pm_to_blib.ts.
=cut
sub pm_to_blib {
my $self = shift;
my $make = $self->SUPER::pm_to_blib;
$make =~ s{^pm_to_blib :}{pm_to_blib.ts :}m;
$make =~ s{\$\(TOUCH\) pm_to_blib}{\$(TOUCH) pm_to_blib.ts};
$make = <<'MAKE' . $make;
# Dummy target to match Unix target name; we use pm_to_blib.ts as
# timestamp file to avoid repeated invocations under VMS
pm_to_blib : pm_to_blib.ts
$(NOECHO) $(NOOP)
MAKE
return $make;
}
=item perl_script (override)
If name passed in doesn't specify a readable file, appends F<.com> or
F<.pl> and tries again, since it's customary to have file types on all files
under VMS.
=cut
sub perl_script {
my($self,$file) = @_;
return $file if -r $file && ! -d _;
return "$file.com" if -r "$file.com";
return "$file.pl" if -r "$file.pl";
return '';
}
=item replace_manpage_separator
Use as separator a character which is legal in a VMS-syntax file name.
=cut
sub replace_manpage_separator {
my($self,$man) = @_;
$man = unixify($man);
$man =~ s#/+#__#g;
$man;
}
=item init_DEST
(override) Because of the difficulty concatenating VMS filepaths we
must pre-expand the DEST* variables.
=cut
sub init_DEST {
my $self = shift;
$self->SUPER::init_DEST;
# Expand DEST variables.
foreach my $var ($self->installvars) {
my $destvar = 'DESTINSTALL'.$var;
$self->{$destvar} = $self->eliminate_macros($self->{$destvar});
}
}
=item init_DIRFILESEP
No seperator between a directory path and a filename on VMS.
=cut
sub init_DIRFILESEP {
my($self) = shift;
$self->{DIRFILESEP} = '';
return 1;
}
=item init_main (override)
=cut
sub init_main {
my($self) = shift;
$self->SUPER::init_main;
$self->{DEFINE} ||= '';
if ($self->{DEFINE} ne '') {
my(@terms) = split(/\s+/,$self->{DEFINE});
my(@defs,@udefs);
foreach my $def (@terms) {
next unless $def;
my $targ = \@defs;
if ($def =~ s/^-([DU])//) { # If it was a Unix-style definition
$targ = \@udefs if $1 eq 'U';
$def =~ s/='(.*)'$/=$1/; # then remove shell-protection ''
$def =~ s/^'(.*)'$/$1/; # from entire term or argument
}
if ($def =~ /=/) {
$def =~ s/"/""/g; # Protect existing " from DCL
$def = qq["$def"]; # and quote to prevent parsing of =
}
push @$targ, $def;
}
$self->{DEFINE} = '';
if (@defs) {
$self->{DEFINE} = '/Define=(' . join(',',@defs) . ')';
}
if (@udefs) {
$self->{DEFINE} .= '/Undef=(' . join(',',@udefs) . ')';
}
}
}
=item init_tools (override)
Provide VMS-specific forms of various utility commands.
Sets DEV_NULL to nothing because I don't know how to do it on VMS.
Changes EQUALIZE_TIMESTAMP to set revision date of target file to
one second later than source file, since MMK interprets precisely
equal revision dates for a source and target file as a sign that the
target needs to be updated.
=cut
sub init_tools {
my($self) = @_;
$self->{NOOP} = 'Continue';
$self->{NOECHO} ||= '@ ';
$self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE} || 'Descrip.MMS';
$self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE};
$self->{MAKE_APERL_FILE} ||= 'Makeaperl.MMS';
$self->{MAKEFILE_OLD} ||= $self->eliminate_macros('$(FIRST_MAKEFILE)_old');
#
# If an extension is not specified, then MMS/MMK assumes an
# an extension of .MMS. If there really is no extension,
# then a trailing "." needs to be appended to specify a
# a null extension.
#
$self->{MAKEFILE} .= '.' unless $self->{MAKEFILE} =~ m/\./;
$self->{FIRST_MAKEFILE} .= '.' unless $self->{FIRST_MAKEFILE} =~ m/\./;
$self->{MAKE_APERL_FILE} .= '.' unless $self->{MAKE_APERL_FILE} =~ m/\./;
$self->{MAKEFILE_OLD} .= '.' unless $self->{MAKEFILE_OLD} =~ m/\./;
$self->{MACROSTART} ||= '/Macro=(';
$self->{MACROEND} ||= ')';
$self->{USEMAKEFILE} ||= '/Descrip=';
$self->{EQUALIZE_TIMESTAMP} ||= '$(ABSPERLRUN) -we "open F,qq{>>$ARGV[1]};close F;utime(0,(stat($ARGV[0]))[9]+1,$ARGV[1])"';
$self->{MOD_INSTALL} ||=
$self->oneliner(<<'CODE', ['-MExtUtils::Install']);
install([ from_to => {split(' ', <STDIN>)}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]);
CODE
$self->{UMASK_NULL} = '! ';
$self->SUPER::init_tools;
# Use the default shell
$self->{SHELL} ||= 'Posix';
# Redirection on VMS goes before the command, not after as on Unix.
# $(DEV_NULL) is used once and its not worth going nuts over making
# it work. However, Unix's DEV_NULL is quite wrong for VMS.
$self->{DEV_NULL} = '';
return;
}
=item init_platform (override)
Add PERL_VMS, MM_VMS_REVISION and MM_VMS_VERSION.
MM_VMS_REVISION is for backwards compatibility before MM_VMS had a
$VERSION.
=cut
sub init_platform {
my($self) = shift;
$self->{MM_VMS_REVISION} = $Revision;
$self->{MM_VMS_VERSION} = $VERSION;
$self->{PERL_VMS} = $self->catdir($self->{PERL_SRC}, 'VMS')
if $self->{PERL_SRC};
}
=item platform_constants
=cut
sub platform_constants {
my($self) = shift;
my $make_frag = '';
foreach my $macro (qw(PERL_VMS MM_VMS_REVISION MM_VMS_VERSION))
{
next unless defined $self->{$macro};
$make_frag .= "$macro = $self->{$macro}\n";
}
return $make_frag;
}
=item init_VERSION (override)
Override the *DEFINE_VERSION macros with VMS semantics. Translate the
MAKEMAKER filepath to VMS style.
=cut
sub init_VERSION {
my $self = shift;
$self->SUPER::init_VERSION;
$self->{DEFINE_VERSION} = '"$(VERSION_MACRO)=""$(VERSION)"""';
$self->{XS_DEFINE_VERSION} = '"$(XS_VERSION_MACRO)=""$(XS_VERSION)"""';
$self->{MAKEMAKER} = vmsify($INC{'ExtUtils/MakeMaker.pm'});
}
=item constants (override)
Fixes up numerous file and directory macros to insure VMS syntax
regardless of input syntax. Also makes lists of files
comma-separated.
=cut
sub constants {
my($self) = @_;
# Be kind about case for pollution
for (@ARGV) { $_ = uc($_) if /POLLUTE/i; }
# Cleanup paths for directories in MMS macros.
foreach my $macro ( qw [
INST_BIN INST_SCRIPT INST_LIB INST_ARCHLIB
PERL_LIB PERL_ARCHLIB
PERL_INC PERL_SRC ],
(map { 'INSTALL'.$_ } $self->installvars)
)
{
next unless defined $self->{$macro};
next if $macro =~ /MAN/ && $self->{$macro} eq 'none';
$self->{$macro} = $self->fixpath($self->{$macro},1);
}
# Cleanup paths for files in MMS macros.
foreach my $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKEFILE_OLD
MAKE_APERL_FILE MYEXTLIB] )
{
next unless defined $self->{$macro};
$self->{$macro} = $self->fixpath($self->{$macro},0);
}
# Fixup files for MMS macros
# XXX is this list complete?
for my $macro (qw/
FULLEXT VERSION_FROM
/ ) {
next unless defined $self->{$macro};
$self->{$macro} = $self->fixpath($self->{$macro},0);
}
for my $macro (qw/
OBJECT LDFROM
/ ) {
next unless defined $self->{$macro};
# Must expand macros before splitting on unescaped whitespace.
$self->{$macro} = $self->eliminate_macros($self->{$macro});
if ($self->{$macro} =~ /(?<!\^)\s/) {
$self->{$macro} =~ s/(\\)?\n+\s+/ /g;
$self->{$macro} = $self->wraplist(
map $self->fixpath($_,0), split /,?(?<!\^)\s+/, $self->{$macro}
);
}
else {
$self->{$macro} = $self->fixpath($self->{$macro},0);
}
}
for my $macro (qw/ XS MAN1PODS MAN3PODS PM /) {
# Where is the space coming from? --jhi
next unless $self ne " " && defined $self->{$macro};
my %tmp = ();
for my $key (keys %{$self->{$macro}}) {
$tmp{$self->fixpath($key,0)} =
$self->fixpath($self->{$macro}{$key},0);
}
$self->{$macro} = \%tmp;
}
for my $macro (qw/ C O_FILES H /) {
next unless defined $self->{$macro};
my @tmp = ();
for my $val (@{$self->{$macro}}) {
push(@tmp,$self->fixpath($val,0));
}
$self->{$macro} = \@tmp;
}
# mms/k does not define a $(MAKE) macro.
$self->{MAKE} = '$(MMS)$(MMSQUALIFIERS)';
return $self->SUPER::constants;
}
=item special_targets
Clear the default .SUFFIXES and put in our own list.
=cut
sub special_targets {
my $self = shift;
my $make_frag .= <<'MAKE_FRAG';
.SUFFIXES :
.SUFFIXES : $(OBJ_EXT) .c .cpp .cxx .xs
MAKE_FRAG
return $make_frag;
}
=item cflags (override)
Bypass shell script and produce qualifiers for CC directly (but warn
user if a shell script for this extension exists). Fold multiple
/Defines into one, since some C compilers pay attention to only one
instance of this qualifier on the command line.
=cut
sub cflags {
my($self,$libperl) = @_;
my($quals) = $self->{CCFLAGS} || $Config{'ccflags'};
my($definestr,$undefstr,$flagoptstr) = ('','','');
my($incstr) = '/Include=($(PERL_INC)';
my($name,$sys,@m);
( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ;
print "Unix shell script ".$Config{"$self->{'BASEEXT'}_cflags"}.
" required to modify CC command for $self->{'BASEEXT'}\n"
if ($Config{$name});
if ($quals =~ / -[DIUOg]/) {
while ($quals =~ / -([Og])(\d*)\b/) {
my($type,$lvl) = ($1,$2);
$quals =~ s/ -$type$lvl\b\s*//;
if ($type eq 'g') { $flagoptstr = '/NoOptimize'; }
else { $flagoptstr = '/Optimize' . (defined($lvl) ? "=$lvl" : ''); }
}
while ($quals =~ / -([DIU])(\S+)/) {
my($type,$def) = ($1,$2);
$quals =~ s/ -$type$def\s*//;
$def =~ s/"/""/g;
if ($type eq 'D') { $definestr .= qq["$def",]; }
elsif ($type eq 'I') { $incstr .= ',' . $self->fixpath($def,1); }
else { $undefstr .= qq["$def",]; }
}
}
if (length $quals and $quals !~ m!/!) {
warn "MM_VMS: Ignoring unrecognized CCFLAGS elements \"$quals\"\n";
$quals = '';
}
$definestr .= q["PERL_POLLUTE",] if $self->{POLLUTE};
if (length $definestr) { chop($definestr); $quals .= "/Define=($definestr)"; }
if (length $undefstr) { chop($undefstr); $quals .= "/Undef=($undefstr)"; }
# Deal with $self->{DEFINE} here since some C compilers pay attention
# to only one /Define clause on command line, so we have to
# conflate the ones from $Config{'ccflags'} and $self->{DEFINE}
# ($self->{DEFINE} has already been VMSified in constants() above)
if ($self->{DEFINE}) { $quals .= $self->{DEFINE}; }
for my $type (qw(Def Undef)) {
my(@terms);
while ($quals =~ m:/${type}i?n?e?=([^/]+):ig) {
my $term = $1;
$term =~ s:^\((.+)\)$:$1:;
push @terms, $term;
}
if ($type eq 'Def') {
push @terms, qw[ $(DEFINE_VERSION) $(XS_DEFINE_VERSION) ];
}
if (@terms) {
$quals =~ s:/${type}i?n?e?=[^/]+::ig;
$quals .= "/${type}ine=(" . join(',',@terms) . ')';
}
}
$libperl or $libperl = $self->{LIBPERL_A} || "libperl.olb";
# Likewise with $self->{INC} and /Include
if ($self->{'INC'}) {
my(@includes) = split(/\s+/,$self->{INC});
foreach (@includes) {
s/^-I//;
$incstr .= ','.$self->fixpath($_,1);
}
}
$quals .= "$incstr)";
# $quals =~ s/,,/,/g; $quals =~ s/\(,/(/g;
$self->{CCFLAGS} = $quals;
$self->{PERLTYPE} ||= '';
$self->{OPTIMIZE} ||= $flagoptstr || $Config{'optimize'};
if ($self->{OPTIMIZE} !~ m!/!) {
if ($self->{OPTIMIZE} =~ m!-g!) { $self->{OPTIMIZE} = '/Debug/NoOptimize' }
elsif ($self->{OPTIMIZE} =~ /-O(\d*)/) {
$self->{OPTIMIZE} = '/Optimize' . (defined($1) ? "=$1" : '');
}
else {
warn "MM_VMS: Can't parse OPTIMIZE \"$self->{OPTIMIZE}\"; using default\n" if length $self->{OPTIMIZE};
$self->{OPTIMIZE} = '/Optimize';
}
}
return $self->{CFLAGS} = qq{
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
PERLTYPE = $self->{PERLTYPE}
};
}
=item const_cccmd (override)
Adds directives to point C preprocessor to the right place when
handling #include E<lt>sys/foo.hE<gt> directives. Also constructs CC
command line a bit differently than MM_Unix method.
=cut
sub const_cccmd {
my($self,$libperl) = @_;
my(@m);
return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
return '' unless $self->needs_linking();
if ($Config{'vms_cc_type'} eq 'gcc') {
push @m,'
.FIRST
',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]';
}
elsif ($Config{'vms_cc_type'} eq 'vaxc') {
push @m,'
.FIRST
',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").eqs."" Then Define/NoLog SYS Sys$Library
',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").nes."" Then Define/NoLog SYS VAXC$Include';
}
else {
push @m,'
.FIRST
',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").eqs."" Then Define/NoLog SYS ',
($Config{'archname'} eq 'VMS_AXP' ? 'Sys$Library' : 'DECC$Library_Include'),'
',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").nes."" Then Define/NoLog SYS DECC$System_Include';
}
push(@m, "\n\nCCCMD = $Config{'cc'} \$(CCFLAGS)\$(OPTIMIZE)\n");
$self->{CONST_CCCMD} = join('',@m);
}
=item tools_other (override)
Throw in some dubious extra macros for Makefile args.
Also keep around the old $(SAY) macro in case somebody's using it.
=cut
sub tools_other {
my($self) = @_;
# XXX Are these necessary? Does anyone override them? They're longer
# than just typing the literal string.
my $extra_tools = <<'EXTRA_TOOLS';
# Just in case anyone is using the old macro.
USEMACROS = $(MACROSTART)
SAY = $(ECHO)
EXTRA_TOOLS
return $self->SUPER::tools_other . $extra_tools;
}
=item init_dist (override)
VMSish defaults for some values.
macro description default
ZIPFLAGS flags to pass to ZIP -Vu
COMPRESS compression command to gzip
use for tarfiles
SUFFIX suffix to put on -gz
compressed files
SHAR shar command to use vms_share
DIST_DEFAULT default target to use to tardist
create a distribution
DISTVNAME Use VERSION_SYM instead of $(DISTNAME)-$(VERSION_SYM)
VERSION for the name
=cut
sub init_dist {
my($self) = @_;
$self->{ZIPFLAGS} ||= '-Vu';
$self->{COMPRESS} ||= 'gzip';
$self->{SUFFIX} ||= '-gz';
$self->{SHAR} ||= 'vms_share';
$self->{DIST_DEFAULT} ||= 'zipdist';
$self->SUPER::init_dist;
$self->{DISTVNAME} = "$self->{DISTNAME}-$self->{VERSION_SYM}"
unless $self->{ARGS}{DISTVNAME};
return;
}
=item c_o (override)
Use VMS syntax on command line. In particular, $(DEFINE) and
$(PERL_INC) have been pulled into $(CCCMD). Also use MM[SK] macros.
=cut
sub c_o {
my($self) = @_;
return '' unless $self->needs_linking();
'
.c$(OBJ_EXT) :
$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c
.cpp$(OBJ_EXT) :
$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cpp
.cxx$(OBJ_EXT) :
$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cxx
';
}
=item xs_c (override)
Use MM[SK] macros.
=cut
sub xs_c {
my($self) = @_;
return '' unless $self->needs_linking();
'
.xs.c :
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET)
';
}
=item xs_o (override)
Use MM[SK] macros, and VMS command line for C compiler.
=cut
sub xs_o { # many makes are too dumb to use xs_c then c_o
my($self) = @_;
return '' unless $self->needs_linking();
'
.xs$(OBJ_EXT) :
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).c
$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c
';
}
=item dlsyms (override)
Create VMS linker options files specifying universal symbols for this
extension's shareable image, and listing other shareable images or
libraries to which it should be linked.
=cut
sub dlsyms {
my($self,%attribs) = @_;
return '' unless $self->needs_linking();
my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
my(@m);
unless ($self->{SKIPHASH}{'dynamic'}) {
push(@m,'
dynamic :: $(INST_ARCHAUTODIR)$(BASEEXT).opt
$(NOECHO) $(NOOP)
');
}
push(@m,'
static :: $(INST_ARCHAUTODIR)$(BASEEXT).opt
$(NOECHO) $(NOOP)
') unless $self->{SKIPHASH}{'static'};
push @m,'
$(INST_ARCHAUTODIR)$(BASEEXT).opt : $(BASEEXT).opt
$(CP) $(MMS$SOURCE) $(MMS$TARGET)
$(BASEEXT).opt : Makefile.PL
$(PERLRUN) -e "use ExtUtils::Mksymlists;" -
',qq[-e "Mksymlists('NAME' => '$self->{NAME}', 'DL_FUNCS' => ],
neatvalue($funcs),q[, 'DL_VARS' => ],neatvalue($vars),
q[, 'FUNCLIST' => ],neatvalue($funclist),qq[)"\n];
push @m, ' $(PERL) -e "print ""$(INST_STATIC)/Include=';
if ($self->{OBJECT} =~ /\bBASEEXT\b/ or
$self->{OBJECT} =~ /\b$self->{BASEEXT}\b/i) {
push @m, ($Config{d_vms_case_sensitive_symbols}
? uc($self->{BASEEXT}) :'$(BASEEXT)');
}
else { # We don't have a "main" object file, so pull 'em all in
# Upcase module names if linker is being case-sensitive
my($upcase) = $Config{d_vms_case_sensitive_symbols};
my(@omods) = split ' ', $self->eliminate_macros($self->{OBJECT});
for (@omods) {
s/\.[^.]*$//; # Trim off file type
s[\$\(\w+_EXT\)][]; # even as a macro
s/.*[:>\/\]]//; # Trim off dir spec
$_ = uc if $upcase;
};
my(@lines);
my $tmp = shift @omods;
foreach my $elt (@omods) {
$tmp .= ",$elt";
if (length($tmp) > 80) { push @lines, $tmp; $tmp = ''; }
}
push @lines, $tmp;
push @m, '(', join( qq[, -\\n\\t"";" >>\$(MMS\$TARGET)\n\t\$(PERL) -e "print ""], @lines),')';
}
push @m, '\n$(INST_STATIC)/Library\n"";" >>$(MMS$TARGET)',"\n";
if (length $self->{LDLOADLIBS}) {
my($line) = '';
foreach my $lib (split ' ', $self->{LDLOADLIBS}) {
$lib =~ s%\$%\\\$%g; # Escape '$' in VMS filespecs
if (length($line) + length($lib) > 160) {
push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n";
$line = $lib . '\n';
}
else { $line .= $lib . '\n'; }
}
push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n" if $line;
}
join('',@m);
}
=item dynamic_lib (override)
Use VMS Link command.
=cut
sub dynamic_lib {
my($self, %attribs) = @_;
return '' unless $self->needs_linking(); #might be because of a subdir
return '' unless $self->has_link_code();
my($otherldflags) = $attribs{OTHERLDFLAGS} || "";
my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
my $shr = $Config{'dbgprefix'} . 'PerlShr';
my(@m);
push @m,"
OTHERLDFLAGS = $otherldflags
INST_DYNAMIC_DEP = $inst_dynamic_dep
";
push @m, '
$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
If F$TrnLNm("',$shr,'").eqs."" Then Define/NoLog/User ',"$shr Sys\$Share:$shr.$Config{'dlext'}",'
Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,$(PERL_INC)perlshr_attr.opt/Option
';
join('',@m);
}
=item static_lib (override)
Use VMS commands to manipulate object library.
=cut
sub static_lib {
my($self) = @_;
return '' unless $self->needs_linking();
return '
$(INST_STATIC) :
$(NOECHO) $(NOOP)
' unless ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB});
my(@m);
push @m,'
# Rely on suffix rule for update action
$(OBJECT) : $(INST_ARCHAUTODIR)$(DFSEP).exists
$(INST_STATIC) : $(OBJECT) $(MYEXTLIB)
';
# If this extension has its own library (eg SDBM_File)
# then copy that to $(INST_STATIC) and add $(OBJECT) into it.
push(@m, "\t",'$(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB};
push(@m,"\t",'If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)',"\n");
# if there was a library to copy, then we can't use MMS$SOURCE_LIST,
# 'cause it's a library and you can't stick them in other libraries.
# In that case, we use $OBJECT instead and hope for the best
if ($self->{MYEXTLIB}) {
push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(OBJECT)',"\n");
} else {
push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n");
}
push @m, "\t\$(NOECHO) \$(PERL) -e 1 >\$(INST_ARCHAUTODIR)extralibs.ld\n";
foreach my $lib (split ' ', $self->{EXTRALIBS}) {
push(@m,"\t",'$(NOECHO) $(PERL) -e "print qq{',$lib,'\n}" >>$(INST_ARCHAUTODIR)extralibs.ld',"\n");
}
join('',@m);
}
=item extra_clean_files
Clean up some OS specific files. Plus the temp file used to shorten
a lot of commands. And the name mangler database.
=cut
sub extra_clean_files {
return qw(
*.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *.Opt $(BASEEXT).bso
.MM_Tmp cxx_repository
);
}
=item zipfile_target
=item tarfile_target
=item shdist_target
Syntax for invoking shar, tar and zip differs from that for Unix.
=cut
sub zipfile_target {
my($self) = shift;
return <<'MAKE_FRAG';
$(DISTVNAME).zip : distdir
$(PREOP)
$(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) [.$(DISTVNAME)...]*.*;
$(RM_RF) $(DISTVNAME)
$(POSTOP)
MAKE_FRAG
}
sub tarfile_target {
my($self) = shift;
return <<'MAKE_FRAG';
$(DISTVNAME).tar$(SUFFIX) : distdir
$(PREOP)
$(TO_UNIX)
$(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)...]
$(RM_RF) $(DISTVNAME)
$(COMPRESS) $(DISTVNAME).tar
$(POSTOP)
MAKE_FRAG
}
sub shdist_target {
my($self) = shift;
return <<'MAKE_FRAG';
shdist : distdir
$(PREOP)
$(SHAR) [.$(DISTVNAME)...]*.*; $(DISTVNAME).share
$(RM_RF) $(DISTVNAME)
$(POSTOP)
MAKE_FRAG
}
# --- Test and Installation Sections ---
=item install (override)
Work around DCL's 255 character limit several times,and use
VMS-style command line quoting in a few cases.
=cut
sub install {
my($self, %attribs) = @_;
my(@m);
push @m, q[
install :: all pure_install doc_install
$(NOECHO) $(NOOP)
install_perl :: all pure_perl_install doc_perl_install
$(NOECHO) $(NOOP)
install_site :: all pure_site_install doc_site_install
$(NOECHO) $(NOOP)
pure_install :: pure_$(INSTALLDIRS)_install
$(NOECHO) $(NOOP)
doc_install :: doc_$(INSTALLDIRS)_install
$(NOECHO) $(NOOP)
pure__install : pure_site_install
$(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
doc__install : doc_site_install
$(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
# This hack brought to you by DCL's 255-character command line limit
pure_perl_install ::
$(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
$(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLPRIVLIB) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLARCHLIB) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLBIN) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLMAN3DIR) " >>.MM_tmp
$(NOECHO) $(MOD_INSTALL) <.MM_tmp
$(NOECHO) $(RM_F) .MM_tmp
$(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[
# Likewise
pure_site_install ::
$(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
$(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLSITELIB) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLSITEARCH) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLSITEBIN) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLSITEMAN1DIR) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLSITEMAN3DIR) " >>.MM_tmp
$(NOECHO) $(MOD_INSTALL) <.MM_tmp
$(NOECHO) $(RM_F) .MM_tmp
$(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[
pure_vendor_install ::
$(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
$(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLVENDORLIB) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLVENDORARCH) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLVENDORBIN) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLVENDORMAN1DIR) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLVENDORMAN3DIR) " >>.MM_tmp
$(NOECHO) $(MOD_INSTALL) <.MM_tmp
$(NOECHO) $(RM_F) .MM_tmp
# Ditto
doc_perl_install ::
$(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
$(NOECHO) $(ECHO_N) "installed into|$(INSTALLPRIVLIB)|" >.MM_tmp
$(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
$(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
$(NOECHO) $(RM_F) .MM_tmp
# And again
doc_site_install ::
$(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
$(NOECHO) $(ECHO_N) "installed into|$(INSTALLSITELIB)|" >.MM_tmp
$(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
$(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
$(NOECHO) $(RM_F) .MM_tmp
doc_vendor_install ::
$(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
$(NOECHO) $(ECHO_N) "installed into|$(INSTALLVENDORLIB)|" >.MM_tmp
$(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
$(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
$(NOECHO) $(RM_F) .MM_tmp
];
push @m, q[
uninstall :: uninstall_from_$(INSTALLDIRS)dirs
$(NOECHO) $(NOOP)
uninstall_from_perldirs ::
$(NOECHO) $(UNINSTALL) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[
$(NOECHO) $(ECHO) "Uninstall is now deprecated and makes no actual changes."
$(NOECHO) $(ECHO) "Please check the list above carefully for errors, and manually remove"
$(NOECHO) $(ECHO) "the appropriate files. Sorry for the inconvenience."
uninstall_from_sitedirs ::
$(NOECHO) $(UNINSTALL) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[
$(NOECHO) $(ECHO) "Uninstall is now deprecated and makes no actual changes."
$(NOECHO) $(ECHO) "Please check the list above carefully for errors, and manually remove"
$(NOECHO) $(ECHO) "the appropriate files. Sorry for the inconvenience."
];
join('',@m);
}
=item perldepend (override)
Use VMS-style syntax for files; it's cheaper to just do it directly here
than to have the MM_Unix method call C<catfile> repeatedly. Also, if
we have to rebuild Config.pm, use MM[SK] to do it.
=cut
sub perldepend {
my($self) = @_;
my(@m);
push @m, '
$(OBJECT) : $(PERL_INC)EXTERN.h, $(PERL_INC)INTERN.h, $(PERL_INC)XSUB.h
$(OBJECT) : $(PERL_INC)av.h, $(PERL_INC)config.h
$(OBJECT) : $(PERL_INC)cop.h, $(PERL_INC)cv.h, $(PERL_INC)embed.h
$(OBJECT) : $(PERL_INC)embedvar.h, $(PERL_INC)form.h
$(OBJECT) : $(PERL_INC)gv.h, $(PERL_INC)handy.h, $(PERL_INC)hv.h
$(OBJECT) : $(PERL_INC)intrpvar.h, $(PERL_INC)iperlsys.h, $(PERL_INC)keywords.h
$(OBJECT) : $(PERL_INC)mg.h, $(PERL_INC)nostdio.h, $(PERL_INC)op.h
$(OBJECT) : $(PERL_INC)opcode.h, $(PERL_INC)patchlevel.h
$(OBJECT) : $(PERL_INC)perl.h, $(PERL_INC)perlio.h
$(OBJECT) : $(PERL_INC)perlsdio.h, $(PERL_INC)perlvars.h
$(OBJECT) : $(PERL_INC)perly.h, $(PERL_INC)pp.h, $(PERL_INC)pp_proto.h
$(OBJECT) : $(PERL_INC)proto.h, $(PERL_INC)regcomp.h, $(PERL_INC)regexp.h
$(OBJECT) : $(PERL_INC)regnodes.h, $(PERL_INC)scope.h, $(PERL_INC)sv.h
$(OBJECT) : $(PERL_INC)thread.h, $(PERL_INC)util.h, $(PERL_INC)vmsish.h
' if $self->{OBJECT};
if ($self->{PERL_SRC}) {
my(@macros);
my($mmsquals) = '$(USEMAKEFILE)[.vms]$(FIRST_MAKEFILE)';
push(@macros,'__AXP__=1') if $Config{'archname'} eq 'VMS_AXP';
push(@macros,'DECC=1') if $Config{'vms_cc_type'} eq 'decc';
push(@macros,'GNUC=1') if $Config{'vms_cc_type'} eq 'gcc';
push(@macros,'SOCKET=1') if $Config{'d_has_sockets'};
push(@macros,qq["CC=$Config{'cc'}"]) if $Config{'cc'} =~ m!/!;
$mmsquals .= '$(USEMACROS)' . join(',',@macros) . '$(MACROEND)' if @macros;
push(@m,q[
# Check for unpropagated config.sh changes. Should never happen.
# We do NOT just update config.h because that is not sufficient.
# An out of date config.h is not fatal but complains loudly!
$(PERL_INC)config.h : $(PERL_SRC)config.sh
$(NOOP)
$(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh
$(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.h or genconfig.pl"
olddef = F$Environment("Default")
Set Default $(PERL_SRC)
$(MMS)],$mmsquals,);
if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) {
my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm',0));
$target =~ s/\Q$prefix/[/;
push(@m," $target");
}
else { push(@m,' $(MMS$TARGET)'); }
push(@m,q[
Set Default 'olddef'
]);
}
push(@m, join(" ", map($self->fixpath($_,0),values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n")
if %{$self->{XS}};
join('',@m);
}
=item makeaperl (override)
Undertake to build a new set of Perl images using VMS commands. Since
VMS does dynamic loading, it's not necessary to statically link each
extension into the Perl image, so this isn't the normal build path.
Consequently, it hasn't really been tested, and may well be incomplete.
=cut
our %olbs; # needs to be localized
sub makeaperl {
my($self, %attribs) = @_;
my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmpdir, $libperl) =
@attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
my(@m);
push @m, "
# --- MakeMaker makeaperl section ---
MAP_TARGET = $target
";
return join '', @m if $self->{PARENT};
my($dir) = join ":", @{$self->{DIR}};
unless ($self->{MAKEAPERL}) {
push @m, q{
$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
$(NOECHO) $(ECHO) "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)"
$(NOECHO) $(PERLRUNINST) \
Makefile.PL DIR=}, $dir, q{ \
FIRST_MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
MAKEAPERL=1 NORECURS=1 };
push @m, map(q[ \\\n\t\t"$_"], @ARGV),q{
$(MAP_TARGET) :: $(MAKE_APERL_FILE)
$(MAKE)$(USEMAKEFILE)$(MAKE_APERL_FILE) static $(MMS$TARGET)
};
push @m, "\n";
return join '', @m;
}
my($linkcmd,@optlibs,@staticpkgs,$extralist,$targdir,$libperldir,%libseen);
local($_);
# The front matter of the linkcommand...
$linkcmd = join ' ', $Config{'ld'},
grep($_, @Config{qw(large split ldflags ccdlflags)});
$linkcmd =~ s/\s+/ /g;
# Which *.olb files could we make use of...
local(%olbs); # XXX can this be lexical?
$olbs{$self->{INST_ARCHAUTODIR}} = "$self->{BASEEXT}\$(LIB_EXT)";
require File::Find;
File::Find::find(sub {
return unless m/\Q$self->{LIB_EXT}\E$/;
return if m/^libperl/;
if( exists $self->{INCLUDE_EXT} ){
my $found = 0;
(my $xx = $File::Find::name) =~ s,.*?/auto/,,;
$xx =~ s,/?$_,,;
$xx =~ s,/,::,g;
# Throw away anything not explicitly marked for inclusion.
# DynaLoader is implied.
foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){
if( $xx eq $incl ){
$found++;
last;
}
}
return unless $found;
}
elsif( exists $self->{EXCLUDE_EXT} ){
(my $xx = $File::Find::name) =~ s,.*?/auto/,,;
$xx =~ s,/?$_,,;
$xx =~ s,/,::,g;
# Throw away anything explicitly marked for exclusion
foreach my $excl (@{$self->{EXCLUDE_EXT}}){
return if( $xx eq $excl );
}
}
$olbs{$ENV{DEFAULT}} = $_;
}, grep( -d $_, @{$searchdirs || []}));
# We trust that what has been handed in as argument will be buildable
$static = [] unless $static;
@olbs{@{$static}} = (1) x @{$static};
$extra = [] unless $extra && ref $extra eq 'ARRAY';
# Sort the object libraries in inverse order of
# filespec length to try to insure that dependent extensions
# will appear before their parents, so the linker will
# search the parent library to resolve references.
# (e.g. Intuit::DWIM will precede Intuit, so unresolved
# references from [.intuit.dwim]dwim.obj can be found
# in [.intuit]intuit.olb).
for (sort { length($a) <=> length($b) } keys %olbs) {
next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/;
my($dir) = $self->fixpath($_,1);
my($extralibs) = $dir . "extralibs.ld";
my($extopt) = $dir . $olbs{$_};
$extopt =~ s/$self->{LIB_EXT}$/.opt/;
push @optlibs, "$dir$olbs{$_}";
# Get external libraries this extension will need
if (-f $extralibs ) {
my %seenthis;
open my $list, "<", $extralibs or warn $!,next;
while (<$list>) {
chomp;
# Include a library in the link only once, unless it's mentioned
# multiple times within a single extension's options file, in which
# case we assume the builder needed to search it again later in the
# link.
my $skip = exists($libseen{$_}) && !exists($seenthis{$_});
$libseen{$_}++; $seenthis{$_}++;
next if $skip;
push @$extra,$_;
}
}
# Get full name of extension for ExtUtils::Miniperl
if (-f $extopt) {
open my $opt, '<', $extopt or die $!;
while (<$opt>) {
next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/;
my $pkg = $1;
$pkg =~ s#__*#::#g;
push @staticpkgs,$pkg;
}
}
}
# Place all of the external libraries after all of the Perl extension
# libraries in the final link, in order to maximize the opportunity
# for XS code from multiple extensions to resolve symbols against the
# same external library while only including that library once.
push @optlibs, @$extra;
$target = "Perl$Config{'exe_ext'}" unless $target;
my $shrtarget;
($shrtarget,$targdir) = fileparse($target);
$shrtarget =~ s/^([^.]*)/$1Shr/;
$shrtarget = $targdir . $shrtarget;
$target = "Perlshr.$Config{'dlext'}" unless $target;
$tmpdir = "[]" unless $tmpdir;
$tmpdir = $self->fixpath($tmpdir,1);
if (@optlibs) { $extralist = join(' ',@optlibs); }
else { $extralist = ''; }
# Let ExtUtils::Liblist find the necessary libs for us (but skip PerlShr)
# that's what we're building here).
push @optlibs, grep { !/PerlShr/i } split ' ', +($self->ext())[2];
if ($libperl) {
unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) {
print "Warning: $libperl not found\n";
undef $libperl;
}
}
unless ($libperl) {
if (defined $self->{PERL_SRC}) {
$libperl = $self->catfile($self->{PERL_SRC},"libperl$self->{LIB_EXT}");
} elsif (-f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',"libperl$self->{LIB_EXT}")) ) {
} else {
print "Warning: $libperl not found
If you're going to build a static perl binary, make sure perl is installed
otherwise ignore this warning\n";
}
}
$libperldir = $self->fixpath((fileparse($libperl))[1],1);
push @m, '
# Fill in the target you want to produce if it\'s not perl
MAP_TARGET = ',$self->fixpath($target,0),'
MAP_SHRTARGET = ',$self->fixpath($shrtarget,0),"
MAP_LINKCMD = $linkcmd
MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : '',"
MAP_EXTRA = $extralist
MAP_LIBPERL = ",$self->fixpath($libperl,0),'
';
push @m,"\n${tmpdir}Makeaperl.Opt : \$(MAP_EXTRA)\n";
foreach (@optlibs) {
push @m,' $(NOECHO) $(PERL) -e "print q{',$_,'}" >>$(MMS$TARGET)',"\n";
}
push @m,"\n${tmpdir}PerlShr.Opt :\n\t";
push @m,'$(NOECHO) $(PERL) -e "print q{$(MAP_SHRTARGET)}" >$(MMS$TARGET)',"\n";
push @m,'
$(MAP_SHRTARGET) : $(MAP_LIBPERL) Makeaperl.Opt ',"${libperldir}Perlshr_Attr.Opt",'
$(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_LIBPERL), Makeaperl.Opt/Option ',"${libperldir}Perlshr_Attr.Opt/Option",'
$(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}PerlShr.Opt",'
$(MAP_LINKCMD) ',"${tmpdir}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option
$(NOECHO) $(ECHO) "To install the new ""$(MAP_TARGET)"" binary, say"
$(NOECHO) $(ECHO) " $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)"
$(NOECHO) $(ECHO) "To remove the intermediate files, say
$(NOECHO) $(ECHO) " $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) map_clean"
';
push @m,"\n${tmpdir}perlmain.c : \$(FIRST_MAKEFILE)\n\t\$(NOECHO) \$(PERL) -e 1 >${tmpdir}Writemain.tmp\n";
push @m, "# More from the 255-char line length limit\n";
foreach (@staticpkgs) {
push @m,' $(NOECHO) $(PERL) -e "print q{',$_,qq[}" >>${tmpdir}Writemain.tmp\n];
}
push @m, sprintf <<'MAKE_FRAG', $tmpdir, $tmpdir;
$(NOECHO) $(PERL) $(MAP_PERLINC) -ane "use ExtUtils::Miniperl; writemain(@F)" %sWritemain.tmp >$(MMS$TARGET)
$(NOECHO) $(RM_F) %sWritemain.tmp
MAKE_FRAG
push @m, q[
# Still more from the 255-char line length limit
doc_inst_perl :
$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
$(NOECHO) $(ECHO) "Perl binary $(MAP_TARGET)|" >.MM_tmp
$(NOECHO) $(ECHO) "MAP_STATIC|$(MAP_STATIC)|" >>.MM_tmp
$(NOECHO) $(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp
$(NOECHO) $(ECHO) -e "MAP_LIBPERL|$(MAP_LIBPERL)|" >>.MM_tmp
$(NOECHO) $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q[
$(NOECHO) $(RM_F) .MM_tmp
];
push @m, "
inst_perl : pure_inst_perl doc_inst_perl
\$(NOECHO) \$(NOOP)
pure_inst_perl : \$(MAP_TARGET)
$self->{CP} \$(MAP_SHRTARGET) ",$self->fixpath($Config{'installbin'},1),"
$self->{CP} \$(MAP_TARGET) ",$self->fixpath($Config{'installbin'},1),"
clean :: map_clean
\$(NOECHO) \$(NOOP)
map_clean :
\$(RM_F) ${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}perlmain.c \$(FIRST_MAKEFILE)
\$(RM_F) ${tmpdir}Makeaperl.Opt ${tmpdir}PerlShr.Opt \$(MAP_TARGET)
";
join '', @m;
}
# --- Output postprocessing section ---
=item maketext_filter (override)
Insure that colons marking targets are preceded by space, in order
to distinguish the target delimiter from a colon appearing as
part of a filespec.
=cut
sub maketext_filter {
my($self, $text) = @_;
$text =~ s/^([^\s:=]+)(:+\s)/$1 $2/mg;
return $text;
}
=item prefixify (override)
prefixifying on VMS is simple. Each should simply be:
perl_root:[some.dir]
which can just be converted to:
volume:[your.prefix.some.dir]
otherwise you get the default layout.
In effect, your search prefix is ignored and $Config{vms_prefix} is
used instead.
=cut
sub prefixify {
my($self, $var, $sprefix, $rprefix, $default) = @_;
# Translate $(PERLPREFIX) to a real path.
$rprefix = $self->eliminate_macros($rprefix);
$rprefix = vmspath($rprefix) if $rprefix;
$sprefix = vmspath($sprefix) if $sprefix;
$default = vmsify($default)
unless $default =~ /\[.*\]/;
(my $var_no_install = $var) =~ s/^install//;
my $path = $self->{uc $var} ||
$ExtUtils::MM_Unix::Config_Override{lc $var} ||
$Config{lc $var} || $Config{lc $var_no_install};
if( !$path ) {
warn " no Config found for $var.\n" if $Verbose >= 2;
$path = $self->_prefixify_default($rprefix, $default);
}
elsif( !$self->{ARGS}{PREFIX} || !$self->file_name_is_absolute($path) ) {
# do nothing if there's no prefix or if its relative
}
elsif( $sprefix eq $rprefix ) {
warn " no new prefix.\n" if $Verbose >= 2;
}
else {
warn " prefixify $var => $path\n" if $Verbose >= 2;
warn " from $sprefix to $rprefix\n" if $Verbose >= 2;
my($path_vol, $path_dirs) = $self->splitpath( $path );
if( $path_vol eq $Config{vms_prefix}.':' ) {
warn " $Config{vms_prefix}: seen\n" if $Verbose >= 2;
$path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
$path = $self->_catprefix($rprefix, $path_dirs);
}
else {
$path = $self->_prefixify_default($rprefix, $default);
}
}
print " now $path\n" if $Verbose >= 2;
return $self->{uc $var} = $path;
}
sub _prefixify_default {
my($self, $rprefix, $default) = @_;
warn " cannot prefix, using default.\n" if $Verbose >= 2;
if( !$default ) {
warn "No default!\n" if $Verbose >= 1;
return;
}
if( !$rprefix ) {
warn "No replacement prefix!\n" if $Verbose >= 1;
return '';
}
return $self->_catprefix($rprefix, $default);
}
sub _catprefix {
my($self, $rprefix, $default) = @_;
my($rvol, $rdirs) = $self->splitpath($rprefix);
if( $rvol ) {
return $self->catpath($rvol,
$self->catdir($rdirs, $default),
''
)
}
else {
return $self->catdir($rdirs, $default);
}
}
=item cd
=cut
sub cd {
my($self, $dir, @cmds) = @_;
$dir = vmspath($dir);
my $cmd = join "\n\t", map "$_", @cmds;
# No leading tab makes it look right when embedded
my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd;
startdir = F$Environment("Default")
Set Default %s
%s
Set Default 'startdir'
MAKE_FRAG
# No trailing newline makes this easier to embed
chomp $make_frag;
return $make_frag;
}
=item oneliner
=cut
sub oneliner {
my($self, $cmd, $switches) = @_;
$switches = [] unless defined $switches;
# Strip leading and trailing newlines
$cmd =~ s{^\n+}{};
$cmd =~ s{\n+$}{};
$cmd = $self->quote_literal($cmd);
$cmd = $self->escape_newlines($cmd);
# Switches must be quoted else they will be lowercased.
$switches = join ' ', map { qq{"$_"} } @$switches;
return qq{\$(ABSPERLRUN) $switches -e $cmd "--"};
}
=item B<echo>
perl trips up on "<foo>" thinking it's an input redirect. So we use the
native Write command instead. Besides, its faster.
=cut
sub echo {
my($self, $text, $file, $opts) = @_;
# Compatibility with old options
if( !ref $opts ) {
my $append = $opts;
$opts = { append => $append || 0 };
}
my $opencmd = $opts->{append} ? 'Open/Append' : 'Open/Write';
$opts->{allow_variables} = 0 unless defined $opts->{allow_variables};
my $ql_opts = { allow_variables => $opts->{allow_variables} };
my @cmds = ("\$(NOECHO) $opencmd MMECHOFILE $file ");
push @cmds, map { '$(NOECHO) Write MMECHOFILE '.$self->quote_literal($_, $ql_opts) }
split /\n/, $text;
push @cmds, '$(NOECHO) Close MMECHOFILE';
return @cmds;
}
=item quote_literal
=cut
sub quote_literal {
my($self, $text, $opts) = @_;
$opts->{allow_variables} = 1 unless defined $opts->{allow_variables};
# I believe this is all we should need.
$text =~ s{"}{""}g;
$text = $opts->{allow_variables}
? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text);
return qq{"$text"};
}
=item escape_dollarsigns
Quote, don't escape.
=cut
sub escape_dollarsigns {
my($self, $text) = @_;
# Quote dollar signs which are not starting a variable
$text =~ s{\$ (?!\() }{"\$"}gx;
return $text;
}
=item escape_all_dollarsigns
Quote, don't escape.
=cut
sub escape_all_dollarsigns {
my($self, $text) = @_;
# Quote dollar signs
$text =~ s{\$}{"\$\"}gx;
return $text;
}
=item escape_newlines
=cut
sub escape_newlines {
my($self, $text) = @_;
$text =~ s{\n}{-\n}g;
return $text;
}
=item max_exec_len
256 characters.
=cut
sub max_exec_len {
my $self = shift;
return $self->{_MAX_EXEC_LEN} ||= 256;
}
=item init_linker
=cut
sub init_linker {
my $self = shift;
$self->{EXPORT_LIST} ||= '$(BASEEXT).opt';
my $shr = $Config{dbgprefix} . 'PERLSHR';
if ($self->{PERL_SRC}) {
$self->{PERL_ARCHIVE} ||=
$self->catfile($self->{PERL_SRC}, "$shr.$Config{'dlext'}");
}
else {
$self->{PERL_ARCHIVE} ||=
$ENV{$shr} ? $ENV{$shr} : "Sys\$Share:$shr.$Config{'dlext'}";
}
$self->{PERL_ARCHIVE_AFTER} ||= '';
}
=item catdir (override)
=item catfile (override)
Eliminate the macros in the output to the MMS/MMK file.
(File::Spec::VMS used to do this for us, but it's being removed)
=cut
sub catdir {
my $self = shift;
# Process the macros on VMS MMS/MMK
my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_ } @_;
my $dir = $self->SUPER::catdir(@args);
# Fix up the directory and force it to VMS format.
$dir = $self->fixpath($dir, 1);
return $dir;
}
sub catfile {
my $self = shift;
# Process the macros on VMS MMS/MMK
my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_ } @_;
my $file = $self->SUPER::catfile(@args);
$file = vmsify($file);
return $file
}
=item eliminate_macros
Expands MM[KS]/Make macros in a text string, using the contents of
identically named elements of C<%$self>, and returns the result
as a file specification in Unix syntax.
NOTE: This is the canonical version of the method. The version in
File::Spec::VMS is deprecated.
=cut
sub eliminate_macros {
my($self,$path) = @_;
return '' unless $path;
$self = {} unless ref $self;
if ($path =~ /\s/) {
return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
}
my($npath) = unixify($path);
# sometimes unixify will return a string with an off-by-one trailing null
$npath =~ s{\0$}{};
my($complex) = 0;
my($head,$macro,$tail);
# perform m##g in scalar context so it acts as an iterator
while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
if (defined $self->{$2}) {
($head,$macro,$tail) = ($1,$2,$3);
if (ref $self->{$macro}) {
if (ref $self->{$macro} eq 'ARRAY') {
$macro = join ' ', @{$self->{$macro}};
}
else {
print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
"\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
$macro = "\cB$macro\cB";
$complex = 1;
}
}
else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
$npath = "$head$macro$tail";
}
}
if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
$npath;
}
=item fixpath
my $path = $mm->fixpath($path);
my $path = $mm->fixpath($path, $is_dir);
Catchall routine to clean up problem MM[SK]/Make macros. Expands macros
in any directory specification, in order to avoid juxtaposing two
VMS-syntax directories when MM[SK] is run. Also expands expressions which
are all macro, so that we can tell how long the expansion is, and avoid
overrunning DCL's command buffer when MM[KS] is running.
fixpath() checks to see whether the result matches the name of a
directory in the current default directory and returns a directory or
file specification accordingly. C<$is_dir> can be set to true to
force fixpath() to consider the path to be a directory or false to force
it to be a file.
NOTE: This is the canonical version of the method. The version in
File::Spec::VMS is deprecated.
=cut
sub fixpath {
my($self,$path,$force_path) = @_;
return '' unless $path;
$self = bless {}, $self unless ref $self;
my($fixedpath,$prefix,$name);
if ($path =~ /[ \t]/) {
return join ' ',
map { $self->fixpath($_,$force_path) }
split /[ \t]+/, $path;
}
if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
$fixedpath = vmspath($self->eliminate_macros($path));
}
else {
$fixedpath = vmsify($self->eliminate_macros($path));
}
}
elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
my($vmspre) = $self->eliminate_macros("\$($prefix)");
# is it a dir or just a name?
$vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
$fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
$fixedpath = vmspath($fixedpath) if $force_path;
}
else {
$fixedpath = $path;
$fixedpath = vmspath($fixedpath) if $force_path;
}
# No hints, so we try to guess
if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
$fixedpath = vmspath($fixedpath) if -d $fixedpath;
}
# Trim off root dirname if it's had other dirs inserted in front of it.
$fixedpath =~ s/\.000000([\]>])/$1/;
# Special case for VMS absolute directory specs: these will have had device
# prepended during trip through Unix syntax in eliminate_macros(), since
# Unix syntax has no way to express "absolute from the top of this device's
# directory tree".
if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
return $fixedpath;
}
=item os_flavor
VMS is VMS.
=cut
sub os_flavor {
return('VMS');
}
=back
=head1 AUTHOR
Original author Charles Bailey F<bailey@newman.upenn.edu>
Maintained by Michael G Schwern F<schwern@pobox.com>
See L<ExtUtils::MakeMaker> for patching and contact information.
=cut
1;
EXTUTILS_MM_VMS
$fatpacked{"ExtUtils/MM_VOS.pm"} = <<'EXTUTILS_MM_VOS';
package ExtUtils::MM_VOS;
use strict;
our $VERSION = '6.64';
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
=head1 NAME
ExtUtils::MM_VOS - VOS specific subclass of ExtUtils::MM_Unix
=head1 SYNOPSIS
Don't use this module directly.
Use ExtUtils::MM and let it choose.
=head1 DESCRIPTION
This is a subclass of ExtUtils::MM_Unix which contains functionality for
VOS.
Unless otherwise stated it works just like ExtUtils::MM_Unix
=head2 Overridden methods
=head3 extra_clean_files
Cleanup VOS core files
=cut
sub extra_clean_files {
return qw(*.kp);
}
=head1 AUTHOR
Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix
=head1 SEE ALSO
L<ExtUtils::MakeMaker>
=cut
1;
EXTUTILS_MM_VOS
$fatpacked{"ExtUtils/MM_Win32.pm"} = <<'EXTUTILS_MM_WIN32';
package ExtUtils::MM_Win32;
use strict;
=head1 NAME
ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker
=head1 SYNOPSIS
use ExtUtils::MM_Win32; # Done internally by ExtUtils::MakeMaker if needed
=head1 DESCRIPTION
See ExtUtils::MM_Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
=cut
use ExtUtils::MakeMaker::Config;
use File::Basename;
use File::Spec;
use ExtUtils::MakeMaker qw( neatvalue );
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
our $VERSION = '6.64';
$ENV{EMXSHELL} = 'sh'; # to run `commands`
my ( $BORLAND, $GCC, $DLLTOOL ) = _identify_compiler_environment( \%Config );
sub _identify_compiler_environment {
my ( $config ) = @_;
my $BORLAND = $config->{cc} =~ /^bcc/i ? 1 : 0;
my $GCC = $config->{cc} =~ /\bgcc\b/i ? 1 : 0;
my $DLLTOOL = $config->{dlltool} || 'dlltool';
return ( $BORLAND, $GCC, $DLLTOOL );
}
=head2 Overridden methods
=over 4
=item B<dlsyms>
=cut
sub dlsyms {
my($self,%attribs) = @_;
my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {};
my(@m);
if (not $self->{SKIPHASH}{'dynamic'}) {
push(@m,"
$self->{BASEEXT}.def: Makefile.PL
",
q! $(PERLRUN) -MExtUtils::Mksymlists \\
-e "Mksymlists('NAME'=>\"!, $self->{NAME},
q!\", 'DLBASE' => '!,$self->{DLBASE},
# The above two lines quoted differently to work around
# a bug in the 4DOS/4NT command line interpreter. The visible
# result of the bug was files named q('extension_name',) *with the
# single quotes and the comma* in the extension build directories.
q!', 'DL_FUNCS' => !,neatvalue($funcs),
q!, 'FUNCLIST' => !,neatvalue($funclist),
q!, 'IMPORTS' => !,neatvalue($imports),
q!, 'DL_VARS' => !, neatvalue($vars), q!);"
!);
}
join('',@m);
}
=item replace_manpage_separator
Changes the path separator with .
=cut
sub replace_manpage_separator {
my($self,$man) = @_;
$man =~ s,/+,.,g;
$man;
}
=item B<maybe_command>
Since Windows has nothing as simple as an executable bit, we check the
file extension.
The PATHEXT env variable will be used to get a list of extensions that
might indicate a command, otherwise .com, .exe, .bat and .cmd will be
used by default.
=cut
sub maybe_command {
my($self,$file) = @_;
my @e = exists($ENV{'PATHEXT'})
? split(/;/, $ENV{PATHEXT})
: qw(.com .exe .bat .cmd);
my $e = '';
for (@e) { $e .= "\Q$_\E|" }
chop $e;
# see if file ends in one of the known extensions
if ($file =~ /($e)$/i) {
return $file if -e $file;
}
else {
for (@e) {
return "$file$_" if -e "$file$_";
}
}
return;
}
=item B<init_DIRFILESEP>
Using \ for Windows.
=cut
sub init_DIRFILESEP {
my($self) = shift;
# The ^ makes sure its not interpreted as an escape in nmake
$self->{DIRFILESEP} = $self->is_make_type('nmake') ? '^\\' :
$self->is_make_type('dmake') ? '\\\\'
: '\\';
}
=item init_tools
Override some of the slower, portable commands with Windows specific ones.
=cut
sub init_tools {
my ($self) = @_;
$self->{NOOP} ||= 'rem';
$self->{DEV_NULL} ||= '> NUL';
$self->{FIXIN} ||= $self->{PERL_CORE} ?
"\$(PERLRUN) $self->{PERL_SRC}/win32/bin/pl2bat.pl" :
'pl2bat.bat';
$self->SUPER::init_tools;
# Setting SHELL from $Config{sh} can break dmake. Its ok without it.
delete $self->{SHELL};
return;
}
=item init_others
Override the default link and compile tools.
LDLOADLIBS's default is changed to $Config{libs}.
Adjustments are made for Borland's quirks needing -L to come first.
=cut
sub init_others {
my $self = shift;
$self->{LD} ||= 'link';
$self->{AR} ||= 'lib';
$self->SUPER::init_others;
$self->{LDLOADLIBS} ||= $Config{libs};
# -Lfoo must come first for Borland, so we put it in LDDLFLAGS
if ($BORLAND) {
my $libs = $self->{LDLOADLIBS};
my $libpath = '';
while ($libs =~ s/(?:^|\s)(("?)-L.+?\2)(?:\s|$)/ /) {
$libpath .= ' ' if length $libpath;
$libpath .= $1;
}
$self->{LDLOADLIBS} = $libs;
$self->{LDDLFLAGS} ||= $Config{lddlflags};
$self->{LDDLFLAGS} .= " $libpath";
}
return;
}
=item init_platform
Add MM_Win32_VERSION.
=item platform_constants
=cut
sub init_platform {
my($self) = shift;
$self->{MM_Win32_VERSION} = $VERSION;
return;
}
sub platform_constants {
my($self) = shift;
my $make_frag = '';
foreach my $macro (qw(MM_Win32_VERSION))
{
next unless defined $self->{$macro};
$make_frag .= "$macro = $self->{$macro}\n";
}
return $make_frag;
}
=item constants
Add MAXLINELENGTH for dmake before all the constants are output.
=cut
sub constants {
my $self = shift;
my $make_text = $self->SUPER::constants;
return $make_text unless $self->is_make_type('dmake');
# dmake won't read any single "line" (even those with escaped newlines)
# larger than a certain size which can be as small as 8k. PM_TO_BLIB
# on large modules like DateTime::TimeZone can create lines over 32k.
# So we'll crank it up to a <ironic>WHOPPING</ironic> 64k.
#
# This has to come here before all the constants and not in
# platform_constants which is after constants.
my $size = $self->{MAXLINELENGTH} || 64 * 1024;
my $prefix = qq{
# Get dmake to read long commands like PM_TO_BLIB
MAXLINELENGTH = $size
};
return $prefix . $make_text;
}
=item special_targets
Add .USESHELL target for dmake.
=cut
sub special_targets {
my($self) = @_;
my $make_frag = $self->SUPER::special_targets;
$make_frag .= <<'MAKE_FRAG' if $self->is_make_type('dmake');
.USESHELL :
MAKE_FRAG
return $make_frag;
}
=item static_lib
Changes how to run the linker.
The rest is duplicate code from MM_Unix. Should move the linker code
to its own method.
=cut
sub static_lib {
my($self) = @_;
return '' unless $self->has_link_code;
my(@m);
push(@m, <<'END');
$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists
$(RM_RF) $@
END
# If this extension has its own library (eg SDBM_File)
# then copy that to $(INST_STATIC) and add $(OBJECT) into it.
push @m, <<'MAKE_FRAG' if $self->{MYEXTLIB};
$(CP) $(MYEXTLIB) $@
MAKE_FRAG
push @m,
q{ $(AR) }.($BORLAND ? '$@ $(OBJECT:^"+")'
: ($GCC ? '-ru $@ $(OBJECT)'
: '-out:$@ $(OBJECT)')).q{
$(CHMOD) $(PERM_RWX) $@
$(NOECHO) $(ECHO) "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)\extralibs.ld
};
# Old mechanism - still available:
push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS};
$(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)\ext.libs
MAKE_FRAG
join('', @m);
}
=item dynamic_lib
Complicated stuff for Win32 that I don't understand. :(
=cut
sub dynamic_lib {
my($self, %attribs) = @_;
return '' unless $self->needs_linking(); #might be because of a subdir
return '' unless $self->has_link_code;
my($otherldflags) = $attribs{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': '');
my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
my($ldfrom) = '$(LDFROM)';
my(@m);
push(@m,'
# This section creates the dynamically loadable $(INST_DYNAMIC)
# from $(OBJECT) and possibly $(MYEXTLIB).
OTHERLDFLAGS = '.$otherldflags.'
INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
');
if ($GCC) {
push(@m,
q{ }.$DLLTOOL.q{ --def $(EXPORT_LIST) --output-exp dll.exp
$(LD) -o $@ -Wl,--base-file -Wl,dll.base $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp
}.$DLLTOOL.q{ --def $(EXPORT_LIST) --base-file dll.base --output-exp dll.exp
$(LD) -o $@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp });
} elsif ($BORLAND) {
push(@m,
q{ $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) }.$ldfrom.q{,$@,,}
.($self->is_make_type('dmake')
? q{$(PERL_ARCHIVE:s,/,\,) $(LDLOADLIBS:s,/,\,) }
.q{$(MYEXTLIB:s,/,\,),$(EXPORT_LIST:s,/,\,)}
: q{$(subst /,\,$(PERL_ARCHIVE)) $(subst /,\,$(LDLOADLIBS)) }
.q{$(subst /,\,$(MYEXTLIB)),$(subst /,\,$(EXPORT_LIST))})
.q{,$(RESFILES)});
} else { # VC
push(@m,
q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) }
.q{$(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)});
# Embed the manifest file if it exists
push(@m, q{
if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2
if exist $@.manifest del $@.manifest});
}
push @m, '
$(CHMOD) $(PERM_RWX) $@
';
join('',@m);
}
=item extra_clean_files
Clean out some extra dll.{base,exp} files which might be generated by
gcc. Otherwise, take out all *.pdb files.
=cut
sub extra_clean_files {
my $self = shift;
return $GCC ? (qw(dll.base dll.exp)) : ('*.pdb');
}
=item init_linker
=cut
sub init_linker {
my $self = shift;
$self->{PERL_ARCHIVE} = "\$(PERL_INC)\\$Config{libperl}";
$self->{PERL_ARCHIVE_AFTER} = '';
$self->{EXPORT_LIST} = '$(BASEEXT).def';
}
=item perl_script
Checks for the perl program under several common perl extensions.
=cut
sub perl_script {
my($self,$file) = @_;
return $file if -r $file && -f _;
return "$file.pl" if -r "$file.pl" && -f _;
return "$file.plx" if -r "$file.plx" && -f _;
return "$file.bat" if -r "$file.bat" && -f _;
return;
}
=item xs_o
This target is stubbed out. Not sure why.
=cut
sub xs_o {
return ''
}
=item pasthru
All we send is -nologo to nmake to prevent it from printing its damned
banner.
=cut
sub pasthru {
my($self) = shift;
return "PASTHRU = " . ($self->is_make_type('nmake') ? "-nologo" : "");
}
=item arch_check (override)
Normalize all arguments for consistency of comparison.
=cut
sub arch_check {
my $self = shift;
# Win32 is an XS module, minperl won't have it.
# arch_check() is not critical, so just fake it.
return 1 unless $self->can_load_xs;
return $self->SUPER::arch_check( map { $self->_normalize_path_name($_) } @_);
}
sub _normalize_path_name {
my $self = shift;
my $file = shift;
require Win32;
my $short = Win32::GetShortPathName($file);
return defined $short ? lc $short : lc $file;
}
=item oneliner
These are based on what command.com does on Win98. They may be wrong
for other Windows shells, I don't know.
=cut
sub oneliner {
my($self, $cmd, $switches) = @_;
$switches = [] unless defined $switches;
# Strip leading and trailing newlines
$cmd =~ s{^\n+}{};
$cmd =~ s{\n+$}{};
$cmd = $self->quote_literal($cmd);
$cmd = $self->escape_newlines($cmd);
$switches = join ' ', @$switches;
return qq{\$(ABSPERLRUN) $switches -e $cmd --};
}
sub quote_literal {
my($self, $text, $opts) = @_;
$opts->{allow_variables} = 1 unless defined $opts->{allow_variables};
# See: http://www.autohotkey.net/~deleyd/parameters/parameters.htm#CPP
# Apply the Microsoft C/C++ parsing rules
$text =~ s{\\\\"}{\\\\\\\\\\"}g; # \\" -> \\\\\"
$text =~ s{(?<!\\)\\"}{\\\\\\"}g; # \" -> \\\"
$text =~ s{(?<!\\)"}{\\"}g; # " -> \"
$text = qq{"$text"} if $text =~ /[ \t]/;
# Apply the Command Prompt parsing rules (cmd.exe)
my @text = split /("[^"]*")/, $text;
# We should also escape parentheses, but it breaks one-liners containing
# $(MACRO)s in makefiles.
s{([<>|&^@!])}{^$1}g foreach grep { !/^"[^"]*"$/ } @text;
$text = join('', @text);
# dmake expands {{ to { and }} to }.
if( $self->is_make_type('dmake') ) {
$text =~ s/{/{{/g;
$text =~ s/}/}}/g;
}
$text = $opts->{allow_variables}
? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text);
return $text;
}
sub escape_newlines {
my($self, $text) = @_;
# Escape newlines
$text =~ s{\n}{\\\n}g;
return $text;
}
=item cd
dmake can handle Unix style cd'ing but nmake (at least 1.5) cannot. It
wants:
cd dir1\dir2
command
another_command
cd ..\..
=cut
sub cd {
my($self, $dir, @cmds) = @_;
return $self->SUPER::cd($dir, @cmds) unless $self->is_make_type('nmake');
my $cmd = join "\n\t", map "$_", @cmds;
my $updirs = $self->catdir(map { $self->updir } $self->splitdir($dir));
# No leading tab and no trailing newline makes for easier embedding.
my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd, $updirs;
cd %s
%s
cd %s
MAKE_FRAG
chomp $make_frag;
return $make_frag;
}
=item max_exec_len
nmake 1.50 limits command length to 2048 characters.
=cut
sub max_exec_len {
my $self = shift;
return $self->{_MAX_EXEC_LEN} ||= 2 * 1024;
}
=item os_flavor
Windows is Win32.
=cut
sub os_flavor {
return('Win32');
}
=item cflags
Defines the PERLDLL symbol if we are configured for static building since all
code destined for the perl5xx.dll must be compiled with the PERLDLL symbol
defined.
=cut
sub cflags {
my($self,$libperl)=@_;
return $self->{CFLAGS} if $self->{CFLAGS};
return '' unless $self->needs_linking();
my $base = $self->SUPER::cflags($libperl);
foreach (split /\n/, $base) {
/^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2;
};
$self->{CCFLAGS} .= " -DPERLDLL" if ($self->{LINKTYPE} eq 'static');
return $self->{CFLAGS} = qq{
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
PERLTYPE = $self->{PERLTYPE}
};
}
sub is_make_type {
my($self, $type) = @_;
return !! ($self->make =~ /\b$type(?:\.exe)?$/);
}
1;
__END__
=back
=cut
EXTUTILS_MM_WIN32
$fatpacked{"ExtUtils/MM_Win95.pm"} = <<'EXTUTILS_MM_WIN95';
package ExtUtils::MM_Win95;
use strict;
our $VERSION = '6.64';
require ExtUtils::MM_Win32;
our @ISA = qw(ExtUtils::MM_Win32);
use ExtUtils::MakeMaker::Config;
=head1 NAME
ExtUtils::MM_Win95 - method to customize MakeMaker for Win9X
=head1 SYNOPSIS
You should not be using this module directly.
=head1 DESCRIPTION
This is a subclass of ExtUtils::MM_Win32 containing changes necessary
to get MakeMaker playing nice with command.com and other Win9Xisms.
=head2 Overridden methods
Most of these make up for limitations in the Win9x/nmake command shell.
Mostly its lack of &&.
=over 4
=item xs_c
The && problem.
=cut
sub xs_c {
my($self) = shift;
return '' unless $self->needs_linking();
'
.xs.c:
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.c
'
}
=item xs_cpp
The && problem
=cut
sub xs_cpp {
my($self) = shift;
return '' unless $self->needs_linking();
'
.xs.cpp:
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.cpp
';
}
=item xs_o
The && problem.
=cut
sub xs_o {
my($self) = shift;
return '' unless $self->needs_linking();
'
.xs$(OBJ_EXT):
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.c
$(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
';
}
=item max_exec_len
Win98 chokes on things like Encode if we set the max length to nmake's max
of 2K. So we go for a more conservative value of 1K.
=cut
sub max_exec_len {
my $self = shift;
return $self->{_MAX_EXEC_LEN} ||= 1024;
}
=item os_flavor
Win95 and Win98 and WinME are collectively Win9x and Win32
=cut
sub os_flavor {
my $self = shift;
return ($self->SUPER::os_flavor, 'Win9x');
}
=back
=head1 AUTHOR
Code originally inside MM_Win32. Original author unknown.
Currently maintained by Michael G Schwern C<schwern@pobox.com>.
Send patches and ideas to C<makemaker@perl.org>.
See http://www.makemaker.org.
=cut
1;
EXTUTILS_MM_WIN95
$fatpacked{"ExtUtils/MY.pm"} = <<'EXTUTILS_MY';
package ExtUtils::MY;
use strict;
require ExtUtils::MM;
our $VERSION = '6.64';
our @ISA = qw(ExtUtils::MM);
{
package MY;
our @ISA = qw(ExtUtils::MY);
}
sub DESTROY {}
=head1 NAME
ExtUtils::MY - ExtUtils::MakeMaker subclass for customization
=head1 SYNOPSIS
# in your Makefile.PL
sub MY::whatever {
...
}
=head1 DESCRIPTION
B<FOR INTERNAL USE ONLY>
ExtUtils::MY is a subclass of ExtUtils::MM. Its provided in your
Makefile.PL for you to add and override MakeMaker functionality.
It also provides a convenient alias via the MY class.
ExtUtils::MY might turn out to be a temporary solution, but MY won't
go away.
=cut
EXTUTILS_MY
$fatpacked{"ExtUtils/MakeMaker.pm"} = <<'EXTUTILS_MAKEMAKER';
# $Id$
package ExtUtils::MakeMaker;
use strict;
BEGIN {require 5.006;}
require Exporter;
use ExtUtils::MakeMaker::Config;
use Carp;
use File::Path;
our $Verbose = 0; # exported
our @Parent; # needs to be localized
our @Get_from_Config; # referenced by MM_Unix
our @MM_Sections;
our @Overridable;
my @Prepend_parent;
my %Recognized_Att_Keys;
our $VERSION = '6.64';
$VERSION = eval $VERSION;
# Emulate something resembling CVS $Revision$
(our $Revision = $VERSION) =~ s{_}{};
$Revision = int $Revision * 10000;
our $Filename = __FILE__; # referenced outside MakeMaker
our @ISA = qw(Exporter);
our @EXPORT = qw(&WriteMakefile &writeMakefile $Verbose &prompt);
our @EXPORT_OK = qw($VERSION &neatvalue &mkbootstrap &mksymlists
&WriteEmptyMakefile);
# These will go away once the last of the Win32 & VMS specific code is
# purged.
my $Is_VMS = $^O eq 'VMS';
my $Is_Win32 = $^O eq 'MSWin32';
full_setup();
require ExtUtils::MM; # Things like CPAN assume loading ExtUtils::MakeMaker
# will give them MM.
require ExtUtils::MY; # XXX pre-5.8 versions of ExtUtils::Embed expect
# loading ExtUtils::MakeMaker will give them MY.
# This will go when Embed is its own CPAN module.
sub WriteMakefile {
croak "WriteMakefile: Need even number of args" if @_ % 2;
require ExtUtils::MY;
my %att = @_;
_convert_compat_attrs(\%att);
_verify_att(\%att);
my $mm = MM->new(\%att);
$mm->flush;
return $mm;
}
# Basic signatures of the attributes WriteMakefile takes. Each is the
# reference type. Empty value indicate it takes a non-reference
# scalar.
my %Att_Sigs;
my %Special_Sigs = (
AUTHOR => 'ARRAY',
C => 'ARRAY',
CONFIG => 'ARRAY',
CONFIGURE => 'CODE',
DIR => 'ARRAY',
DL_FUNCS => 'HASH',
DL_VARS => 'ARRAY',
EXCLUDE_EXT => 'ARRAY',
EXE_FILES => 'ARRAY',
FUNCLIST => 'ARRAY',
H => 'ARRAY',
IMPORTS => 'HASH',
INCLUDE_EXT => 'ARRAY',
LIBS => ['ARRAY',''],
MAN1PODS => 'HASH',
MAN3PODS => 'HASH',
META_ADD => 'HASH',
META_MERGE => 'HASH',
PL_FILES => 'HASH',
PM => 'HASH',
PMLIBDIRS => 'ARRAY',
PMLIBPARENTDIRS => 'ARRAY',
PREREQ_PM => 'HASH',
BUILD_REQUIRES => 'HASH',
CONFIGURE_REQUIRES => 'HASH',
TEST_REQUIRES => 'HASH',
SKIP => 'ARRAY',
TYPEMAPS => 'ARRAY',
XS => 'HASH',
VERSION => ['version',''],
_KEEP_AFTER_FLUSH => '',
clean => 'HASH',
depend => 'HASH',
dist => 'HASH',
dynamic_lib=> 'HASH',
linkext => 'HASH',
macro => 'HASH',
postamble => 'HASH',
realclean => 'HASH',
test => 'HASH',
tool_autosplit => 'HASH',
);
@Att_Sigs{keys %Recognized_Att_Keys} = ('') x keys %Recognized_Att_Keys;
@Att_Sigs{keys %Special_Sigs} = values %Special_Sigs;
sub _convert_compat_attrs { #result of running several times should be same
my($att) = @_;
if (exists $att->{AUTHOR}) {
if ($att->{AUTHOR}) {
if (!ref($att->{AUTHOR})) {
my $t = $att->{AUTHOR};
$att->{AUTHOR} = [$t];
}
} else {
$att->{AUTHOR} = [];
}
}
}
sub _verify_att {
my($att) = @_;
while( my($key, $val) = each %$att ) {
my $sig = $Att_Sigs{$key};
unless( defined $sig ) {
warn "WARNING: $key is not a known parameter.\n";
next;
}
my @sigs = ref $sig ? @$sig : $sig;
my $given = ref $val;
unless( grep { _is_of_type($val, $_) } @sigs ) {
my $takes = join " or ", map { _format_att($_) } @sigs;
my $has = _format_att($given);
warn "WARNING: $key takes a $takes not a $has.\n".
" Please inform the author.\n";
}
}
}
# Check if a given thing is a reference or instance of $type
sub _is_of_type {
my($thing, $type) = @_;
return 1 if ref $thing eq $type;
local $SIG{__DIE__};
return 1 if eval{ $thing->isa($type) };
return 0;
}
sub _format_att {
my $given = shift;
return $given eq '' ? "string/number"
: uc $given eq $given ? "$given reference"
: "$given object"
;
}
sub prompt ($;$) { ## no critic
my($mess, $def) = @_;
confess("prompt function called without an argument")
unless defined $mess;
my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ;
my $dispdef = defined $def ? "[$def] " : " ";
$def = defined $def ? $def : "";
local $|=1;
local $\;
print "$mess $dispdef";
my $ans;
if ($ENV{PERL_MM_USE_DEFAULT} || (!$isa_tty && eof STDIN)) {
print "$def\n";
}
else {
$ans = <STDIN>;
if( defined $ans ) {
chomp $ans;
}
else { # user hit ctrl-D
print "\n";
}
}
return (!defined $ans || $ans eq '') ? $def : $ans;
}
sub eval_in_subdirs {
my($self) = @_;
use Cwd qw(cwd abs_path);
my $pwd = cwd() || die "Can't figure out your cwd!";
local @INC = map eval {abs_path($_) if -e} || $_, @INC;
push @INC, '.'; # '.' has to always be at the end of @INC
foreach my $dir (@{$self->{DIR}}){
my($abs) = $self->catdir($pwd,$dir);
eval { $self->eval_in_x($abs); };
last if $@;
}
chdir $pwd;
die $@ if $@;
}
sub eval_in_x {
my($self,$dir) = @_;
chdir $dir or carp("Couldn't change to directory $dir: $!");
{
package main;
do './Makefile.PL';
};
if ($@) {
# if ($@ =~ /prerequisites/) {
# die "MakeMaker WARNING: $@";
# } else {
# warn "WARNING from evaluation of $dir/Makefile.PL: $@";
# }
die "ERROR from evaluation of $dir/Makefile.PL: $@";
}
}
# package name for the classes into which the first object will be blessed
my $PACKNAME = 'PACK000';
sub full_setup {
$Verbose ||= 0;
my @attrib_help = qw/
AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION
C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DISTVNAME
DL_FUNCS DL_VARS
EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE
FULLPERL FULLPERLRUN FULLPERLRUNINST
FUNCLIST H IMPORTS
INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB INST_MAN1DIR INST_MAN3DIR
INSTALLDIRS
DESTDIR PREFIX INSTALL_BASE
PERLPREFIX SITEPREFIX VENDORPREFIX
INSTALLPRIVLIB INSTALLSITELIB INSTALLVENDORLIB
INSTALLARCHLIB INSTALLSITEARCH INSTALLVENDORARCH
INSTALLBIN INSTALLSITEBIN INSTALLVENDORBIN
INSTALLMAN1DIR INSTALLMAN3DIR
INSTALLSITEMAN1DIR INSTALLSITEMAN3DIR
INSTALLVENDORMAN1DIR INSTALLVENDORMAN3DIR
INSTALLSCRIPT INSTALLSITESCRIPT INSTALLVENDORSCRIPT
PERL_LIB PERL_ARCHLIB
SITELIBEXP SITEARCHEXP
INC INCLUDE_EXT LDFROM LIB LIBPERL_A LIBS LICENSE
LINKTYPE MAKE MAKEAPERL MAKEFILE MAKEFILE_OLD MAN1PODS MAN3PODS MAP_TARGET
META_ADD META_MERGE MIN_PERL_VERSION BUILD_REQUIRES CONFIGURE_REQUIRES
MYEXTLIB NAME NEEDS_LINKING NOECHO NO_META NO_MYMETA
NORECURS NO_VC OBJECT OPTIMIZE PERL_MALLOC_OK PERL PERLMAINCC PERLRUN
PERLRUNINST PERL_CORE
PERL_SRC PERM_DIR PERM_RW PERM_RWX
PL_FILES PM PM_FILTER PMLIBDIRS PMLIBPARENTDIRS POLLUTE PPM_INSTALL_EXEC
PPM_INSTALL_SCRIPT PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ
SIGN SKIP TEST_REQUIRES TYPEMAPS VERSION VERSION_FROM XS XSOPT XSPROTOARG
XS_VERSION clean depend dist dynamic_lib linkext macro realclean
tool_autosplit
MACPERL_SRC MACPERL_LIB MACLIBS_68K MACLIBS_PPC MACLIBS_SC MACLIBS_MRC
MACLIBS_ALL_68K MACLIBS_ALL_PPC MACLIBS_SHARED
/;
# IMPORTS is used under OS/2 and Win32
# @Overridable is close to @MM_Sections but not identical. The
# order is important. Many subroutines declare macros. These
# depend on each other. Let's try to collect the macros up front,
# then pasthru, then the rules.
# MM_Sections are the sections we have to call explicitly
# in Overridable we have subroutines that are used indirectly
@MM_Sections =
qw(
post_initialize const_config constants platform_constants
tool_autosplit tool_xsubpp tools_other
makemakerdflt
dist macro depend cflags const_loadlibs const_cccmd
post_constants
pasthru
special_targets
c_o xs_c xs_o
top_targets blibdirs linkext dlsyms dynamic dynamic_bs
dynamic_lib static static_lib manifypods processPL
installbin subdirs
clean_subdirs clean realclean_subdirs realclean
metafile signature
dist_basics dist_core distdir dist_test dist_ci distmeta distsignature
install force perldepend makefile staticmake test ppd
); # loses section ordering
@Overridable = @MM_Sections;
push @Overridable, qw[
libscan makeaperl needs_linking
subdir_x test_via_harness test_via_script
init_VERSION init_dist init_INST init_INSTALL init_DEST init_dirscan
init_PM init_MANPODS init_xs init_PERL init_DIRFILESEP init_linker
];
push @MM_Sections, qw[
pm_to_blib selfdocument
];
# Postamble needs to be the last that was always the case
push @MM_Sections, "postamble";
push @Overridable, "postamble";
# All sections are valid keys.
@Recognized_Att_Keys{@MM_Sections} = (1) x @MM_Sections;
# we will use all these variables in the Makefile
@Get_from_Config =
qw(
ar cc cccdlflags ccdlflags dlext dlsrc exe_ext full_ar ld
lddlflags ldflags libc lib_ext obj_ext osname osvers ranlib
sitelibexp sitearchexp so
);
# 5.5.3 doesn't have any concept of vendor libs
push @Get_from_Config, qw( vendorarchexp vendorlibexp ) if $] >= 5.006;
foreach my $item (@attrib_help){
$Recognized_Att_Keys{$item} = 1;
}
foreach my $item (@Get_from_Config) {
$Recognized_Att_Keys{uc $item} = $Config{$item};
print "Attribute '\U$item\E' => '$Config{$item}'\n"
if ($Verbose >= 2);
}
#
# When we eval a Makefile.PL in a subdirectory, that one will ask
# us (the parent) for the values and will prepend "..", so that
# all files to be installed end up below OUR ./blib
#
@Prepend_parent = qw(
INST_BIN INST_LIB INST_ARCHLIB INST_SCRIPT
MAP_TARGET INST_MAN1DIR INST_MAN3DIR PERL_SRC
PERL FULLPERL
);
}
sub writeMakefile {
die <<END;
The extension you are trying to build apparently is rather old and
most probably outdated. We detect that from the fact, that a
subroutine "writeMakefile" is called, and this subroutine is not
supported anymore since about October 1994.
Please contact the author or look into CPAN (details about CPAN can be
found in the FAQ and at http:/www.perl.com) for a more recent version
of the extension. If you're really desperate, you can try to change
the subroutine name from writeMakefile to WriteMakefile and rerun
'perl Makefile.PL', but you're most probably left alone, when you do
so.
The MakeMaker team
END
}
sub new {
my($class,$self) = @_;
my($key);
_convert_compat_attrs($self) if defined $self && $self;
# Store the original args passed to WriteMakefile()
foreach my $k (keys %$self) {
$self->{ARGS}{$k} = $self->{$k};
}
$self = {} unless defined $self;
# Temporarily bless it into MM so it can be used as an
# object. It will be blessed into a temp package later.
bless $self, "MM";
# Cleanup all the module requirement bits
for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) {
$self->{$key} ||= {};
$self->clean_versions( $key );
}
if ("@ARGV" =~ /\bPREREQ_PRINT\b/) {
$self->_PREREQ_PRINT;
}
# PRINT_PREREQ is RedHatism.
if ("@ARGV" =~ /\bPRINT_PREREQ\b/) {
$self->_PRINT_PREREQ;
}
print "MakeMaker (v$VERSION)\n" if $Verbose;
if (-f "MANIFEST" && ! -f "Makefile" && ! $ENV{PERL_CORE}){
check_manifest();
}
check_hints($self);
# Translate X.Y.Z to X.00Y00Z
if( defined $self->{MIN_PERL_VERSION} ) {
$self->{MIN_PERL_VERSION} =~ s{ ^ (\d+) \. (\d+) \. (\d+) $ }
{sprintf "%d.%03d%03d", $1, $2, $3}ex;
}
my $perl_version_ok = eval {
local $SIG{__WARN__} = sub {
# simulate "use warnings FATAL => 'all'" for vintage perls
die @_;
};
!$self->{MIN_PERL_VERSION} or $self->{MIN_PERL_VERSION} <= $]
};
if (!$perl_version_ok) {
if (!defined $perl_version_ok) {
die <<'END';
Warning: MIN_PERL_VERSION is not in a recognized format.
Recommended is a quoted numerical value like '5.005' or '5.008001'.
END
}
elsif ($self->{PREREQ_FATAL}) {
die sprintf <<"END", $self->{MIN_PERL_VERSION}, $];
MakeMaker FATAL: perl version too low for this distribution.
Required is %s. We run %s.
END
}
else {
warn sprintf
"Warning: Perl version %s or higher required. We run %s.\n",
$self->{MIN_PERL_VERSION}, $];
}
}
my %configure_att; # record &{$self->{CONFIGURE}} attributes
my(%initial_att) = %$self; # record initial attributes
my(%unsatisfied) = ();
my $prereqs = $self->_all_prereqs;
foreach my $prereq (sort keys %$prereqs) {
my $required_version = $prereqs->{$prereq};
my $installed_file = MM->_installed_file_for_module($prereq);
my $pr_version = 0;
$pr_version = MM->parse_version($installed_file) if $installed_file;
$pr_version = 0 if $pr_version eq 'undef';
# convert X.Y_Z alpha version #s to X.YZ for easier comparisons
$pr_version =~ s/(\d+)\.(\d+)_(\d+)/$1.$2$3/;
if (!$installed_file) {
warn sprintf "Warning: prerequisite %s %s not found.\n",
$prereq, $required_version
unless $self->{PREREQ_FATAL}
or $ENV{PERL_CORE};
$unsatisfied{$prereq} = 'not installed';
}
elsif ($pr_version < $required_version ){
warn sprintf "Warning: prerequisite %s %s not found. We have %s.\n",
$prereq, $required_version, ($pr_version || 'unknown version')
unless $self->{PREREQ_FATAL}
or $ENV{PERL_CORE};
$unsatisfied{$prereq} = $required_version ? $required_version : 'unknown version' ;
}
}
if (%unsatisfied && $self->{PREREQ_FATAL}){
my $failedprereqs = join "\n", map {" $_ $unsatisfied{$_}"}
sort { $a cmp $b } keys %unsatisfied;
die <<"END";
MakeMaker FATAL: prerequisites not found.
$failedprereqs
Please install these modules first and rerun 'perl Makefile.PL'.
END
}
if (defined $self->{CONFIGURE}) {
if (ref $self->{CONFIGURE} eq 'CODE') {
%configure_att = %{&{$self->{CONFIGURE}}};
_convert_compat_attrs(\%configure_att);
$self = { %$self, %configure_att };
} else {
croak "Attribute 'CONFIGURE' to WriteMakefile() not a code reference\n";
}
}
# This is for old Makefiles written pre 5.00, will go away
if ( Carp::longmess("") =~ /runsubdirpl/s ){
carp("WARNING: Please rerun 'perl Makefile.PL' to regenerate your Makefiles\n");
}
my $newclass = ++$PACKNAME;
local @Parent = @Parent; # Protect against non-local exits
{
print "Blessing Object into class [$newclass]\n" if $Verbose>=2;
mv_all_methods("MY",$newclass);
bless $self, $newclass;
push @Parent, $self;
require ExtUtils::MY;
no strict 'refs'; ## no critic;
@{"$newclass\:\:ISA"} = 'MM';
}
if (defined $Parent[-2]){
$self->{PARENT} = $Parent[-2];
for my $key (@Prepend_parent) {
next unless defined $self->{PARENT}{$key};
# Don't stomp on WriteMakefile() args.
next if defined $self->{ARGS}{$key} and
$self->{ARGS}{$key} eq $self->{$key};
$self->{$key} = $self->{PARENT}{$key};
unless ($Is_VMS && $key =~ /PERL$/) {
$self->{$key} = $self->catdir("..",$self->{$key})
unless $self->file_name_is_absolute($self->{$key});
} else {
# PERL or FULLPERL will be a command verb or even a
# command with an argument instead of a full file
# specification under VMS. So, don't turn the command
# into a filespec, but do add a level to the path of
# the argument if not already absolute.
my @cmd = split /\s+/, $self->{$key};
$cmd[1] = $self->catfile('[-]',$cmd[1])
unless (@cmd < 2) || $self->file_name_is_absolute($cmd[1]);
$self->{$key} = join(' ', @cmd);
}
}
if ($self->{PARENT}) {
$self->{PARENT}->{CHILDREN}->{$newclass} = $self;
foreach my $opt (qw(POLLUTE PERL_CORE LINKTYPE)) {
if (exists $self->{PARENT}->{$opt}
and not exists $self->{$opt})
{
# inherit, but only if already unspecified
$self->{$opt} = $self->{PARENT}->{$opt};
}
}
}
my @fm = grep /^FIRST_MAKEFILE=/, @ARGV;
parse_args($self,@fm) if @fm;
} else {
parse_args($self,split(' ', $ENV{PERL_MM_OPT} || ''),@ARGV);
}
$self->{NAME} ||= $self->guess_name;
($self->{NAME_SYM} = $self->{NAME}) =~ s/\W+/_/g;
$self->init_MAKE;
$self->init_main;
$self->init_VERSION;
$self->init_dist;
$self->init_INST;
$self->init_INSTALL;
$self->init_DEST;
$self->init_dirscan;
$self->init_PM;
$self->init_MANPODS;
$self->init_xs;
$self->init_PERL;
$self->init_DIRFILESEP;
$self->init_linker;
$self->init_ABSTRACT;
$self->arch_check(
$INC{'Config.pm'},
$self->catfile($Config{'archlibexp'}, "Config.pm")
);
$self->init_tools();
$self->init_others();
$self->init_platform();
$self->init_PERM();
my($argv) = neatvalue(\@ARGV);
$argv =~ s/^\[/(/;
$argv =~ s/\]$/)/;
push @{$self->{RESULT}}, <<END;
# This Makefile is for the $self->{NAME} extension to perl.
#
# It was generated automatically by MakeMaker version
# $VERSION (Revision: $Revision) from the contents of
# Makefile.PL. Don't edit this file, edit Makefile.PL instead.
#
# ANY CHANGES MADE HERE WILL BE LOST!
#
# MakeMaker ARGV: $argv
#
END
push @{$self->{RESULT}}, $self->_MakeMaker_Parameters_section(\%initial_att);
if (defined $self->{CONFIGURE}) {
push @{$self->{RESULT}}, <<END;
# MakeMaker 'CONFIGURE' Parameters:
END
if (scalar(keys %configure_att) > 0) {
foreach my $key (sort keys %configure_att){
next if $key eq 'ARGS';
my($v) = neatvalue($configure_att{$key});
$v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/;
$v =~ tr/\n/ /s;
push @{$self->{RESULT}}, "# $key => $v";
}
}
else
{
push @{$self->{RESULT}}, "# no values returned";
}
undef %configure_att; # free memory
}
# turn the SKIP array into a SKIPHASH hash
for my $skip (@{$self->{SKIP} || []}) {
$self->{SKIPHASH}{$skip} = 1;
}
delete $self->{SKIP}; # free memory
if ($self->{PARENT}) {
for (qw/install dist dist_basics dist_core distdir dist_test dist_ci/) {
$self->{SKIPHASH}{$_} = 1;
}
}
# We run all the subdirectories now. They don't have much to query
# from the parent, but the parent has to query them: if they need linking!
unless ($self->{NORECURS}) {
$self->eval_in_subdirs if @{$self->{DIR}};
}
foreach my $section ( @MM_Sections ){
# Support for new foo_target() methods.
my $method = $section;
$method .= '_target' unless $self->can($method);
print "Processing Makefile '$section' section\n" if ($Verbose >= 2);
my($skipit) = $self->skipcheck($section);
if ($skipit){
push @{$self->{RESULT}}, "\n# --- MakeMaker $section section $skipit.";
} else {
my(%a) = %{$self->{$section} || {}};
push @{$self->{RESULT}}, "\n# --- MakeMaker $section section:";
push @{$self->{RESULT}}, "# " . join ", ", %a if $Verbose && %a;
push @{$self->{RESULT}}, $self->maketext_filter(
$self->$method( %a )
);
}
}
push @{$self->{RESULT}}, "\n# End.";
$self;
}
sub WriteEmptyMakefile {
croak "WriteEmptyMakefile: Need an even number of args" if @_ % 2;
my %att = @_;
my $self = MM->new(\%att);
my $new = $self->{MAKEFILE};
my $old = $self->{MAKEFILE_OLD};
if (-f $old) {
_unlink($old) or warn "unlink $old: $!";
}
if ( -f $new ) {
_rename($new, $old) or warn "rename $new => $old: $!"
}
open my $mfh, '>', $new or die "open $new for write: $!";
print $mfh <<'EOP';
all :
clean :
install :
makemakerdflt :
test :
EOP
close $mfh or die "close $new for write: $!";
}
=begin private
=head3 _installed_file_for_module
my $file = MM->_installed_file_for_module($module);
Return the first installed .pm $file associated with the $module. The
one which will show up when you C<use $module>.
$module is something like "strict" or "Test::More".
=end private
=cut
sub _installed_file_for_module {
my $class = shift;
my $prereq = shift;
my $file = "$prereq.pm";
$file =~ s{::}{/}g;
my $path;
for my $dir (@INC) {
my $tmp = File::Spec->catfile($dir, $file);
if ( -r $tmp ) {
$path = $tmp;
last;
}
}
return $path;
}
# Extracted from MakeMaker->new so we can test it
sub _MakeMaker_Parameters_section {
my $self = shift;
my $att = shift;
my @result = <<'END';
# MakeMaker Parameters:
END
foreach my $key (sort keys %$att){
next if $key eq 'ARGS';
my ($v) = neatvalue($att->{$key});
if ($key eq 'PREREQ_PM') {
# CPAN.pm takes prereqs from this field in 'Makefile'
# and does not know about BUILD_REQUIRES
$v = neatvalue({
%{ $att->{PREREQ_PM} || {} },
%{ $att->{BUILD_REQUIRES} || {} },
%{ $att->{TEST_REQUIRES} || {} },
});
} else {
$v = neatvalue($att->{$key});
}
$v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/;
$v =~ tr/\n/ /s;
push @result, "# $key => $v";
}
return @result;
}
sub check_manifest {
print "Checking if your kit is complete...\n";
require ExtUtils::Manifest;
# avoid warning
$ExtUtils::Manifest::Quiet = $ExtUtils::Manifest::Quiet = 1;
my(@missed) = ExtUtils::Manifest::manicheck();
if (@missed) {
print "Warning: the following files are missing in your kit:\n";
print "\t", join "\n\t", @missed;
print "\n";
print "Please inform the author.\n";
} else {
print "Looks good\n";
}
}
sub parse_args{
my($self, @args) = @_;
foreach (@args) {
unless (m/(.*?)=(.*)/) {
++$Verbose if m/^verb/;
next;
}
my($name, $value) = ($1, $2);
if ($value =~ m/^~(\w+)?/) { # tilde with optional username
$value =~ s [^~(\w*)]
[$1 ?
((getpwnam($1))[7] || "~$1") :
(getpwuid($>))[7]
]ex;
}
# Remember the original args passed it. It will be useful later.
$self->{ARGS}{uc $name} = $self->{uc $name} = $value;
}
# catch old-style 'potential_libs' and inform user how to 'upgrade'
if (defined $self->{potential_libs}){
my($msg)="'potential_libs' => '$self->{potential_libs}' should be";
if ($self->{potential_libs}){
print "$msg changed to:\n\t'LIBS' => ['$self->{potential_libs}']\n";
} else {
print "$msg deleted.\n";
}
$self->{LIBS} = [$self->{potential_libs}];
delete $self->{potential_libs};
}
# catch old-style 'ARMAYBE' and inform user how to 'upgrade'
if (defined $self->{ARMAYBE}){
my($armaybe) = $self->{ARMAYBE};
print "ARMAYBE => '$armaybe' should be changed to:\n",
"\t'dynamic_lib' => {ARMAYBE => '$armaybe'}\n";
my(%dl) = %{$self->{dynamic_lib} || {}};
$self->{dynamic_lib} = { %dl, ARMAYBE => $armaybe};
delete $self->{ARMAYBE};
}
if (defined $self->{LDTARGET}){
print "LDTARGET should be changed to LDFROM\n";
$self->{LDFROM} = $self->{LDTARGET};
delete $self->{LDTARGET};
}
# Turn a DIR argument on the command line into an array
if (defined $self->{DIR} && ref \$self->{DIR} eq 'SCALAR') {
# So they can choose from the command line, which extensions they want
# the grep enables them to have some colons too much in case they
# have to build a list with the shell
$self->{DIR} = [grep $_, split ":", $self->{DIR}];
}
# Turn a INCLUDE_EXT argument on the command line into an array
if (defined $self->{INCLUDE_EXT} && ref \$self->{INCLUDE_EXT} eq 'SCALAR') {
$self->{INCLUDE_EXT} = [grep $_, split '\s+', $self->{INCLUDE_EXT}];
}
# Turn a EXCLUDE_EXT argument on the command line into an array
if (defined $self->{EXCLUDE_EXT} && ref \$self->{EXCLUDE_EXT} eq 'SCALAR') {
$self->{EXCLUDE_EXT} = [grep $_, split '\s+', $self->{EXCLUDE_EXT}];
}
foreach my $mmkey (sort keys %$self){
next if $mmkey eq 'ARGS';
print " $mmkey => ", neatvalue($self->{$mmkey}), "\n" if $Verbose;
print "'$mmkey' is not a known MakeMaker parameter name.\n"
unless exists $Recognized_Att_Keys{$mmkey};
}
$| = 1 if $Verbose;
}
sub check_hints {
my($self) = @_;
# We allow extension-specific hints files.
require File::Spec;
my $curdir = File::Spec->curdir;
my $hint_dir = File::Spec->catdir($curdir, "hints");
return unless -d $hint_dir;
# First we look for the best hintsfile we have
my($hint)="${^O}_$Config{osvers}";
$hint =~ s/\./_/g;
$hint =~ s/_$//;
return unless $hint;
# Also try without trailing minor version numbers.
while (1) {
last if -f File::Spec->catfile($hint_dir, "$hint.pl"); # found
} continue {
last unless $hint =~ s/_[^_]*$//; # nothing to cut off
}
my $hint_file = File::Spec->catfile($hint_dir, "$hint.pl");
return unless -f $hint_file; # really there
_run_hintfile($self, $hint_file);
}
sub _run_hintfile {
our $self;
local($self) = shift; # make $self available to the hint file.
my($hint_file) = shift;
local($@, $!);
warn "Processing hints file $hint_file\n";
# Just in case the ./ isn't on the hint file, which File::Spec can
# often strip off, we bung the curdir into @INC
local @INC = (File::Spec->curdir, @INC);
my $ret = do $hint_file;
if( !defined $ret ) {
my $error = $@ || $!;
warn $error;
}
}
sub mv_all_methods {
my($from,$to) = @_;
# Here you see the *current* list of methods that are overridable
# from Makefile.PL via MY:: subroutines. As of VERSION 5.07 I'm
# still trying to reduce the list to some reasonable minimum --
# because I want to make it easier for the user. A.K.
local $SIG{__WARN__} = sub {
# can't use 'no warnings redefined', 5.6 only
warn @_ unless $_[0] =~ /^Subroutine .* redefined/
};
foreach my $method (@Overridable) {
# We cannot say "next" here. Nick might call MY->makeaperl
# which isn't defined right now
# Above statement was written at 4.23 time when Tk-b8 was
# around. As Tk-b9 only builds with 5.002something and MM 5 is
# standard, we try to enable the next line again. It was
# commented out until MM 5.23
next unless defined &{"${from}::$method"};
{
no strict 'refs'; ## no critic
*{"${to}::$method"} = \&{"${from}::$method"};
# If we delete a method, then it will be undefined and cannot
# be called. But as long as we have Makefile.PLs that rely on
# %MY:: being intact, we have to fill the hole with an
# inheriting method:
{
package MY;
my $super = "SUPER::".$method;
*{$method} = sub {
shift->$super(@_);
};
}
}
}
# We have to clean out %INC also, because the current directory is
# changed frequently and Graham Barr prefers to get his version
# out of a History.pl file which is "required" so woudn't get
# loaded again in another extension requiring a History.pl
# With perl5.002_01 the deletion of entries in %INC caused Tk-b11
# to core dump in the middle of a require statement. The required
# file was Tk/MMutil.pm. The consequence is, we have to be
# extremely careful when we try to give perl a reason to reload a
# library with same name. The workaround prefers to drop nothing
# from %INC and teach the writers not to use such libraries.
# my $inc;
# foreach $inc (keys %INC) {
# #warn "***$inc*** deleted";
# delete $INC{$inc};
# }
}
sub skipcheck {
my($self) = shift;
my($section) = @_;
if ($section eq 'dynamic') {
print "Warning (non-fatal): Target 'dynamic' depends on targets ",
"in skipped section 'dynamic_bs'\n"
if $self->{SKIPHASH}{dynamic_bs} && $Verbose;
print "Warning (non-fatal): Target 'dynamic' depends on targets ",
"in skipped section 'dynamic_lib'\n"
if $self->{SKIPHASH}{dynamic_lib} && $Verbose;
}
if ($section eq 'dynamic_lib') {
print "Warning (non-fatal): Target '\$(INST_DYNAMIC)' depends on ",
"targets in skipped section 'dynamic_bs'\n"
if $self->{SKIPHASH}{dynamic_bs} && $Verbose;
}
if ($section eq 'static') {
print "Warning (non-fatal): Target 'static' depends on targets ",
"in skipped section 'static_lib'\n"
if $self->{SKIPHASH}{static_lib} && $Verbose;
}
return 'skipped' if $self->{SKIPHASH}{$section};
return '';
}
sub flush {
my $self = shift;
my $finalname = $self->{MAKEFILE};
print "Writing $finalname for $self->{NAME}\n";
unlink($finalname, "MakeMaker.tmp", $Is_VMS ? 'Descrip.MMS' : ());
open(my $fh,">", "MakeMaker.tmp")
or die "Unable to open MakeMaker.tmp: $!";
for my $chunk (@{$self->{RESULT}}) {
print $fh "$chunk\n"
or die "Can't write to MakeMaker.tmp: $!";
}
close $fh
or die "Can't write to MakeMaker.tmp: $!";
_rename("MakeMaker.tmp", $finalname) or
warn "rename MakeMaker.tmp => $finalname: $!";
chmod 0644, $finalname unless $Is_VMS;
unless ($self->{NO_MYMETA}) {
# Write MYMETA.yml to communicate metadata up to the CPAN clients
if ( $self->write_mymeta( $self->mymeta ) ) {
print "Writing MYMETA.yml and MYMETA.json\n";
}
}
my %keep = map { ($_ => 1) } qw(NEEDS_LINKING HAS_LINK_CODE);
if ($self->{PARENT} && !$self->{_KEEP_AFTER_FLUSH}) {
foreach (keys %$self) { # safe memory
delete $self->{$_} unless $keep{$_};
}
}
system("$Config::Config{eunicefix} $finalname") unless $Config::Config{eunicefix} eq ":";
}
# This is a rename for OS's where the target must be unlinked first.
sub _rename {
my($src, $dest) = @_;
chmod 0666, $dest;
unlink $dest;
return rename $src, $dest;
}
# This is an unlink for OS's where the target must be writable first.
sub _unlink {
my @files = @_;
chmod 0666, @files;
return unlink @files;
}
# The following mkbootstrap() is only for installations that are calling
# the pre-4.1 mkbootstrap() from their old Makefiles. This MakeMaker
# writes Makefiles, that use ExtUtils::Mkbootstrap directly.
sub mkbootstrap {
die <<END;
!!! Your Makefile has been built such a long time ago, !!!
!!! that is unlikely to work with current MakeMaker. !!!
!!! Please rebuild your Makefile !!!
END
}
# Ditto for mksymlists() as of MakeMaker 5.17
sub mksymlists {
die <<END;
!!! Your Makefile has been built such a long time ago, !!!
!!! that is unlikely to work with current MakeMaker. !!!
!!! Please rebuild your Makefile !!!
END
}
sub neatvalue {
my($v) = @_;
return "undef" unless defined $v;
my($t) = ref $v;
return "q[$v]" unless $t;
if ($t eq 'ARRAY') {
my(@m, @neat);
push @m, "[";
foreach my $elem (@$v) {
push @neat, "q[$elem]";
}
push @m, join ", ", @neat;
push @m, "]";
return join "", @m;
}
return "$v" unless $t eq 'HASH';
my(@m, $key, $val);
while (($key,$val) = each %$v){
last unless defined $key; # cautious programming in case (undef,undef) is true
push(@m,"$key=>".neatvalue($val)) ;
}
return "{ ".join(', ',@m)." }";
}
# Look for weird version numbers, warn about them and set them to 0
# before CPAN::Meta chokes.
sub clean_versions {
my($self, $key) = @_;
my $reqs = $self->{$key};
for my $module (keys %$reqs) {
my $version = $reqs->{$module};
if( !defined $version or $version !~ /^[\d_\.]+$/ ) {
carp "Unparsable version '$version' for prerequisite $module";
$reqs->{$module} = 0;
}
}
}
sub selfdocument {
my($self) = @_;
my(@m);
if ($Verbose){
push @m, "\n# Full list of MakeMaker attribute values:";
foreach my $key (sort keys %$self){
next if $key eq 'RESULT' || $key =~ /^[A-Z][a-z]/;
my($v) = neatvalue($self->{$key});
$v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/;
$v =~ tr/\n/ /s;
push @m, "# $key => $v";
}
}
join "\n", @m;
}
1;
__END__
=head1 NAME
ExtUtils::MakeMaker - Create a module Makefile
=head1 SYNOPSIS
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => "Foo::Bar",
VERSION_FROM => "lib/Foo/Bar.pm",
);
=head1 DESCRIPTION
This utility is designed to write a Makefile for an extension module
from a Makefile.PL. It is based on the Makefile.SH model provided by
Andy Dougherty and the perl5-porters.
It splits the task of generating the Makefile into several subroutines
that can be individually overridden. Each subroutine returns the text
it wishes to have written to the Makefile.
As there are various Make programs with incompatible syntax, which
use operating system shells, again with incompatible syntax, it is
important for users of this module to know which flavour of Make
a Makefile has been written for so they'll use the correct one and
won't have to face the possibly bewildering errors resulting from
using the wrong one.
On POSIX systems, that program will likely be GNU Make; on Microsoft
Windows, it will be either Microsoft NMake or DMake. Note that this
module does not support generating Makefiles for GNU Make on Windows.
See the section on the L</"MAKE"> parameter for details.
MakeMaker is object oriented. Each directory below the current
directory that contains a Makefile.PL is treated as a separate
object. This makes it possible to write an unlimited number of
Makefiles with a single invocation of WriteMakefile().
=head2 How To Write A Makefile.PL
See ExtUtils::MakeMaker::Tutorial.
The long answer is the rest of the manpage :-)
=head2 Default Makefile Behaviour
The generated Makefile enables the user of the extension to invoke
perl Makefile.PL # optionally "perl Makefile.PL verbose"
make
make test # optionally set TEST_VERBOSE=1
make install # See below
The Makefile to be produced may be altered by adding arguments of the
form C<KEY=VALUE>. E.g.
perl Makefile.PL INSTALL_BASE=~
Other interesting targets in the generated Makefile are
make config # to check if the Makefile is up-to-date
make clean # delete local temp files (Makefile gets renamed)
make realclean # delete derived files (including ./blib)
make ci # check in all the files in the MANIFEST file
make dist # see below the Distribution Support section
=head2 make test
MakeMaker checks for the existence of a file named F<test.pl> in the
current directory and if it exists it execute the script with the
proper set of perl C<-I> options.
MakeMaker also checks for any files matching glob("t/*.t"). It will
execute all matching files in alphabetical order via the
L<Test::Harness> module with the C<-I> switches set correctly.
If you'd like to see the raw output of your tests, set the
C<TEST_VERBOSE> variable to true.
make test TEST_VERBOSE=1
=head2 make testdb
A useful variation of the above is the target C<testdb>. It runs the
test under the Perl debugger (see L<perldebug>). If the file
F<test.pl> exists in the current directory, it is used for the test.
If you want to debug some other testfile, set the C<TEST_FILE> variable
thusly:
make testdb TEST_FILE=t/mytest.t
By default the debugger is called using C<-d> option to perl. If you
want to specify some other option, set the C<TESTDB_SW> variable:
make testdb TESTDB_SW=-Dx
=head2 make install
make alone puts all relevant files into directories that are named by
the macros INST_LIB, INST_ARCHLIB, INST_SCRIPT, INST_MAN1DIR and
INST_MAN3DIR. All these default to something below ./blib if you are
I<not> building below the perl source directory. If you I<are>
building below the perl source, INST_LIB and INST_ARCHLIB default to
../../lib, and INST_SCRIPT is not defined.
The I<install> target of the generated Makefile copies the files found
below each of the INST_* directories to their INSTALL*
counterparts. Which counterparts are chosen depends on the setting of
INSTALLDIRS according to the following table:
INSTALLDIRS set to
perl site vendor
PERLPREFIX SITEPREFIX VENDORPREFIX
INST_ARCHLIB INSTALLARCHLIB INSTALLSITEARCH INSTALLVENDORARCH
INST_LIB INSTALLPRIVLIB INSTALLSITELIB INSTALLVENDORLIB
INST_BIN INSTALLBIN INSTALLSITEBIN INSTALLVENDORBIN
INST_SCRIPT INSTALLSCRIPT INSTALLSITESCRIPT INSTALLVENDORSCRIPT
INST_MAN1DIR INSTALLMAN1DIR INSTALLSITEMAN1DIR INSTALLVENDORMAN1DIR
INST_MAN3DIR INSTALLMAN3DIR INSTALLSITEMAN3DIR INSTALLVENDORMAN3DIR
The INSTALL... macros in turn default to their %Config
($Config{installprivlib}, $Config{installarchlib}, etc.) counterparts.
You can check the values of these variables on your system with
perl '-V:install.*'
And to check the sequence in which the library directories are
searched by perl, run
perl -le 'print join $/, @INC'
Sometimes older versions of the module you're installing live in other
directories in @INC. Because Perl loads the first version of a module it
finds, not the newest, you might accidentally get one of these older
versions even after installing a brand new version. To delete I<all other
versions of the module you're installing> (not simply older ones) set the
C<UNINST> variable.
make install UNINST=1
=head2 INSTALL_BASE
INSTALL_BASE can be passed into Makefile.PL to change where your
module will be installed. INSTALL_BASE is more like what everyone
else calls "prefix" than PREFIX is.
To have everything installed in your home directory, do the following.
# Unix users, INSTALL_BASE=~ works fine
perl Makefile.PL INSTALL_BASE=/path/to/your/home/dir
Like PREFIX, it sets several INSTALL* attributes at once. Unlike
PREFIX it is easy to predict where the module will end up. The
installation pattern looks like this:
INSTALLARCHLIB INSTALL_BASE/lib/perl5/$Config{archname}
INSTALLPRIVLIB INSTALL_BASE/lib/perl5
INSTALLBIN INSTALL_BASE/bin
INSTALLSCRIPT INSTALL_BASE/bin
INSTALLMAN1DIR INSTALL_BASE/man/man1
INSTALLMAN3DIR INSTALL_BASE/man/man3
INSTALL_BASE in MakeMaker and C<--install_base> in Module::Build (as
of 0.28) install to the same location. If you want MakeMaker and
Module::Build to install to the same location simply set INSTALL_BASE
and C<--install_base> to the same location.
INSTALL_BASE was added in 6.31.
=head2 PREFIX and LIB attribute
PREFIX and LIB can be used to set several INSTALL* attributes in one
go. Here's an example for installing into your home directory.
# Unix users, PREFIX=~ works fine
perl Makefile.PL PREFIX=/path/to/your/home/dir
This will install all files in the module under your home directory,
with man pages and libraries going into an appropriate place (usually
~/man and ~/lib). How the exact location is determined is complicated
and depends on how your Perl was configured. INSTALL_BASE works more
like what other build systems call "prefix" than PREFIX and we
recommend you use that instead.
Another way to specify many INSTALL directories with a single
parameter is LIB.
perl Makefile.PL LIB=~/lib
This will install the module's architecture-independent files into
~/lib, the architecture-dependent files into ~/lib/$archname.
Note, that in both cases the tilde expansion is done by MakeMaker, not
by perl by default, nor by make.
Conflicts between parameters LIB, PREFIX and the various INSTALL*
arguments are resolved so that:
=over 4
=item *
setting LIB overrides any setting of INSTALLPRIVLIB, INSTALLARCHLIB,
INSTALLSITELIB, INSTALLSITEARCH (and they are not affected by PREFIX);
=item *
without LIB, setting PREFIX replaces the initial C<$Config{prefix}>
part of those INSTALL* arguments, even if the latter are explicitly
set (but are set to still start with C<$Config{prefix}>).
=back
If the user has superuser privileges, and is not working on AFS or
relatives, then the defaults for INSTALLPRIVLIB, INSTALLARCHLIB,
INSTALLSCRIPT, etc. will be appropriate, and this incantation will be
the best:
perl Makefile.PL;
make;
make test
make install
make install per default writes some documentation of what has been
done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This feature
can be bypassed by calling make pure_install.
=head2 AFS users
will have to specify the installation directories as these most
probably have changed since perl itself has been installed. They will
have to do this by calling
perl Makefile.PL INSTALLSITELIB=/afs/here/today \
INSTALLSCRIPT=/afs/there/now INSTALLMAN3DIR=/afs/for/manpages
make
Be careful to repeat this procedure every time you recompile an
extension, unless you are sure the AFS installation directories are
still valid.
=head2 Static Linking of a new Perl Binary
An extension that is built with the above steps is ready to use on
systems supporting dynamic loading. On systems that do not support
dynamic loading, any newly created extension has to be linked together
with the available resources. MakeMaker supports the linking process
by creating appropriate targets in the Makefile whenever an extension
is built. You can invoke the corresponding section of the makefile with
make perl
That produces a new perl binary in the current directory with all
extensions linked in that can be found in INST_ARCHLIB, SITELIBEXP,
and PERL_ARCHLIB. To do that, MakeMaker writes a new Makefile, on
UNIX, this is called Makefile.aperl (may be system dependent). If you
want to force the creation of a new perl, it is recommended, that you
delete this Makefile.aperl, so the directories are searched-through
for linkable libraries again.
The binary can be installed into the directory where perl normally
resides on your machine with
make inst_perl
To produce a perl binary with a different name than C<perl>, either say
perl Makefile.PL MAP_TARGET=myperl
make myperl
make inst_perl
or say
perl Makefile.PL
make myperl MAP_TARGET=myperl
make inst_perl MAP_TARGET=myperl
In any case you will be prompted with the correct invocation of the
C<inst_perl> target that installs the new binary into INSTALLBIN.
make inst_perl per default writes some documentation of what has been
done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This
can be bypassed by calling make pure_inst_perl.
Warning: the inst_perl: target will most probably overwrite your
existing perl binary. Use with care!
Sometimes you might want to build a statically linked perl although
your system supports dynamic loading. In this case you may explicitly
set the linktype with the invocation of the Makefile.PL or make:
perl Makefile.PL LINKTYPE=static # recommended
or
make LINKTYPE=static # works on most systems
=head2 Determination of Perl Library and Installation Locations
MakeMaker needs to know, or to guess, where certain things are
located. Especially INST_LIB and INST_ARCHLIB (where to put the files
during the make(1) run), PERL_LIB and PERL_ARCHLIB (where to read
existing modules from), and PERL_INC (header files and C<libperl*.*>).
Extensions may be built either using the contents of the perl source
directory tree or from the installed perl library. The recommended way
is to build extensions after you have run 'make install' on perl
itself. You can do that in any directory on your hard disk that is not
below the perl source tree. The support for extensions below the ext
directory of the perl distribution is only good for the standard
extensions that come with perl.
If an extension is being built below the C<ext/> directory of the perl
source then MakeMaker will set PERL_SRC automatically (e.g.,
C<../..>). If PERL_SRC is defined and the extension is recognized as
a standard extension, then other variables default to the following:
PERL_INC = PERL_SRC
PERL_LIB = PERL_SRC/lib
PERL_ARCHLIB = PERL_SRC/lib
INST_LIB = PERL_LIB
INST_ARCHLIB = PERL_ARCHLIB
If an extension is being built away from the perl source then MakeMaker
will leave PERL_SRC undefined and default to using the installed copy
of the perl library. The other variables default to the following:
PERL_INC = $archlibexp/CORE
PERL_LIB = $privlibexp
PERL_ARCHLIB = $archlibexp
INST_LIB = ./blib/lib
INST_ARCHLIB = ./blib/arch
If perl has not yet been installed then PERL_SRC can be defined on the
command line as shown in the previous section.
=head2 Which architecture dependent directory?
If you don't want to keep the defaults for the INSTALL* macros,
MakeMaker helps you to minimize the typing needed: the usual
relationship between INSTALLPRIVLIB and INSTALLARCHLIB is determined
by Configure at perl compilation time. MakeMaker supports the user who
sets INSTALLPRIVLIB. If INSTALLPRIVLIB is set, but INSTALLARCHLIB not,
then MakeMaker defaults the latter to be the same subdirectory of
INSTALLPRIVLIB as Configure decided for the counterparts in %Config ,
otherwise it defaults to INSTALLPRIVLIB. The same relationship holds
for INSTALLSITELIB and INSTALLSITEARCH.
MakeMaker gives you much more freedom than needed to configure
internal variables and get different results. It is worth to mention,
that make(1) also lets you configure most of the variables that are
used in the Makefile. But in the majority of situations this will not
be necessary, and should only be done if the author of a package
recommends it (or you know what you're doing).
=head2 Using Attributes and Parameters
The following attributes may be specified as arguments to WriteMakefile()
or as NAME=VALUE pairs on the command line.
=over 2
=item ABSTRACT
One line description of the module. Will be included in PPD file.
=item ABSTRACT_FROM
Name of the file that contains the package description. MakeMaker looks
for a line in the POD matching /^($package\s-\s)(.*)/. This is typically
the first line in the "=head1 NAME" section. $2 becomes the abstract.
=item AUTHOR
Array of strings containing name (and email address) of package author(s).
Is used in CPAN Meta files (META.yml or META.json) and PPD
(Perl Package Description) files for PPM (Perl Package Manager).
=item BINARY_LOCATION
Used when creating PPD files for binary packages. It can be set to a
full or relative path or URL to the binary archive for a particular
architecture. For example:
perl Makefile.PL BINARY_LOCATION=x86/Agent.tar.gz
builds a PPD package that references a binary of the C<Agent> package,
located in the C<x86> directory relative to the PPD itself.
=item BUILD_REQUIRES
A hash of modules that are needed to build your module but not run it.
This will go into the C<build_requires> field of your CPAN Meta file.
(F<META.yml> or F<META.json>).
The format is the same as PREREQ_PM.
=item C
Ref to array of *.c file names. Initialised from a directory scan
and the values portion of the XS attribute hash. This is not
currently used by MakeMaker but may be handy in Makefile.PLs.
=item CCFLAGS
String that will be included in the compiler call command line between
the arguments INC and OPTIMIZE.
=item CONFIG
Arrayref. E.g. [qw(archname manext)] defines ARCHNAME & MANEXT from
config.sh. MakeMaker will add to CONFIG the following values anyway:
ar
cc
cccdlflags
ccdlflags
dlext
dlsrc
ld
lddlflags
ldflags
libc
lib_ext
obj_ext
ranlib
sitelibexp
sitearchexp
so
=item CONFIGURE
CODE reference. The subroutine should return a hash reference. The
hash may contain further attributes, e.g. {LIBS =E<gt> ...}, that have to
be determined by some evaluation method.
=item CONFIGURE_REQUIRES
A hash of modules that are required to run Makefile.PL itself, but not
to run your distribution.
This will go into the C<configure_requires> field of your CPAN Meta file
(F<META.yml> or F<META.json>)
Defaults to C<<< { "ExtUtils::MakeMaker" => 0 } >>>
The format is the same as PREREQ_PM.
=item DEFINE
Something like C<"-DHAVE_UNISTD_H">
=item DESTDIR
This is the root directory into which the code will be installed. It
I<prepends itself to the normal prefix>. For example, if your code
would normally go into F</usr/local/lib/perl> you could set DESTDIR=~/tmp/
and installation would go into F<~/tmp/usr/local/lib/perl>.
This is primarily of use for people who repackage Perl modules.
NOTE: Due to the nature of make, it is important that you put the trailing
slash on your DESTDIR. F<~/tmp/> not F<~/tmp>.
=item DIR
Ref to array of subdirectories containing Makefile.PLs e.g. ['sdbm']
in ext/SDBM_File
=item DISTNAME
A safe filename for the package.
Defaults to NAME above but with :: replaced with -.
For example, Foo::Bar becomes Foo-Bar.
=item DISTVNAME
Your name for distributing the package with the version number
included. This is used by 'make dist' to name the resulting archive
file.
Defaults to DISTNAME-VERSION.
For example, version 1.04 of Foo::Bar becomes Foo-Bar-1.04.
On some OS's where . has special meaning VERSION_SYM may be used in
place of VERSION.
=item DL_FUNCS
Hashref of symbol names for routines to be made available as universal
symbols. Each key/value pair consists of the package name and an
array of routine names in that package. Used only under AIX, OS/2,
VMS and Win32 at present. The routine names supplied will be expanded
in the same way as XSUB names are expanded by the XS() macro.
Defaults to
{"$(NAME)" => ["boot_$(NAME)" ] }
e.g.
{"RPC" => [qw( boot_rpcb rpcb_gettime getnetconfigent )],
"NetconfigPtr" => [ 'DESTROY'] }
Please see the L<ExtUtils::Mksymlists> documentation for more information
about the DL_FUNCS, DL_VARS and FUNCLIST attributes.
=item DL_VARS
Array of symbol names for variables to be made available as universal symbols.
Used only under AIX, OS/2, VMS and Win32 at present. Defaults to [].
(e.g. [ qw(Foo_version Foo_numstreams Foo_tree ) ])
=item EXCLUDE_EXT
Array of extension names to exclude when doing a static build. This
is ignored if INCLUDE_EXT is present. Consult INCLUDE_EXT for more
details. (e.g. [ qw( Socket POSIX ) ] )
This attribute may be most useful when specified as a string on the
command line: perl Makefile.PL EXCLUDE_EXT='Socket Safe'
=item EXE_FILES
Ref to array of executable files. The files will be copied to the
INST_SCRIPT directory. Make realclean will delete them from there
again.
If your executables start with something like #!perl or
#!/usr/bin/perl MakeMaker will change this to the path of the perl
'Makefile.PL' was invoked with so the programs will be sure to run
properly even if perl is not in /usr/bin/perl.
=item FIRST_MAKEFILE
The name of the Makefile to be produced. This is used for the second
Makefile that will be produced for the MAP_TARGET.
Defaults to 'Makefile' or 'Descrip.MMS' on VMS.
(Note: we couldn't use MAKEFILE because dmake uses this for something
else).
=item FULLPERL
Perl binary able to run this extension, load XS modules, etc...
=item FULLPERLRUN
Like PERLRUN, except it uses FULLPERL.
=item FULLPERLRUNINST
Like PERLRUNINST, except it uses FULLPERL.
=item FUNCLIST
This provides an alternate means to specify function names to be
exported from the extension. Its value is a reference to an
array of function names to be exported by the extension. These
names are passed through unaltered to the linker options file.
=item H
Ref to array of *.h file names. Similar to C.
=item IMPORTS
This attribute is used to specify names to be imported into the
extension. Takes a hash ref.
It is only used on OS/2 and Win32.
=item INC
Include file dirs eg: C<"-I/usr/5include -I/path/to/inc">
=item INCLUDE_EXT
Array of extension names to be included when doing a static build.
MakeMaker will normally build with all of the installed extensions when
doing a static build, and that is usually the desired behavior. If
INCLUDE_EXT is present then MakeMaker will build only with those extensions
which are explicitly mentioned. (e.g. [ qw( Socket POSIX ) ])
It is not necessary to mention DynaLoader or the current extension when
filling in INCLUDE_EXT. If the INCLUDE_EXT is mentioned but is empty then
only DynaLoader and the current extension will be included in the build.
This attribute may be most useful when specified as a string on the
command line: perl Makefile.PL INCLUDE_EXT='POSIX Socket Devel::Peek'
=item INSTALLARCHLIB
Used by 'make install', which copies files from INST_ARCHLIB to this
directory if INSTALLDIRS is set to perl.
=item INSTALLBIN
Directory to install binary files (e.g. tkperl) into if
INSTALLDIRS=perl.
=item INSTALLDIRS
Determines which of the sets of installation directories to choose:
perl, site or vendor. Defaults to site.
=item INSTALLMAN1DIR
=item INSTALLMAN3DIR
These directories get the man pages at 'make install' time if
INSTALLDIRS=perl. Defaults to $Config{installman*dir}.
If set to 'none', no man pages will be installed.
=item INSTALLPRIVLIB
Used by 'make install', which copies files from INST_LIB to this
directory if INSTALLDIRS is set to perl.
Defaults to $Config{installprivlib}.
=item INSTALLSCRIPT
Used by 'make install' which copies files from INST_SCRIPT to this
directory if INSTALLDIRS=perl.
=item INSTALLSITEARCH
Used by 'make install', which copies files from INST_ARCHLIB to this
directory if INSTALLDIRS is set to site (default).
=item INSTALLSITEBIN
Used by 'make install', which copies files from INST_BIN to this
directory if INSTALLDIRS is set to site (default).
=item INSTALLSITELIB
Used by 'make install', which copies files from INST_LIB to this
directory if INSTALLDIRS is set to site (default).
=item INSTALLSITEMAN1DIR
=item INSTALLSITEMAN3DIR
These directories get the man pages at 'make install' time if
INSTALLDIRS=site (default). Defaults to
$(SITEPREFIX)/man/man$(MAN*EXT).
If set to 'none', no man pages will be installed.
=item INSTALLSITESCRIPT
Used by 'make install' which copies files from INST_SCRIPT to this
directory if INSTALLDIRS is set to site (default).
=item INSTALLVENDORARCH
Used by 'make install', which copies files from INST_ARCHLIB to this
directory if INSTALLDIRS is set to vendor.
=item INSTALLVENDORBIN
Used by 'make install', which copies files from INST_BIN to this
directory if INSTALLDIRS is set to vendor.
=item INSTALLVENDORLIB
Used by 'make install', which copies files from INST_LIB to this
directory if INSTALLDIRS is set to vendor.
=item INSTALLVENDORMAN1DIR
=item INSTALLVENDORMAN3DIR
These directories get the man pages at 'make install' time if
INSTALLDIRS=vendor. Defaults to $(VENDORPREFIX)/man/man$(MAN*EXT).
If set to 'none', no man pages will be installed.
=item INSTALLVENDORSCRIPT
Used by 'make install' which copies files from INST_SCRIPT to this
directory if INSTALLDIRS is set to vendor.
=item INST_ARCHLIB
Same as INST_LIB for architecture dependent files.
=item INST_BIN
Directory to put real binary files during 'make'. These will be copied
to INSTALLBIN during 'make install'
=item INST_LIB
Directory where we put library files of this extension while building
it.
=item INST_MAN1DIR
Directory to hold the man pages at 'make' time
=item INST_MAN3DIR
Directory to hold the man pages at 'make' time
=item INST_SCRIPT
Directory, where executable files should be installed during
'make'. Defaults to "./blib/script", just to have a dummy location during
testing. make install will copy the files in INST_SCRIPT to
INSTALLSCRIPT.
=item LD
Program to be used to link libraries for dynamic loading.
Defaults to $Config{ld}.
=item LDDLFLAGS
Any special flags that might need to be passed to ld to create a
shared library suitable for dynamic loading. It is up to the makefile
to use it. (See L<Config/lddlflags>)
Defaults to $Config{lddlflags}.
=item LDFROM
Defaults to "$(OBJECT)" and is used in the ld command to specify
what files to link/load from (also see dynamic_lib below for how to
specify ld flags)
=item LIB
LIB should only be set at C<perl Makefile.PL> time but is allowed as a
MakeMaker argument. It has the effect of setting both INSTALLPRIVLIB
and INSTALLSITELIB to that value regardless any explicit setting of
those arguments (or of PREFIX). INSTALLARCHLIB and INSTALLSITEARCH
are set to the corresponding architecture subdirectory.
=item LIBPERL_A
The filename of the perllibrary that will be used together with this
extension. Defaults to libperl.a.
=item LIBS
An anonymous array of alternative library
specifications to be searched for (in order) until
at least one library is found. E.g.
'LIBS' => ["-lgdbm", "-ldbm -lfoo", "-L/path -ldbm.nfs"]
Mind, that any element of the array
contains a complete set of arguments for the ld
command. So do not specify
'LIBS' => ["-ltcl", "-ltk", "-lX11"]
See ODBM_File/Makefile.PL for an example, where an array is needed. If
you specify a scalar as in
'LIBS' => "-ltcl -ltk -lX11"
MakeMaker will turn it into an array with one element.
=item LICENSE
The licensing terms of your distribution. Generally its "perl" for the
same license as Perl itself.
See L<Module::Build::API> for the list of options.
Defaults to "unknown".
=item LINKTYPE
'static' or 'dynamic' (default unless usedl=undef in
config.sh). Should only be used to force static linking (also see
linkext below).
=item MAKE
Variant of make you intend to run the generated Makefile with. This
parameter lets Makefile.PL know what make quirks to account for when
generating the Makefile.
MakeMaker also honors the MAKE environment variable. This parameter
takes precedent.
Currently the only significant values are 'dmake' and 'nmake' for Windows
users, instructing MakeMaker to generate a Makefile in the flavour of
DMake ("Dennis Vadura's Make") or Microsoft NMake respectively.
Defaults to $Config{make}, which may go looking for a Make program
in your environment.
How are you supposed to know what flavour of Make a Makefile has
been generated for if you didn't specify a value explicitly? Search
the generated Makefile for the definition of the MAKE variable,
which is used to recursively invoke the Make utility. That will tell
you what Make you're supposed to invoke the Makefile with.
=item MAKEAPERL
Boolean which tells MakeMaker, that it should include the rules to
make a perl. This is handled automatically as a switch by
MakeMaker. The user normally does not need it.
=item MAKEFILE_OLD
When 'make clean' or similar is run, the $(FIRST_MAKEFILE) will be
backed up at this location.
Defaults to $(FIRST_MAKEFILE).old or $(FIRST_MAKEFILE)_old on VMS.
=item MAN1PODS
Hashref of pod-containing files. MakeMaker will default this to all
EXE_FILES files that include POD directives. The files listed
here will be converted to man pages and installed as was requested
at Configure time.
This hash should map POD files (or scripts containing POD) to the
man file names under the C<blib/man1/> directory, as in the following
example:
MAN1PODS => {
'doc/command.pod' => 'blib/man1/command.1',
'scripts/script.pl' => 'blib/man1/script.1',
}
=item MAN3PODS
Hashref that assigns to *.pm and *.pod files the files into which the
manpages are to be written. MakeMaker parses all *.pod and *.pm files
for POD directives. Files that contain POD will be the default keys of
the MAN3PODS hashref. These will then be converted to man pages during
C<make> and will be installed during C<make install>.
Example similar to MAN1PODS.
=item MAP_TARGET
If it is intended, that a new perl binary be produced, this variable
may hold a name for that binary. Defaults to perl
=item META_ADD
=item META_MERGE
A hashrefs of items to add to the CPAN Meta file (F<META.yml> or
F<META.json>).
They differ in how they behave if they have the same key as the
default metadata. META_ADD will override the default value with its
own. META_MERGE will merge its value with the default.
Unless you want to override the defaults, prefer META_MERGE so as to
get the advantage of any future defaults.
=item MIN_PERL_VERSION
The minimum required version of Perl for this distribution.
Either 5.006001 or 5.6.1 format is acceptable.
=item MYEXTLIB
If the extension links to a library that it builds set this to the
name of the library (see SDBM_File)
=item NAME
The package representing the distribution. For example, C<Test::More>
or C<ExtUtils::MakeMaker>. It will be used to derive information about
the distribution such as the L<DISTNAME>, installation locations
within the Perl library and where XS files will be looked for by
default (see L<XS>).
C<NAME> I<must> be a valid Perl package name and it I<must> have an
associated C<.pm> file. For example, C<Foo::Bar> is a valid C<NAME>
and there must exist F<Foo/Bar.pm>. Any XS code should be in
F<Bar.xs> unless stated otherwise.
Your distribution B<must> have a C<NAME>.
=item NEEDS_LINKING
MakeMaker will figure out if an extension contains linkable code
anywhere down the directory tree, and will set this variable
accordingly, but you can speed it up a very little bit if you define
this boolean variable yourself.
=item NOECHO
Command so make does not print the literal commands its running.
By setting it to an empty string you can generate a Makefile that
prints all commands. Mainly used in debugging MakeMaker itself.
Defaults to C<@>.
=item NORECURS
Boolean. Attribute to inhibit descending into subdirectories.
=item NO_META
When true, suppresses the generation and addition to the MANIFEST of
the META.yml and META.json module meta-data files during 'make distdir'.
Defaults to false.
=item NO_MYMETA
When true, suppresses the generation of MYMETA.yml and MYMETA.json module
meta-data files during 'perl Makefile.PL'.
Defaults to false.
=item NO_VC
In general, any generated Makefile checks for the current version of
MakeMaker and the version the Makefile was built under. If NO_VC is
set, the version check is neglected. Do not write this into your
Makefile.PL, use it interactively instead.
=item OBJECT
List of object files, defaults to '$(BASEEXT)$(OBJ_EXT)', but can be a long
string containing all object files, e.g. "tkpBind.o
tkpButton.o tkpCanvas.o"
(Where BASEEXT is the last component of NAME, and OBJ_EXT is $Config{obj_ext}.)
=item OPTIMIZE
Defaults to C<-O>. Set it to C<-g> to turn debugging on. The flag is
passed to subdirectory makes.
=item PERL
Perl binary for tasks that can be done by miniperl
=item PERL_CORE
Set only when MakeMaker is building the extensions of the Perl core
distribution.
=item PERLMAINCC
The call to the program that is able to compile perlmain.c. Defaults
to $(CC).
=item PERL_ARCHLIB
Same as for PERL_LIB, but for architecture dependent files.
Used only when MakeMaker is building the extensions of the Perl core
distribution (because normally $(PERL_ARCHLIB) is automatically in @INC,
and adding it would get in the way of PERL5LIB).
=item PERL_LIB
Directory containing the Perl library to use.
Used only when MakeMaker is building the extensions of the Perl core
distribution (because normally $(PERL_LIB) is automatically in @INC,
and adding it would get in the way of PERL5LIB).
=item PERL_MALLOC_OK
defaults to 0. Should be set to TRUE if the extension can work with
the memory allocation routines substituted by the Perl malloc() subsystem.
This should be applicable to most extensions with exceptions of those
=over 4
=item *
with bugs in memory allocations which are caught by Perl's malloc();
=item *
which interact with the memory allocator in other ways than via
malloc(), realloc(), free(), calloc(), sbrk() and brk();
=item *
which rely on special alignment which is not provided by Perl's malloc().
=back
B<NOTE.> Negligence to set this flag in I<any one> of loaded extension
nullifies many advantages of Perl's malloc(), such as better usage of
system resources, error detection, memory usage reporting, catchable failure
of memory allocations, etc.
=item PERLPREFIX
Directory under which core modules are to be installed.
Defaults to $Config{installprefixexp} falling back to
$Config{installprefix}, $Config{prefixexp} or $Config{prefix} should
$Config{installprefixexp} not exist.
Overridden by PREFIX.
=item PERLRUN
Use this instead of $(PERL) when you wish to run perl. It will set up
extra necessary flags for you.
=item PERLRUNINST
Use this instead of $(PERL) when you wish to run perl to work with
modules. It will add things like -I$(INST_ARCH) and other necessary
flags so perl can see the modules you're about to install.
=item PERL_SRC
Directory containing the Perl source code (use of this should be
avoided, it may be undefined)
=item PERM_DIR
Desired permission for directories. Defaults to C<755>.
=item PERM_RW
Desired permission for read/writable files. Defaults to C<644>.
=item PERM_RWX
Desired permission for executable files. Defaults to C<755>.
=item PL_FILES
MakeMaker can run programs to generate files for you at build time.
By default any file named *.PL (except Makefile.PL and Build.PL) in
the top level directory will be assumed to be a Perl program and run
passing its own basename in as an argument. For example...
perl foo.PL foo
This behavior can be overridden by supplying your own set of files to
search. PL_FILES accepts a hash ref, the key being the file to run
and the value is passed in as the first argument when the PL file is run.
PL_FILES => {'bin/foobar.PL' => 'bin/foobar'}
Would run bin/foobar.PL like this:
perl bin/foobar.PL bin/foobar
If multiple files from one program are desired an array ref can be used.
PL_FILES => {'bin/foobar.PL' => [qw(bin/foobar1 bin/foobar2)]}
In this case the program will be run multiple times using each target file.
perl bin/foobar.PL bin/foobar1
perl bin/foobar.PL bin/foobar2
PL files are normally run B<after> pm_to_blib and include INST_LIB and
INST_ARCH in its C<@INC> so the just built modules can be
accessed... unless the PL file is making a module (or anything else in
PM) in which case it is run B<before> pm_to_blib and does not include
INST_LIB and INST_ARCH in its C<@INC>. This apparently odd behavior
is there for backwards compatibility (and its somewhat DWIM).
=item PM
Hashref of .pm files and *.pl files to be installed. e.g.
{'name_of_file.pm' => '$(INST_LIBDIR)/install_as.pm'}
By default this will include *.pm and *.pl and the files found in
the PMLIBDIRS directories. Defining PM in the
Makefile.PL will override PMLIBDIRS.
=item PMLIBDIRS
Ref to array of subdirectories containing library files. Defaults to
[ 'lib', $(BASEEXT) ]. The directories will be scanned and I<any> files
they contain will be installed in the corresponding location in the
library. A libscan() method can be used to alter the behaviour.
Defining PM in the Makefile.PL will override PMLIBDIRS.
(Where BASEEXT is the last component of NAME.)
=item PM_FILTER
A filter program, in the traditional Unix sense (input from stdin, output
to stdout) that is passed on each .pm file during the build (in the
pm_to_blib() phase). It is empty by default, meaning no filtering is done.
Great care is necessary when defining the command if quoting needs to be
done. For instance, you would need to say:
{'PM_FILTER' => 'grep -v \\"^\\#\\"'}
to remove all the leading comments on the fly during the build. The
extra \\ are necessary, unfortunately, because this variable is interpolated
within the context of a Perl program built on the command line, and double
quotes are what is used with the -e switch to build that command line. The
# is escaped for the Makefile, since what is going to be generated will then
be:
PM_FILTER = grep -v \"^\#\"
Without the \\ before the #, we'd have the start of a Makefile comment,
and the macro would be incorrectly defined.
=item POLLUTE
Release 5.005 grandfathered old global symbol names by providing preprocessor
macros for extension source compatibility. As of release 5.6, these
preprocessor definitions are not available by default. The POLLUTE flag
specifies that the old names should still be defined:
perl Makefile.PL POLLUTE=1
Please inform the module author if this is necessary to successfully install
a module under 5.6 or later.
=item PPM_INSTALL_EXEC
Name of the executable used to run C<PPM_INSTALL_SCRIPT> below. (e.g. perl)
=item PPM_INSTALL_SCRIPT
Name of the script that gets executed by the Perl Package Manager after
the installation of a package.
=item PREFIX
This overrides all the default install locations. Man pages,
libraries, scripts, etc... MakeMaker will try to make an educated
guess about where to place things under the new PREFIX based on your
Config defaults. Failing that, it will fall back to a structure
which should be sensible for your platform.
If you specify LIB or any INSTALL* variables they will not be effected
by the PREFIX.
=item PREREQ_FATAL
Bool. If this parameter is true, failing to have the required modules
(or the right versions thereof) will be fatal. C<perl Makefile.PL>
will C<die> instead of simply informing the user of the missing dependencies.
It is I<extremely> rare to have to use C<PREREQ_FATAL>. Its use by module
authors is I<strongly discouraged> and should never be used lightly.
Module installation tools have ways of resolving umet dependencies but
to do that they need a F<Makefile>. Using C<PREREQ_FATAL> breaks this.
That's bad.
Assuming you have good test coverage, your tests should fail with
missing dependencies informing the user more strongly that something
is wrong. You can write a F<t/00compile.t> test which will simply
check that your code compiles and stop "make test" prematurely if it
doesn't. See L<Test::More/BAIL_OUT> for more details.
=item PREREQ_PM
A hash of modules that are needed to run your module. The keys are
the module names ie. Test::More, and the minimum version is the
value. If the required version number is 0 any version will do.
This will go into the C<requires> field of your CPAN Meta file
(F<META.yml> or F<META.json>).
PREREQ_PM => {
# Require Test::More at least 0.47
"Test::More" => "0.47",
# Require any version of Acme::Buffy
"Acme::Buffy" => 0,
}
=item PREREQ_PRINT
Bool. If this parameter is true, the prerequisites will be printed to
stdout and MakeMaker will exit. The output format is an evalable hash
ref.
$PREREQ_PM = {
'A::B' => Vers1,
'C::D' => Vers2,
...
};
If a distribution defines a minimal required perl version, this is
added to the output as an additional line of the form:
$MIN_PERL_VERSION = '5.008001';
If BUILD_REQUIRES is not empty, it will be dumped as $BUILD_REQUIRES hasref.
=item PRINT_PREREQ
RedHatism for C<PREREQ_PRINT>. The output format is different, though:
perl(A::B)>=Vers1 perl(C::D)>=Vers2 ...
A minimal required perl version, if present, will look like this:
perl(perl)>=5.008001
=item SITEPREFIX
Like PERLPREFIX, but only for the site install locations.
Defaults to $Config{siteprefixexp}. Perls prior to 5.6.0 didn't have
an explicit siteprefix in the Config. In those cases
$Config{installprefix} will be used.
Overridable by PREFIX
=item SIGN
When true, perform the generation and addition to the MANIFEST of the
SIGNATURE file in the distdir during 'make distdir', via 'cpansign
-s'.
Note that you need to install the Module::Signature module to
perform this operation.
Defaults to false.
=item SKIP
Arrayref. E.g. [qw(name1 name2)] skip (do not write) sections of the
Makefile. Caution! Do not use the SKIP attribute for the negligible
speedup. It may seriously damage the resulting Makefile. Only use it
if you really need it.
=item TEST_REQUIRES
A hash of modules that are needed to test your module but not run or
build it.
This will go into the C<test_requires> field of your CPAN Meta file.
(F<META.yml> or F<META.json>).
The format is the same as PREREQ_PM.
=item TYPEMAPS
Ref to array of typemap file names. Use this when the typemaps are
in some directory other than the current directory or when they are
not named B<typemap>. The last typemap in the list takes
precedence. A typemap in the current directory has highest
precedence, even if it isn't listed in TYPEMAPS. The default system
typemap has lowest precedence.
=item VENDORPREFIX
Like PERLPREFIX, but only for the vendor install locations.
Defaults to $Config{vendorprefixexp}.
Overridable by PREFIX
=item VERBINST
If true, make install will be verbose
=item VERSION
Your version number for distributing the package. This defaults to
0.1.
=item VERSION_FROM
Instead of specifying the VERSION in the Makefile.PL you can let
MakeMaker parse a file to determine the version number. The parsing
routine requires that the file named by VERSION_FROM contains one
single line to compute the version number. The first line in the file
that contains something like a $VERSION assignment or C<package Name
VERSION> will be used. The following lines will be parsed o.k.:
# Good
package Foo::Bar 1.23; # 1.23
$VERSION = '1.00'; # 1.00
*VERSION = \'1.01'; # 1.01
($VERSION) = q$Revision$ =~ /(\d+)/g; # The digits in $Revision$
$FOO::VERSION = '1.10'; # 1.10
*FOO::VERSION = \'1.11'; # 1.11
but these will fail:
# Bad
my $VERSION = '1.01';
local $VERSION = '1.02';
local $FOO::VERSION = '1.30';
"Version strings" are incompatible should not be used.
# Bad
$VERSION = 1.2.3;
$VERSION = v1.2.3;
L<version> objects are fine. As of MakeMaker 6.35 version.pm will be
automatically loaded, but you must declare the dependency on version.pm.
For compatibility with older MakeMaker you should load on the same line
as $VERSION is declared.
# All on one line
use version; our $VERSION = qv(1.2.3);
(Putting C<my> or C<local> on the preceding line will work o.k.)
The file named in VERSION_FROM is not added as a dependency to
Makefile. This is not really correct, but it would be a major pain
during development to have to rewrite the Makefile for any smallish
change in that file. If you want to make sure that the Makefile
contains the correct VERSION macro after any change of the file, you
would have to do something like
depend => { Makefile => '$(VERSION_FROM)' }
See attribute C<depend> below.
=item VERSION_SYM
A sanitized VERSION with . replaced by _. For places where . has
special meaning (some filesystems, RCS labels, etc...)
=item XS
Hashref of .xs files. MakeMaker will default this. e.g.
{'name_of_file.xs' => 'name_of_file.c'}
The .c files will automatically be included in the list of files
deleted by a make clean.
=item XSOPT
String of options to pass to xsubpp. This might include C<-C++> or
C<-extern>. Do not include typemaps here; the TYPEMAP parameter exists for
that purpose.
=item XSPROTOARG
May be set to an empty string, which is identical to C<-prototypes>, or
C<-noprototypes>. See the xsubpp documentation for details. MakeMaker
defaults to the empty string.
=item XS_VERSION
Your version number for the .xs file of this package. This defaults
to the value of the VERSION attribute.
=back
=head2 Additional lowercase attributes
can be used to pass parameters to the methods which implement that
part of the Makefile. Parameters are specified as a hash ref but are
passed to the method as a hash.
=over 2
=item clean
{FILES => "*.xyz foo"}
=item depend
{ANY_TARGET => ANY_DEPENDENCY, ...}
(ANY_TARGET must not be given a double-colon rule by MakeMaker.)
=item dist
{TARFLAGS => 'cvfF', COMPRESS => 'gzip', SUFFIX => '.gz',
SHAR => 'shar -m', DIST_CP => 'ln', ZIP => '/bin/zip',
ZIPFLAGS => '-rl', DIST_DEFAULT => 'private tardist' }
If you specify COMPRESS, then SUFFIX should also be altered, as it is
needed to tell make the target file of the compression. Setting
DIST_CP to ln can be useful, if you need to preserve the timestamps on
your files. DIST_CP can take the values 'cp', which copies the file,
'ln', which links the file, and 'best' which copies symbolic links and
links the rest. Default is 'best'.
=item dynamic_lib
{ARMAYBE => 'ar', OTHERLDFLAGS => '...', INST_DYNAMIC_DEP => '...'}
=item linkext
{LINKTYPE => 'static', 'dynamic' or ''}
NB: Extensions that have nothing but *.pm files had to say
{LINKTYPE => ''}
with Pre-5.0 MakeMakers. Since version 5.00 of MakeMaker such a line
can be deleted safely. MakeMaker recognizes when there's nothing to
be linked.
=item macro
{ANY_MACRO => ANY_VALUE, ...}
=item postamble
Anything put here will be passed to MY::postamble() if you have one.
=item realclean
{FILES => '$(INST_ARCHAUTODIR)/*.xyz'}
=item test
{TESTS => 't/*.t'}
=item tool_autosplit
{MAXLEN => 8}
=back
=head2 Overriding MakeMaker Methods
If you cannot achieve the desired Makefile behaviour by specifying
attributes you may define private subroutines in the Makefile.PL.
Each subroutine returns the text it wishes to have written to
the Makefile. To override a section of the Makefile you can
either say:
sub MY::c_o { "new literal text" }
or you can edit the default by saying something like:
package MY; # so that "SUPER" works right
sub c_o {
my $inherited = shift->SUPER::c_o(@_);
$inherited =~ s/old text/new text/;
$inherited;
}
If you are running experiments with embedding perl as a library into
other applications, you might find MakeMaker is not sufficient. You'd
better have a look at ExtUtils::Embed which is a collection of utilities
for embedding.
If you still need a different solution, try to develop another
subroutine that fits your needs and submit the diffs to
C<makemaker@perl.org>
For a complete description of all MakeMaker methods see
L<ExtUtils::MM_Unix>.
Here is a simple example of how to add a new target to the generated
Makefile:
sub MY::postamble {
return <<'MAKE_FRAG';
$(MYEXTLIB): sdbm/Makefile
cd sdbm && $(MAKE) all
MAKE_FRAG
}
=head2 The End Of Cargo Cult Programming
WriteMakefile() now does some basic sanity checks on its parameters to
protect against typos and malformatted values. This means some things
which happened to work in the past will now throw warnings and
possibly produce internal errors.
Some of the most common mistakes:
=over 2
=item C<< MAN3PODS => ' ' >>
This is commonly used to suppress the creation of man pages. MAN3PODS
takes a hash ref not a string, but the above worked by accident in old
versions of MakeMaker.
The correct code is C<< MAN3PODS => { } >>.
=back
=head2 Hintsfile support
MakeMaker.pm uses the architecture specific information from
Config.pm. In addition it evaluates architecture specific hints files
in a C<hints/> directory. The hints files are expected to be named
like their counterparts in C<PERL_SRC/hints>, but with an C<.pl> file
name extension (eg. C<next_3_2.pl>). They are simply C<eval>ed by
MakeMaker within the WriteMakefile() subroutine, and can be used to
execute commands as well as to include special variables. The rules
which hintsfile is chosen are the same as in Configure.
The hintsfile is eval()ed immediately after the arguments given to
WriteMakefile are stuffed into a hash reference $self but before this
reference becomes blessed. So if you want to do the equivalent to
override or create an attribute you would say something like
$self->{LIBS} = ['-ldbm -lucb -lc'];
=head2 Distribution Support
For authors of extensions MakeMaker provides several Makefile
targets. Most of the support comes from the ExtUtils::Manifest module,
where additional documentation can be found.
=over 4
=item make distcheck
reports which files are below the build directory but not in the
MANIFEST file and vice versa. (See ExtUtils::Manifest::fullcheck() for
details)
=item make skipcheck
reports which files are skipped due to the entries in the
C<MANIFEST.SKIP> file (See ExtUtils::Manifest::skipcheck() for
details)
=item make distclean
does a realclean first and then the distcheck. Note that this is not
needed to build a new distribution as long as you are sure that the
MANIFEST file is ok.
=item make manifest
rewrites the MANIFEST file, adding all remaining files found (See
ExtUtils::Manifest::mkmanifest() for details)
=item make distdir
Copies all the files that are in the MANIFEST file to a newly created
directory with the name C<$(DISTNAME)-$(VERSION)>. If that directory
exists, it will be removed first.
Additionally, it will create META.yml and META.json module meta-data file
in the distdir and add this to the distdir's MANIFEST. You can shut this
behavior off with the NO_META flag.
=item make disttest
Makes a distdir first, and runs a C<perl Makefile.PL>, a make, and
a make test in that directory.
=item make tardist
First does a distdir. Then a command $(PREOP) which defaults to a null
command, followed by $(TO_UNIX), which defaults to a null command under
UNIX, and will convert files in distribution directory to UNIX format
otherwise. Next it runs C<tar> on that directory into a tarfile and
deletes the directory. Finishes with a command $(POSTOP) which
defaults to a null command.
=item make dist
Defaults to $(DIST_DEFAULT) which in turn defaults to tardist.
=item make uutardist
Runs a tardist first and uuencodes the tarfile.
=item make shdist
First does a distdir. Then a command $(PREOP) which defaults to a null
command. Next it runs C<shar> on that directory into a sharfile and
deletes the intermediate directory again. Finishes with a command
$(POSTOP) which defaults to a null command. Note: For shdist to work
properly a C<shar> program that can handle directories is mandatory.
=item make zipdist
First does a distdir. Then a command $(PREOP) which defaults to a null
command. Runs C<$(ZIP) $(ZIPFLAGS)> on that directory into a
zipfile. Then deletes that directory. Finishes with a command
$(POSTOP) which defaults to a null command.
=item make ci
Does a $(CI) and a $(RCS_LABEL) on all files in the MANIFEST file.
=back
Customization of the dist targets can be done by specifying a hash
reference to the dist attribute of the WriteMakefile call. The
following parameters are recognized:
CI ('ci -u')
COMPRESS ('gzip --best')
POSTOP ('@ :')
PREOP ('@ :')
TO_UNIX (depends on the system)
RCS_LABEL ('rcs -q -Nv$(VERSION_SYM):')
SHAR ('shar')
SUFFIX ('.gz')
TAR ('tar')
TARFLAGS ('cvf')
ZIP ('zip')
ZIPFLAGS ('-r')
An example:
WriteMakefile(
...other options...
dist => {
COMPRESS => "bzip2",
SUFFIX => ".bz2"
}
);
=head2 Module Meta-Data (META and MYMETA)
Long plaguing users of MakeMaker based modules has been the problem of
getting basic information about the module out of the sources
I<without> running the F<Makefile.PL> and doing a bunch of messy
heuristics on the resulting F<Makefile>. Over the years, it has become
standard to keep this information in one or more CPAN Meta files
distributed with each distribution.
The original format of CPAN Meta files was L<YAML> and the corresponding
file was called F<META.yml>. In 2010, version 2 of the L<CPAN::Meta::Spec>
was released, which mandates JSON format for the metadata in order to
overcome certain compatibility issues between YAML serializers and to
avoid breaking older clients unable to handle a new version of the spec.
The L<CPAN::Meta> library is now standard for accessing old and new-style
Meta files.
If L<CPAN::Meta> is installed, MakeMaker will automatically generate
F<META.json> and F<META.yml> files for you and add them to your F<MANIFEST> as
part of the 'distdir' target (and thus the 'dist' target). This is intended to
seamlessly and rapidly populate CPAN with module meta-data. If you wish to
shut this feature off, set the C<NO_META> C<WriteMakefile()> flag to true.
At the 2008 QA Hackathon in Oslo, Perl module toolchain maintainers agrees
to use the CPAN Meta format to communicate post-configuration requirements
between toolchain components. These files, F<MYMETA.json> and F<MYMETA.yml>,
are generated when F<Makefile.PL> generates a F<Makefile> (if L<CPAN::Meta>
is installed). Clients like L<CPAN> or L<CPANPLUS> will read this
files to see what prerequisites must be fulfilled before building or testing
the distribution. If you with to shut this feature off, set the C<NO_MYMETA>
C<WriteMakeFile()> flag to true.
=head2 Disabling an extension
If some events detected in F<Makefile.PL> imply that there is no way
to create the Module, but this is a normal state of things, then you
can create a F<Makefile> which does nothing, but succeeds on all the
"usual" build targets. To do so, use
use ExtUtils::MakeMaker qw(WriteEmptyMakefile);
WriteEmptyMakefile();
instead of WriteMakefile().
This may be useful if other modules expect this module to be I<built>
OK, as opposed to I<work> OK (say, this system-dependent module builds
in a subdirectory of some other distribution, or is listed as a
dependency in a CPAN::Bundle, but the functionality is supported by
different means on the current architecture).
=head2 Other Handy Functions
=over 4
=item prompt
my $value = prompt($message);
my $value = prompt($message, $default);
The C<prompt()> function provides an easy way to request user input
used to write a makefile. It displays the $message as a prompt for
input. If a $default is provided it will be used as a default. The
function returns the $value selected by the user.
If C<prompt()> detects that it is not running interactively and there
is nothing on STDIN or if the PERL_MM_USE_DEFAULT environment variable
is set to true, the $default will be used without prompting. This
prevents automated processes from blocking on user input.
If no $default is provided an empty string will be used instead.
=back
=head1 ENVIRONMENT
=over 4
=item PERL_MM_OPT
Command line options used by C<MakeMaker-E<gt>new()>, and thus by
C<WriteMakefile()>. The string is split on whitespace, and the result
is processed before any actual command line arguments are processed.
=item PERL_MM_USE_DEFAULT
If set to a true value then MakeMaker's prompt function will
always return the default without waiting for user input.
=item PERL_CORE
Same as the PERL_CORE parameter. The parameter overrides this.
=back
=head1 SEE ALSO
L<Module::Build> is a pure-Perl alternative to MakeMaker which does
not rely on make or any other external utility. It is easier to
extend to suit your needs.
L<Module::Install> is a wrapper around MakeMaker which adds features
not normally available.
L<ExtUtils::ModuleMaker> and L<Module::Starter> are both modules to
help you setup your distribution.
L<CPAN::Meta> and L<CPAN::Meta::Spec> explain CPAN Meta files in detail.
=head1 AUTHORS
Andy Dougherty C<doughera@lafayette.edu>, Andreas KE<ouml>nig
C<andreas.koenig@mind.de>, Tim Bunce C<timb@cpan.org>. VMS
support by Charles Bailey C<bailey@newman.upenn.edu>. OS/2 support
by Ilya Zakharevich C<ilya@math.ohio-state.edu>.
Currently maintained by Michael G Schwern C<schwern@pobox.com>
Send patches and ideas to C<makemaker@perl.org>.
Send bug reports via http://rt.cpan.org/. Please send your
generated Makefile along with your report.
For more up-to-date information, see L<http://www.makemaker.org>.
Repository available at L<https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker>.
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<http://www.perl.com/perl/misc/Artistic.html>
=cut
EXTUTILS_MAKEMAKER
$fatpacked{"ExtUtils/MakeMaker/Config.pm"} = <<'EXTUTILS_MAKEMAKER_CONFIG';
package ExtUtils::MakeMaker::Config;
use strict;
our $VERSION = '6.64';
use Config ();
# Give us an overridable config.
our %Config = %Config::Config;
sub import {
my $caller = caller;
no strict 'refs'; ## no critic
*{$caller.'::Config'} = \%Config;
}
1;
=head1 NAME
ExtUtils::MakeMaker::Config - Wrapper around Config.pm
=head1 SYNOPSIS
use ExtUtils::MakeMaker::Config;
print $Config{installbin}; # or whatever
=head1 DESCRIPTION
B<FOR INTERNAL USE ONLY>
A very thin wrapper around Config.pm so MakeMaker is easier to test.
=cut
EXTUTILS_MAKEMAKER_CONFIG
$fatpacked{"ExtUtils/Mkbootstrap.pm"} = <<'EXTUTILS_MKBOOTSTRAP';
package ExtUtils::Mkbootstrap;
# There's just too much Dynaloader incest here to turn on strict vars.
use strict 'refs';
our $VERSION = '6.64';
require Exporter;
our @ISA = ('Exporter');
our @EXPORT = ('&Mkbootstrap');
use Config;
our $Verbose = 0;
sub Mkbootstrap {
my($baseext, @bsloadlibs)=@_;
@bsloadlibs = grep($_, @bsloadlibs); # strip empty libs
print " bsloadlibs=@bsloadlibs\n" if $Verbose;
# We need DynaLoader here because we and/or the *_BS file may
# call dl_findfile(). We don't say `use' here because when
# first building perl extensions the DynaLoader will not have
# been built when MakeMaker gets first used.
require DynaLoader;
rename "$baseext.bs", "$baseext.bso"
if -s "$baseext.bs";
if (-f "${baseext}_BS"){
$_ = "${baseext}_BS";
package DynaLoader; # execute code as if in DynaLoader
local($osname, $dlsrc) = (); # avoid warnings
($osname, $dlsrc) = @Config::Config{qw(osname dlsrc)};
$bscode = "";
unshift @INC, ".";
require $_;
shift @INC;
}
if ($Config{'dlsrc'} =~ /^dl_dld/){
package DynaLoader;
push(@dl_resolve_using, dl_findfile('-lc'));
}
my(@all) = (@bsloadlibs, @DynaLoader::dl_resolve_using);
my($method) = '';
if (@all){
open my $bs, ">", "$baseext.bs"
or die "Unable to open $baseext.bs: $!";
print "Writing $baseext.bs\n";
print " containing: @all" if $Verbose;
print $bs "# $baseext DynaLoader bootstrap file for $^O architecture.\n";
print $bs "# Do not edit this file, changes will be lost.\n";
print $bs "# This file was automatically generated by the\n";
print $bs "# Mkbootstrap routine in ExtUtils::Mkbootstrap (v$VERSION).\n";
print $bs "\@DynaLoader::dl_resolve_using = ";
# If @all contains names in the form -lxxx or -Lxxx then it's asking for
# runtime library location so we automatically add a call to dl_findfile()
if (" @all" =~ m/ -[lLR]/){
print $bs " dl_findfile(qw(\n @all\n ));\n";
}else{
print $bs " qw(@all);\n";
}
# write extra code if *_BS says so
print $bs $DynaLoader::bscode if $DynaLoader::bscode;
print $bs "\n1;\n";
close $bs;
}
}
1;
__END__
=head1 NAME
ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader
=head1 SYNOPSIS
C<Mkbootstrap>
=head1 DESCRIPTION
Mkbootstrap typically gets called from an extension Makefile.
There is no C<*.bs> file supplied with the extension. Instead, there may
be a C<*_BS> file which has code for the special cases, like posix for
berkeley db on the NeXT.
This file will get parsed, and produce a maybe empty
C<@DynaLoader::dl_resolve_using> array for the current architecture.
That will be extended by $BSLOADLIBS, which was computed by
ExtUtils::Liblist::ext(). If this array still is empty, we do nothing,
else we write a .bs file with an C<@DynaLoader::dl_resolve_using>
array.
The C<*_BS> file can put some code into the generated C<*.bs> file by
placing it in C<$bscode>. This is a handy 'escape' mechanism that may
prove useful in complex situations.
If @DynaLoader::dl_resolve_using contains C<-L*> or C<-l*> entries then
Mkbootstrap will automatically add a dl_findfile() call to the
generated C<*.bs> file.
=cut
EXTUTILS_MKBOOTSTRAP
$fatpacked{"ExtUtils/Mksymlists.pm"} = <<'EXTUTILS_MKSYMLISTS';
package ExtUtils::Mksymlists;
use 5.006;
use strict qw[ subs refs ];
# no strict 'vars'; # until filehandles are exempted
use Carp;
use Exporter;
use Config;
our @ISA = qw(Exporter);
our @EXPORT = qw(&Mksymlists);
our $VERSION = '6.64';
sub Mksymlists {
my(%spec) = @_;
my($osname) = $^O;
croak("Insufficient information specified to Mksymlists")
unless ( $spec{NAME} or
($spec{FILE} and ($spec{DL_FUNCS} or $spec{FUNCLIST})) );
$spec{DL_VARS} = [] unless $spec{DL_VARS};
($spec{FILE} = $spec{NAME}) =~ s/.*::// unless $spec{FILE};
$spec{FUNCLIST} = [] unless $spec{FUNCLIST};
$spec{DL_FUNCS} = { $spec{NAME} => [] }
unless ( ($spec{DL_FUNCS} and keys %{$spec{DL_FUNCS}}) or
@{$spec{FUNCLIST}});
if (defined $spec{DL_FUNCS}) {
foreach my $package (keys %{$spec{DL_FUNCS}}) {
my($packprefix,$bootseen);
($packprefix = $package) =~ s/\W/_/g;
foreach my $sym (@{$spec{DL_FUNCS}->{$package}}) {
if ($sym =~ /^boot_/) {
push(@{$spec{FUNCLIST}},$sym);
$bootseen++;
}
else {
push(@{$spec{FUNCLIST}},"XS_${packprefix}_$sym");
}
}
push(@{$spec{FUNCLIST}},"boot_$packprefix") unless $bootseen;
}
}
# We'll need this if we ever add any OS which uses mod2fname
# not as pseudo-builtin.
# require DynaLoader;
if (defined &DynaLoader::mod2fname and not $spec{DLBASE}) {
$spec{DLBASE} = DynaLoader::mod2fname([ split(/::/,$spec{NAME}) ]);
}
if ($osname eq 'aix') { _write_aix(\%spec); }
elsif ($osname eq 'MacOS'){ _write_aix(\%spec) }
elsif ($osname eq 'VMS') { _write_vms(\%spec) }
elsif ($osname eq 'os2') { _write_os2(\%spec) }
elsif ($osname eq 'MSWin32') { _write_win32(\%spec) }
else {
croak("Don't know how to create linker option file for $osname\n");
}
}
sub _write_aix {
my($data) = @_;
rename "$data->{FILE}.exp", "$data->{FILE}.exp_old";
open( my $exp, ">", "$data->{FILE}.exp")
or croak("Can't create $data->{FILE}.exp: $!\n");
print $exp join("\n",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}};
print $exp join("\n",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}};
close $exp;
}
sub _write_os2 {
my($data) = @_;
require Config;
my $threaded = ($Config::Config{archname} =~ /-thread/ ? " threaded" : "");
if (not $data->{DLBASE}) {
($data->{DLBASE} = $data->{NAME}) =~ s/.*:://;
$data->{DLBASE} = substr($data->{DLBASE},0,7) . '_';
}
my $distname = $data->{DISTNAME} || $data->{NAME};
$distname = "Distribution $distname";
my $patchlevel = " pl$Config{perl_patchlevel}" || '';
my $comment = sprintf "Perl (v%s%s%s) module %s",
$Config::Config{version}, $threaded, $patchlevel, $data->{NAME};
chomp $comment;
if ($data->{INSTALLDIRS} and $data->{INSTALLDIRS} eq 'perl') {
$distname = 'perl5-porters@perl.org';
$comment = "Core $comment";
}
$comment = "$comment (Perl-config: $Config{config_args})";
$comment = substr($comment, 0, 200) . "...)" if length $comment > 203;
rename "$data->{FILE}.def", "$data->{FILE}_def.old";
open(my $def, ">", "$data->{FILE}.def")
or croak("Can't create $data->{FILE}.def: $!\n");
print $def "LIBRARY '$data->{DLBASE}' INITINSTANCE TERMINSTANCE\n";
print $def "DESCRIPTION '\@#$distname:$data->{VERSION}#\@ $comment'\n";
print $def "CODE LOADONCALL\n";
print $def "DATA LOADONCALL NONSHARED MULTIPLE\n";
print $def "EXPORTS\n ";
print $def join("\n ",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}};
print $def join("\n ",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}};
if (%{$data->{IMPORTS}}) {
print $def "IMPORTS\n";
my ($name, $exp);
while (($name, $exp)= each %{$data->{IMPORTS}}) {
print $def " $name=$exp\n";
}
}
close $def;
}
sub _write_win32 {
my($data) = @_;
require Config;
if (not $data->{DLBASE}) {
($data->{DLBASE} = $data->{NAME}) =~ s/.*:://;
$data->{DLBASE} = substr($data->{DLBASE},0,7) . '_';
}
rename "$data->{FILE}.def", "$data->{FILE}_def.old";
open( my $def, ">", "$data->{FILE}.def" )
or croak("Can't create $data->{FILE}.def: $!\n");
# put library name in quotes (it could be a keyword, like 'Alias')
if ($Config::Config{'cc'} !~ /^gcc/i) {
print $def "LIBRARY \"$data->{DLBASE}\"\n";
}
print $def "EXPORTS\n ";
my @syms;
# Export public symbols both with and without underscores to
# ensure compatibility between DLLs from different compilers
# NOTE: DynaLoader itself only uses the names without underscores,
# so this is only to cover the case when the extension DLL may be
# linked to directly from C. GSAR 97-07-10
if ($Config::Config{'cc'} =~ /^bcc/i) {
for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) {
push @syms, "_$_", "$_ = _$_";
}
}
else {
for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) {
push @syms, "$_", "_$_ = $_";
}
}
print $def join("\n ",@syms, "\n") if @syms;
if (%{$data->{IMPORTS}}) {
print $def "IMPORTS\n";
my ($name, $exp);
while (($name, $exp)= each %{$data->{IMPORTS}}) {
print $def " $name=$exp\n";
}
}
close $def;
}
sub _write_vms {
my($data) = @_;
require Config; # a reminder for once we do $^O
require ExtUtils::XSSymSet;
my($isvax) = $Config::Config{'archname'} =~ /VAX/i;
my($set) = new ExtUtils::XSSymSet;
rename "$data->{FILE}.opt", "$data->{FILE}.opt_old";
open(my $opt,">", "$data->{FILE}.opt")
or croak("Can't create $data->{FILE}.opt: $!\n");
# Options file declaring universal symbols
# Used when linking shareable image for dynamic extension,
# or when linking PerlShr into which we've added this package
# as a static extension
# We don't do anything to preserve order, so we won't relax
# the GSMATCH criteria for a dynamic extension
print $opt "case_sensitive=yes\n"
if $Config::Config{d_vms_case_sensitive_symbols};
foreach my $sym (@{$data->{FUNCLIST}}) {
my $safe = $set->addsym($sym);
if ($isvax) { print $opt "UNIVERSAL=$safe\n" }
else { print $opt "SYMBOL_VECTOR=($safe=PROCEDURE)\n"; }
}
foreach my $sym (@{$data->{DL_VARS}}) {
my $safe = $set->addsym($sym);
print $opt "PSECT_ATTR=${sym},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
if ($isvax) { print $opt "UNIVERSAL=$safe\n" }
else { print $opt "SYMBOL_VECTOR=($safe=DATA)\n"; }
}
close $opt;
}
1;
__END__
=head1 NAME
ExtUtils::Mksymlists - write linker options files for dynamic extension
=head1 SYNOPSIS
use ExtUtils::Mksymlists;
Mksymlists({ NAME => $name ,
DL_VARS => [ $var1, $var2, $var3 ],
DL_FUNCS => { $pkg1 => [ $func1, $func2 ],
$pkg2 => [ $func3 ] });
=head1 DESCRIPTION
C<ExtUtils::Mksymlists> produces files used by the linker under some OSs
during the creation of shared libraries for dynamic extensions. It is
normally called from a MakeMaker-generated Makefile when the extension
is built. The linker option file is generated by calling the function
C<Mksymlists>, which is exported by default from C<ExtUtils::Mksymlists>.
It takes one argument, a list of key-value pairs, in which the following
keys are recognized:
=over 4
=item DLBASE
This item specifies the name by which the linker knows the
extension, which may be different from the name of the
extension itself (for instance, some linkers add an '_' to the
name of the extension). If it is not specified, it is derived
from the NAME attribute. It is presently used only by OS2 and Win32.
=item DL_FUNCS
This is identical to the DL_FUNCS attribute available via MakeMaker,
from which it is usually taken. Its value is a reference to an
associative array, in which each key is the name of a package, and
each value is an a reference to an array of function names which
should be exported by the extension. For instance, one might say
C<DL_FUNCS =E<gt> { Homer::Iliad =E<gt> [ qw(trojans greeks) ],
Homer::Odyssey =E<gt> [ qw(travellers family suitors) ] }>. The
function names should be identical to those in the XSUB code;
C<Mksymlists> will alter the names written to the linker option
file to match the changes made by F<xsubpp>. In addition, if
none of the functions in a list begin with the string B<boot_>,
C<Mksymlists> will add a bootstrap function for that package,
just as xsubpp does. (If a B<boot_E<lt>pkgE<gt>> function is
present in the list, it is passed through unchanged.) If
DL_FUNCS is not specified, it defaults to the bootstrap
function for the extension specified in NAME.
=item DL_VARS
This is identical to the DL_VARS attribute available via MakeMaker,
and, like DL_FUNCS, it is usually specified via MakeMaker. Its
value is a reference to an array of variable names which should
be exported by the extension.
=item FILE
This key can be used to specify the name of the linker option file
(minus the OS-specific extension), if for some reason you do not
want to use the default value, which is the last word of the NAME
attribute (I<e.g.> for C<Tk::Canvas>, FILE defaults to C<Canvas>).
=item FUNCLIST
This provides an alternate means to specify function names to be
exported from the extension. Its value is a reference to an
array of function names to be exported by the extension. These
names are passed through unaltered to the linker options file.
Specifying a value for the FUNCLIST attribute suppresses automatic
generation of the bootstrap function for the package. To still create
the bootstrap name you have to specify the package name in the
DL_FUNCS hash:
Mksymlists({ NAME => $name ,
FUNCLIST => [ $func1, $func2 ],
DL_FUNCS => { $pkg => [] } });
=item IMPORTS
This attribute is used to specify names to be imported into the
extension. It is currently only used by OS/2 and Win32.
=item NAME
This gives the name of the extension (I<e.g.> C<Tk::Canvas>) for which
the linker option file will be produced.
=back
When calling C<Mksymlists>, one should always specify the NAME
attribute. In most cases, this is all that's necessary. In
the case of unusual extensions, however, the other attributes
can be used to provide additional information to the linker.
=head1 AUTHOR
Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>>
=head1 REVISION
Last revised 14-Feb-1996, for Perl 5.002.
EXTUTILS_MKSYMLISTS
$fatpacked{"ExtUtils/testlib.pm"} = <<'EXTUTILS_TESTLIB';
package ExtUtils::testlib;
use strict;
use warnings;
our $VERSION = '6.64';
use Cwd;
use File::Spec;
# So the tests can chdir around and not break @INC.
# We use getcwd() because otherwise rel2abs will blow up under taint
# mode pre-5.8. We detaint is so @INC won't be tainted. This is
# no worse, and probably better, than just shoving an untainted,
# relative "blib/lib" onto @INC.
my $cwd;
BEGIN {
($cwd) = getcwd() =~ /(.*)/;
}
use lib map { File::Spec->rel2abs($_, $cwd) } qw(blib/arch blib/lib);
1;
__END__
=head1 NAME
ExtUtils::testlib - add blib/* directories to @INC
=head1 SYNOPSIS
use ExtUtils::testlib;
=head1 DESCRIPTION
After an extension has been built and before it is installed it may be
desirable to test it bypassing C<make test>. By adding
use ExtUtils::testlib;
to a test program the intermediate directories used by C<make> are
added to @INC.
EXTUTILS_TESTLIB
$fatpacked{"File/Path.pm"} = <<'FILE_PATH';
package File::Path;
use 5.005_04;
use strict;
use Cwd 'getcwd';
use File::Basename ();
use File::Spec ();
BEGIN {
if ($] < 5.006) {
# can't say 'opendir my $dh, $dirname'
# need to initialise $dh
eval "use Symbol";
}
}
use Exporter ();
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
$VERSION = '2.09';
@ISA = qw(Exporter);
@EXPORT = qw(mkpath rmtree);
@EXPORT_OK = qw(make_path remove_tree);
my $Is_VMS = $^O eq 'VMS';
my $Is_MacOS = $^O eq 'MacOS';
# These OSes complain if you want to remove a file that you have no
# write permission to:
my $Force_Writeable = grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2);
# Unix-like systems need to stat each directory in order to detect
# race condition. MS-Windows is immune to this particular attack.
my $Need_Stat_Check = !($^O eq 'MSWin32');
sub _carp {
require Carp;
goto &Carp::carp;
}
sub _croak {
require Carp;
goto &Carp::croak;
}
sub _error {
my $arg = shift;
my $message = shift;
my $object = shift;
if ($arg->{error}) {
$object = '' unless defined $object;
$message .= ": $!" if $!;
push @{${$arg->{error}}}, {$object => $message};
}
else {
_carp(defined($object) ? "$message for $object: $!" : "$message: $!");
}
}
sub make_path {
push @_, {} unless @_ and UNIVERSAL::isa($_[-1],'HASH');
goto &mkpath;
}
sub mkpath {
my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH'));
my $arg;
my $paths;
if ($old_style) {
my ($verbose, $mode);
($paths, $verbose, $mode) = @_;
$paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY');
$arg->{verbose} = $verbose;
$arg->{mode} = defined $mode ? $mode : 0777;
}
else {
$arg = pop @_;
$arg->{mode} = delete $arg->{mask} if exists $arg->{mask};
$arg->{mode} = 0777 unless exists $arg->{mode};
${$arg->{error}} = [] if exists $arg->{error};
$arg->{owner} = delete $arg->{user} if exists $arg->{user};
$arg->{owner} = delete $arg->{uid} if exists $arg->{uid};
if (exists $arg->{owner} and $arg->{owner} =~ /\D/) {
my $uid = (getpwnam $arg->{owner})[2];
if (defined $uid) {
$arg->{owner} = $uid;
}
else {
_error($arg, "unable to map $arg->{owner} to a uid, ownership not changed");
delete $arg->{owner};
}
}
if (exists $arg->{group} and $arg->{group} =~ /\D/) {
my $gid = (getgrnam $arg->{group})[2];
if (defined $gid) {
$arg->{group} = $gid;
}
else {
_error($arg, "unable to map $arg->{group} to a gid, group ownership not changed");
delete $arg->{group};
}
}
if (exists $arg->{owner} and not exists $arg->{group}) {
$arg->{group} = -1; # chown will leave group unchanged
}
if (exists $arg->{group} and not exists $arg->{owner}) {
$arg->{owner} = -1; # chown will leave owner unchanged
}
$paths = [@_];
}
return _mkpath($arg, $paths);
}
sub _mkpath {
my $arg = shift;
my $paths = shift;
my(@created,$path);
foreach $path (@$paths) {
next unless defined($path) and length($path);
$path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT
# Logic wants Unix paths, so go with the flow.
if ($Is_VMS) {
next if $path eq '/';
$path = VMS::Filespec::unixify($path);
}
next if -d $path;
my $parent = File::Basename::dirname($path);
unless (-d $parent or $path eq $parent) {
push(@created,_mkpath($arg, [$parent]));
}
print "mkdir $path\n" if $arg->{verbose};
if (mkdir($path,$arg->{mode})) {
push(@created, $path);
if (exists $arg->{owner}) {
# NB: $arg->{group} guaranteed to be set during initialisation
if (!chown $arg->{owner}, $arg->{group}, $path) {
_error($arg, "Cannot change ownership of $path to $arg->{owner}:$arg->{group}");
}
}
}
else {
my $save_bang = $!;
my ($e, $e1) = ($save_bang, $^E);
$e .= "; $e1" if $e ne $e1;
# allow for another process to have created it meanwhile
if (!-d $path) {
$! = $save_bang;
if ($arg->{error}) {
push @{${$arg->{error}}}, {$path => $e};
}
else {
_croak("mkdir $path: $e");
}
}
}
}
return @created;
}
sub remove_tree {
push @_, {} unless @_ and UNIVERSAL::isa($_[-1],'HASH');
goto &rmtree;
}
sub _is_subdir {
my($dir, $test) = @_;
my($dv, $dd) = File::Spec->splitpath($dir, 1);
my($tv, $td) = File::Spec->splitpath($test, 1);
# not on same volume
return 0 if $dv ne $tv;
my @d = File::Spec->splitdir($dd);
my @t = File::Spec->splitdir($td);
# @t can't be a subdir if it's shorter than @d
return 0 if @t < @d;
return join('/', @d) eq join('/', splice @t, 0, +@d);
}
sub rmtree {
my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH'));
my $arg;
my $paths;
if ($old_style) {
my ($verbose, $safe);
($paths, $verbose, $safe) = @_;
$arg->{verbose} = $verbose;
$arg->{safe} = defined $safe ? $safe : 0;
if (defined($paths) and length($paths)) {
$paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY');
}
else {
_carp ("No root path(s) specified\n");
return 0;
}
}
else {
$arg = pop @_;
${$arg->{error}} = [] if exists $arg->{error};
${$arg->{result}} = [] if exists $arg->{result};
$paths = [@_];
}
$arg->{prefix} = '';
$arg->{depth} = 0;
my @clean_path;
$arg->{cwd} = getcwd() or do {
_error($arg, "cannot fetch initial working directory");
return 0;
};
for ($arg->{cwd}) { /\A(.*)\Z/; $_ = $1 } # untaint
for my $p (@$paths) {
# need to fixup case and map \ to / on Windows
my $ortho_root = $^O eq 'MSWin32' ? _slash_lc($p) : $p;
my $ortho_cwd = $^O eq 'MSWin32' ? _slash_lc($arg->{cwd}) : $arg->{cwd};
my $ortho_root_length = length($ortho_root);
$ortho_root_length-- if $^O eq 'VMS'; # don't compare '.' with ']'
if ($ortho_root_length && _is_subdir($ortho_root, $ortho_cwd)) {
local $! = 0;
_error($arg, "cannot remove path when cwd is $arg->{cwd}", $p);
next;
}
if ($Is_MacOS) {
$p = ":$p" unless $p =~ /:/;
$p .= ":" unless $p =~ /:\z/;
}
elsif ($^O eq 'MSWin32') {
$p =~ s{[/\\]\z}{};
}
else {
$p =~ s{/\z}{};
}
push @clean_path, $p;
}
@{$arg}{qw(device inode perm)} = (lstat $arg->{cwd})[0,1] or do {
_error($arg, "cannot stat initial working directory", $arg->{cwd});
return 0;
};
return _rmtree($arg, \@clean_path);
}
sub _rmtree {
my $arg = shift;
my $paths = shift;
my $count = 0;
my $curdir = File::Spec->curdir();
my $updir = File::Spec->updir();
my (@files, $root);
ROOT_DIR:
foreach $root (@$paths) {
# since we chdir into each directory, it may not be obvious
# to figure out where we are if we generate a message about
# a file name. We therefore construct a semi-canonical
# filename, anchored from the directory being unlinked (as
# opposed to being truly canonical, anchored from the root (/).
my $canon = $arg->{prefix}
? File::Spec->catfile($arg->{prefix}, $root)
: $root
;
my ($ldev, $lino, $perm) = (lstat $root)[0,1,2] or next ROOT_DIR;
if ( -d _ ) {
$root = VMS::Filespec::vmspath(VMS::Filespec::pathify($root)) if $Is_VMS;
if (!chdir($root)) {
# see if we can escalate privileges to get in
# (e.g. funny protection mask such as -w- instead of rwx)
$perm &= 07777;
my $nperm = $perm | 0700;
if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $root))) {
_error($arg, "cannot make child directory read-write-exec", $canon);
next ROOT_DIR;
}
elsif (!chdir($root)) {
_error($arg, "cannot chdir to child", $canon);
next ROOT_DIR;
}
}
my ($cur_dev, $cur_inode, $perm) = (stat $curdir)[0,1,2] or do {
_error($arg, "cannot stat current working directory", $canon);
next ROOT_DIR;
};
if ($Need_Stat_Check) {
($ldev eq $cur_dev and $lino eq $cur_inode)
or _croak("directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting.");
}
$perm &= 07777; # don't forget setuid, setgid, sticky bits
my $nperm = $perm | 0700;
# notabene: 0700 is for making readable in the first place,
# it's also intended to change it to writable in case we have
# to recurse in which case we are better than rm -rf for
# subtrees with strange permissions
if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $curdir))) {
_error($arg, "cannot make directory read+writeable", $canon);
$nperm = $perm;
}
my $d;
$d = gensym() if $] < 5.006;
if (!opendir $d, $curdir) {
_error($arg, "cannot opendir", $canon);
@files = ();
}
else {
no strict 'refs';
if (!defined ${"\cTAINT"} or ${"\cTAINT"}) {
# Blindly untaint dir names if taint mode is
# active, or any perl < 5.006
@files = map { /\A(.*)\z/s; $1 } readdir $d;
}
else {
@files = readdir $d;
}
closedir $d;
}
if ($Is_VMS) {
# Deleting large numbers of files from VMS Files-11
# filesystems is faster if done in reverse ASCIIbetical order.
# include '.' to '.;' from blead patch #31775
@files = map {$_ eq '.' ? '.;' : $_} reverse @files;
}
@files = grep {$_ ne $updir and $_ ne $curdir} @files;
if (@files) {
# remove the contained files before the directory itself
my $narg = {%$arg};
@{$narg}{qw(device inode cwd prefix depth)}
= ($cur_dev, $cur_inode, $updir, $canon, $arg->{depth}+1);
$count += _rmtree($narg, \@files);
}
# restore directory permissions of required now (in case the rmdir
# below fails), while we are still in the directory and may do so
# without a race via '.'
if ($nperm != $perm and not chmod($perm, $curdir)) {
_error($arg, "cannot reset chmod", $canon);
}
# don't leave the client code in an unexpected directory
chdir($arg->{cwd})
or _croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting.");
# ensure that a chdir upwards didn't take us somewhere other
# than we expected (see CVE-2002-0435)
($cur_dev, $cur_inode) = (stat $curdir)[0,1]
or _croak("cannot stat prior working directory $arg->{cwd}: $!, aborting.");
if ($Need_Stat_Check) {
($arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode)
or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting.");
}
if ($arg->{depth} or !$arg->{keep_root}) {
if ($arg->{safe} &&
($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
print "skipped $root\n" if $arg->{verbose};
next ROOT_DIR;
}
if ($Force_Writeable and !chmod $perm | 0700, $root) {
_error($arg, "cannot make directory writeable", $canon);
}
print "rmdir $root\n" if $arg->{verbose};
if (rmdir $root) {
push @{${$arg->{result}}}, $root if $arg->{result};
++$count;
}
else {
_error($arg, "cannot remove directory", $canon);
if ($Force_Writeable && !chmod($perm, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
) {
_error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon);
}
}
}
}
else {
# not a directory
$root = VMS::Filespec::vmsify("./$root")
if $Is_VMS
&& !File::Spec->file_name_is_absolute($root)
&& ($root !~ m/(?<!\^)[\]>]+/); # not already in VMS syntax
if ($arg->{safe} &&
($Is_VMS ? !&VMS::Filespec::candelete($root)
: !(-l $root || -w $root)))
{
print "skipped $root\n" if $arg->{verbose};
next ROOT_DIR;
}
my $nperm = $perm & 07777 | 0600;
if ($Force_Writeable and $nperm != $perm and not chmod $nperm, $root) {
_error($arg, "cannot make file writeable", $canon);
}
print "unlink $canon\n" if $arg->{verbose};
# delete all versions under VMS
for (;;) {
if (unlink $root) {
push @{${$arg->{result}}}, $root if $arg->{result};
}
else {
_error($arg, "cannot unlink file", $canon);
$Force_Writeable and chmod($perm, $root) or
_error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon);
last;
}
++$count;
last unless $Is_VMS && lstat $root;
}
}
}
return $count;
}
sub _slash_lc {
# fix up slashes and case on MSWin32 so that we can determine that
# c:\path\to\dir is underneath C:/Path/To
my $path = shift;
$path =~ tr{\\}{/};
return lc($path);
}
1;
__END__
=head1 NAME
File::Path - Create or remove directory trees
=head1 VERSION
This document describes version 2.09 of File::Path, released
2013-01-17.
=head1 SYNOPSIS
use File::Path qw(make_path remove_tree);
make_path('foo/bar/baz', '/zug/zwang');
make_path('foo/bar/baz', '/zug/zwang', {
verbose => 1,
mode => 0711,
});
remove_tree('foo/bar/baz', '/zug/zwang');
remove_tree('foo/bar/baz', '/zug/zwang', {
verbose => 1,
error => \my $err_list,
});
# legacy (interface promoted before v2.00)
mkpath('/foo/bar/baz');
mkpath('/foo/bar/baz', 1, 0711);
mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
rmtree('foo/bar/baz', 1, 1);
rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);
# legacy (interface promoted before v2.06)
mkpath('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 });
rmtree('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 });
=head1 DESCRIPTION
This module provide a convenient way to create directories of
arbitrary depth and to delete an entire directory subtree from the
filesystem.
The following functions are provided:
=over
=item make_path( $dir1, $dir2, .... )
=item make_path( $dir1, $dir2, ...., \%opts )
The C<make_path> function creates the given directories if they don't
exists before, much like the Unix command C<mkdir -p>.
The function accepts a list of directories to be created. Its
behaviour may be tuned by an optional hashref appearing as the last
parameter on the call.
The function returns the list of directories actually created during
the call; in scalar context the number of directories created.
The following keys are recognised in the option hash:
=over
=item mode => $num
The numeric permissions mode to apply to each created directory
(defaults to 0777), to be modified by the current C<umask>. If the
directory already exists (and thus does not need to be created),
the permissions will not be modified.
C<mask> is recognised as an alias for this parameter.
=item verbose => $bool
If present, will cause C<make_path> to print the name of each directory
as it is created. By default nothing is printed.
=item error => \$err
If present, it should be a reference to a scalar.
This scalar will be made to reference an array, which will
be used to store any errors that are encountered. See the L</"ERROR
HANDLING"> section for more information.
If this parameter is not used, certain error conditions may raise
a fatal error that will cause the program will halt, unless trapped
in an C<eval> block.
=item owner => $owner
=item user => $owner
=item uid => $owner
If present, will cause any created directory to be owned by C<$owner>.
If the value is numeric, it will be interpreted as a uid, otherwise
as username is assumed. An error will be issued if the username cannot be
mapped to a uid, or the uid does not exist, or the process lacks the
privileges to change ownership.
Ownwership of directories that already exist will not be changed.
C<user> and C<uid> are aliases of C<owner>.
=item group => $group
If present, will cause any created directory to be owned by the group C<$group>.
If the value is numeric, it will be interpreted as a gid, otherwise
as group name is assumed. An error will be issued if the group name cannot be
mapped to a gid, or the gid does not exist, or the process lacks the
privileges to change group ownership.
Group ownwership of directories that already exist will not be changed.
make_path '/var/tmp/webcache', {owner=>'nobody', group=>'nogroup'};
=back
=item mkpath( $dir )
=item mkpath( $dir, $verbose, $mode )
=item mkpath( [$dir1, $dir2,...], $verbose, $mode )
=item mkpath( $dir1, $dir2,..., \%opt )
The mkpath() function provide the legacy interface of make_path() with
a different interpretation of the arguments passed. The behaviour and
return value of the function is otherwise identical to make_path().
=item remove_tree( $dir1, $dir2, .... )
=item remove_tree( $dir1, $dir2, ...., \%opts )
The C<remove_tree> function deletes the given directories and any
files and subdirectories they might contain, much like the Unix
command C<rm -r> or C<del /s> on Windows.
The function accepts a list of directories to be
removed. Its behaviour may be tuned by an optional hashref
appearing as the last parameter on the call.
The functions returns the number of files successfully deleted.
The following keys are recognised in the option hash:
=over
=item verbose => $bool
If present, will cause C<remove_tree> to print the name of each file as
it is unlinked. By default nothing is printed.
=item safe => $bool
When set to a true value, will cause C<remove_tree> to skip the files
for which the process lacks the required privileges needed to delete
files, such as delete privileges on VMS. In other words, the code
will make no attempt to alter file permissions. Thus, if the process
is interrupted, no filesystem object will be left in a more
permissive mode.
=item keep_root => $bool
When set to a true value, will cause all files and subdirectories
to be removed, except the initially specified directories. This comes
in handy when cleaning out an application's scratch directory.
remove_tree( '/tmp', {keep_root => 1} );
=item result => \$res
If present, it should be a reference to a scalar.
This scalar will be made to reference an array, which will
be used to store all files and directories unlinked
during the call. If nothing is unlinked, the array will be empty.
remove_tree( '/tmp', {result => \my $list} );
print "unlinked $_\n" for @$list;
This is a useful alternative to the C<verbose> key.
=item error => \$err
If present, it should be a reference to a scalar.
This scalar will be made to reference an array, which will
be used to store any errors that are encountered. See the L</"ERROR
HANDLING"> section for more information.
Removing things is a much more dangerous proposition than
creating things. As such, there are certain conditions that
C<remove_tree> may encounter that are so dangerous that the only
sane action left is to kill the program.
Use C<error> to trap all that is reasonable (problems with
permissions and the like), and let it die if things get out
of hand. This is the safest course of action.
=back
=item rmtree( $dir )
=item rmtree( $dir, $verbose, $safe )
=item rmtree( [$dir1, $dir2,...], $verbose, $safe )
=item rmtree( $dir1, $dir2,..., \%opt )
The rmtree() function provide the legacy interface of remove_tree()
with a different interpretation of the arguments passed. The behaviour
and return value of the function is otherwise identical to
remove_tree().
=back
=head2 ERROR HANDLING
=over 4
=item B<NOTE:>
The following error handling mechanism is considered
experimental and is subject to change pending feedback from
users.
=back
If C<make_path> or C<remove_tree> encounter an error, a diagnostic
message will be printed to C<STDERR> via C<carp> (for non-fatal
errors), or via C<croak> (for fatal errors).
If this behaviour is not desirable, the C<error> attribute may be
used to hold a reference to a variable, which will be used to store
the diagnostics. The variable is made a reference to an array of hash
references. Each hash contain a single key/value pair where the key
is the name of the file, and the value is the error message (including
the contents of C<$!> when appropriate). If a general error is
encountered the diagnostic key will be empty.
An example usage looks like:
remove_tree( 'foo/bar', 'bar/rat', {error => \my $err} );
if (@$err) {
for my $diag (@$err) {
my ($file, $message) = %$diag;
if ($file eq '') {
print "general error: $message\n";
}
else {
print "problem unlinking $file: $message\n";
}
}
}
else {
print "No error encountered\n";
}
Note that if no errors are encountered, C<$err> will reference an
empty array. This means that C<$err> will always end up TRUE; so you
need to test C<@$err> to determine if errors occured.
=head2 NOTES
C<File::Path> blindly exports C<mkpath> and C<rmtree> into the
current namespace. These days, this is considered bad style, but
to change it now would break too much code. Nonetheless, you are
invited to specify what it is you are expecting to use:
use File::Path 'rmtree';
The routines C<make_path> and C<remove_tree> are B<not> exported
by default. You must specify which ones you want to use.
use File::Path 'remove_tree';
Note that a side-effect of the above is that C<mkpath> and C<rmtree>
are no longer exported at all. This is due to the way the C<Exporter>
module works. If you are migrating a codebase to use the new
interface, you will have to list everything explicitly. But that's
just good practice anyway.
use File::Path qw(remove_tree rmtree);
=head3 API CHANGES
The API was changed in the 2.0 branch. For a time, C<mkpath> and
C<rmtree> tried, unsuccessfully, to deal with the two different
calling mechanisms. This approach was considered a failure.
The new semantics are now only available with C<make_path> and
C<remove_tree>. The old semantics are only available through
C<mkpath> and C<rmtree>. Users are strongly encouraged to upgrade
to at least 2.08 in order to avoid surprises.
=head3 SECURITY CONSIDERATIONS
There were race conditions 1.x implementations of File::Path's
C<rmtree> function (although sometimes patched depending on the OS
distribution or platform). The 2.0 version contains code to avoid the
problem mentioned in CVE-2002-0435.
See the following pages for more information:
http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=286905
http://www.nntp.perl.org/group/perl.perl5.porters/2005/01/msg97623.html
http://www.debian.org/security/2005/dsa-696
Additionally, unless the C<safe> parameter is set (or the
third parameter in the traditional interface is TRUE), should a
C<remove_tree> be interrupted, files that were originally in read-only
mode may now have their permissions set to a read-write (or "delete
OK") mode.
=head1 DIAGNOSTICS
FATAL errors will cause the program to halt (C<croak>), since the
problem is so severe that it would be dangerous to continue. (This
can always be trapped with C<eval>, but it's not a good idea. Under
the circumstances, dying is the best thing to do).
SEVERE errors may be trapped using the modern interface. If the
they are not trapped, or the old interface is used, such an error
will cause the program will halt.
All other errors may be trapped using the modern interface, otherwise
they will be C<carp>ed about. Program execution will not be halted.
=over 4
=item mkdir [path]: [errmsg] (SEVERE)
C<make_path> was unable to create the path. Probably some sort of
permissions error at the point of departure, or insufficient resources
(such as free inodes on Unix).
=item No root path(s) specified
C<make_path> was not given any paths to create. This message is only
emitted if the routine is called with the traditional interface.
The modern interface will remain silent if given nothing to do.
=item No such file or directory
On Windows, if C<make_path> gives you this warning, it may mean that
you have exceeded your filesystem's maximum path length.
=item cannot fetch initial working directory: [errmsg]
C<remove_tree> attempted to determine the initial directory by calling
C<Cwd::getcwd>, but the call failed for some reason. No attempt
will be made to delete anything.
=item cannot stat initial working directory: [errmsg]
C<remove_tree> attempted to stat the initial directory (after having
successfully obtained its name via C<getcwd>), however, the call
failed for some reason. No attempt will be made to delete anything.
=item cannot chdir to [dir]: [errmsg]
C<remove_tree> attempted to set the working directory in order to
begin deleting the objects therein, but was unsuccessful. This is
usually a permissions issue. The routine will continue to delete
other things, but this directory will be left intact.
=item directory [dir] changed before chdir, expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL)
C<remove_tree> recorded the device and inode of a directory, and then
moved into it. It then performed a C<stat> on the current directory
and detected that the device and inode were no longer the same. As
this is at the heart of the race condition problem, the program
will die at this point.
=item cannot make directory [dir] read+writeable: [errmsg]
C<remove_tree> attempted to change the permissions on the current directory
to ensure that subsequent unlinkings would not run into problems,
but was unable to do so. The permissions remain as they were, and
the program will carry on, doing the best it can.
=item cannot read [dir]: [errmsg]
C<remove_tree> tried to read the contents of the directory in order
to acquire the names of the directory entries to be unlinked, but
was unsuccessful. This is usually a permissions issue. The
program will continue, but the files in this directory will remain
after the call.
=item cannot reset chmod [dir]: [errmsg]
C<remove_tree>, after having deleted everything in a directory, attempted
to restore its permissions to the original state but failed. The
directory may wind up being left behind.
=item cannot remove [dir] when cwd is [dir]
The current working directory of the program is F</some/path/to/here>
and you are attempting to remove an ancestor, such as F</some/path>.
The directory tree is left untouched.
The solution is to C<chdir> out of the child directory to a place
outside the directory tree to be removed.
=item cannot chdir to [parent-dir] from [child-dir]: [errmsg], aborting. (FATAL)
C<remove_tree>, after having deleted everything and restored the permissions
of a directory, was unable to chdir back to the parent. The program
halts to avoid a race condition from occurring.
=item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL)
C<remove_tree> was unable to stat the parent directory after have returned
from the child. Since there is no way of knowing if we returned to
where we think we should be (by comparing device and inode) the only
way out is to C<croak>.
=item previous directory [parent-dir] changed before entering [child-dir], expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL)
When C<remove_tree> returned from deleting files in a child directory, a
check revealed that the parent directory it returned to wasn't the one
it started out from. This is considered a sign of malicious activity.
=item cannot make directory [dir] writeable: [errmsg]
Just before removing a directory (after having successfully removed
everything it contained), C<remove_tree> attempted to set the permissions
on the directory to ensure it could be removed and failed. Program
execution continues, but the directory may possibly not be deleted.
=item cannot remove directory [dir]: [errmsg]
C<remove_tree> attempted to remove a directory, but failed. This may because
some objects that were unable to be removed remain in the directory, or
a permissions issue. The directory will be left behind.
=item cannot restore permissions of [dir] to [0nnn]: [errmsg]
After having failed to remove a directory, C<remove_tree> was unable to
restore its permissions from a permissive state back to a possibly
more restrictive setting. (Permissions given in octal).
=item cannot make file [file] writeable: [errmsg]
C<remove_tree> attempted to force the permissions of a file to ensure it
could be deleted, but failed to do so. It will, however, still attempt
to unlink the file.
=item cannot unlink file [file]: [errmsg]
C<remove_tree> failed to remove a file. Probably a permissions issue.
=item cannot restore permissions of [file] to [0nnn]: [errmsg]
After having failed to remove a file, C<remove_tree> was also unable
to restore the permissions on the file to a possibly less permissive
setting. (Permissions given in octal).
=item unable to map [owner] to a uid, ownership not changed");
C<make_path> was instructed to give the ownership of created
directories to the symbolic name [owner], but C<getpwnam> did
not return the corresponding numeric uid. The directory will
be created, but ownership will not be changed.
=item unable to map [group] to a gid, group ownership not changed
C<make_path> was instructed to give the group ownership of created
directories to the symbolic name [group], but C<getgrnam> did
not return the corresponding numeric gid. The directory will
be created, but group ownership will not be changed.
=back
=head1 SEE ALSO
=over 4
=item *
L<File::Remove>
Allows files and directories to be moved to the Trashcan/Recycle
Bin (where they may later be restored if necessary) if the operating
system supports such functionality. This feature may one day be
made available directly in C<File::Path>.
=item *
L<File::Find::Rule>
When removing directory trees, if you want to examine each file to
decide whether to delete it (and possibly leaving large swathes
alone), F<File::Find::Rule> offers a convenient and flexible approach
to examining directory trees.
=back
=head1 BUGS
Please report all bugs on the RT queue:
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path>
You can also send pull requests to the Github repository:
L<https://github.com/dland/File-Path>
=head1 ACKNOWLEDGEMENTS
Paul Szabo identified the race condition originally, and Brendan
O'Dea wrote an implementation for Debian that addressed the problem.
That code was used as a basis for the current code. Their efforts
are greatly appreciated.
Gisle Aas made a number of improvements to the documentation for
2.07 and his advice and assistance is also greatly appreciated.
=head1 AUTHORS
Tim Bunce and Charles Bailey. Currently maintained by David Landgren
<F<david@landgren.net>>.
=head1 COPYRIGHT
This module is copyright (C) Charles Bailey, Tim Bunce and
David Landgren 1995-2013. All rights reserved.
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
FILE_PATH
$fatpacked{"File/Temp.pm"} = <<'FILE_TEMP';
package File::Temp;
=head1 NAME
File::Temp - return name and handle of a temporary file safely
=begin __INTERNALS
=head1 PORTABILITY
This section is at the top in order to provide easier access to
porters. It is not expected to be rendered by a standard pod
formatting tool. Please skip straight to the SYNOPSIS section if you
are not trying to port this module to a new platform.
This module is designed to be portable across operating systems and it
currently supports Unix, VMS, DOS, OS/2, Windows and Mac OS
(Classic). When porting to a new OS there are generally three main
issues that have to be solved:
=over 4
=item *
Can the OS unlink an open file? If it can not then the
C<_can_unlink_opened_file> method should be modified.
=item *
Are the return values from C<stat> reliable? By default all the
return values from C<stat> are compared when unlinking a temporary
file using the filename and the handle. Operating systems other than
unix do not always have valid entries in all fields. If utility function
C<File::Temp::unlink0> fails then the C<stat> comparison should be
modified accordingly.
=item *
Security. Systems that can not support a test for the sticky bit
on a directory can not use the MEDIUM and HIGH security tests.
The C<_can_do_level> method should be modified accordingly.
=back
=end __INTERNALS
=head1 SYNOPSIS
use File::Temp qw/ tempfile tempdir /;
$fh = tempfile();
($fh, $filename) = tempfile();
($fh, $filename) = tempfile( $template, DIR => $dir);
($fh, $filename) = tempfile( $template, SUFFIX => '.dat');
($fh, $filename) = tempfile( $template, TMPDIR => 1 );
binmode( $fh, ":utf8" );
$dir = tempdir( CLEANUP => 1 );
($fh, $filename) = tempfile( DIR => $dir );
Object interface:
require File::Temp;
use File::Temp ();
use File::Temp qw/ :seekable /;
$fh = File::Temp->new();
$fname = $fh->filename;
$fh = File::Temp->new(TEMPLATE => $template);
$fname = $fh->filename;
$tmp = File::Temp->new( UNLINK => 0, SUFFIX => '.dat' );
print $tmp "Some data\n";
print "Filename is $tmp\n";
$tmp->seek( 0, SEEK_END );
The following interfaces are provided for compatibility with
existing APIs. They should not be used in new code.
MkTemp family:
use File::Temp qw/ :mktemp /;
($fh, $file) = mkstemp( "tmpfileXXXXX" );
($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix);
$tmpdir = mkdtemp( $template );
$unopened_file = mktemp( $template );
POSIX functions:
use File::Temp qw/ :POSIX /;
$file = tmpnam();
$fh = tmpfile();
($fh, $file) = tmpnam();
Compatibility functions:
$unopened_file = File::Temp::tempnam( $dir, $pfx );
=head1 DESCRIPTION
C<File::Temp> can be used to create and open temporary files in a safe
way. There is both a function interface and an object-oriented
interface. The File::Temp constructor or the tempfile() function can
be used to return the name and the open filehandle of a temporary
file. The tempdir() function can be used to create a temporary
directory.
The security aspect of temporary file creation is emphasized such that
a filehandle and filename are returned together. This helps guarantee
that a race condition can not occur where the temporary file is
created by another process between checking for the existence of the
file and its opening. Additional security levels are provided to
check, for example, that the sticky bit is set on world writable
directories. See L<"safe_level"> for more information.
For compatibility with popular C library functions, Perl implementations of
the mkstemp() family of functions are provided. These are, mkstemp(),
mkstemps(), mkdtemp() and mktemp().
Additionally, implementations of the standard L<POSIX|POSIX>
tmpnam() and tmpfile() functions are provided if required.
Implementations of mktemp(), tmpnam(), and tempnam() are provided,
but should be used with caution since they return only a filename
that was valid when function was called, so cannot guarantee
that the file will not exist by the time the caller opens the filename.
Filehandles returned by these functions support the seekable methods.
=cut
# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls
# People would like a version on 5.004 so give them what they want :-)
use 5.004;
use strict;
use Carp;
use File::Spec 0.8;
use Cwd ();
use File::Path qw/ rmtree /;
use Fcntl 1.03;
use IO::Seekable; # For SEEK_*
use Errno;
use Scalar::Util 'refaddr';
require VMS::Stdio if $^O eq 'VMS';
# pre-emptively load Carp::Heavy. If we don't when we run out of file
# handles and attempt to call croak() we get an error message telling
# us that Carp::Heavy won't load rather than an error telling us we
# have run out of file handles. We either preload croak() or we
# switch the calls to croak from _gettemp() to use die.
eval { require Carp::Heavy; };
# Need the Symbol package if we are running older perl
require Symbol if $] < 5.006;
### For the OO interface
use base qw/ IO::Handle IO::Seekable /;
use overload '""' => "STRINGIFY", '0+' => "NUMIFY",
fallback => 1;
# use 'our' on v5.6.0
use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL);
$DEBUG = 0;
$KEEP_ALL = 0;
# We are exporting functions
use base qw/Exporter/;
# Export list - to allow fine tuning of export table
@EXPORT_OK = qw{
tempfile
tempdir
tmpnam
tmpfile
mktemp
mkstemp
mkstemps
mkdtemp
unlink0
cleanup
SEEK_SET
SEEK_CUR
SEEK_END
};
# Groups of functions for export
%EXPORT_TAGS = (
'POSIX' => [qw/ tmpnam tmpfile /],
'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/],
'seekable' => [qw/ SEEK_SET SEEK_CUR SEEK_END /],
);
# add contents of these tags to @EXPORT
Exporter::export_tags('POSIX','mktemp','seekable');
# Version number
$VERSION = '0.23';
# This is a list of characters that can be used in random filenames
my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
a b c d e f g h i j k l m n o p q r s t u v w x y z
0 1 2 3 4 5 6 7 8 9 _
/);
# Maximum number of tries to make a temp file before failing
use constant MAX_TRIES => 1000;
# Minimum number of X characters that should be in a template
use constant MINX => 4;
# Default template when no template supplied
use constant TEMPXXX => 'X' x 10;
# Constants for the security level
use constant STANDARD => 0;
use constant MEDIUM => 1;
use constant HIGH => 2;
# OPENFLAGS. If we defined the flag to use with Sysopen here this gives
# us an optimisation when many temporary files are requested
my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;
my $LOCKFLAG;
unless ($^O eq 'MacOS') {
for my $oflag (qw/ NOFOLLOW BINARY LARGEFILE NOINHERIT /) {
my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
no strict 'refs';
$OPENFLAGS |= $bit if eval {
# Make sure that redefined die handlers do not cause problems
# e.g. CGI::Carp
local $SIG{__DIE__} = sub {};
local $SIG{__WARN__} = sub {};
$bit = &$func();
1;
};
}
# Special case O_EXLOCK
$LOCKFLAG = eval {
local $SIG{__DIE__} = sub {};
local $SIG{__WARN__} = sub {};
&Fcntl::O_EXLOCK();
};
}
# On some systems the O_TEMPORARY flag can be used to tell the OS
# to automatically remove the file when it is closed. This is fine
# in most cases but not if tempfile is called with UNLINK=>0 and
# the filename is requested -- in the case where the filename is to
# be passed to another routine. This happens on windows. We overcome
# this by using a second open flags variable
my $OPENTEMPFLAGS = $OPENFLAGS;
unless ($^O eq 'MacOS') {
for my $oflag (qw/ TEMPORARY /) {
my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
local($@);
no strict 'refs';
$OPENTEMPFLAGS |= $bit if eval {
# Make sure that redefined die handlers do not cause problems
# e.g. CGI::Carp
local $SIG{__DIE__} = sub {};
local $SIG{__WARN__} = sub {};
$bit = &$func();
1;
};
}
}
# Private hash tracking which files have been created by each process id via the OO interface
my %FILES_CREATED_BY_OBJECT;
# INTERNAL ROUTINES - not to be used outside of package
# Generic routine for getting a temporary filename
# modelled on OpenBSD _gettemp() in mktemp.c
# The template must contain X's that are to be replaced
# with the random values
# Arguments:
# TEMPLATE - string containing the XXXXX's that is converted
# to a random filename and opened if required
# Optionally, a hash can also be supplied containing specific options
# "open" => if true open the temp file, else just return the name
# default is 0
# "mkdir"=> if true, we are creating a temp directory rather than tempfile
# default is 0
# "suffixlen" => number of characters at end of PATH to be ignored.
# default is 0.
# "unlink_on_close" => indicates that, if possible, the OS should remove
# the file as soon as it is closed. Usually indicates
# use of the O_TEMPORARY flag to sysopen.
# Usually irrelevant on unix
# "use_exlock" => Indicates that O_EXLOCK should be used. Default is true.
# Optionally a reference to a scalar can be passed into the function
# On error this will be used to store the reason for the error
# "ErrStr" => \$errstr
# "open" and "mkdir" can not both be true
# "unlink_on_close" is not used when "mkdir" is true.
# The default options are equivalent to mktemp().
# Returns:
# filehandle - open file handle (if called with doopen=1, else undef)
# temp name - name of the temp file or directory
# For example:
# ($fh, $name) = _gettemp($template, "open" => 1);
# for the current version, failures are associated with
# stored in an error string and returned to give the reason whilst debugging
# This routine is not called by any external function
sub _gettemp {
croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);'
unless scalar(@_) >= 1;
# the internal error string - expect it to be overridden
# Need this in case the caller decides not to supply us a value
# need an anonymous scalar
my $tempErrStr;
# Default options
my %options = (
"open" => 0,
"mkdir" => 0,
"suffixlen" => 0,
"unlink_on_close" => 0,
"use_exlock" => 1,
"ErrStr" => \$tempErrStr,
);
# Read the template
my $template = shift;
if (ref($template)) {
# Use a warning here since we have not yet merged ErrStr
carp "File::Temp::_gettemp: template must not be a reference";
return ();
}
# Check that the number of entries on stack are even
if (scalar(@_) % 2 != 0) {
# Use a warning here since we have not yet merged ErrStr
carp "File::Temp::_gettemp: Must have even number of options";
return ();
}
# Read the options and merge with defaults
%options = (%options, @_) if @_;
# Make sure the error string is set to undef
${$options{ErrStr}} = undef;
# Can not open the file and make a directory in a single call
if ($options{"open"} && $options{"mkdir"}) {
${$options{ErrStr}} = "doopen and domkdir can not both be true\n";
return ();
}
# Find the start of the end of the Xs (position of last X)
# Substr starts from 0
my $start = length($template) - 1 - $options{"suffixlen"};
# Check that we have at least MINX x X (e.g. 'XXXX") at the end of the string
# (taking suffixlen into account). Any fewer is insecure.
# Do it using substr - no reason to use a pattern match since
# we know where we are looking and what we are looking for
if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) {
${$options{ErrStr}} = "The template must end with at least ".
MINX . " 'X' characters\n";
return ();
}
# Replace all the X at the end of the substring with a
# random character or just all the XX at the end of a full string.
# Do it as an if, since the suffix adjusts which section to replace
# and suffixlen=0 returns nothing if used in the substr directly
# and generate a full path from the template
my $path = _replace_XX($template, $options{"suffixlen"});
# Split the path into constituent parts - eventually we need to check
# whether the directory exists
# We need to know whether we are making a temp directory
# or a tempfile
my ($volume, $directories, $file);
my $parent; # parent directory
if ($options{"mkdir"}) {
# There is no filename at the end
($volume, $directories, $file) = File::Spec->splitpath( $path, 1);
# The parent is then $directories without the last directory
# Split the directory and put it back together again
my @dirs = File::Spec->splitdir($directories);
# If @dirs only has one entry (i.e. the directory template) that means
# we are in the current directory
if ($#dirs == 0) {
$parent = File::Spec->curdir;
} else {
if ($^O eq 'VMS') { # need volume to avoid relative dir spec
$parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]);
$parent = 'sys$disk:[]' if $parent eq '';
} else {
# Put it back together without the last one
$parent = File::Spec->catdir(@dirs[0..$#dirs-1]);
# ...and attach the volume (no filename)
$parent = File::Spec->catpath($volume, $parent, '');
}
}
} else {
# Get rid of the last filename (use File::Basename for this?)
($volume, $directories, $file) = File::Spec->splitpath( $path );
# Join up without the file part
$parent = File::Spec->catpath($volume,$directories,'');
# If $parent is empty replace with curdir
$parent = File::Spec->curdir
unless $directories ne '';
}
# Check that the parent directories exist
# Do this even for the case where we are simply returning a name
# not a file -- no point returning a name that includes a directory
# that does not exist or is not writable
unless (-e $parent) {
${$options{ErrStr}} = "Parent directory ($parent) does not exist";
return ();
}
unless (-d $parent) {
${$options{ErrStr}} = "Parent directory ($parent) is not a directory";
return ();
}
# Check the stickiness of the directory and chown giveaway if required
# If the directory is world writable the sticky bit
# must be set
if (File::Temp->safe_level == MEDIUM) {
my $safeerr;
unless (_is_safe($parent,\$safeerr)) {
${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
return ();
}
} elsif (File::Temp->safe_level == HIGH) {
my $safeerr;
unless (_is_verysafe($parent, \$safeerr)) {
${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
return ();
}
}
# Now try MAX_TRIES time to open the file
for (my $i = 0; $i < MAX_TRIES; $i++) {
# Try to open the file if requested
if ($options{"open"}) {
my $fh;
# If we are running before perl5.6.0 we can not auto-vivify
if ($] < 5.006) {
$fh = &Symbol::gensym;
}
# Try to make sure this will be marked close-on-exec
# XXX: Win32 doesn't respect this, nor the proper fcntl,
# but may have O_NOINHERIT. This may or may not be in Fcntl.
local $^F = 2;
# Attempt to open the file
my $open_success = undef;
if ( $^O eq 'VMS' and $options{"unlink_on_close"} && !$KEEP_ALL) {
# make it auto delete on close by setting FAB$V_DLT bit
$fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt');
$open_success = $fh;
} else {
my $flags = ( ($options{"unlink_on_close"} && !$KEEP_ALL) ?
$OPENTEMPFLAGS :
$OPENFLAGS );
$flags |= $LOCKFLAG if (defined $LOCKFLAG && $options{use_exlock});
$open_success = sysopen($fh, $path, $flags, 0600);
}
if ( $open_success ) {
# in case of odd umask force rw
chmod(0600, $path);
# Opened successfully - return file handle and name
return ($fh, $path);
} else {
# Error opening file - abort with error
# if the reason was anything but EEXIST
unless ($!{EEXIST}) {
${$options{ErrStr}} = "Could not create temp file $path: $!";
return ();
}
# Loop round for another try
}
} elsif ($options{"mkdir"}) {
# Open the temp directory
if (mkdir( $path, 0700)) {
# in case of odd umask
chmod(0700, $path);
return undef, $path;
} else {
# Abort with error if the reason for failure was anything
# except EEXIST
unless ($!{EEXIST}) {
${$options{ErrStr}} = "Could not create directory $path: $!";
return ();
}
# Loop round for another try
}
} else {
# Return true if the file can not be found
# Directory has been checked previously
return (undef, $path) unless -e $path;
# Try again until MAX_TRIES
}
# Did not successfully open the tempfile/dir
# so try again with a different set of random letters
# No point in trying to increment unless we have only
# 1 X say and the randomness could come up with the same
# file MAX_TRIES in a row.
# Store current attempt - in principal this implies that the
# 3rd time around the open attempt that the first temp file
# name could be generated again. Probably should store each
# attempt and make sure that none are repeated
my $original = $path;
my $counter = 0; # Stop infinite loop
my $MAX_GUESS = 50;
do {
# Generate new name from original template
$path = _replace_XX($template, $options{"suffixlen"});
$counter++;
} until ($path ne $original || $counter > $MAX_GUESS);
# Check for out of control looping
if ($counter > $MAX_GUESS) {
${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)";
return ();
}
}
# If we get here, we have run out of tries
${ $options{ErrStr} } = "Have exceeded the maximum number of attempts ("
. MAX_TRIES . ") to open temp file/dir";
return ();
}
# Internal routine to replace the XXXX... with random characters
# This has to be done by _gettemp() every time it fails to
# open a temp file/dir
# Arguments: $template (the template with XXX),
# $ignore (number of characters at end to ignore)
# Returns: modified template
sub _replace_XX {
croak 'Usage: _replace_XX($template, $ignore)'
unless scalar(@_) == 2;
my ($path, $ignore) = @_;
# Do it as an if, since the suffix adjusts which section to replace
# and suffixlen=0 returns nothing if used in the substr directly
# Alternatively, could simply set $ignore to length($path)-1
# Don't want to always use substr when not required though.
my $end = ( $] >= 5.006 ? "\\z" : "\\Z" );
if ($ignore) {
substr($path, 0, - $ignore) =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge;
} else {
$path =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge;
}
return $path;
}
# Internal routine to force a temp file to be writable after
# it is created so that we can unlink it. Windows seems to occasionally
# force a file to be readonly when written to certain temp locations
sub _force_writable {
my $file = shift;
chmod 0600, $file;
}
# internal routine to check to see if the directory is safe
# First checks to see if the directory is not owned by the
# current user or root. Then checks to see if anyone else
# can write to the directory and if so, checks to see if
# it has the sticky bit set
# Will not work on systems that do not support sticky bit
#Args: directory path to check
# Optionally: reference to scalar to contain error message
# Returns true if the path is safe and false otherwise.
# Returns undef if can not even run stat() on the path
# This routine based on version written by Tom Christiansen
# Presumably, by the time we actually attempt to create the
# file or directory in this directory, it may not be safe
# anymore... Have to run _is_safe directly after the open.
sub _is_safe {
my $path = shift;
my $err_ref = shift;
# Stat path
my @info = stat($path);
unless (scalar(@info)) {
$$err_ref = "stat(path) returned no values";
return 0;
}
;
return 1 if $^O eq 'VMS'; # owner delete control at file level
# Check to see whether owner is neither superuser (or a system uid) nor me
# Use the effective uid from the $> variable
# UID is in [4]
if ($info[4] > File::Temp->top_system_uid() && $info[4] != $>) {
Carp::cluck(sprintf "uid=$info[4] topuid=%s euid=$> path='$path'",
File::Temp->top_system_uid());
$$err_ref = "Directory owned neither by root nor the current user"
if ref($err_ref);
return 0;
}
# check whether group or other can write file
# use 066 to detect either reading or writing
# use 022 to check writability
# Do it with S_IWOTH and S_IWGRP for portability (maybe)
# mode is in info[2]
if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable?
($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable?
# Must be a directory
unless (-d $path) {
$$err_ref = "Path ($path) is not a directory"
if ref($err_ref);
return 0;
}
# Must have sticky bit set
unless (-k $path) {
$$err_ref = "Sticky bit not set on $path when dir is group|world writable"
if ref($err_ref);
return 0;
}
}
return 1;
}
# Internal routine to check whether a directory is safe
# for temp files. Safer than _is_safe since it checks for
# the possibility of chown giveaway and if that is a possibility
# checks each directory in the path to see if it is safe (with _is_safe)
# If _PC_CHOWN_RESTRICTED is not set, does the full test of each
# directory anyway.
# Takes optional second arg as scalar ref to error reason
sub _is_verysafe {
# Need POSIX - but only want to bother if really necessary due to overhead
require POSIX;
my $path = shift;
print "_is_verysafe testing $path\n" if $DEBUG;
return 1 if $^O eq 'VMS'; # owner delete control at file level
my $err_ref = shift;
# Should Get the value of _PC_CHOWN_RESTRICTED if it is defined
# and If it is not there do the extensive test
local($@);
my $chown_restricted;
$chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED()
if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1};
# If chown_resticted is set to some value we should test it
if (defined $chown_restricted) {
# Return if the current directory is safe
return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted );
}
# To reach this point either, the _PC_CHOWN_RESTRICTED symbol
# was not available or the symbol was there but chown giveaway
# is allowed. Either way, we now have to test the entire tree for
# safety.
# Convert path to an absolute directory if required
unless (File::Spec->file_name_is_absolute($path)) {
$path = File::Spec->rel2abs($path);
}
# Split directory into components - assume no file
my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1);
# Slightly less efficient than having a function in File::Spec
# to chop off the end of a directory or even a function that
# can handle ../ in a directory tree
# Sometimes splitdir() returns a blank at the end
# so we will probably check the bottom directory twice in some cases
my @dirs = File::Spec->splitdir($directories);
# Concatenate one less directory each time around
foreach my $pos (0.. $#dirs) {
# Get a directory name
my $dir = File::Spec->catpath($volume,
File::Spec->catdir(@dirs[0.. $#dirs - $pos]),
''
);
print "TESTING DIR $dir\n" if $DEBUG;
# Check the directory
return 0 unless _is_safe($dir,$err_ref);
}
return 1;
}
# internal routine to determine whether unlink works on this
# platform for files that are currently open.
# Returns true if we can, false otherwise.
# Currently WinNT, OS/2 and VMS can not unlink an opened file
# On VMS this is because the O_EXCL flag is used to open the
# temporary file. Currently I do not know enough about the issues
# on VMS to decide whether O_EXCL is a requirement.
sub _can_unlink_opened_file {
if (grep { $^O eq $_ } qw/MSWin32 os2 VMS dos MacOS haiku/) {
return 0;
} else {
return 1;
}
}
# internal routine to decide which security levels are allowed
# see safe_level() for more information on this
# Controls whether the supplied security level is allowed
# $cando = _can_do_level( $level )
sub _can_do_level {
# Get security level
my $level = shift;
# Always have to be able to do STANDARD
return 1 if $level == STANDARD;
# Currently, the systems that can do HIGH or MEDIUM are identical
if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos' || $^O eq 'MacOS' || $^O eq 'mpeix') {
return 0;
} else {
return 1;
}
}
# This routine sets up a deferred unlinking of a specified
# filename and filehandle. It is used in the following cases:
# - Called by unlink0 if an opened file can not be unlinked
# - Called by tempfile() if files are to be removed on shutdown
# - Called by tempdir() if directories are to be removed on shutdown
# Arguments:
# _deferred_unlink( $fh, $fname, $isdir );
#
# - filehandle (so that it can be explicitly closed if open
# - filename (the thing we want to remove)
# - isdir (flag to indicate that we are being given a directory)
# [and hence no filehandle]
# Status is not referred to since all the magic is done with an END block
{
# Will set up two lexical variables to contain all the files to be
# removed. One array for files, another for directories They will
# only exist in this block.
# This means we only have to set up a single END block to remove
# all files.
# in order to prevent child processes inadvertently deleting the parent
# temp files we use a hash to store the temp files and directories
# created by a particular process id.
# %files_to_unlink contains values that are references to an array of
# array references containing the filehandle and filename associated with
# the temp file.
my (%files_to_unlink, %dirs_to_unlink);
# Set up an end block to use these arrays
END {
local($., $@, $!, $^E, $?);
cleanup(at_exit => 1);
}
# Cleanup function. Always triggered on END (with at_exit => 1) but
# can be invoked manually.
sub cleanup {
my %h = @_;
my $at_exit = delete $h{at_exit};
$at_exit = 0 if not defined $at_exit;
{ my @k = sort keys %h; die "unrecognized parameters: @k" if @k }
if (!$KEEP_ALL) {
# Files
my @files = (exists $files_to_unlink{$$} ?
@{ $files_to_unlink{$$} } : () );
foreach my $file (@files) {
# close the filehandle without checking its state
# in order to make real sure that this is closed
# if its already closed then I dont care about the answer
# probably a better way to do this
close($file->[0]); # file handle is [0]
if (-f $file->[1]) { # file name is [1]
_force_writable( $file->[1] ); # for windows
unlink $file->[1] or warn "Error removing ".$file->[1];
}
}
# Dirs
my @dirs = (exists $dirs_to_unlink{$$} ?
@{ $dirs_to_unlink{$$} } : () );
my ($cwd, $cwd_to_remove);
foreach my $dir (@dirs) {
if (-d $dir) {
# Some versions of rmtree will abort if you attempt to remove
# the directory you are sitting in. For automatic cleanup
# at program exit, we avoid this by chdir()ing out of the way
# first. If not at program exit, it's best not to mess with the
# current directory, so just let it fail with a warning.
if ($at_exit) {
$cwd = Cwd::abs_path(File::Spec->curdir) if not defined $cwd;
my $abs = Cwd::abs_path($dir);
if ($abs eq $cwd) {
$cwd_to_remove = $dir;
next;
}
}
eval { rmtree($dir, $DEBUG, 0); };
warn $@ if ($@ && $^W);
}
}
if (defined $cwd_to_remove) {
# We do need to clean up the current directory, and everything
# else is done, so get out of there and remove it.
chdir $cwd_to_remove or die "cannot chdir to $cwd_to_remove: $!";
my $updir = File::Spec->updir;
chdir $updir or die "cannot chdir to $updir: $!";
eval { rmtree($cwd_to_remove, $DEBUG, 0); };
warn $@ if ($@ && $^W);
}
# clear the arrays
@{ $files_to_unlink{$$} } = ()
if exists $files_to_unlink{$$};
@{ $dirs_to_unlink{$$} } = ()
if exists $dirs_to_unlink{$$};
}
}
# This is the sub called to register a file for deferred unlinking
# This could simply store the input parameters and defer everything
# until the END block. For now we do a bit of checking at this
# point in order to make sure that (1) we have a file/dir to delete
# and (2) we have been called with the correct arguments.
sub _deferred_unlink {
croak 'Usage: _deferred_unlink($fh, $fname, $isdir)'
unless scalar(@_) == 3;
my ($fh, $fname, $isdir) = @_;
warn "Setting up deferred removal of $fname\n"
if $DEBUG;
# make sure we save the absolute path for later cleanup
# OK to untaint because we only ever use this internally
# as a file path, never interpolating into the shell
$fname = Cwd::abs_path($fname);
($fname) = $fname =~ /^(.*)$/;
# If we have a directory, check that it is a directory
if ($isdir) {
if (-d $fname) {
# Directory exists so store it
# first on VMS turn []foo into [.foo] for rmtree
$fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS';
$dirs_to_unlink{$$} = []
unless exists $dirs_to_unlink{$$};
push (@{ $dirs_to_unlink{$$} }, $fname);
} else {
carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W;
}
} else {
if (-f $fname) {
# file exists so store handle and name for later removal
$files_to_unlink{$$} = []
unless exists $files_to_unlink{$$};
push(@{ $files_to_unlink{$$} }, [$fh, $fname]);
} else {
carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W;
}
}
}
}
# normalize argument keys to upper case and do consistent handling
# of leading template vs TEMPLATE
sub _parse_args {
my $leading_template = (scalar(@_) % 2 == 1 ? shift(@_) : '' );
my %args = @_;
%args = map { uc($_), $args{$_} } keys %args;
# template (store it in an array so that it will
# disappear from the arg list of tempfile)
my @template = (
exists $args{TEMPLATE} ? $args{TEMPLATE} :
$leading_template ? $leading_template : ()
);
delete $args{TEMPLATE};
return( \@template, \%args );
}
=head1 OBJECT-ORIENTED INTERFACE
This is the primary interface for interacting with
C<File::Temp>. Using the OO interface a temporary file can be created
when the object is constructed and the file can be removed when the
object is no longer required.
Note that there is no method to obtain the filehandle from the
C<File::Temp> object. The object itself acts as a filehandle. The object
isa C<IO::Handle> and isa C<IO::Seekable> so all those methods are
available.
Also, the object is configured such that it stringifies to the name of the
temporary file and so can be compared to a filename directly. It numifies
to the C<refaddr> the same as other handles and so can be compared to other
handles with C<==>.
$fh eq $filename # as a string
$fh != \*STDOUT # as a number
=over 4
=item B<new>
Create a temporary file object.
my $tmp = File::Temp->new();
by default the object is constructed as if C<tempfile>
was called without options, but with the additional behaviour
that the temporary file is removed by the object destructor
if UNLINK is set to true (the default).
Supported arguments are the same as for C<tempfile>: UNLINK
(defaulting to true), DIR, EXLOCK and SUFFIX. Additionally, the filename
template is specified using the TEMPLATE option. The OPEN option
is not supported (the file is always opened).
$tmp = File::Temp->new( TEMPLATE => 'tempXXXXX',
DIR => 'mydir',
SUFFIX => '.dat');
Arguments are case insensitive.
Can call croak() if an error occurs.
=cut
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my ($maybe_template, $args) = _parse_args(@_);
# see if they are unlinking (defaulting to yes)
my $unlink = (exists $args->{UNLINK} ? $args->{UNLINK} : 1 );
delete $args->{UNLINK};
# Protect OPEN
delete $args->{OPEN};
# Open the file and retain file handle and file name
my ($fh, $path) = tempfile( @$maybe_template, %$args );
print "Tmp: $fh - $path\n" if $DEBUG;
# Store the filename in the scalar slot
${*$fh} = $path;
# Cache the filename by pid so that the destructor can decide whether to remove it
$FILES_CREATED_BY_OBJECT{$$}{$path} = 1;
# Store unlink information in hash slot (plus other constructor info)
%{*$fh} = %$args;
# create the object
bless $fh, $class;
# final method-based configuration
$fh->unlink_on_destroy( $unlink );
return $fh;
}
=item B<newdir>
Create a temporary directory using an object oriented interface.
$dir = File::Temp->newdir();
By default the directory is deleted when the object goes out of scope.
Supports the same options as the C<tempdir> function. Note that directories
created with this method default to CLEANUP => 1.
$dir = File::Temp->newdir( $template, %options );
A template may be specified either with a leading template or
with a TEMPLATE argument.
=cut
sub newdir {
my $self = shift;
my ($maybe_template, $args) = _parse_args(@_);
# handle CLEANUP without passing CLEANUP to tempdir
my $cleanup = (exists $args->{CLEANUP} ? $args->{CLEANUP} : 1 );
delete $args->{CLEANUP};
my $tempdir = tempdir( @$maybe_template, %$args);
# get a safe absolute path for cleanup, just like
# happens in _deferred_unlink
my $real_dir = Cwd::abs_path( $tempdir );
($real_dir) = $real_dir =~ /^(.*)$/;
return bless { DIRNAME => $tempdir,
REALNAME => $real_dir,
CLEANUP => $cleanup,
LAUNCHPID => $$,
}, "File::Temp::Dir";
}
=item B<filename>
Return the name of the temporary file associated with this object
(if the object was created using the "new" constructor).
$filename = $tmp->filename;
This method is called automatically when the object is used as
a string.
=cut
sub filename {
my $self = shift;
return ${*$self};
}
sub STRINGIFY {
my $self = shift;
return $self->filename;
}
# For reference, can't use '0+'=>\&Scalar::Util::refaddr directly because
# refaddr() demands one parameter only, whereas overload.pm calls with three
# even for unary operations like '0+'.
sub NUMIFY {
return refaddr($_[0]);
}
=item B<dirname>
Return the name of the temporary directory associated with this
object (if the object was created using the "newdir" constructor).
$dirname = $tmpdir->dirname;
This method is called automatically when the object is used in string context.
=item B<unlink_on_destroy>
Control whether the file is unlinked when the object goes out of scope.
The file is removed if this value is true and $KEEP_ALL is not.
$fh->unlink_on_destroy( 1 );
Default is for the file to be removed.
=cut
sub unlink_on_destroy {
my $self = shift;
if (@_) {
${*$self}{UNLINK} = shift;
}
return ${*$self}{UNLINK};
}
=item B<DESTROY>
When the object goes out of scope, the destructor is called. This
destructor will attempt to unlink the file (using L<unlink1|"unlink1">)
if the constructor was called with UNLINK set to 1 (the default state
if UNLINK is not specified).
No error is given if the unlink fails.
If the object has been passed to a child process during a fork, the
file will be deleted when the object goes out of scope in the parent.
For a temporary directory object the directory will be removed unless
the CLEANUP argument was used in the constructor (and set to false) or
C<unlink_on_destroy> was modified after creation. Note that if a temp
directory is your current directory, it cannot be removed - a warning
will be given in this case. C<chdir()> out of the directory before
letting the object go out of scope.
If the global variable $KEEP_ALL is true, the file or directory
will not be removed.
=cut
sub DESTROY {
local($., $@, $!, $^E, $?);
my $self = shift;
# Make sure we always remove the file from the global hash
# on destruction. This prevents the hash from growing uncontrollably
# and post-destruction there is no reason to know about the file.
my $file = $self->filename;
my $was_created_by_proc;
if (exists $FILES_CREATED_BY_OBJECT{$$}{$file}) {
$was_created_by_proc = 1;
delete $FILES_CREATED_BY_OBJECT{$$}{$file};
}
if (${*$self}{UNLINK} && !$KEEP_ALL) {
print "# ---------> Unlinking $self\n" if $DEBUG;
# only delete if this process created it
return unless $was_created_by_proc;
# The unlink1 may fail if the file has been closed
# by the caller. This leaves us with the decision
# of whether to refuse to remove the file or simply
# do an unlink without test. Seems to be silly
# to do this when we are trying to be careful
# about security
_force_writable( $file ); # for windows
unlink1( $self, $file )
or unlink($file);
}
}
=back
=head1 FUNCTIONS
This section describes the recommended interface for generating
temporary files and directories.
=over 4
=item B<tempfile>
This is the basic function to generate temporary files.
The behaviour of the file can be changed using various options:
$fh = tempfile();
($fh, $filename) = tempfile();
Create a temporary file in the directory specified for temporary
files, as specified by the tmpdir() function in L<File::Spec>.
($fh, $filename) = tempfile($template);
Create a temporary file in the current directory using the supplied
template. Trailing `X' characters are replaced with random letters to
generate the filename. At least four `X' characters must be present
at the end of the template.
($fh, $filename) = tempfile($template, SUFFIX => $suffix)
Same as previously, except that a suffix is added to the template
after the `X' translation. Useful for ensuring that a temporary
filename has a particular extension when needed by other applications.
But see the WARNING at the end.
($fh, $filename) = tempfile($template, DIR => $dir);
Translates the template as before except that a directory name
is specified.
($fh, $filename) = tempfile($template, TMPDIR => 1);
Equivalent to specifying a DIR of "File::Spec->tmpdir", writing the file
into the same temporary directory as would be used if no template was
specified at all.
($fh, $filename) = tempfile($template, UNLINK => 1);
Return the filename and filehandle as before except that the file is
automatically removed when the program exits (dependent on
$KEEP_ALL). Default is for the file to be removed if a file handle is
requested and to be kept if the filename is requested. In a scalar
context (where no filename is returned) the file is always deleted
either (depending on the operating system) on exit or when it is
closed (unless $KEEP_ALL is true when the temp file is created).
Use the object-oriented interface if fine-grained control of when
a file is removed is required.
If the template is not specified, a template is always
automatically generated. This temporary file is placed in tmpdir()
(L<File::Spec>) unless a directory is specified explicitly with the
DIR option.
$fh = tempfile( DIR => $dir );
If called in scalar context, only the filehandle is returned and the
file will automatically be deleted when closed on operating systems
that support this (see the description of tmpfile() elsewhere in this
document). This is the preferred mode of operation, as if you only
have a filehandle, you can never create a race condition by fumbling
with the filename. On systems that can not unlink an open file or can
not mark a file as temporary when it is opened (for example, Windows
NT uses the C<O_TEMPORARY> flag) the file is marked for deletion when
the program ends (equivalent to setting UNLINK to 1). The C<UNLINK>
flag is ignored if present.
(undef, $filename) = tempfile($template, OPEN => 0);
This will return the filename based on the template but
will not open this file. Cannot be used in conjunction with
UNLINK set to true. Default is to always open the file
to protect from possible race conditions. A warning is issued
if warnings are turned on. Consider using the tmpnam()
and mktemp() functions described elsewhere in this document
if opening the file is not required.
If the operating system supports it (for example BSD derived systems), the
filehandle will be opened with O_EXLOCK (open with exclusive file lock).
This can sometimes cause problems if the intention is to pass the filename
to another system that expects to take an exclusive lock itself (such as
DBD::SQLite) whilst ensuring that the tempfile is not reused. In this
situation the "EXLOCK" option can be passed to tempfile. By default EXLOCK
will be true (this retains compatibility with earlier releases).
($fh, $filename) = tempfile($template, EXLOCK => 0);
Options can be combined as required.
Will croak() if there is an error.
=cut
sub tempfile {
if ( @_ && $_[0] eq 'File::Temp' ) {
croak "'tempfile' can't be called as a method";
}
# Can not check for argument count since we can have any
# number of args
# Default options
my %options = (
"DIR" => undef, # Directory prefix
"SUFFIX" => '', # Template suffix
"UNLINK" => 0, # Do not unlink file on exit
"OPEN" => 1, # Open file
"TMPDIR" => 0, # Place tempfile in tempdir if template specified
"EXLOCK" => 1, # Open file with O_EXLOCK
);
# Check to see whether we have an odd or even number of arguments
my ($maybe_template, $args) = _parse_args(@_);
my $template = @$maybe_template ? $maybe_template->[0] : undef;
# Read the options and merge with defaults
%options = (%options, %$args);
# First decision is whether or not to open the file
if (! $options{"OPEN"}) {
warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n"
if $^W;
}
if ($options{"DIR"} and $^O eq 'VMS') {
# on VMS turn []foo into [.foo] for concatenation
$options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"});
}
# Construct the template
# Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc
# functions or simply constructing a template and using _gettemp()
# explicitly. Go for the latter
# First generate a template if not defined and prefix the directory
# If no template must prefix the temp directory
if (defined $template) {
# End up with current directory if neither DIR not TMPDIR are set
if ($options{"DIR"}) {
$template = File::Spec->catfile($options{"DIR"}, $template);
} elsif ($options{TMPDIR}) {
$template = File::Spec->catfile(File::Spec->tmpdir, $template );
}
} else {
if ($options{"DIR"}) {
$template = File::Spec->catfile($options{"DIR"}, TEMPXXX);
} else {
$template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX);
}
}
# Now add a suffix
$template .= $options{"SUFFIX"};
# Determine whether we should tell _gettemp to unlink the file
# On unix this is irrelevant and can be worked out after the file is
# opened (simply by unlinking the open filehandle). On Windows or VMS
# we have to indicate temporary-ness when we open the file. In general
# we only want a true temporary file if we are returning just the
# filehandle - if the user wants the filename they probably do not
# want the file to disappear as soon as they close it (which may be
# important if they want a child process to use the file)
# For this reason, tie unlink_on_close to the return context regardless
# of OS.
my $unlink_on_close = ( wantarray ? 0 : 1);
# Create the file
my ($fh, $path, $errstr);
croak "Error in tempfile() using template $template: $errstr"
unless (($fh, $path) = _gettemp($template,
"open" => $options{'OPEN'},
"mkdir"=> 0 ,
"unlink_on_close" => $unlink_on_close,
"suffixlen" => length($options{'SUFFIX'}),
"ErrStr" => \$errstr,
"use_exlock" => $options{EXLOCK},
) );
# Set up an exit handler that can do whatever is right for the
# system. This removes files at exit when requested explicitly or when
# system is asked to unlink_on_close but is unable to do so because
# of OS limitations.
# The latter should be achieved by using a tied filehandle.
# Do not check return status since this is all done with END blocks.
_deferred_unlink($fh, $path, 0) if $options{"UNLINK"};
# Return
if (wantarray()) {
if ($options{'OPEN'}) {
return ($fh, $path);
} else {
return (undef, $path);
}
} else {
# Unlink the file. It is up to unlink0 to decide what to do with
# this (whether to unlink now or to defer until later)
unlink0($fh, $path) or croak "Error unlinking file $path using unlink0";
# Return just the filehandle.
return $fh;
}
}
=item B<tempdir>
This is the recommended interface for creation of temporary
directories. By default the directory will not be removed on exit
(that is, it won't be temporary; this behaviour can not be changed
because of issues with backwards compatibility). To enable removal
either use the CLEANUP option which will trigger removal on program
exit, or consider using the "newdir" method in the object interface which
will allow the directory to be cleaned up when the object goes out of
scope.
The behaviour of the function depends on the arguments:
$tempdir = tempdir();
Create a directory in tmpdir() (see L<File::Spec|File::Spec>).
$tempdir = tempdir( $template );
Create a directory from the supplied template. This template is
similar to that described for tempfile(). `X' characters at the end
of the template are replaced with random letters to construct the
directory name. At least four `X' characters must be in the template.
$tempdir = tempdir ( DIR => $dir );
Specifies the directory to use for the temporary directory.
The temporary directory name is derived from an internal template.
$tempdir = tempdir ( $template, DIR => $dir );
Prepend the supplied directory name to the template. The template
should not include parent directory specifications itself. Any parent
directory specifications are removed from the template before
prepending the supplied directory.
$tempdir = tempdir ( $template, TMPDIR => 1 );
Using the supplied template, create the temporary directory in
a standard location for temporary files. Equivalent to doing
$tempdir = tempdir ( $template, DIR => File::Spec->tmpdir);
but shorter. Parent directory specifications are stripped from the
template itself. The C<TMPDIR> option is ignored if C<DIR> is set
explicitly. Additionally, C<TMPDIR> is implied if neither a template
nor a directory are supplied.
$tempdir = tempdir( $template, CLEANUP => 1);
Create a temporary directory using the supplied template, but
attempt to remove it (and all files inside it) when the program
exits. Note that an attempt will be made to remove all files from
the directory even if they were not created by this module (otherwise
why ask to clean it up?). The directory removal is made with
the rmtree() function from the L<File::Path|File::Path> module.
Of course, if the template is not specified, the temporary directory
will be created in tmpdir() and will also be removed at program exit.
Will croak() if there is an error.
=cut
# '
sub tempdir {
if ( @_ && $_[0] eq 'File::Temp' ) {
croak "'tempdir' can't be called as a method";
}
# Can not check for argument count since we can have any
# number of args
# Default options
my %options = (
"CLEANUP" => 0, # Remove directory on exit
"DIR" => '', # Root directory
"TMPDIR" => 0, # Use tempdir with template
);
# Check to see whether we have an odd or even number of arguments
my ($maybe_template, $args) = _parse_args(@_);
my $template = @$maybe_template ? $maybe_template->[0] : undef;
# Read the options and merge with defaults
%options = (%options, %$args);
# Modify or generate the template
# Deal with the DIR and TMPDIR options
if (defined $template) {
# Need to strip directory path if using DIR or TMPDIR
if ($options{'TMPDIR'} || $options{'DIR'}) {
# Strip parent directory from the filename
#
# There is no filename at the end
$template = VMS::Filespec::vmspath($template) if $^O eq 'VMS';
my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1);
# Last directory is then our template
$template = (File::Spec->splitdir($directories))[-1];
# Prepend the supplied directory or temp dir
if ($options{"DIR"}) {
$template = File::Spec->catdir($options{"DIR"}, $template);
} elsif ($options{TMPDIR}) {
# Prepend tmpdir
$template = File::Spec->catdir(File::Spec->tmpdir, $template);
}
}
} else {
if ($options{"DIR"}) {
$template = File::Spec->catdir($options{"DIR"}, TEMPXXX);
} else {
$template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX);
}
}
# Create the directory
my $tempdir;
my $suffixlen = 0;
if ($^O eq 'VMS') { # dir names can end in delimiters
$template =~ m/([\.\]:>]+)$/;
$suffixlen = length($1);
}
if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) {
# dir name has a trailing ':'
++$suffixlen;
}
my $errstr;
croak "Error in tempdir() using $template: $errstr"
unless ((undef, $tempdir) = _gettemp($template,
"open" => 0,
"mkdir"=> 1 ,
"suffixlen" => $suffixlen,
"ErrStr" => \$errstr,
) );
# Install exit handler; must be dynamic to get lexical
if ( $options{'CLEANUP'} && -d $tempdir) {
_deferred_unlink(undef, $tempdir, 1);
}
# Return the dir name
return $tempdir;
}
=back
=head1 MKTEMP FUNCTIONS
The following functions are Perl implementations of the
mktemp() family of temp file generation system calls.
=over 4
=item B<mkstemp>
Given a template, returns a filehandle to the temporary file and the name
of the file.
($fh, $name) = mkstemp( $template );
In scalar context, just the filehandle is returned.
The template may be any filename with some number of X's appended
to it, for example F</tmp/temp.XXXX>. The trailing X's are replaced
with unique alphanumeric combinations.
Will croak() if there is an error.
=cut
sub mkstemp {
croak "Usage: mkstemp(template)"
if scalar(@_) != 1;
my $template = shift;
my ($fh, $path, $errstr);
croak "Error in mkstemp using $template: $errstr"
unless (($fh, $path) = _gettemp($template,
"open" => 1,
"mkdir"=> 0 ,
"suffixlen" => 0,
"ErrStr" => \$errstr,
) );
if (wantarray()) {
return ($fh, $path);
} else {
return $fh;
}
}
=item B<mkstemps>
Similar to mkstemp(), except that an extra argument can be supplied
with a suffix to be appended to the template.
($fh, $name) = mkstemps( $template, $suffix );
For example a template of C<testXXXXXX> and suffix of C<.dat>
would generate a file similar to F<testhGji_w.dat>.
Returns just the filehandle alone when called in scalar context.
Will croak() if there is an error.
=cut
sub mkstemps {
croak "Usage: mkstemps(template, suffix)"
if scalar(@_) != 2;
my $template = shift;
my $suffix = shift;
$template .= $suffix;
my ($fh, $path, $errstr);
croak "Error in mkstemps using $template: $errstr"
unless (($fh, $path) = _gettemp($template,
"open" => 1,
"mkdir"=> 0 ,
"suffixlen" => length($suffix),
"ErrStr" => \$errstr,
) );
if (wantarray()) {
return ($fh, $path);
} else {
return $fh;
}
}
=item B<mkdtemp>
Create a directory from a template. The template must end in
X's that are replaced by the routine.
$tmpdir_name = mkdtemp($template);
Returns the name of the temporary directory created.
Directory must be removed by the caller.
Will croak() if there is an error.
=cut
#' # for emacs
sub mkdtemp {
croak "Usage: mkdtemp(template)"
if scalar(@_) != 1;
my $template = shift;
my $suffixlen = 0;
if ($^O eq 'VMS') { # dir names can end in delimiters
$template =~ m/([\.\]:>]+)$/;
$suffixlen = length($1);
}
if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) {
# dir name has a trailing ':'
++$suffixlen;
}
my ($junk, $tmpdir, $errstr);
croak "Error creating temp directory from template $template\: $errstr"
unless (($junk, $tmpdir) = _gettemp($template,
"open" => 0,
"mkdir"=> 1 ,
"suffixlen" => $suffixlen,
"ErrStr" => \$errstr,
) );
return $tmpdir;
}
=item B<mktemp>
Returns a valid temporary filename but does not guarantee
that the file will not be opened by someone else.
$unopened_file = mktemp($template);
Template is the same as that required by mkstemp().
Will croak() if there is an error.
=cut
sub mktemp {
croak "Usage: mktemp(template)"
if scalar(@_) != 1;
my $template = shift;
my ($tmpname, $junk, $errstr);
croak "Error getting name to temp file from template $template: $errstr"
unless (($junk, $tmpname) = _gettemp($template,
"open" => 0,
"mkdir"=> 0 ,
"suffixlen" => 0,
"ErrStr" => \$errstr,
) );
return $tmpname;
}
=back
=head1 POSIX FUNCTIONS
This section describes the re-implementation of the tmpnam()
and tmpfile() functions described in L<POSIX>
using the mkstemp() from this module.
Unlike the L<POSIX|POSIX> implementations, the directory used
for the temporary file is not specified in a system include
file (C<P_tmpdir>) but simply depends on the choice of tmpdir()
returned by L<File::Spec|File::Spec>. On some implementations this
location can be set using the C<TMPDIR> environment variable, which
may not be secure.
If this is a problem, simply use mkstemp() and specify a template.
=over 4
=item B<tmpnam>
When called in scalar context, returns the full name (including path)
of a temporary file (uses mktemp()). The only check is that the file does
not already exist, but there is no guarantee that that condition will
continue to apply.
$file = tmpnam();
When called in list context, a filehandle to the open file and
a filename are returned. This is achieved by calling mkstemp()
after constructing a suitable template.
($fh, $file) = tmpnam();
If possible, this form should be used to prevent possible
race conditions.
See L<File::Spec/tmpdir> for information on the choice of temporary
directory for a particular operating system.
Will croak() if there is an error.
=cut
sub tmpnam {
# Retrieve the temporary directory name
my $tmpdir = File::Spec->tmpdir;
croak "Error temporary directory is not writable"
if $tmpdir eq '';
# Use a ten character template and append to tmpdir
my $template = File::Spec->catfile($tmpdir, TEMPXXX);
if (wantarray() ) {
return mkstemp($template);
} else {
return mktemp($template);
}
}
=item B<tmpfile>
Returns the filehandle of a temporary file.
$fh = tmpfile();
The file is removed when the filehandle is closed or when the program
exits. No access to the filename is provided.
If the temporary file can not be created undef is returned.
Currently this command will probably not work when the temporary
directory is on an NFS file system.
Will croak() if there is an error.
=cut
sub tmpfile {
# Simply call tmpnam() in a list context
my ($fh, $file) = tmpnam();
# Make sure file is removed when filehandle is closed
# This will fail on NFS
unlink0($fh, $file)
or return undef;
return $fh;
}
=back
=head1 ADDITIONAL FUNCTIONS
These functions are provided for backwards compatibility
with common tempfile generation C library functions.
They are not exported and must be addressed using the full package
name.
=over 4
=item B<tempnam>
Return the name of a temporary file in the specified directory
using a prefix. The file is guaranteed not to exist at the time
the function was called, but such guarantees are good for one
clock tick only. Always use the proper form of C<sysopen>
with C<O_CREAT | O_EXCL> if you must open such a filename.
$filename = File::Temp::tempnam( $dir, $prefix );
Equivalent to running mktemp() with $dir/$prefixXXXXXXXX
(using unix file convention as an example)
Because this function uses mktemp(), it can suffer from race conditions.
Will croak() if there is an error.
=cut
sub tempnam {
croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2;
my ($dir, $prefix) = @_;
# Add a string to the prefix
$prefix .= 'XXXXXXXX';
# Concatenate the directory to the file
my $template = File::Spec->catfile($dir, $prefix);
return mktemp($template);
}
=back
=head1 UTILITY FUNCTIONS
Useful functions for dealing with the filehandle and filename.
=over 4
=item B<unlink0>
Given an open filehandle and the associated filename, make a safe
unlink. This is achieved by first checking that the filename and
filehandle initially point to the same file and that the number of
links to the file is 1 (all fields returned by stat() are compared).
Then the filename is unlinked and the filehandle checked once again to
verify that the number of links on that file is now 0. This is the
closest you can come to making sure that the filename unlinked was the
same as the file whose descriptor you hold.
unlink0($fh, $path)
or die "Error unlinking file $path safely";
Returns false on error but croaks() if there is a security
anomaly. The filehandle is not closed since on some occasions this is
not required.
On some platforms, for example Windows NT, it is not possible to
unlink an open file (the file must be closed first). On those
platforms, the actual unlinking is deferred until the program ends and
good status is returned. A check is still performed to make sure that
the filehandle and filename are pointing to the same thing (but not at
the time the end block is executed since the deferred removal may not
have access to the filehandle).
Additionally, on Windows NT not all the fields returned by stat() can
be compared. For example, the C<dev> and C<rdev> fields seem to be
different. Also, it seems that the size of the file returned by stat()
does not always agree, with C<stat(FH)> being more accurate than
C<stat(filename)>, presumably because of caching issues even when
using autoflush (this is usually overcome by waiting a while after
writing to the tempfile before attempting to C<unlink0> it).
Finally, on NFS file systems the link count of the file handle does
not always go to zero immediately after unlinking. Currently, this
command is expected to fail on NFS disks.
This function is disabled if the global variable $KEEP_ALL is true
and an unlink on open file is supported. If the unlink is to be deferred
to the END block, the file is still registered for removal.
This function should not be called if you are using the object oriented
interface since the it will interfere with the object destructor deleting
the file.
=cut
sub unlink0 {
croak 'Usage: unlink0(filehandle, filename)'
unless scalar(@_) == 2;
# Read args
my ($fh, $path) = @_;
cmpstat($fh, $path) or return 0;
# attempt remove the file (does not work on some platforms)
if (_can_unlink_opened_file()) {
# return early (Without unlink) if we have been instructed to retain files.
return 1 if $KEEP_ALL;
# XXX: do *not* call this on a directory; possible race
# resulting in recursive removal
croak "unlink0: $path has become a directory!" if -d $path;
unlink($path) or return 0;
# Stat the filehandle
my @fh = stat $fh;
print "Link count = $fh[3] \n" if $DEBUG;
# Make sure that the link count is zero
# - Cygwin provides deferred unlinking, however,
# on Win9x the link count remains 1
# On NFS the link count may still be 1 but we can't know that
# we are on NFS. Since we can't be sure, we'll defer it
return 1 if $fh[3] == 0 || $^O eq 'cygwin';
}
# fall-through if we can't unlink now
_deferred_unlink($fh, $path, 0);
return 1;
}
=item B<cmpstat>
Compare C<stat> of filehandle with C<stat> of provided filename. This
can be used to check that the filename and filehandle initially point
to the same file and that the number of links to the file is 1 (all
fields returned by stat() are compared).
cmpstat($fh, $path)
or die "Error comparing handle with file";
Returns false if the stat information differs or if the link count is
greater than 1. Calls croak if there is a security anomaly.
On certain platforms, for example Windows, not all the fields returned by stat()
can be compared. For example, the C<dev> and C<rdev> fields seem to be
different in Windows. Also, it seems that the size of the file
returned by stat() does not always agree, with C<stat(FH)> being more
accurate than C<stat(filename)>, presumably because of caching issues
even when using autoflush (this is usually overcome by waiting a while
after writing to the tempfile before attempting to C<unlink0> it).
Not exported by default.
=cut
sub cmpstat {
croak 'Usage: cmpstat(filehandle, filename)'
unless scalar(@_) == 2;
# Read args
my ($fh, $path) = @_;
warn "Comparing stat\n"
if $DEBUG;
# Stat the filehandle - which may be closed if someone has manually
# closed the file. Can not turn off warnings without using $^W
# unless we upgrade to 5.006 minimum requirement
my @fh;
{
local ($^W) = 0;
@fh = stat $fh;
}
return unless @fh;
if ($fh[3] > 1 && $^W) {
carp "unlink0: fstat found too many links; SB=@fh" if $^W;
}
# Stat the path
my @path = stat $path;
unless (@path) {
carp "unlink0: $path is gone already" if $^W;
return;
}
# this is no longer a file, but may be a directory, or worse
unless (-f $path) {
confess "panic: $path is no longer a file: SB=@fh";
}
# Do comparison of each member of the array
# On WinNT dev and rdev seem to be different
# depending on whether it is a file or a handle.
# Cannot simply compare all members of the stat return
# Select the ones we can use
my @okstat = (0..$#fh); # Use all by default
if ($^O eq 'MSWin32') {
@okstat = (1,2,3,4,5,7,8,9,10);
} elsif ($^O eq 'os2') {
@okstat = (0, 2..$#fh);
} elsif ($^O eq 'VMS') { # device and file ID are sufficient
@okstat = (0, 1);
} elsif ($^O eq 'dos') {
@okstat = (0,2..7,11..$#fh);
} elsif ($^O eq 'mpeix') {
@okstat = (0..4,8..10);
}
# Now compare each entry explicitly by number
for (@okstat) {
print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG;
# Use eq rather than == since rdev, blksize, and blocks (6, 11,
# and 12) will be '' on platforms that do not support them. This
# is fine since we are only comparing integers.
unless ($fh[$_] eq $path[$_]) {
warn "Did not match $_ element of stat\n" if $DEBUG;
return 0;
}
}
return 1;
}
=item B<unlink1>
Similar to C<unlink0> except after file comparison using cmpstat, the
filehandle is closed prior to attempting to unlink the file. This
allows the file to be removed without using an END block, but does
mean that the post-unlink comparison of the filehandle state provided
by C<unlink0> is not available.
unlink1($fh, $path)
or die "Error closing and unlinking file";
Usually called from the object destructor when using the OO interface.
Not exported by default.
This function is disabled if the global variable $KEEP_ALL is true.
Can call croak() if there is a security anomaly during the stat()
comparison.
=cut
sub unlink1 {
croak 'Usage: unlink1(filehandle, filename)'
unless scalar(@_) == 2;
# Read args
my ($fh, $path) = @_;
cmpstat($fh, $path) or return 0;
# Close the file
close( $fh ) or return 0;
# Make sure the file is writable (for windows)
_force_writable( $path );
# return early (without unlink) if we have been instructed to retain files.
return 1 if $KEEP_ALL;
# remove the file
return unlink($path);
}
=item B<cleanup>
Calling this function will cause any temp files or temp directories
that are registered for removal to be removed. This happens automatically
when the process exits but can be triggered manually if the caller is sure
that none of the temp files are required. This method can be registered as
an Apache callback.
Note that if a temp directory is your current directory, it cannot be
removed. C<chdir()> out of the directory first before calling
C<cleanup()>. (For the cleanup at program exit when the CLEANUP flag
is set, this happens automatically.)
On OSes where temp files are automatically removed when the temp file
is closed, calling this function will have no effect other than to remove
temporary directories (which may include temporary files).
File::Temp::cleanup();
Not exported by default.
=back
=head1 PACKAGE VARIABLES
These functions control the global state of the package.
=over 4
=item B<safe_level>
Controls the lengths to which the module will go to check the safety of the
temporary file or directory before proceeding.
Options are:
=over 8
=item STANDARD
Do the basic security measures to ensure the directory exists and is
writable, that temporary files are opened only if they do not already
exist, and that possible race conditions are avoided. Finally the
L<unlink0|"unlink0"> function is used to remove files safely.
=item MEDIUM
In addition to the STANDARD security, the output directory is checked
to make sure that it is owned either by root or the user running the
program. If the directory is writable by group or by other, it is then
checked to make sure that the sticky bit is set.
Will not work on platforms that do not support the C<-k> test
for sticky bit.
=item HIGH
In addition to the MEDIUM security checks, also check for the
possibility of ``chown() giveaway'' using the L<POSIX|POSIX>
sysconf() function. If this is a possibility, each directory in the
path is checked in turn for safeness, recursively walking back to the
root directory.
For platforms that do not support the L<POSIX|POSIX>
C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is
assumed that ``chown() giveaway'' is possible and the recursive test
is performed.
=back
The level can be changed as follows:
File::Temp->safe_level( File::Temp::HIGH );
The level constants are not exported by the module.
Currently, you must be running at least perl v5.6.0 in order to
run with MEDIUM or HIGH security. This is simply because the
safety tests use functions from L<Fcntl|Fcntl> that are not
available in older versions of perl. The problem is that the version
number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though
they are different versions.
On systems that do not support the HIGH or MEDIUM safety levels
(for example Win NT or OS/2) any attempt to change the level will
be ignored. The decision to ignore rather than raise an exception
allows portable programs to be written with high security in mind
for the systems that can support this without those programs failing
on systems where the extra tests are irrelevant.
If you really need to see whether the change has been accepted
simply examine the return value of C<safe_level>.
$newlevel = File::Temp->safe_level( File::Temp::HIGH );
die "Could not change to high security"
if $newlevel != File::Temp::HIGH;
=cut
{
# protect from using the variable itself
my $LEVEL = STANDARD;
sub safe_level {
my $self = shift;
if (@_) {
my $level = shift;
if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) {
carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W;
} else {
# Don't allow this on perl 5.005 or earlier
if ($] < 5.006 && $level != STANDARD) {
# Cant do MEDIUM or HIGH checks
croak "Currently requires perl 5.006 or newer to do the safe checks";
}
# Check that we are allowed to change level
# Silently ignore if we can not.
$LEVEL = $level if _can_do_level($level);
}
}
return $LEVEL;
}
}
=item TopSystemUID
This is the highest UID on the current system that refers to a root
UID. This is used to make sure that the temporary directory is
owned by a system UID (C<root>, C<bin>, C<sys> etc) rather than
simply by root.
This is required since on many unix systems C</tmp> is not owned
by root.
Default is to assume that any UID less than or equal to 10 is a root
UID.
File::Temp->top_system_uid(10);
my $topid = File::Temp->top_system_uid;
This value can be adjusted to reduce security checking if required.
The value is only relevant when C<safe_level> is set to MEDIUM or higher.
=cut
{
my $TopSystemUID = 10;
$TopSystemUID = 197108 if $^O eq 'interix'; # "Administrator"
sub top_system_uid {
my $self = shift;
if (@_) {
my $newuid = shift;
croak "top_system_uid: UIDs should be numeric"
unless $newuid =~ /^\d+$/s;
$TopSystemUID = $newuid;
}
return $TopSystemUID;
}
}
=item B<$KEEP_ALL>
Controls whether temporary files and directories should be retained
regardless of any instructions in the program to remove them
automatically. This is useful for debugging but should not be used in
production code.
$File::Temp::KEEP_ALL = 1;
Default is for files to be removed as requested by the caller.
In some cases, files will only be retained if this variable is true
when the file is created. This means that you can not create a temporary
file, set this variable and expect the temp file to still be around
when the program exits.
=item B<$DEBUG>
Controls whether debugging messages should be enabled.
$File::Temp::DEBUG = 1;
Default is for debugging mode to be disabled.
=back
=head1 WARNING
For maximum security, endeavour always to avoid ever looking at,
touching, or even imputing the existence of the filename. You do not
know that that filename is connected to the same file as the handle
you have, and attempts to check this can only trigger more race
conditions. It's far more secure to use the filehandle alone and
dispense with the filename altogether.
If you need to pass the handle to something that expects a filename
then on a unix system you can use C<"/dev/fd/" . fileno($fh)> for
arbitrary programs. Perl code that uses the 2-argument version of
C<< open >> can be passed C<< "+<=&" . fileno($fh) >>. Otherwise you
will need to pass the filename. You will have to clear the
close-on-exec bit on that file descriptor before passing it to another
process.
use Fcntl qw/F_SETFD F_GETFD/;
fcntl($tmpfh, F_SETFD, 0)
or die "Can't clear close-on-exec flag on temp fh: $!\n";
=head2 Temporary files and NFS
Some problems are associated with using temporary files that reside
on NFS file systems and it is recommended that a local filesystem
is used whenever possible. Some of the security tests will most probably
fail when the temp file is not local. Additionally, be aware that
the performance of I/O operations over NFS will not be as good as for
a local disk.
=head2 Forking
In some cases files created by File::Temp are removed from within an
END block. Since END blocks are triggered when a child process exits
(unless C<POSIX::_exit()> is used by the child) File::Temp takes care
to only remove those temp files created by a particular process ID. This
means that a child will not attempt to remove temp files created by the
parent process.
If you are forking many processes in parallel that are all creating
temporary files, you may need to reset the random number seed using
srand(EXPR) in each child else all the children will attempt to walk
through the same set of random file names and may well cause
themselves to give up if they exceed the number of retry attempts.
=head2 Directory removal
Note that if you have chdir'ed into the temporary directory and it is
subsequently cleaned up (either in the END block or as part of object
destruction), then you will get a warning from File::Path::rmtree().
=head2 Taint mode
If you need to run code under taint mode, updating to the latest
L<File::Spec> is highly recommended.
=head2 BINMODE
The file returned by File::Temp will have been opened in binary mode
if such a mode is available. If that is not correct, use the C<binmode()>
function to change the mode of the filehandle.
Note that you can modify the encoding of a file opened by File::Temp
also by using C<binmode()>.
=head1 HISTORY
Originally began life in May 1999 as an XS interface to the system
mkstemp() function. In March 2000, the OpenBSD mkstemp() code was
translated to Perl for total control of the code's
security checking, to ensure the presence of the function regardless of
operating system and to help with portability. The module was shipped
as a standard part of perl from v5.6.1.
=head1 SEE ALSO
L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path>
See L<IO::File> and L<File::MkTemp>, L<Apache::TempFile> for
different implementations of temporary file handling.
See L<File::Tempdir> for an alternative object-oriented wrapper for
the C<tempdir> function.
=head1 AUTHOR
Tim Jenness E<lt>tjenness@cpan.orgE<gt>
Copyright (C) 2007-2010 Tim Jenness.
Copyright (C) 1999-2007 Tim Jenness and the UK Particle Physics and
Astronomy Research Council. All Rights Reserved. This program is free
software; you can redistribute it and/or modify it under the same
terms as Perl itself.
Original Perl implementation loosely based on the OpenBSD C code for
mkstemp(). Thanks to Tom Christiansen for suggesting that this module
should be written and providing ideas for code improvements and
security enhancements.
=cut
package File::Temp::Dir;
use File::Path qw/ rmtree /;
use strict;
use overload '""' => "STRINGIFY",
'0+' => \&File::Temp::NUMIFY,
fallback => 1;
# private class specifically to support tempdir objects
# created by File::Temp->newdir
# ostensibly the same method interface as File::Temp but without
# inheriting all the IO::Seekable methods and other cruft
# Read-only - returns the name of the temp directory
sub dirname {
my $self = shift;
return $self->{DIRNAME};
}
sub STRINGIFY {
my $self = shift;
return $self->dirname;
}
sub unlink_on_destroy {
my $self = shift;
if (@_) {
$self->{CLEANUP} = shift;
}
return $self->{CLEANUP};
}
sub DESTROY {
my $self = shift;
local($., $@, $!, $^E, $?);
if ($self->unlink_on_destroy &&
$$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) {
if (-d $self->{REALNAME}) {
# Some versions of rmtree will abort if you attempt to remove
# the directory you are sitting in. We protect that and turn it
# into a warning. We do this because this occurs during object
# destruction and so can not be caught by the user.
eval { rmtree($self->{REALNAME}, $File::Temp::DEBUG, 0); };
warn $@ if ($@ && $^W);
}
}
}
1;
# vim: ts=2 sts=2 sw=2 et:
FILE_TEMP
$fatpacked{"File/pushd.pm"} = <<'FILE_PUSHD';
use strict;
use warnings;
package File::pushd;
# ABSTRACT: change directory temporarily for a limited scope
our $VERSION = '1.005'; # VERSION
our @EXPORT = qw( pushd tempd );
our @ISA = qw( Exporter );
use Exporter;
use Carp;
use Cwd qw( getcwd abs_path );
use File::Path qw( rmtree );
use File::Temp qw();
use File::Spec;
use overload
q{""} => sub { File::Spec->canonpath( $_[0]->{_pushd} ) },
fallback => 1;
#--------------------------------------------------------------------------#
# pushd()
#--------------------------------------------------------------------------#
sub pushd {
my ($target_dir, $options) = @_;
$options->{untaint_pattern} ||= qr{^([-+@\w./]+)$};
$target_dir = "." unless defined $target_dir;
croak "Can't locate directory $target_dir" unless -d $target_dir;
my $tainted_orig = getcwd;
my $orig;
if ( $tainted_orig =~ $options->{untaint_pattern} ) {
$orig = $1;
}
else {
$orig = $tainted_orig;
}
my $tainted_dest;
eval { $tainted_dest = $target_dir ? abs_path( $target_dir ) : $orig };
croak "Can't locate absolute path for $target_dir: $@" if $@;
my $dest;
if ( $tainted_dest =~ $options->{untaint_pattern} ) {
$dest = $1;
}
else {
$dest = $tainted_dest;
}
if ($dest ne $orig) {
chdir $dest or croak "Can't chdir to $dest\: $!";
}
my $self = bless {
_pushd => $dest,
_original => $orig
}, __PACKAGE__;
return $self;
}
#--------------------------------------------------------------------------#
# tempd()
#--------------------------------------------------------------------------#
sub tempd {
my ($options) = @_;
my $dir;
eval { $dir = pushd( File::Temp::tempdir( CLEANUP => 0 ), $options ) };
croak $@ if $@;
$dir->{_tempd} = 1;
return $dir;
}
#--------------------------------------------------------------------------#
# preserve()
#--------------------------------------------------------------------------#
sub preserve {
my $self = shift;
return 1 if ! $self->{"_tempd"};
if ( @_ == 0 ) {
return $self->{_preserve} = 1;
}
else {
return $self->{_preserve} = $_[0] ? 1 : 0;
}
}
#--------------------------------------------------------------------------#
# DESTROY()
# Revert to original directory as object is destroyed and cleanup
# if necessary
#--------------------------------------------------------------------------#
sub DESTROY {
my ($self) = @_;
my $orig = $self->{_original};
chdir $orig if $orig; # should always be so, but just in case...
if ( $self->{_tempd} &&
!$self->{_preserve} ) {
# don't destroy existing $@ if there is no error.
my $err = do {
local $@;
eval { rmtree( $self->{_pushd} ) };
$@;
};
carp $err if $err;
}
}
1;
__END__
=pod
=head1 NAME
File::pushd - change directory temporarily for a limited scope
=head1 VERSION
version 1.005
=head1 SYNOPSIS
use File::pushd;
chdir $ENV{HOME};
# change directory again for a limited scope
{
my $dir = pushd( '/tmp' );
# working directory changed to /tmp
}
# working directory has reverted to $ENV{HOME}
# tempd() is equivalent to pushd( File::Temp::tempdir )
{
my $dir = tempd();
}
# object stringifies naturally as an absolute path
{
my $dir = pushd( '/tmp' );
my $filename = File::Spec->catfile( $dir, "somefile.txt" );
# gives /tmp/somefile.txt
}
=head1 DESCRIPTION
File::pushd does a temporary C<<< chdir >>> that is easily and automatically
reverted, similar to C<<< pushd >>> in some Unix command shells. It works by
creating an object that caches the original working directory. When the object
is destroyed, the destructor calls C<<< chdir >>> to revert to the original working
directory. By storing the object in a lexical variable with a limited scope,
this happens automatically at the end of the scope.
This is very handy when working with temporary directories for tasks like
testing; a function is provided to streamline getting a temporary
directory from L<File::Temp>.
For convenience, the object stringifies as the canonical form of the absolute
pathname of the directory entered.
=head1 USAGE
use File::pushd;
Using File::pushd automatically imports the C<<< pushd >>> and C<<< tempd >>> functions.
=head2 pushd
{
my $dir = pushd( $target_directory );
}
Caches the current working directory, calls C<<< chdir >>> to change to the target
directory, and returns a File::pushd object. When the object is
destroyed, the working directory reverts to the original directory.
The provided target directory can be a relative or absolute path. If
called with no arguments, it uses the current directory as its target and
returns to the current directory when the object is destroyed.
If the target directory does not exist or if the directory change fails
for some reason, C<<< pushd >>> will die with an error message.
Can be given a hashref as an optional second argument. The only supported
option is C<<< untaint_pattern >>>, which is used to untaint file paths involved.
It defaults to C<<< qr{^([-+@\w./]+)$} >>>, which is reasonably restrictive (e.g.
it does not even allow spaces in the path). Change this to suit your
circumstances and security needs if running under taint mode. B<Note>: you
must include the parentheses in the pattern to capture the untainted
portion of the path.
=head2 tempd
{
my $dir = tempd();
}
This function is like C<<< pushd >>> but automatically creates and calls C<<< chdir >>> to
a temporary directory created by L<File::Temp>. Unlike normal L<File::Temp>
cleanup which happens at the end of the program, this temporary directory is
removed when the object is destroyed. (But also see C<<< preserve >>>.) A warning
will be issued if the directory cannot be removed.
As with C<<< pushd >>>, C<<< tempd >>> will die if C<<< chdir >>> fails.
It may be given a single options hash that will be passed internally
to CE<lt>pushdE<gt>.
=head2 preserve
{
my $dir = tempd();
$dir->preserve; # mark to preserve at end of scope
$dir->preserve(0); # mark to delete at end of scope
}
Controls whether a temporary directory will be cleaned up when the object is
destroyed. With no arguments, C<<< preserve >>> sets the directory to be preserved.
With an argument, the directory will be preserved if the argument is true, or
marked for cleanup if the argument is false. Only C<<< tempd >>> objects may be
marked for cleanup. (Target directories to C<<< pushd >>> are always preserved.)
C<<< preserve >>> returns true if the directory will be preserved, and false
otherwise.
=head1 SEE ALSO
=over
=item *
L<File::chdir>
=back
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
at L<https://github.com/dagolden/file-pushd/issues>.
You will be notified automatically of any progress on your issue.
=head2 Source Code
This is open source software. The code repository is available for
public review and contribution under the terms of the license.
L<https://github.com/dagolden/file-pushd>
git clone git://github.com/dagolden/file-pushd.git
=head1 AUTHOR
David Golden <dagolden@cpan.org>
=head1 CONTRIBUTOR
Diab Jerius <djerius@cfa.harvard.edu>
=head1 COPYRIGHT AND LICENSE
This software is Copyright (c) 2013 by David A Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
FILE_PUSHD
$fatpacked{"Getopt/Long.pm"} = <<'GETOPT_LONG';
#! perl
# Getopt::Long.pm -- Universal options parsing
# Author : Johan Vromans
# Created On : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
# Last Modified On: Tue Mar 12 14:42:25 2013
# Update Count : 1638
# Status : Released
################ Module Preamble ################
package Getopt::Long;
use 5.004;
use strict;
use vars qw($VERSION);
$VERSION = 2.39;
# For testing versions only.
use vars qw($VERSION_STRING);
$VERSION_STRING = "2.39";
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK);
@ISA = qw(Exporter);
# Exported subroutines.
sub GetOptions(@); # always
sub GetOptionsFromArray(@); # on demand
sub GetOptionsFromString(@); # on demand
sub Configure(@); # on demand
sub HelpMessage(@); # on demand
sub VersionMessage(@); # in demand
BEGIN {
# Init immediately so their contents can be used in the 'use vars' below.
@EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
@EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure
&GetOptionsFromArray &GetOptionsFromString);
}
# User visible variables.
use vars @EXPORT, @EXPORT_OK;
use vars qw($error $debug $major_version $minor_version);
# Deprecated visible variables.
use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
$passthrough);
# Official invisible variables.
use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix);
# Public subroutines.
sub config(@); # deprecated name
# Private subroutines.
sub ConfigDefaults();
sub ParseOptionSpec($$);
sub OptCtl($);
sub FindOption($$$$$);
sub ValidValue ($$$$$);
################ Local Variables ################
# $requested_version holds the version that was mentioned in the 'use'
# or 'require', if any. It can be used to enable or disable specific
# features.
my $requested_version = 0;
################ Resident subroutines ################
sub ConfigDefaults() {
# Handle POSIX compliancy.
if ( defined $ENV{"POSIXLY_CORRECT"} ) {
$genprefix = "(--|-)";
$autoabbrev = 0; # no automatic abbrev of options
$bundling = 0; # no bundling of single letter switches
$getopt_compat = 0; # disallow '+' to start options
$order = $REQUIRE_ORDER;
}
else {
$genprefix = "(--|-|\\+)";
$autoabbrev = 1; # automatic abbrev of options
$bundling = 0; # bundling off by default
$getopt_compat = 1; # allow '+' to start options
$order = $PERMUTE;
}
# Other configurable settings.
$debug = 0; # for debugging
$error = 0; # error tally
$ignorecase = 1; # ignore case when matching options
$passthrough = 0; # leave unrecognized options alone
$gnu_compat = 0; # require --opt=val if value is optional
$longprefix = "(--)"; # what does a long prefix look like
}
# Override import.
sub import {
my $pkg = shift; # package
my @syms = (); # symbols to import
my @config = (); # configuration
my $dest = \@syms; # symbols first
for ( @_ ) {
if ( $_ eq ':config' ) {
$dest = \@config; # config next
next;
}
push(@$dest, $_); # push
}
# Hide one level and call super.
local $Exporter::ExportLevel = 1;
push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions
$requested_version = 0;
$pkg->SUPER::import(@syms);
# And configure.
Configure(@config) if @config;
}
################ Initialization ################
# Values for $order. See GNU getopt.c for details.
($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
# Version major/minor numbers.
($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
ConfigDefaults();
################ OO Interface ################
package Getopt::Long::Parser;
# Store a copy of the default configuration. Since ConfigDefaults has
# just been called, what we get from Configure is the default.
my $default_config = do {
Getopt::Long::Configure ()
};
sub new {
my $that = shift;
my $class = ref($that) || $that;
my %atts = @_;
# Register the callers package.
my $self = { caller_pkg => (caller)[0] };
bless ($self, $class);
# Process config attributes.
if ( defined $atts{config} ) {
my $save = Getopt::Long::Configure ($default_config, @{$atts{config}});
$self->{settings} = Getopt::Long::Configure ($save);
delete ($atts{config});
}
# Else use default config.
else {
$self->{settings} = $default_config;
}
if ( %atts ) { # Oops
die(__PACKAGE__.": unhandled attributes: ".
join(" ", sort(keys(%atts)))."\n");
}
$self;
}
sub configure {
my ($self) = shift;
# Restore settings, merge new settings in.
my $save = Getopt::Long::Configure ($self->{settings}, @_);
# Restore orig config and save the new config.
$self->{settings} = Getopt::Long::Configure ($save);
}
sub getoptions {
my ($self) = shift;
return $self->getoptionsfromarray(\@ARGV, @_);
}
sub getoptionsfromarray {
my ($self) = shift;
# Restore config settings.
my $save = Getopt::Long::Configure ($self->{settings});
# Call main routine.
my $ret = 0;
$Getopt::Long::caller = $self->{caller_pkg};
eval {
# Locally set exception handler to default, otherwise it will
# be called implicitly here, and again explicitly when we try
# to deliver the messages.
local ($SIG{__DIE__}) = 'DEFAULT';
$ret = Getopt::Long::GetOptionsFromArray (@_);
};
# Restore saved settings.
Getopt::Long::Configure ($save);
# Handle errors and return value.
die ($@) if $@;
return $ret;
}
package Getopt::Long;
################ Back to Normal ################
# Indices in option control info.
# Note that ParseOptions uses the fields directly. Search for 'hard-wired'.
use constant CTL_TYPE => 0;
#use constant CTL_TYPE_FLAG => '';
#use constant CTL_TYPE_NEG => '!';
#use constant CTL_TYPE_INCR => '+';
#use constant CTL_TYPE_INT => 'i';
#use constant CTL_TYPE_INTINC => 'I';
#use constant CTL_TYPE_XINT => 'o';
#use constant CTL_TYPE_FLOAT => 'f';
#use constant CTL_TYPE_STRING => 's';
use constant CTL_CNAME => 1;
use constant CTL_DEFAULT => 2;
use constant CTL_DEST => 3;
use constant CTL_DEST_SCALAR => 0;
use constant CTL_DEST_ARRAY => 1;
use constant CTL_DEST_HASH => 2;
use constant CTL_DEST_CODE => 3;
use constant CTL_AMIN => 4;
use constant CTL_AMAX => 5;
# FFU.
#use constant CTL_RANGE => ;
#use constant CTL_REPEAT => ;
# Rather liberal patterns to match numbers.
use constant PAT_INT => "[-+]?_*[0-9][0-9_]*";
use constant PAT_XINT =>
"(?:".
"[-+]?_*[1-9][0-9_]*".
"|".
"0x_*[0-9a-f][0-9a-f_]*".
"|".
"0b_*[01][01_]*".
"|".
"0[0-7_]*".
")";
use constant PAT_FLOAT => "[-+]?[0-9._]+(\.[0-9_]+)?([eE][-+]?[0-9_]+)?";
sub GetOptions(@) {
# Shift in default array.
unshift(@_, \@ARGV);
# Try to keep caller() and Carp consistent.
goto &GetOptionsFromArray;
}
sub GetOptionsFromString(@) {
my ($string) = shift;
require Text::ParseWords;
my $args = [ Text::ParseWords::shellwords($string) ];
$caller ||= (caller)[0]; # current context
my $ret = GetOptionsFromArray($args, @_);
return ( $ret, $args ) if wantarray;
if ( @$args ) {
$ret = 0;
warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n");
}
$ret;
}
sub GetOptionsFromArray(@) {
my ($argv, @optionlist) = @_; # local copy of the option descriptions
my $argend = '--'; # option list terminator
my %opctl = (); # table of option specs
my $pkg = $caller || (caller)[0]; # current context
# Needed if linkage is omitted.
my @ret = (); # accum for non-options
my %linkage; # linkage
my $userlinkage; # user supplied HASH
my $opt; # current option
my $prefix = $genprefix; # current prefix
$error = '';
if ( $debug ) {
# Avoid some warnings if debugging.
local ($^W) = 0;
print STDERR
("Getopt::Long $Getopt::Long::VERSION ",
"called from package \"$pkg\".",
"\n ",
"argv: (@$argv)",
"\n ",
"autoabbrev=$autoabbrev,".
"bundling=$bundling,",
"getopt_compat=$getopt_compat,",
"gnu_compat=$gnu_compat,",
"order=$order,",
"\n ",
"ignorecase=$ignorecase,",
"requested_version=$requested_version,",
"passthrough=$passthrough,",
"genprefix=\"$genprefix\",",
"longprefix=\"$longprefix\".",
"\n");
}
# Check for ref HASH as first argument.
# First argument may be an object. It's OK to use this as long
# as it is really a hash underneath.
$userlinkage = undef;
if ( @optionlist && ref($optionlist[0]) and
UNIVERSAL::isa($optionlist[0],'HASH') ) {
$userlinkage = shift (@optionlist);
print STDERR ("=> user linkage: $userlinkage\n") if $debug;
}
# See if the first element of the optionlist contains option
# starter characters.
# Be careful not to interpret '<>' as option starters.
if ( @optionlist && $optionlist[0] =~ /^\W+$/
&& !($optionlist[0] eq '<>'
&& @optionlist > 0
&& ref($optionlist[1])) ) {
$prefix = shift (@optionlist);
# Turn into regexp. Needs to be parenthesized!
$prefix =~ s/(\W)/\\$1/g;
$prefix = "([" . $prefix . "])";
print STDERR ("=> prefix=\"$prefix\"\n") if $debug;
}
# Verify correctness of optionlist.
%opctl = ();
while ( @optionlist ) {
my $opt = shift (@optionlist);
unless ( defined($opt) ) {
$error .= "Undefined argument in option spec\n";
next;
}
# Strip leading prefix so people can specify "--foo=i" if they like.
$opt = $+ if $opt =~ /^$prefix+(.*)$/s;
if ( $opt eq '<>' ) {
if ( (defined $userlinkage)
&& !(@optionlist > 0 && ref($optionlist[0]))
&& (exists $userlinkage->{$opt})
&& ref($userlinkage->{$opt}) ) {
unshift (@optionlist, $userlinkage->{$opt});
}
unless ( @optionlist > 0
&& ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
$error .= "Option spec <> requires a reference to a subroutine\n";
# Kill the linkage (to avoid another error).
shift (@optionlist)
if @optionlist && ref($optionlist[0]);
next;
}
$linkage{'<>'} = shift (@optionlist);
next;
}
# Parse option spec.
my ($name, $orig) = ParseOptionSpec ($opt, \%opctl);
unless ( defined $name ) {
# Failed. $orig contains the error message. Sorry for the abuse.
$error .= $orig;
# Kill the linkage (to avoid another error).
shift (@optionlist)
if @optionlist && ref($optionlist[0]);
next;
}
# If no linkage is supplied in the @optionlist, copy it from
# the userlinkage if available.
if ( defined $userlinkage ) {
unless ( @optionlist > 0 && ref($optionlist[0]) ) {
if ( exists $userlinkage->{$orig} &&
ref($userlinkage->{$orig}) ) {
print STDERR ("=> found userlinkage for \"$orig\": ",
"$userlinkage->{$orig}\n")
if $debug;
unshift (@optionlist, $userlinkage->{$orig});
}
else {
# Do nothing. Being undefined will be handled later.
next;
}
}
}
# Copy the linkage. If omitted, link to global variable.
if ( @optionlist > 0 && ref($optionlist[0]) ) {
print STDERR ("=> link \"$orig\" to $optionlist[0]\n")
if $debug;
my $rl = ref($linkage{$orig} = shift (@optionlist));
if ( $rl eq "ARRAY" ) {
$opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY;
}
elsif ( $rl eq "HASH" ) {
$opctl{$name}[CTL_DEST] = CTL_DEST_HASH;
}
elsif ( $rl eq "SCALAR" || $rl eq "REF" ) {
# if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
# my $t = $linkage{$orig};
# $$t = $linkage{$orig} = [];
# }
# elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
# }
# else {
# Ok.
# }
}
elsif ( $rl eq "CODE" ) {
# Ok.
}
else {
$error .= "Invalid option linkage for \"$opt\"\n";
}
}
else {
# Link to global $opt_XXX variable.
# Make sure a valid perl identifier results.
my $ov = $orig;
$ov =~ s/\W/_/g;
if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n")
if $debug;
eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;");
}
elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n")
if $debug;
eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;");
}
else {
print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n")
if $debug;
eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;");
}
}
if ( $opctl{$name}[CTL_TYPE] eq 'I'
&& ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY
|| $opctl{$name}[CTL_DEST] == CTL_DEST_HASH )
) {
$error .= "Invalid option linkage for \"$opt\"\n";
}
}
# Bail out if errors found.
die ($error) if $error;
$error = 0;
# Supply --version and --help support, if needed and allowed.
if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) {
if ( !defined($opctl{version}) ) {
$opctl{version} = ['','version',0,CTL_DEST_CODE,undef];
$linkage{version} = \&VersionMessage;
}
$auto_version = 1;
}
if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) {
if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) {
$opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef];
$linkage{help} = \&HelpMessage;
}
$auto_help = 1;
}
# Show the options tables if debugging.
if ( $debug ) {
my ($arrow, $k, $v);
$arrow = "=> ";
while ( ($k,$v) = each(%opctl) ) {
print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n");
$arrow = " ";
}
}
# Process argument list
my $goon = 1;
while ( $goon && @$argv > 0 ) {
# Get next argument.
$opt = shift (@$argv);
print STDERR ("=> arg \"", $opt, "\"\n") if $debug;
# Double dash is option list terminator.
if ( defined($opt) && $opt eq $argend ) {
push (@ret, $argend) if $passthrough;
last;
}
# Look it up.
my $tryopt = $opt;
my $found; # success status
my $key; # key (if hash type)
my $arg; # option argument
my $ctl; # the opctl entry
($found, $opt, $ctl, $arg, $key) =
FindOption ($argv, $prefix, $argend, $opt, \%opctl);
if ( $found ) {
# FindOption undefines $opt in case of errors.
next unless defined $opt;
my $argcnt = 0;
while ( defined $arg ) {
# Get the canonical name.
print STDERR ("=> cname for \"$opt\" is ") if $debug;
$opt = $ctl->[CTL_CNAME];
print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug;
if ( defined $linkage{$opt} ) {
print STDERR ("=> ref(\$L{$opt}) -> ",
ref($linkage{$opt}), "\n") if $debug;
if ( ref($linkage{$opt}) eq 'SCALAR'
|| ref($linkage{$opt}) eq 'REF' ) {
if ( $ctl->[CTL_TYPE] eq '+' ) {
print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
if $debug;
if ( defined ${$linkage{$opt}} ) {
${$linkage{$opt}} += $arg;
}
else {
${$linkage{$opt}} = $arg;
}
}
elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
print STDERR ("=> ref(\$L{$opt}) auto-vivified",
" to ARRAY\n")
if $debug;
my $t = $linkage{$opt};
$$t = $linkage{$opt} = [];
print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
if $debug;
push (@{$linkage{$opt}}, $arg);
}
elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
print STDERR ("=> ref(\$L{$opt}) auto-vivified",
" to HASH\n")
if $debug;
my $t = $linkage{$opt};
$$t = $linkage{$opt} = {};
print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
if $debug;
$linkage{$opt}->{$key} = $arg;
}
else {
print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
if $debug;
${$linkage{$opt}} = $arg;
}
}
elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
if $debug;
push (@{$linkage{$opt}}, $arg);
}
elsif ( ref($linkage{$opt}) eq 'HASH' ) {
print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
if $debug;
$linkage{$opt}->{$key} = $arg;
}
elsif ( ref($linkage{$opt}) eq 'CODE' ) {
print STDERR ("=> &L{$opt}(\"$opt\"",
$ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "",
", \"$arg\")\n")
if $debug;
my $eval_error = do {
local $@;
local $SIG{__DIE__} = 'DEFAULT';
eval {
&{$linkage{$opt}}
(Getopt::Long::CallBack->new
(name => $opt,
ctl => $ctl,
opctl => \%opctl,
linkage => \%linkage,
prefix => $prefix,
),
$ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
$arg);
};
$@;
};
print STDERR ("=> die($eval_error)\n")
if $debug && $eval_error ne '';
if ( $eval_error =~ /^!/ ) {
if ( $eval_error =~ /^!FINISH\b/ ) {
$goon = 0;
}
}
elsif ( $eval_error ne '' ) {
warn ($eval_error);
$error++;
}
}
else {
print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
"\" in linkage\n");
die("Getopt::Long -- internal error!\n");
}
}
# No entry in linkage means entry in userlinkage.
elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
if ( defined $userlinkage->{$opt} ) {
print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
if $debug;
push (@{$userlinkage->{$opt}}, $arg);
}
else {
print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
if $debug;
$userlinkage->{$opt} = [$arg];
}
}
elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
if ( defined $userlinkage->{$opt} ) {
print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
if $debug;
$userlinkage->{$opt}->{$key} = $arg;
}
else {
print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
if $debug;
$userlinkage->{$opt} = {$key => $arg};
}
}
else {
if ( $ctl->[CTL_TYPE] eq '+' ) {
print STDERR ("=> \$L{$opt} += \"$arg\"\n")
if $debug;
if ( defined $userlinkage->{$opt} ) {
$userlinkage->{$opt} += $arg;
}
else {
$userlinkage->{$opt} = $arg;
}
}
else {
print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
$userlinkage->{$opt} = $arg;
}
}
$argcnt++;
last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1;
undef($arg);
# Need more args?
if ( $argcnt < $ctl->[CTL_AMIN] ) {
if ( @$argv ) {
if ( ValidValue($ctl, $argv->[0], 1, $argend, $prefix) ) {
$arg = shift(@$argv);
if ( $ctl->[CTL_TYPE] =~ /^[iIo]$/ ) {
$arg =~ tr/_//d;
$arg = $ctl->[CTL_TYPE] eq 'o' && $arg =~ /^0/
? oct($arg)
: 0+$arg
}
($key,$arg) = $arg =~ /^([^=]+)=(.*)/
if $ctl->[CTL_DEST] == CTL_DEST_HASH;
next;
}
warn("Value \"$$argv[0]\" invalid for option $opt\n");
$error++;
}
else {
warn("Insufficient arguments for option $opt\n");
$error++;
}
}
# Any more args?
if ( @$argv && ValidValue($ctl, $argv->[0], 0, $argend, $prefix) ) {
$arg = shift(@$argv);
if ( $ctl->[CTL_TYPE] =~ /^[iIo]$/ ) {
$arg =~ tr/_//d;
$arg = $ctl->[CTL_TYPE] eq 'o' && $arg =~ /^0/
? oct($arg)
: 0+$arg
}
($key,$arg) = $arg =~ /^([^=]+)=(.*)/
if $ctl->[CTL_DEST] == CTL_DEST_HASH;
next;
}
}
}
# Not an option. Save it if we $PERMUTE and don't have a <>.
elsif ( $order == $PERMUTE ) {
# Try non-options call-back.
my $cb;
if ( (defined ($cb = $linkage{'<>'})) ) {
print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
if $debug;
my $eval_error = do {
local $@;
local $SIG{__DIE__} = 'DEFAULT';
eval {
# The arg to <> cannot be the CallBack object
# since it may be passed to other modules that
# get confused (e.g., Archive::Tar). Well,
# it's not relevant for this callback anyway.
&$cb($tryopt);
};
$@;
};
print STDERR ("=> die($eval_error)\n")
if $debug && $eval_error ne '';
if ( $eval_error =~ /^!/ ) {
if ( $eval_error =~ /^!FINISH\b/ ) {
$goon = 0;
}
}
elsif ( $eval_error ne '' ) {
warn ($eval_error);
$error++;
}
}
else {
print STDERR ("=> saving \"$tryopt\" ",
"(not an option, may permute)\n") if $debug;
push (@ret, $tryopt);
}
next;
}
# ...otherwise, terminate.
else {
# Push this one back and exit.
unshift (@$argv, $tryopt);
return ($error == 0);
}
}
# Finish.
if ( @ret && $order == $PERMUTE ) {
# Push back accumulated arguments
print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
if $debug;
unshift (@$argv, @ret);
}
return ($error == 0);
}
# A readable representation of what's in an optbl.
sub OptCtl ($) {
my ($v) = @_;
my @v = map { defined($_) ? ($_) : ("<undef>") } @$v;
"[".
join(",",
"\"$v[CTL_TYPE]\"",
"\"$v[CTL_CNAME]\"",
"\"$v[CTL_DEFAULT]\"",
("\$","\@","\%","\&")[$v[CTL_DEST] || 0],
$v[CTL_AMIN] || '',
$v[CTL_AMAX] || '',
# $v[CTL_RANGE] || '',
# $v[CTL_REPEAT] || '',
). "]";
}
# Parse an option specification and fill the tables.
sub ParseOptionSpec ($$) {
my ($opt, $opctl) = @_;
# Match option spec.
if ( $opt !~ m;^
(
# Option name
(?: \w+[-\w]* )
# Alias names, or "?"
(?: \| (?: \? | \w[-\w]* ) )*
# Aliases
(?: \| (?: [^-|!+=:][^|!+=:]* )? )*
)?
(
# Either modifiers ...
[!+]
|
# ... or a value/dest/repeat specification
[=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )?
|
# ... or an optional-with-default spec
: (?: -?\d+ | \+ ) [@%]?
)?
$;x ) {
return (undef, "Error in option spec: \"$opt\"\n");
}
my ($names, $spec) = ($1, $2);
$spec = '' unless defined $spec;
# $orig keeps track of the primary name the user specified.
# This name will be used for the internal or external linkage.
# In other words, if the user specifies "FoO|BaR", it will
# match any case combinations of 'foo' and 'bar', but if a global
# variable needs to be set, it will be $opt_FoO in the exact case
# as specified.
my $orig;
my @names;
if ( defined $names ) {
@names = split (/\|/, $names);
$orig = $names[0];
}
else {
@names = ('');
$orig = '';
}
# Construct the opctl entries.
my $entry;
if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) {
# Fields are hard-wired here.
$entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0];
}
elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) {
my $def = $1;
my $dest = $2;
my $type = $def eq '+' ? 'I' : 'i';
$dest ||= '$';
$dest = $dest eq '@' ? CTL_DEST_ARRAY
: $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
# Fields are hard-wired here.
$entry = [$type,$orig,$def eq '+' ? undef : $def,
$dest,0,1];
}
else {
my ($mand, $type, $dest) =
$spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;
return (undef, "Cannot repeat while bundling: \"$opt\"\n")
if $bundling && defined($4);
my ($mi, $cm, $ma) = ($5, $6, $7);
return (undef, "{0} is useless in option spec: \"$opt\"\n")
if defined($mi) && !$mi && !defined($ma) && !defined($cm);
$type = 'i' if $type eq 'n';
$dest ||= '$';
$dest = $dest eq '@' ? CTL_DEST_ARRAY
: $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
# Default minargs to 1/0 depending on mand status.
$mi = $mand eq '=' ? 1 : 0 unless defined $mi;
# Adjust mand status according to minargs.
$mand = $mi ? '=' : ':';
# Adjust maxargs.
$ma = $mi ? $mi : 1 unless defined $ma || defined $cm;
return (undef, "Max must be greater than zero in option spec: \"$opt\"\n")
if defined($ma) && !$ma;
return (undef, "Max less than min in option spec: \"$opt\"\n")
if defined($ma) && $ma < $mi;
# Fields are hard-wired here.
$entry = [$type,$orig,undef,$dest,$mi,$ma||-1];
}
# Process all names. First is canonical, the rest are aliases.
my $dups = '';
foreach ( @names ) {
$_ = lc ($_)
if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
if ( exists $opctl->{$_} ) {
$dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
}
if ( $spec eq '!' ) {
$opctl->{"no$_"} = $entry;
$opctl->{"no-$_"} = $entry;
$opctl->{$_} = [@$entry];
$opctl->{$_}->[CTL_TYPE] = '';
}
else {
$opctl->{$_} = $entry;
}
}
if ( $dups && $^W ) {
foreach ( split(/\n+/, $dups) ) {
warn($_."\n");
}
}
($names[0], $orig);
}
# Option lookup.
sub FindOption ($$$$$) {
# returns (1, $opt, $ctl, $arg, $key) if okay,
# returns (1, undef) if option in error,
# returns (0) otherwise.
my ($argv, $prefix, $argend, $opt, $opctl) = @_;
print STDERR ("=> find \"$opt\"\n") if $debug;
return (0) unless defined($opt);
return (0) unless $opt =~ /^($prefix)(.*)$/s;
return (0) if $opt eq "-" && !defined $opctl->{''};
$opt = substr( $opt, length($1) ); # retain taintedness
my $starter = $1;
print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
my $optarg; # value supplied with --opt=value
my $rest; # remainder from unbundling
# If it is a long option, it may include the value.
# With getopt_compat, only if not bundling.
if ( ($starter=~/^$longprefix$/
|| ($getopt_compat && ($bundling == 0 || $bundling == 2)))
&& (my $oppos = index($opt, '=', 1)) > 0) {
my $optorg = $opt;
$opt = substr($optorg, 0, $oppos);
$optarg = substr($optorg, $oppos + 1); # retain tainedness
print STDERR ("=> option \"", $opt,
"\", optarg = \"$optarg\"\n") if $debug;
}
#### Look it up ###
my $tryopt = $opt; # option to try
if ( $bundling && $starter eq '-' ) {
# To try overrides, obey case ignore.
$tryopt = $ignorecase ? lc($opt) : $opt;
# If bundling == 2, long options can override bundles.
if ( $bundling == 2 && length($tryopt) > 1
&& defined ($opctl->{$tryopt}) ) {
print STDERR ("=> $starter$tryopt overrides unbundling\n")
if $debug;
}
else {
$tryopt = $opt;
# Unbundle single letter option.
$rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
$tryopt = substr ($tryopt, 0, 1);
$tryopt = lc ($tryopt) if $ignorecase > 1;
print STDERR ("=> $starter$tryopt unbundled from ",
"$starter$tryopt$rest\n") if $debug;
$rest = undef unless $rest ne '';
}
}
# Try auto-abbreviation.
elsif ( $autoabbrev && $opt ne "" ) {
# Sort the possible long option names.
my @names = sort(keys (%$opctl));
# Downcase if allowed.
$opt = lc ($opt) if $ignorecase;
$tryopt = $opt;
# Turn option name into pattern.
my $pat = quotemeta ($opt);
# Look up in option names.
my @hits = grep (/^$pat/, @names);
print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
"out of ", scalar(@names), "\n") if $debug;
# Check for ambiguous results.
unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
# See if all matches are for the same option.
my %hit;
foreach ( @hits ) {
my $hit = $_;
$hit = $opctl->{$hit}->[CTL_CNAME]
if defined $opctl->{$hit}->[CTL_CNAME];
$hit{$hit} = 1;
}
# Remove auto-supplied options (version, help).
if ( keys(%hit) == 2 ) {
if ( $auto_version && exists($hit{version}) ) {
delete $hit{version};
}
elsif ( $auto_help && exists($hit{help}) ) {
delete $hit{help};
}
}
# Now see if it really is ambiguous.
unless ( keys(%hit) == 1 ) {
return (0) if $passthrough;
warn ("Option ", $opt, " is ambiguous (",
join(", ", @hits), ")\n");
$error++;
return (1, undef);
}
@hits = keys(%hit);
}
# Complete the option name, if appropriate.
if ( @hits == 1 && $hits[0] ne $opt ) {
$tryopt = $hits[0];
$tryopt = lc ($tryopt) if $ignorecase;
print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
if $debug;
}
}
# Map to all lowercase if ignoring case.
elsif ( $ignorecase ) {
$tryopt = lc ($opt);
}
# Check validity by fetching the info.
my $ctl = $opctl->{$tryopt};
unless ( defined $ctl ) {
return (0) if $passthrough;
# Pretend one char when bundling.
if ( $bundling == 1 && length($starter) == 1 ) {
$opt = substr($opt,0,1);
unshift (@$argv, $starter.$rest) if defined $rest;
}
if ( $opt eq "" ) {
warn ("Missing option after ", $starter, "\n");
}
else {
warn ("Unknown option: ", $opt, "\n");
}
$error++;
return (1, undef);
}
# Apparently valid.
$opt = $tryopt;
print STDERR ("=> found ", OptCtl($ctl),
" for \"", $opt, "\"\n") if $debug;
#### Determine argument status ####
# If it is an option w/o argument, we're almost finished with it.
my $type = $ctl->[CTL_TYPE];
my $arg;
if ( $type eq '' || $type eq '!' || $type eq '+' ) {
if ( defined $optarg ) {
return (0) if $passthrough;
warn ("Option ", $opt, " does not take an argument\n");
$error++;
undef $opt;
}
elsif ( $type eq '' || $type eq '+' ) {
# Supply explicit value.
$arg = 1;
}
else {
$opt =~ s/^no-?//i; # strip NO prefix
$arg = 0; # supply explicit value
}
unshift (@$argv, $starter.$rest) if defined $rest;
return (1, $opt, $ctl, $arg);
}
# Get mandatory status and type info.
my $mand = $ctl->[CTL_AMIN];
# Check if there is an option argument available.
if ( $gnu_compat && defined $optarg && $optarg eq '' ) {
return (1, $opt, $ctl, $type eq 's' ? '' : 0) ;#unless $mand;
$optarg = 0 unless $type eq 's';
}
# Check if there is an option argument available.
if ( defined $optarg
? ($optarg eq '')
: !(defined $rest || @$argv > 0) ) {
# Complain if this option needs an argument.
# if ( $mand && !($type eq 's' ? defined($optarg) : 0) ) {
if ( $mand ) {
return (0) if $passthrough;
warn ("Option ", $opt, " requires an argument\n");
$error++;
return (1, undef);
}
if ( $type eq 'I' ) {
# Fake incremental type.
my @c = @$ctl;
$c[CTL_TYPE] = '+';
return (1, $opt, \@c, 1);
}
return (1, $opt, $ctl,
defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
$type eq 's' ? '' : 0);
}
# Get (possibly optional) argument.
$arg = (defined $rest ? $rest
: (defined $optarg ? $optarg : shift (@$argv)));
# Get key if this is a "name=value" pair for a hash option.
my $key;
if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
: ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
($mand ? undef : ($type eq 's' ? "" : 1)));
if (! defined $arg) {
warn ("Option $opt, key \"$key\", requires a value\n");
$error++;
# Push back.
unshift (@$argv, $starter.$rest) if defined $rest;
return (1, undef);
}
}
#### Check if the argument is valid for this option ####
my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";
if ( $type eq 's' ) { # string
# A mandatory string takes anything.
return (1, $opt, $ctl, $arg, $key) if $mand;
# Same for optional string as a hash value
return (1, $opt, $ctl, $arg, $key)
if $ctl->[CTL_DEST] == CTL_DEST_HASH;
# An optional string takes almost anything.
return (1, $opt, $ctl, $arg, $key)
if defined $optarg || defined $rest;
return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??
# Check for option or option list terminator.
if ($arg eq $argend ||
$arg =~ /^$prefix.+/) {
# Push back.
unshift (@$argv, $arg);
# Supply empty value.
$arg = '';
}
}
elsif ( $type eq 'i' # numeric/integer
|| $type eq 'I' # numeric/integer w/ incr default
|| $type eq 'o' ) { # dec/oct/hex/bin value
my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
if ( $bundling && defined $rest
&& $rest =~ /^($key_valid)($o_valid)(.*)$/si ) {
($key, $arg, $rest) = ($1, $2, $+);
chop($key) if $key;
$arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
}
elsif ( $arg =~ /^$o_valid$/si ) {
$arg =~ tr/_//d;
$arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
}
else {
if ( defined $optarg || $mand ) {
if ( $passthrough ) {
unshift (@$argv, defined $rest ? $starter.$rest : $arg)
unless defined $optarg;
return (0);
}
warn ("Value \"", $arg, "\" invalid for option ",
$opt, " (",
$type eq 'o' ? "extended " : '',
"number expected)\n");
$error++;
# Push back.
unshift (@$argv, $starter.$rest) if defined $rest;
return (1, undef);
}
else {
# Push back.
unshift (@$argv, defined $rest ? $starter.$rest : $arg);
if ( $type eq 'I' ) {
# Fake incremental type.
my @c = @$ctl;
$c[CTL_TYPE] = '+';
return (1, $opt, \@c, 1);
}
# Supply default value.
$arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0;
}
}
}
elsif ( $type eq 'f' ) { # real number, int is also ok
# We require at least one digit before a point or 'e',
# and at least one digit following the point and 'e'.
# [-]NN[.NN][eNN]
my $o_valid = PAT_FLOAT;
if ( $bundling && defined $rest &&
$rest =~ /^($key_valid)($o_valid)(.*)$/s ) {
$arg =~ tr/_//d;
($key, $arg, $rest) = ($1, $2, $+);
chop($key) if $key;
unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
}
elsif ( $arg =~ /^$o_valid$/ ) {
$arg =~ tr/_//d;
}
else {
if ( defined $optarg || $mand ) {
if ( $passthrough ) {
unshift (@$argv, defined $rest ? $starter.$rest : $arg)
unless defined $optarg;
return (0);
}
warn ("Value \"", $arg, "\" invalid for option ",
$opt, " (real number expected)\n");
$error++;
# Push back.
unshift (@$argv, $starter.$rest) if defined $rest;
return (1, undef);
}
else {
# Push back.
unshift (@$argv, defined $rest ? $starter.$rest : $arg);
# Supply default value.
$arg = 0.0;
}
}
}
else {
die("Getopt::Long internal error (Can't happen)\n");
}
return (1, $opt, $ctl, $arg, $key);
}
sub ValidValue ($$$$$) {
my ($ctl, $arg, $mand, $argend, $prefix) = @_;
if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
return 0 unless $arg =~ /[^=]+=(.*)/;
$arg = $1;
}
my $type = $ctl->[CTL_TYPE];
if ( $type eq 's' ) { # string
# A mandatory string takes anything.
return (1) if $mand;
return (1) if $arg eq "-";
# Check for option or option list terminator.
return 0 if $arg eq $argend || $arg =~ /^$prefix.+/;
return 1;
}
elsif ( $type eq 'i' # numeric/integer
|| $type eq 'I' # numeric/integer w/ incr default
|| $type eq 'o' ) { # dec/oct/hex/bin value
my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
return $arg =~ /^$o_valid$/si;
}
elsif ( $type eq 'f' ) { # real number, int is also ok
# We require at least one digit before a point or 'e',
# and at least one digit following the point and 'e'.
# [-]NN[.NN][eNN]
my $o_valid = PAT_FLOAT;
return $arg =~ /^$o_valid$/;
}
die("ValidValue: Cannot happen\n");
}
# Getopt::Long Configuration.
sub Configure (@) {
my (@options) = @_;
my $prevconfig =
[ $error, $debug, $major_version, $minor_version,
$autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
$gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
$longprefix ];
if ( ref($options[0]) eq 'ARRAY' ) {
( $error, $debug, $major_version, $minor_version,
$autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
$gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
$longprefix ) = @{shift(@options)};
}
my $opt;
foreach $opt ( @options ) {
my $try = lc ($opt);
my $action = 1;
if ( $try =~ /^no_?(.*)$/s ) {
$action = 0;
$try = $+;
}
if ( ($try eq 'default' or $try eq 'defaults') && $action ) {
ConfigDefaults ();
}
elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
local $ENV{POSIXLY_CORRECT};
$ENV{POSIXLY_CORRECT} = 1 if $action;
ConfigDefaults ();
}
elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
$autoabbrev = $action;
}
elsif ( $try eq 'getopt_compat' ) {
$getopt_compat = $action;
$genprefix = $action ? "(--|-|\\+)" : "(--|-)";
}
elsif ( $try eq 'gnu_getopt' ) {
if ( $action ) {
$gnu_compat = 1;
$bundling = 1;
$getopt_compat = 0;
$genprefix = "(--|-)";
$order = $PERMUTE;
}
}
elsif ( $try eq 'gnu_compat' ) {
$gnu_compat = $action;
}
elsif ( $try =~ /^(auto_?)?version$/ ) {
$auto_version = $action;
}
elsif ( $try =~ /^(auto_?)?help$/ ) {
$auto_help = $action;
}
elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
$ignorecase = $action;
}
elsif ( $try eq 'ignorecase_always' or $try eq 'ignore_case_always' ) {
$ignorecase = $action ? 2 : 0;
}
elsif ( $try eq 'bundling' ) {
$bundling = $action;
}
elsif ( $try eq 'bundling_override' ) {
$bundling = $action ? 2 : 0;
}
elsif ( $try eq 'require_order' ) {
$order = $action ? $REQUIRE_ORDER : $PERMUTE;
}
elsif ( $try eq 'permute' ) {
$order = $action ? $PERMUTE : $REQUIRE_ORDER;
}
elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
$passthrough = $action;
}
elsif ( $try =~ /^prefix=(.+)$/ && $action ) {
$genprefix = $1;
# Turn into regexp. Needs to be parenthesized!
$genprefix = "(" . quotemeta($genprefix) . ")";
eval { '' =~ /$genprefix/; };
die("Getopt::Long: invalid pattern \"$genprefix\"\n") if $@;
}
elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
$genprefix = $1;
# Parenthesize if needed.
$genprefix = "(" . $genprefix . ")"
unless $genprefix =~ /^\(.*\)$/;
eval { '' =~ m"$genprefix"; };
die("Getopt::Long: invalid pattern \"$genprefix\"\n") if $@;
}
elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) {
$longprefix = $1;
# Parenthesize if needed.
$longprefix = "(" . $longprefix . ")"
unless $longprefix =~ /^\(.*\)$/;
eval { '' =~ m"$longprefix"; };
die("Getopt::Long: invalid long prefix pattern \"$longprefix\"\n") if $@;
}
elsif ( $try eq 'debug' ) {
$debug = $action;
}
else {
die("Getopt::Long: unknown or erroneous config parameter \"$opt\"\n")
}
}
$prevconfig;
}
# Deprecated name.
sub config (@) {
Configure (@_);
}
# Issue a standard message for --version.
#
# The arguments are mostly the same as for Pod::Usage::pod2usage:
#
# - a number (exit value)
# - a string (lead in message)
# - a hash with options. See Pod::Usage for details.
#
sub VersionMessage(@) {
# Massage args.
my $pa = setup_pa_args("version", @_);
my $v = $main::VERSION;
my $fh = $pa->{-output} ||
($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR;
print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
$0, defined $v ? " version $v" : (),
"\n",
"(", __PACKAGE__, "::", "GetOptions",
" version ",
defined($Getopt::Long::VERSION_STRING)
? $Getopt::Long::VERSION_STRING : $VERSION, ";",
" Perl version ",
$] >= 5.006 ? sprintf("%vd", $^V) : $],
")\n");
exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT";
}
# Issue a standard message for --help.
#
# The arguments are the same as for Pod::Usage::pod2usage:
#
# - a number (exit value)
# - a string (lead in message)
# - a hash with options. See Pod::Usage for details.
#
sub HelpMessage(@) {
eval {
require Pod::Usage;
import Pod::Usage;
1;
} || die("Cannot provide help: cannot load Pod::Usage\n");
# Note that pod2usage will issue a warning if -exitval => NOEXIT.
pod2usage(setup_pa_args("help", @_));
}
# Helper routine to set up a normalized hash ref to be used as
# argument to pod2usage.
sub setup_pa_args($@) {
my $tag = shift; # who's calling
# If called by direct binding to an option, it will get the option
# name and value as arguments. Remove these, if so.
@_ = () if @_ == 2 && $_[0] eq $tag;
my $pa;
if ( @_ > 1 ) {
$pa = { @_ };
}
else {
$pa = shift || {};
}
# At this point, $pa can be a number (exit value), string
# (message) or hash with options.
if ( UNIVERSAL::isa($pa, 'HASH') ) {
# Get rid of -msg vs. -message ambiguity.
$pa->{-message} = $pa->{-msg};
delete($pa->{-msg});
}
elsif ( $pa =~ /^-?\d+$/ ) {
$pa = { -exitval => $pa };
}
else {
$pa = { -message => $pa };
}
# These are _our_ defaults.
$pa->{-verbose} = 0 unless exists($pa->{-verbose});
$pa->{-exitval} = 0 unless exists($pa->{-exitval});
$pa;
}
# Sneak way to know what version the user requested.
sub VERSION {
$requested_version = $_[1];
shift->SUPER::VERSION(@_);
}
package Getopt::Long::CallBack;
sub new {
my ($pkg, %atts) = @_;
bless { %atts }, $pkg;
}
sub name {
my $self = shift;
''.$self->{name};
}
use overload
# Treat this object as an ordinary string for legacy API.
'""' => \&name,
fallback => 1;
1;
################ Documentation ################
=head1 NAME
Getopt::Long - Extended processing of command line options
=head1 SYNOPSIS
use Getopt::Long;
my $data = "file.dat";
my $length = 24;
my $verbose;
GetOptions ("length=i" => \$length, # numeric
"file=s" => \$data, # string
"verbose" => \$verbose) # flag
or die("Error in command line arguments\n");
=head1 DESCRIPTION
The Getopt::Long module implements an extended getopt function called
GetOptions(). It parses the command line from C<@ARGV>, recognizing
and removing specified options and their possible values.
This function adheres to the POSIX syntax for command
line options, with GNU extensions. In general, this means that options
have long names instead of single letters, and are introduced with a
double dash "--". Support for bundling of command line options, as was
the case with the more traditional single-letter approach, is provided
but not enabled by default.
=head1 Command Line Options, an Introduction
Command line operated programs traditionally take their arguments from
the command line, for example filenames or other information that the
program needs to know. Besides arguments, these programs often take
command line I<options> as well. Options are not necessary for the
program to work, hence the name 'option', but are used to modify its
default behaviour. For example, a program could do its job quietly,
but with a suitable option it could provide verbose information about
what it did.
Command line options come in several flavours. Historically, they are
preceded by a single dash C<->, and consist of a single letter.
-l -a -c
Usually, these single-character options can be bundled:
-lac
Options can have values, the value is placed after the option
character. Sometimes with whitespace in between, sometimes not:
-s 24 -s24
Due to the very cryptic nature of these options, another style was
developed that used long names. So instead of a cryptic C<-l> one
could use the more descriptive C<--long>. To distinguish between a
bundle of single-character options and a long one, two dashes are used
to precede the option name. Early implementations of long options used
a plus C<+> instead. Also, option values could be specified either
like
--size=24
or
--size 24
The C<+> form is now obsolete and strongly deprecated.
=head1 Getting Started with Getopt::Long
Getopt::Long is the Perl5 successor of C<newgetopt.pl>. This was the
first Perl module that provided support for handling the new style of
command line options, in particular long option names, hence the Perl5
name Getopt::Long. This module also supports single-character options
and bundling.
To use Getopt::Long from a Perl program, you must include the
following line in your Perl program:
use Getopt::Long;
This will load the core of the Getopt::Long module and prepare your
program for using it. Most of the actual Getopt::Long code is not
loaded until you really call one of its functions.
In the default configuration, options names may be abbreviated to
uniqueness, case does not matter, and a single dash is sufficient,
even for long option names. Also, options may be placed between
non-option arguments. See L<Configuring Getopt::Long> for more
details on how to configure Getopt::Long.
=head2 Simple options
The most simple options are the ones that take no values. Their mere
presence on the command line enables the option. Popular examples are:
--all --verbose --quiet --debug
Handling simple options is straightforward:
my $verbose = ''; # option variable with default value (false)
my $all = ''; # option variable with default value (false)
GetOptions ('verbose' => \$verbose, 'all' => \$all);
The call to GetOptions() parses the command line arguments that are
present in C<@ARGV> and sets the option variable to the value C<1> if
the option did occur on the command line. Otherwise, the option
variable is not touched. Setting the option value to true is often
called I<enabling> the option.
The option name as specified to the GetOptions() function is called
the option I<specification>. Later we'll see that this specification
can contain more than just the option name. The reference to the
variable is called the option I<destination>.
GetOptions() will return a true value if the command line could be
processed successfully. Otherwise, it will write error messages using
die() and warn(), and return a false result.
=head2 A little bit less simple options
Getopt::Long supports two useful variants of simple options:
I<negatable> options and I<incremental> options.
A negatable option is specified with an exclamation mark C<!> after the
option name:
my $verbose = ''; # option variable with default value (false)
GetOptions ('verbose!' => \$verbose);
Now, using C<--verbose> on the command line will enable C<$verbose>,
as expected. But it is also allowed to use C<--noverbose>, which will
disable C<$verbose> by setting its value to C<0>. Using a suitable
default value, the program can find out whether C<$verbose> is false
by default, or disabled by using C<--noverbose>.
An incremental option is specified with a plus C<+> after the
option name:
my $verbose = ''; # option variable with default value (false)
GetOptions ('verbose+' => \$verbose);
Using C<--verbose> on the command line will increment the value of
C<$verbose>. This way the program can keep track of how many times the
option occurred on the command line. For example, each occurrence of
C<--verbose> could increase the verbosity level of the program.
=head2 Mixing command line option with other arguments
Usually programs take command line options as well as other arguments,
for example, file names. It is good practice to always specify the
options first, and the other arguments last. Getopt::Long will,
however, allow the options and arguments to be mixed and 'filter out'
all the options before passing the rest of the arguments to the
program. To stop Getopt::Long from processing further arguments,
insert a double dash C<--> on the command line:
--size 24 -- --all
In this example, C<--all> will I<not> be treated as an option, but
passed to the program unharmed, in C<@ARGV>.
=head2 Options with values
For options that take values it must be specified whether the option
value is required or not, and what kind of value the option expects.
Three kinds of values are supported: integer numbers, floating point
numbers, and strings.
If the option value is required, Getopt::Long will take the
command line argument that follows the option and assign this to the
option variable. If, however, the option value is specified as
optional, this will only be done if that value does not look like a
valid command line option itself.
my $tag = ''; # option variable with default value
GetOptions ('tag=s' => \$tag);
In the option specification, the option name is followed by an equals
sign C<=> and the letter C<s>. The equals sign indicates that this
option requires a value. The letter C<s> indicates that this value is
an arbitrary string. Other possible value types are C<i> for integer
values, and C<f> for floating point values. Using a colon C<:> instead
of the equals sign indicates that the option value is optional. In
this case, if no suitable value is supplied, string valued options get
an empty string C<''> assigned, while numeric options are set to C<0>.
=head2 Options with multiple values
Options sometimes take several values. For example, a program could
use multiple directories to search for library files:
--library lib/stdlib --library lib/extlib
To accomplish this behaviour, simply specify an array reference as the
destination for the option:
GetOptions ("library=s" => \@libfiles);
Alternatively, you can specify that the option can have multiple
values by adding a "@", and pass a scalar reference as the
destination:
GetOptions ("library=s@" => \$libfiles);
Used with the example above, C<@libfiles> (or C<@$libfiles>) would
contain two strings upon completion: C<"lib/stdlib"> and
C<"lib/extlib">, in that order. It is also possible to specify that
only integer or floating point numbers are acceptable values.
Often it is useful to allow comma-separated lists of values as well as
multiple occurrences of the options. This is easy using Perl's split()
and join() operators:
GetOptions ("library=s" => \@libfiles);
@libfiles = split(/,/,join(',',@libfiles));
Of course, it is important to choose the right separator string for
each purpose.
Warning: What follows is an experimental feature.
Options can take multiple values at once, for example
--coordinates 52.2 16.4 --rgbcolor 255 255 149
This can be accomplished by adding a repeat specifier to the option
specification. Repeat specifiers are very similar to the C<{...}>
repeat specifiers that can be used with regular expression patterns.
For example, the above command line would be handled as follows:
GetOptions('coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color);
The destination for the option must be an array or array reference.
It is also possible to specify the minimal and maximal number of
arguments an option takes. C<foo=s{2,4}> indicates an option that
takes at least two and at most 4 arguments. C<foo=s{1,}> indicates one
or more values; C<foo:s{,}> indicates zero or more option values.
=head2 Options with hash values
If the option destination is a reference to a hash, the option will
take, as value, strings of the form I<key>C<=>I<value>. The value will
be stored with the specified key in the hash.
GetOptions ("define=s" => \%defines);
Alternatively you can use:
GetOptions ("define=s%" => \$defines);
When used with command line options:
--define os=linux --define vendor=redhat
the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os">
with value C<"linux"> and C<"vendor"> with value C<"redhat">. It is
also possible to specify that only integer or floating point numbers
are acceptable values. The keys are always taken to be strings.
=head2 User-defined subroutines to handle options
Ultimate control over what should be done when (actually: each time)
an option is encountered on the command line can be achieved by
designating a reference to a subroutine (or an anonymous subroutine)
as the option destination. When GetOptions() encounters the option, it
will call the subroutine with two or three arguments. The first
argument is the name of the option. (Actually, it is an object that
stringifies to the name of the option.) For a scalar or array destination,
the second argument is the value to be stored. For a hash destination,
the second argument is the key to the hash, and the third argument
the value to be stored. It is up to the subroutine to store the value,
or do whatever it thinks is appropriate.
A trivial application of this mechanism is to implement options that
are related to each other. For example:
my $verbose = ''; # option variable with default value (false)
GetOptions ('verbose' => \$verbose,
'quiet' => sub { $verbose = 0 });
Here C<--verbose> and C<--quiet> control the same variable
C<$verbose>, but with opposite values.
If the subroutine needs to signal an error, it should call die() with
the desired error message as its argument. GetOptions() will catch the
die(), issue the error message, and record that an error result must
be returned upon completion.
If the text of the error message starts with an exclamation mark C<!>
it is interpreted specially by GetOptions(). There is currently one
special command implemented: C<die("!FINISH")> will cause GetOptions()
to stop processing options, as if it encountered a double dash C<-->.
In version 2.37 the first argument to the callback function was
changed from string to object. This was done to make room for
extensions and more detailed control. The object stringifies to the
option name so this change should not introduce compatibility
problems.
Here is an example of how to access the option name and value from within
a subroutine:
GetOptions ('opt=i' => \&handler);
sub handler {
my ($opt_name, $opt_value) = @_;
print("Option name is $opt_name and value is $opt_value\n");
}
=head2 Options with multiple names
Often it is user friendly to supply alternate mnemonic names for
options. For example C<--height> could be an alternate name for
C<--length>. Alternate names can be included in the option
specification, separated by vertical bar C<|> characters. To implement
the above example:
GetOptions ('length|height=f' => \$length);
The first name is called the I<primary> name, the other names are
called I<aliases>. When using a hash to store options, the key will
always be the primary name.
Multiple alternate names are possible.
=head2 Case and abbreviations
Without additional configuration, GetOptions() will ignore the case of
option names, and allow the options to be abbreviated to uniqueness.
GetOptions ('length|height=f' => \$length, "head" => \$head);
This call will allow C<--l> and C<--L> for the length option, but
requires a least C<--hea> and C<--hei> for the head and height options.
=head2 Summary of Option Specifications
Each option specifier consists of two parts: the name specification
and the argument specification.
The name specification contains the name of the option, optionally
followed by a list of alternative names separated by vertical bar
characters.
length option name is "length"
length|size|l name is "length", aliases are "size" and "l"
The argument specification is optional. If omitted, the option is
considered boolean, a value of 1 will be assigned when the option is
used on the command line.
The argument specification can be
=over 4
=item !
The option does not take an argument and may be negated by prefixing
it with "no" or "no-". E.g. C<"foo!"> will allow C<--foo> (a value of
1 will be assigned) as well as C<--nofoo> and C<--no-foo> (a value of
0 will be assigned). If the option has aliases, this applies to the
aliases as well.
Using negation on a single letter option when bundling is in effect is
pointless and will result in a warning.
=item +
The option does not take an argument and will be incremented by 1
every time it appears on the command line. E.g. C<"more+">, when used
with C<--more --more --more>, will increment the value three times,
resulting in a value of 3 (provided it was 0 or undefined at first).
The C<+> specifier is ignored if the option destination is not a scalar.
=item = I<type> [ I<desttype> ] [ I<repeat> ]
The option requires an argument of the given type. Supported types
are:
=over 4
=item s
String. An arbitrary sequence of characters. It is valid for the
argument to start with C<-> or C<-->.
=item i
Integer. An optional leading plus or minus sign, followed by a
sequence of digits.
=item o
Extended integer, Perl style. This can be either an optional leading
plus or minus sign, followed by a sequence of digits, or an octal
string (a zero, optionally followed by '0', '1', .. '7'), or a
hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case
insensitive), or a binary string (C<0b> followed by a series of '0'
and '1').
=item f
Real number. For example C<3.14>, C<-6.23E24> and so on.
=back
The I<desttype> can be C<@> or C<%> to specify that the option is
list or a hash valued. This is only needed when the destination for
the option value is not otherwise specified. It should be omitted when
not needed.
The I<repeat> specifies the number of values this option takes per
occurrence on the command line. It has the format C<{> [ I<min> ] [ C<,> [ I<max> ] ] C<}>.
I<min> denotes the minimal number of arguments. It defaults to 1 for
options with C<=> and to 0 for options with C<:>, see below. Note that
I<min> overrules the C<=> / C<:> semantics.
I<max> denotes the maximum number of arguments. It must be at least
I<min>. If I<max> is omitted, I<but the comma is not>, there is no
upper bound to the number of argument values taken.
=item : I<type> [ I<desttype> ]
Like C<=>, but designates the argument as optional.
If omitted, an empty string will be assigned to string values options,
and the value zero to numeric options.
Note that if a string argument starts with C<-> or C<-->, it will be
considered an option on itself.
=item : I<number> [ I<desttype> ]
Like C<:i>, but if the value is omitted, the I<number> will be assigned.
=item : + [ I<desttype> ]
Like C<:i>, but if the value is omitted, the current value for the
option will be incremented.
=back
=head1 Advanced Possibilities
=head2 Object oriented interface
Getopt::Long can be used in an object oriented way as well:
use Getopt::Long;
$p = Getopt::Long::Parser->new;
$p->configure(...configuration options...);
if ($p->getoptions(...options descriptions...)) ...
if ($p->getoptionsfromarray( \@array, ...options descriptions...)) ...
Configuration options can be passed to the constructor:
$p = new Getopt::Long::Parser
config => [...configuration options...];
=head2 Thread Safety
Getopt::Long is thread safe when using ithreads as of Perl 5.8. It is
I<not> thread safe when using the older (experimental and now
obsolete) threads implementation that was added to Perl 5.005.
=head2 Documentation and help texts
Getopt::Long encourages the use of Pod::Usage to produce help
messages. For example:
use Getopt::Long;
use Pod::Usage;
my $man = 0;
my $help = 0;
GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
pod2usage(1) if $help;
pod2usage(-exitval => 0, -verbose => 2) if $man;
__END__
=head1 NAME
sample - Using Getopt::Long and Pod::Usage
=head1 SYNOPSIS
sample [options] [file ...]
Options:
-help brief help message
-man full documentation
=head1 OPTIONS
=over 8
=item B<-help>
Print a brief help message and exits.
=item B<-man>
Prints the manual page and exits.
=back
=head1 DESCRIPTION
B<This program> will read the given input file(s) and do something
useful with the contents thereof.
=cut
See L<Pod::Usage> for details.
=head2 Parsing options from an arbitrary array
By default, GetOptions parses the options that are present in the
global array C<@ARGV>. A special entry C<GetOptionsFromArray> can be
used to parse options from an arbitrary array.
use Getopt::Long qw(GetOptionsFromArray);
$ret = GetOptionsFromArray(\@myopts, ...);
When used like this, options and their possible values are removed
from C<@myopts>, the global C<@ARGV> is not touched at all.
The following two calls behave identically:
$ret = GetOptions( ... );
$ret = GetOptionsFromArray(\@ARGV, ... );
This also means that a first argument hash reference now becomes the
second argument:
$ret = GetOptions(\%opts, ... );
$ret = GetOptionsFromArray(\@ARGV, \%opts, ... );
=head2 Parsing options from an arbitrary string
A special entry C<GetOptionsFromString> can be used to parse options
from an arbitrary string.
use Getopt::Long qw(GetOptionsFromString);
$ret = GetOptionsFromString($string, ...);
The contents of the string are split into arguments using a call to
C<Text::ParseWords::shellwords>. As with C<GetOptionsFromArray>, the
global C<@ARGV> is not touched.
It is possible that, upon completion, not all arguments in the string
have been processed. C<GetOptionsFromString> will, when called in list
context, return both the return status and an array reference to any
remaining arguments:
($ret, $args) = GetOptionsFromString($string, ... );
If any arguments remain, and C<GetOptionsFromString> was not called in
list context, a message will be given and C<GetOptionsFromString> will
return failure.
As with GetOptionsFromArray, a first argument hash reference now
becomes the second argument.
=head2 Storing options values in a hash
Sometimes, for example when there are a lot of options, having a
separate variable for each of them can be cumbersome. GetOptions()
supports, as an alternative mechanism, storing options values in a
hash.
To obtain this, a reference to a hash must be passed I<as the first
argument> to GetOptions(). For each option that is specified on the
command line, the option value will be stored in the hash with the
option name as key. Options that are not actually used on the command
line will not be put in the hash, on other words,
C<exists($h{option})> (or defined()) can be used to test if an option
was used. The drawback is that warnings will be issued if the program
runs under C<use strict> and uses C<$h{option}> without testing with
exists() or defined() first.
my %h = ();
GetOptions (\%h, 'length=i'); # will store in $h{length}
For options that take list or hash values, it is necessary to indicate
this by appending an C<@> or C<%> sign after the type:
GetOptions (\%h, 'colours=s@'); # will push to @{$h{colours}}
To make things more complicated, the hash may contain references to
the actual destinations, for example:
my $len = 0;
my %h = ('length' => \$len);
GetOptions (\%h, 'length=i'); # will store in $len
This example is fully equivalent with:
my $len = 0;
GetOptions ('length=i' => \$len); # will store in $len
Any mixture is possible. For example, the most frequently used options
could be stored in variables while all other options get stored in the
hash:
my $verbose = 0; # frequently referred
my $debug = 0; # frequently referred
my %h = ('verbose' => \$verbose, 'debug' => \$debug);
GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i');
if ( $verbose ) { ... }
if ( exists $h{filter} ) { ... option 'filter' was specified ... }
=head2 Bundling
With bundling it is possible to set several single-character options
at once. For example if C<a>, C<v> and C<x> are all valid options,
-vax
would set all three.
Getopt::Long supports two levels of bundling. To enable bundling, a
call to Getopt::Long::Configure is required.
The first level of bundling can be enabled with:
Getopt::Long::Configure ("bundling");
Configured this way, single-character options can be bundled but long
options B<must> always start with a double dash C<--> to avoid
ambiguity. For example, when C<vax>, C<a>, C<v> and C<x> are all valid
options,
-vax
would set C<a>, C<v> and C<x>, but
--vax
would set C<vax>.
The second level of bundling lifts this restriction. It can be enabled
with:
Getopt::Long::Configure ("bundling_override");
Now, C<-vax> would set the option C<vax>.
When any level of bundling is enabled, option values may be inserted
in the bundle. For example:
-h24w80
is equivalent to
-h 24 -w 80
When configured for bundling, single-character options are matched
case sensitive while long options are matched case insensitive. To
have the single-character options matched case insensitive as well,
use:
Getopt::Long::Configure ("bundling", "ignorecase_always");
It goes without saying that bundling can be quite confusing.
=head2 The lonesome dash
Normally, a lone dash C<-> on the command line will not be considered
an option. Option processing will terminate (unless "permute" is
configured) and the dash will be left in C<@ARGV>.
It is possible to get special treatment for a lone dash. This can be
achieved by adding an option specification with an empty name, for
example:
GetOptions ('' => \$stdio);
A lone dash on the command line will now be a legal option, and using
it will set variable C<$stdio>.
=head2 Argument callback
A special option 'name' C<< <> >> can be used to designate a subroutine
to handle non-option arguments. When GetOptions() encounters an
argument that does not look like an option, it will immediately call this
subroutine and passes it one parameter: the argument name. Well, actually
it is an object that stringifies to the argument name.
For example:
my $width = 80;
sub process { ... }
GetOptions ('width=i' => \$width, '<>' => \&process);
When applied to the following command line:
arg1 --width=72 arg2 --width=60 arg3
This will call
C<process("arg1")> while C<$width> is C<80>,
C<process("arg2")> while C<$width> is C<72>, and
C<process("arg3")> while C<$width> is C<60>.
This feature requires configuration option B<permute>, see section
L<Configuring Getopt::Long>.
=head1 Configuring Getopt::Long
Getopt::Long can be configured by calling subroutine
Getopt::Long::Configure(). This subroutine takes a list of quoted
strings, each specifying a configuration option to be enabled, e.g.
C<ignore_case>, or disabled, e.g. C<no_ignore_case>. Case does not
matter. Multiple calls to Configure() are possible.
Alternatively, as of version 2.24, the configuration options may be
passed together with the C<use> statement:
use Getopt::Long qw(:config no_ignore_case bundling);
The following options are available:
=over 12
=item default
This option causes all configuration options to be reset to their
default values.
=item posix_default
This option causes all configuration options to be reset to their
default values as if the environment variable POSIXLY_CORRECT had
been set.
=item auto_abbrev
Allow option names to be abbreviated to uniqueness.
Default is enabled unless environment variable
POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is disabled.
=item getopt_compat
Allow C<+> to start options.
Default is enabled unless environment variable
POSIXLY_CORRECT has been set, in which case C<getopt_compat> is disabled.
=item gnu_compat
C<gnu_compat> controls whether C<--opt=> is allowed, and what it should
do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>,
C<--opt=> will give option C<opt> and empty value.
This is the way GNU getopt_long() does it.
=item gnu_getopt
This is a short way of setting C<gnu_compat> C<bundling> C<permute>
C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be
fully compatible with GNU getopt_long().
=item require_order
Whether command line arguments are allowed to be mixed with options.
Default is disabled unless environment variable
POSIXLY_CORRECT has been set, in which case C<require_order> is enabled.
See also C<permute>, which is the opposite of C<require_order>.
=item permute
Whether command line arguments are allowed to be mixed with options.
Default is enabled unless environment variable
POSIXLY_CORRECT has been set, in which case C<permute> is disabled.
Note that C<permute> is the opposite of C<require_order>.
If C<permute> is enabled, this means that
--foo arg1 --bar arg2 arg3
is equivalent to
--foo --bar arg1 arg2 arg3
If an argument callback routine is specified, C<@ARGV> will always be
empty upon successful return of GetOptions() since all options have been
processed. The only exception is when C<--> is used:
--foo arg1 --bar arg2 -- arg3
This will call the callback routine for arg1 and arg2, and then
terminate GetOptions() leaving C<"arg3"> in C<@ARGV>.
If C<require_order> is enabled, options processing
terminates when the first non-option is encountered.
--foo arg1 --bar arg2 arg3
is equivalent to
--foo -- arg1 --bar arg2 arg3
If C<pass_through> is also enabled, options processing will terminate
at the first unrecognized option, or non-option, whichever comes
first.
=item bundling (default: disabled)
Enabling this option will allow single-character options to be
bundled. To distinguish bundles from long option names, long options
I<must> be introduced with C<--> and bundles with C<->.
Note that, if you have options C<a>, C<l> and C<all>, and
auto_abbrev enabled, possible arguments and option settings are:
using argument sets option(s)
------------------------------------------
-a, --a a
-l, --l l
-al, -la, -ala, -all,... a, l
--al, --all all
The surprising part is that C<--a> sets option C<a> (due to auto
completion), not C<all>.
Note: disabling C<bundling> also disables C<bundling_override>.
=item bundling_override (default: disabled)
If C<bundling_override> is enabled, bundling is enabled as with
C<bundling> but now long option names override option bundles.
Note: disabling C<bundling_override> also disables C<bundling>.
B<Note:> Using option bundling can easily lead to unexpected results,
especially when mixing long options and bundles. Caveat emptor.
=item ignore_case (default: enabled)
If enabled, case is ignored when matching option names. If, however,
bundling is enabled as well, single character options will be treated
case-sensitive.
With C<ignore_case>, option specifications for options that only
differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as
duplicates.
Note: disabling C<ignore_case> also disables C<ignore_case_always>.
=item ignore_case_always (default: disabled)
When bundling is in effect, case is ignored on single-character
options also.
Note: disabling C<ignore_case_always> also disables C<ignore_case>.
=item auto_version (default:disabled)
Automatically provide support for the B<--version> option if
the application did not specify a handler for this option itself.
Getopt::Long will provide a standard version message that includes the
program name, its version (if $main::VERSION is defined), and the
versions of Getopt::Long and Perl. The message will be written to
standard output and processing will terminate.
C<auto_version> will be enabled if the calling program explicitly
specified a version number higher than 2.32 in the C<use> or
C<require> statement.
=item auto_help (default:disabled)
Automatically provide support for the B<--help> and B<-?> options if
the application did not specify a handler for this option itself.
Getopt::Long will provide a help message using module L<Pod::Usage>. The
message, derived from the SYNOPSIS POD section, will be written to
standard output and processing will terminate.
C<auto_help> will be enabled if the calling program explicitly
specified a version number higher than 2.32 in the C<use> or
C<require> statement.
=item pass_through (default: disabled)
Options that are unknown, ambiguous or supplied with an invalid option
value are passed through in C<@ARGV> instead of being flagged as
errors. This makes it possible to write wrapper scripts that process
only part of the user supplied command line arguments, and pass the
remaining options to some other program.
If C<require_order> is enabled, options processing will terminate at
the first unrecognized option, or non-option, whichever comes first.
However, if C<permute> is enabled instead, results can become confusing.
Note that the options terminator (default C<-->), if present, will
also be passed through in C<@ARGV>.
=item prefix
The string that starts options. If a constant string is not
sufficient, see C<prefix_pattern>.
=item prefix_pattern
A Perl pattern that identifies the strings that introduce options.
Default is C<--|-|\+> unless environment variable
POSIXLY_CORRECT has been set, in which case it is C<--|->.
=item long_prefix_pattern
A Perl pattern that allows the disambiguation of long and short
prefixes. Default is C<-->.
Typically you only need to set this if you are using nonstandard
prefixes and want some or all of them to have the same semantics as
'--' does under normal circumstances.
For example, setting prefix_pattern to C<--|-|\+|\/> and
long_prefix_pattern to C<--|\/> would add Win32 style argument
handling.
=item debug (default: disabled)
Enable debugging output.
=back
=head1 Exportable Methods
=over
=item VersionMessage
This subroutine provides a standard version message. Its argument can be:
=over 4
=item *
A string containing the text of a message to print I<before> printing
the standard message.
=item *
A numeric value corresponding to the desired exit status.
=item *
A reference to a hash.
=back
If more than one argument is given then the entire argument list is
assumed to be a hash. If a hash is supplied (either as a reference or
as a list) it should contain one or more elements with the following
keys:
=over 4
=item C<-message>
=item C<-msg>
The text of a message to print immediately prior to printing the
program's usage message.
=item C<-exitval>
The desired exit status to pass to the B<exit()> function.
This should be an integer, or else the string "NOEXIT" to
indicate that control should simply be returned without
terminating the invoking process.
=item C<-output>
A reference to a filehandle, or the pathname of a file to which the
usage message should be written. The default is C<\*STDERR> unless the
exit value is less than 2 (in which case the default is C<\*STDOUT>).
=back
You cannot tie this routine directly to an option, e.g.:
GetOptions("version" => \&VersionMessage);
Use this instead:
GetOptions("version" => sub { VersionMessage() });
=item HelpMessage
This subroutine produces a standard help message, derived from the
program's POD section SYNOPSIS using L<Pod::Usage>. It takes the same
arguments as VersionMessage(). In particular, you cannot tie it
directly to an option, e.g.:
GetOptions("help" => \&HelpMessage);
Use this instead:
GetOptions("help" => sub { HelpMessage() });
=back
=head1 Return values and Errors
Configuration errors and errors in the option definitions are
signalled using die() and will terminate the calling program unless
the call to Getopt::Long::GetOptions() was embedded in C<eval { ...
}>, or die() was trapped using C<$SIG{__DIE__}>.
GetOptions returns true to indicate success.
It returns false when the function detected one or more errors during
option parsing. These errors are signalled using warn() and can be
trapped with C<$SIG{__WARN__}>.
=head1 Legacy
The earliest development of C<newgetopt.pl> started in 1990, with Perl
version 4. As a result, its development, and the development of
Getopt::Long, has gone through several stages. Since backward
compatibility has always been extremely important, the current version
of Getopt::Long still supports a lot of constructs that nowadays are
no longer necessary or otherwise unwanted. This section describes
briefly some of these 'features'.
=head2 Default destinations
When no destination is specified for an option, GetOptions will store
the resultant value in a global variable named C<opt_>I<XXX>, where
I<XXX> is the primary name of this option. When a progam executes
under C<use strict> (recommended), these variables must be
pre-declared with our() or C<use vars>.
our $opt_length = 0;
GetOptions ('length=i'); # will store in $opt_length
To yield a usable Perl variable, characters that are not part of the
syntax for variables are translated to underscores. For example,
C<--fpp-struct-return> will set the variable
C<$opt_fpp_struct_return>. Note that this variable resides in the
namespace of the calling program, not necessarily C<main>. For
example:
GetOptions ("size=i", "sizes=i@");
with command line "-size 10 -sizes 24 -sizes 48" will perform the
equivalent of the assignments
$opt_size = 10;
@opt_sizes = (24, 48);
=head2 Alternative option starters
A string of alternative option starter characters may be passed as the
first argument (or the first argument after a leading hash reference
argument).
my $len = 0;
GetOptions ('/', 'length=i' => $len);
Now the command line may look like:
/length 24 -- arg
Note that to terminate options processing still requires a double dash
C<-->.
GetOptions() will not interpret a leading C<< "<>" >> as option starters
if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as
option starters, use C<< "><" >>. Confusing? Well, B<using a starter
argument is strongly deprecated> anyway.
=head2 Configuration variables
Previous versions of Getopt::Long used variables for the purpose of
configuring. Although manipulating these variables still work, it is
strongly encouraged to use the C<Configure> routine that was introduced
in version 2.17. Besides, it is much easier.
=head1 Tips and Techniques
=head2 Pushing multiple values in a hash option
Sometimes you want to combine the best of hashes and arrays. For
example, the command line:
--list add=first --list add=second --list add=third
where each successive 'list add' option will push the value of add
into array ref $list->{'add'}. The result would be like
$list->{add} = [qw(first second third)];
This can be accomplished with a destination routine:
GetOptions('list=s%' =>
sub { push(@{$list{$_[1]}}, $_[2]) });
=head1 Troubleshooting
=head2 GetOptions does not return a false result when an option is not supplied
That's why they're called 'options'.
=head2 GetOptions does not split the command line correctly
The command line is not split by GetOptions, but by the command line
interpreter (CLI). On Unix, this is the shell. On Windows, it is
COMMAND.COM or CMD.EXE. Other operating systems have other CLIs.
It is important to know that these CLIs may behave different when the
command line contains special characters, in particular quotes or
backslashes. For example, with Unix shells you can use single quotes
(C<'>) and double quotes (C<">) to group words together. The following
alternatives are equivalent on Unix:
"two words"
'two words'
two\ words
In case of doubt, insert the following statement in front of your Perl
program:
print STDERR (join("|",@ARGV),"\n");
to verify how your CLI passes the arguments to the program.
=head2 Undefined subroutine &main::GetOptions called
Are you running Windows, and did you write
use GetOpt::Long;
(note the capital 'O')?
=head2 How do I put a "-?" option into a Getopt::Long?
You can only obtain this using an alias, and Getopt::Long of at least
version 2.13.
use Getopt::Long;
GetOptions ("help|?"); # -help and -? will both set $opt_help
Other characters that can't appear in Perl identifiers are also supported
as aliases with Getopt::Long of at least version 2.39.
As of version 2.32 Getopt::Long provides auto-help, a quick and easy way
to add the options --help and -? to your program, and handle them.
See C<auto_help> in section L<Configuring Getopt::Long>.
=head1 AUTHOR
Johan Vromans <jvromans@squirrel.nl>
=head1 COPYRIGHT AND DISCLAIMER
This program is Copyright 1990,2010 by Johan Vromans.
This program is free software; you can redistribute it and/or
modify it under the terms of the Perl Artistic License or the
GNU General Public License as published by the Free Software
Foundation; either version 2 of the License, or (at your option) any
later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
If you do not have a copy of the GNU General Public License write to
the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
MA 02139, USA.
=cut
GETOPT_LONG
$fatpacked{"HTTP/Tiny.pm"} = <<'HTTP_TINY';
# vim: ts=4 sts=4 sw=4 et:
package HTTP::Tiny;
use strict;
use warnings;
# ABSTRACT: A small, simple, correct HTTP/1.1 client
our $VERSION = '0.028'; # VERSION
use Carp ();
my @attributes;
BEGIN {
@attributes = qw(agent cookie_jar default_headers local_address max_redirect max_size proxy timeout SSL_options verify_SSL);
no strict 'refs';
for my $accessor ( @attributes ) {
*{$accessor} = sub {
@_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
};
}
}
sub new {
my($class, %args) = @_;
(my $default_agent = $class) =~ s{::}{-}g;
$default_agent .= "/" . ($class->VERSION || 0);
my $self = {
agent => $default_agent,
max_redirect => 5,
timeout => 60,
verify_SSL => $args{verify_SSL} || $args{verify_ssl} || 0, # no verification by default
};
$args{agent} .= $default_agent
if defined $args{agent} && $args{agent} =~ / $/;
$class->_validate_cookie_jar( $args{cookie_jar} ) if $args{cookie_jar};
for my $key ( @attributes ) {
$self->{$key} = $args{$key} if exists $args{$key}
}
# Never override proxy argument as this breaks backwards compat.
if (!exists $self->{proxy} && (my $http_proxy = $ENV{http_proxy})) {
if ($http_proxy =~ m{\Ahttp://[^/?#:@]+:\d+/?\z}) {
$self->{proxy} = $http_proxy;
}
else {
Carp::croak(qq{Environment 'http_proxy' must be in format http://<host>:<port>/\n});
}
}
return bless $self, $class;
}
for my $sub_name ( qw/get head put post delete/ ) {
my $req_method = uc $sub_name;
no strict 'refs';
eval <<"HERE"; ## no critic
sub $sub_name {
my (\$self, \$url, \$args) = \@_;
\@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH')
or Carp::croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n");
return \$self->request('$req_method', \$url, \$args || {});
}
HERE
}
sub post_form {
my ($self, $url, $data, $args) = @_;
(@_ == 3 || @_ == 4 && ref $args eq 'HASH')
or Carp::croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n");
my $headers = {};
while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
$headers->{lc $key} = $value;
}
delete $args->{headers};
return $self->request('POST', $url, {
%$args,
content => $self->www_form_urlencode($data),
headers => {
%$headers,
'content-type' => 'application/x-www-form-urlencoded'
},
}
);
}
sub mirror {
my ($self, $url, $file, $args) = @_;
@_ == 3 || (@_ == 4 && ref $args eq 'HASH')
or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n");
if ( -e $file and my $mtime = (stat($file))[9] ) {
$args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime);
}
my $tempfile = $file . int(rand(2**31));
open my $fh, ">", $tempfile
or Carp::croak(qq/Error: Could not open temporary file $tempfile for downloading: $!\n/);
binmode $fh;
$args->{data_callback} = sub { print {$fh} $_[0] };
my $response = $self->request('GET', $url, $args);
close $fh
or Carp::croak(qq/Error: Could not close temporary file $tempfile: $!\n/);
if ( $response->{success} ) {
rename $tempfile, $file
or Carp::croak(qq/Error replacing $file with $tempfile: $!\n/);
my $lm = $response->{headers}{'last-modified'};
if ( $lm and my $mtime = $self->_parse_http_date($lm) ) {
utime $mtime, $mtime, $file;
}
}
$response->{success} ||= $response->{status} eq '304';
unlink $tempfile;
return $response;
}
my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/;
sub request {
my ($self, $method, $url, $args) = @_;
@_ == 3 || (@_ == 4 && ref $args eq 'HASH')
or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n");
$args ||= {}; # we keep some state in this during _request
# RFC 2616 Section 8.1.4 mandates a single retry on broken socket
my $response;
for ( 0 .. 1 ) {
$response = eval { $self->_request($method, $url, $args) };
last unless $@ && $idempotent{$method}
&& $@ =~ m{^(?:Socket closed|Unexpected end)};
}
if (my $e = "$@") {
$response = {
url => $url,
success => q{},
status => 599,
reason => 'Internal Exception',
content => $e,
headers => {
'content-type' => 'text/plain',
'content-length' => length $e,
}
};
}
return $response;
}
sub www_form_urlencode {
my ($self, $data) = @_;
(@_ == 2 && ref $data)
or Carp::croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n");
(ref $data eq 'HASH' || ref $data eq 'ARRAY')
or Carp::croak("form data must be a hash or array reference\n");
my @params = ref $data eq 'HASH' ? %$data : @$data;
@params % 2 == 0
or Carp::croak("form data reference must have an even number of terms\n");
my @terms;
while( @params ) {
my ($key, $value) = splice(@params, 0, 2);
if ( ref $value eq 'ARRAY' ) {
unshift @params, map { $key => $_ } @$value;
}
else {
push @terms, join("=", map { $self->_uri_escape($_) } $key, $value);
}
}
return join("&", sort @terms);
}
#--------------------------------------------------------------------------#
# private methods
#--------------------------------------------------------------------------#
my %DefaultPort = (
http => 80,
https => 443,
);
sub _request {
my ($self, $method, $url, $args) = @_;
my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
my $request = {
method => $method,
scheme => $scheme,
host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
uri => $path_query,
headers => {},
};
my $handle = HTTP::Tiny::Handle->new(
timeout => $self->{timeout},
SSL_options => $self->{SSL_options},
verify_SSL => $self->{verify_SSL},
local_address => $self->{local_address},
);
if ($self->{proxy}) {
$request->{uri} = "$scheme://$request->{host_port}$path_query";
die(qq/HTTPS via proxy is not supported\n/)
if $request->{scheme} eq 'https';
$handle->connect(($self->_split_url($self->{proxy}))[0..2]);
}
else {
$handle->connect($scheme, $host, $port);
}
$self->_prepare_headers_and_cb($request, $args, $url);
$handle->write_request($request);
my $response;
do { $response = $handle->read_response_header }
until (substr($response->{status},0,1) ne '1');
$self->_update_cookie_jar( $url, $response ) if $self->{cookie_jar};
if ( my @redir_args = $self->_maybe_redirect($request, $response, $args) ) {
$handle->close;
return $self->_request(@redir_args, $args);
}
if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) {
# response has no message body
}
else {
my $data_cb = $self->_prepare_data_cb($response, $args);
$handle->read_body($data_cb, $response);
}
$handle->close;
$response->{success} = substr($response->{status},0,1) eq '2';
$response->{url} = $url;
return $response;
}
sub _prepare_headers_and_cb {
my ($self, $request, $args, $url) = @_;
for ($self->{default_headers}, $args->{headers}) {
next unless defined;
while (my ($k, $v) = each %$_) {
$request->{headers}{lc $k} = $v;
}
}
$request->{headers}{'host'} = $request->{host_port};
$request->{headers}{'connection'} = "close";
$request->{headers}{'user-agent'} ||= $self->{agent};
if (defined $args->{content}) {
$request->{headers}{'content-type'} ||= "application/octet-stream";
if (ref $args->{content} eq 'CODE') {
$request->{headers}{'transfer-encoding'} = 'chunked'
unless $request->{headers}{'content-length'}
|| $request->{headers}{'transfer-encoding'};
$request->{cb} = $args->{content};
}
else {
my $content = $args->{content};
if ( $] ge '5.008' ) {
utf8::downgrade($content, 1)
or die(qq/Wide character in request message body\n/);
}
$request->{headers}{'content-length'} = length $content
unless $request->{headers}{'content-length'}
|| $request->{headers}{'transfer-encoding'};
$request->{cb} = sub { substr $content, 0, length $content, '' };
}
$request->{trailer_cb} = $args->{trailer_callback}
if ref $args->{trailer_callback} eq 'CODE';
}
### If we have a cookie jar, then maybe add relevant cookies
if ( $self->{cookie_jar} ) {
my $cookies = $self->cookie_jar->cookie_header( $url );
$request->{headers}{cookie} = $cookies if length $cookies;
}
return;
}
sub _prepare_data_cb {
my ($self, $response, $args) = @_;
my $data_cb = $args->{data_callback};
$response->{content} = '';
if (!$data_cb || $response->{status} !~ /^2/) {
if (defined $self->{max_size}) {
$data_cb = sub {
$_[1]->{content} .= $_[0];
die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)
if length $_[1]->{content} > $self->{max_size};
};
}
else {
$data_cb = sub { $_[1]->{content} .= $_[0] };
}
}
return $data_cb;
}
sub _update_cookie_jar {
my ($self, $url, $response) = @_;
my $cookies = $response->{headers}->{'set-cookie'};
return unless defined $cookies;
my @cookies = ref $cookies ? @$cookies : $cookies;
$self->cookie_jar->add( $url, $_ ) for @cookies;
return;
}
sub _validate_cookie_jar {
my ($class, $jar) = @_;
# duck typing
for my $method ( qw/add cookie_header/ ) {
Carp::croak(qq/Cookie jar must provide the '$method' method\n/)
unless ref($jar) && ref($jar)->can($method);
}
return;
}
sub _maybe_redirect {
my ($self, $request, $response, $args) = @_;
my $headers = $response->{headers};
my ($status, $method) = ($response->{status}, $request->{method});
if (($status eq '303' or ($status =~ /^30[127]/ && $method =~ /^GET|HEAD$/))
and $headers->{location}
and ++$args->{redirects} <= $self->{max_redirect}
) {
my $location = ($headers->{location} =~ /^\//)
? "$request->{scheme}://$request->{host_port}$headers->{location}"
: $headers->{location} ;
return (($status eq '303' ? 'GET' : $method), $location);
}
return;
}
sub _split_url {
my $url = pop;
# URI regex adapted from the URI module
my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
or die(qq/Cannot parse URL: '$url'\n/);
$scheme = lc $scheme;
$path_query = "/$path_query" unless $path_query =~ m<\A/>;
my $host = (length($authority)) ? lc $authority : 'localhost';
$host =~ s/\A[^@]*@//; # userinfo
my $port = do {
$host =~ s/:([0-9]*)\z// && length $1
? $1
: ($scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef);
};
return ($scheme, $host, $port, $path_query);
}
# Date conversions adapted from HTTP::Date
my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat";
my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";
sub _http_date {
my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]);
return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
substr($DoW,$wday*4,3),
$mday, substr($MoY,$mon*4,3), $year+1900,
$hour, $min, $sec
);
}
sub _parse_http_date {
my ($self, $str) = @_;
require Time::Local;
my @tl_parts;
if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) {
@tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
}
elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) {
@tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
}
elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) {
@tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6);
}
return eval {
my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1;
$t < 0 ? undef : $t;
};
}
# URI escaping adapted from URI::Escape
# c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1
# perl 5.6 ready UTF-8 encoding adapted from JSON::PP
my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
$escapes{' '}="+";
my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
sub _uri_escape {
my ($self, $str) = @_;
if ( $] ge '5.008' ) {
utf8::encode($str);
}
else {
$str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string
if ( length $str == do { use bytes; length $str } );
$str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag
}
$str =~ s/($unsafe_char)/$escapes{$1}/ge;
return $str;
}
package
HTTP::Tiny::Handle; # hide from PAUSE/indexers
use strict;
use warnings;
use Errno qw[EINTR EPIPE];
use IO::Socket qw[SOCK_STREAM];
sub BUFSIZE () { 32768 } ## no critic
my $Printable = sub {
local $_ = shift;
s/\r/\\r/g;
s/\n/\\n/g;
s/\t/\\t/g;
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
$_;
};
my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
sub new {
my ($class, %args) = @_;
return bless {
rbuf => '',
timeout => 60,
max_line_size => 16384,
max_header_lines => 64,
verify_SSL => 0,
SSL_options => {},
%args
}, $class;
}
sub connect {
@_ == 4 || die(q/Usage: $handle->connect(scheme, host, port)/ . "\n");
my ($self, $scheme, $host, $port) = @_;
if ( $scheme eq 'https' ) {
die(qq/IO::Socket::SSL 1.56 must be installed for https support\n/)
unless eval {require IO::Socket::SSL; IO::Socket::SSL->VERSION(1.56)};
die(qq/Net::SSLeay 1.49 must be installed for https support\n/)
unless eval {require Net::SSLeay; Net::SSLeay->VERSION(1.49)};
}
elsif ( $scheme ne 'http' ) {
die(qq/Unsupported URL scheme '$scheme'\n/);
}
$self->{fh} = 'IO::Socket::INET'->new(
PeerHost => $host,
PeerPort => $port,
$self->{local_address} ?
( LocalAddr => $self->{local_address} ) : (),
Proto => 'tcp',
Type => SOCK_STREAM,
Timeout => $self->{timeout}
) or die(qq/Could not connect to '$host:$port': $@\n/);
binmode($self->{fh})
or die(qq/Could not binmode() socket: '$!'\n/);
if ( $scheme eq 'https') {
my $ssl_args = $self->_ssl_args($host);
IO::Socket::SSL->start_SSL(
$self->{fh},
%$ssl_args,
SSL_create_ctx_callback => sub {
my $ctx = shift;
Net::SSLeay::CTX_set_mode($ctx, Net::SSLeay::MODE_AUTO_RETRY());
},
);
unless ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
my $ssl_err = IO::Socket::SSL->errstr;
die(qq/SSL connection failed for $host: $ssl_err\n/);
}
}
$self->{host} = $host;
$self->{port} = $port;
return $self;
}
sub close {
@_ == 1 || die(q/Usage: $handle->close()/ . "\n");
my ($self) = @_;
CORE::close($self->{fh})
or die(qq/Could not close socket: '$!'\n/);
}
sub write {
@_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n");
my ($self, $buf) = @_;
if ( $] ge '5.008' ) {
utf8::downgrade($buf, 1)
or die(qq/Wide character in write()\n/);
}
my $len = length $buf;
my $off = 0;
local $SIG{PIPE} = 'IGNORE';
while () {
$self->can_write
or die(qq/Timed out while waiting for socket to become ready for writing\n/);
my $r = syswrite($self->{fh}, $buf, $len, $off);
if (defined $r) {
$len -= $r;
$off += $r;
last unless $len > 0;
}
elsif ($! == EPIPE) {
die(qq/Socket closed by remote server: $!\n/);
}
elsif ($! != EINTR) {
if ($self->{fh}->can('errstr')){
my $err = $self->{fh}->errstr();
die (qq/Could not write to SSL socket: '$err'\n /);
}
else {
die(qq/Could not write to socket: '$!'\n/);
}
}
}
return $off;
}
sub read {
@_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n");
my ($self, $len, $allow_partial) = @_;
my $buf = '';
my $got = length $self->{rbuf};
if ($got) {
my $take = ($got < $len) ? $got : $len;
$buf = substr($self->{rbuf}, 0, $take, '');
$len -= $take;
}
while ($len > 0) {
$self->can_read
or die(q/Timed out while waiting for socket to become ready for reading/ . "\n");
my $r = sysread($self->{fh}, $buf, $len, length $buf);
if (defined $r) {
last unless $r;
$len -= $r;
}
elsif ($! != EINTR) {
if ($self->{fh}->can('errstr')){
my $err = $self->{fh}->errstr();
die (qq/Could not read from SSL socket: '$err'\n /);
}
else {
die(qq/Could not read from socket: '$!'\n/);
}
}
}
if ($len && !$allow_partial) {
die(qq/Unexpected end of stream\n/);
}
return $buf;
}
sub readline {
@_ == 1 || die(q/Usage: $handle->readline()/ . "\n");
my ($self) = @_;
while () {
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
return $1;
}
if (length $self->{rbuf} >= $self->{max_line_size}) {
die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/);
}
$self->can_read
or die(qq/Timed out while waiting for socket to become ready for reading\n/);
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
if (defined $r) {
last unless $r;
}
elsif ($! != EINTR) {
if ($self->{fh}->can('errstr')){
my $err = $self->{fh}->errstr();
die (qq/Could not read from SSL socket: '$err'\n /);
}
else {
die(qq/Could not read from socket: '$!'\n/);
}
}
}
die(qq/Unexpected end of stream while looking for line\n/);
}
sub read_header_lines {
@_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n");
my ($self, $headers) = @_;
$headers ||= {};
my $lines = 0;
my $val;
while () {
my $line = $self->readline;
if (++$lines >= $self->{max_header_lines}) {
die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/);
}
elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
my ($field_name) = lc $1;
if (exists $headers->{$field_name}) {
for ($headers->{$field_name}) {
$_ = [$_] unless ref $_ eq "ARRAY";
push @$_, $2;
$val = \$_->[-1];
}
}
else {
$val = \($headers->{$field_name} = $2);
}
}
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
$val
or die(qq/Unexpected header continuation line\n/);
next unless length $1;
$$val .= ' ' if length $$val;
$$val .= $1;
}
elsif ($line =~ /\A \x0D?\x0A \z/x) {
last;
}
else {
die(q/Malformed header line: / . $Printable->($line) . "\n");
}
}
return $headers;
}
sub write_request {
@_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n");
my($self, $request) = @_;
$self->write_request_header(@{$request}{qw/method uri headers/});
$self->write_body($request) if $request->{cb};
return;
}
my %HeaderCase = (
'content-md5' => 'Content-MD5',
'etag' => 'ETag',
'te' => 'TE',
'www-authenticate' => 'WWW-Authenticate',
'x-xss-protection' => 'X-XSS-Protection',
);
sub write_header_lines {
(@_ == 2 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers)/ . "\n");
my($self, $headers) = @_;
my $buf = '';
while (my ($k, $v) = each %$headers) {
my $field_name = lc $k;
if (exists $HeaderCase{$field_name}) {
$field_name = $HeaderCase{$field_name};
}
else {
$field_name =~ /\A $Token+ \z/xo
or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n");
$field_name =~ s/\b(\w)/\u$1/g;
$HeaderCase{lc $field_name} = $field_name;
}
for (ref $v eq 'ARRAY' ? @$v : $v) {
/[^\x0D\x0A]/
or die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n");
$buf .= "$field_name: $_\x0D\x0A";
}
}
$buf .= "\x0D\x0A";
return $self->write($buf);
}
sub read_body {
@_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n");
my ($self, $cb, $response) = @_;
my $te = $response->{headers}{'transfer-encoding'} || '';
if ( grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ) {
$self->read_chunked_body($cb, $response);
}
else {
$self->read_content_body($cb, $response);
}
return;
}
sub write_body {
@_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n");
my ($self, $request) = @_;
if ($request->{headers}{'content-length'}) {
return $self->write_content_body($request);
}
else {
return $self->write_chunked_body($request);
}
}
sub read_content_body {
@_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n");
my ($self, $cb, $response, $content_length) = @_;
$content_length ||= $response->{headers}{'content-length'};
if ( $content_length ) {
my $len = $content_length;
while ($len > 0) {
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
$cb->($self->read($read, 0), $response);
$len -= $read;
}
}
else {
my $chunk;
$cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) );
}
return;
}
sub write_content_body {
@_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n");
my ($self, $request) = @_;
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
while () {
my $data = $request->{cb}->();
defined $data && length $data
or last;
if ( $] ge '5.008' ) {
utf8::downgrade($data, 1)
or die(qq/Wide character in write_content()\n/);
}
$len += $self->write($data);
}
$len == $content_length
or die(qq/Content-Length missmatch (got: $len expected: $content_length)\n/);
return $len;
}
sub read_chunked_body {
@_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n");
my ($self, $cb, $response) = @_;
while () {
my $head = $self->readline;
$head =~ /\A ([A-Fa-f0-9]+)/x
or die(q/Malformed chunk head: / . $Printable->($head) . "\n");
my $len = hex($1)
or last;
$self->read_content_body($cb, $response, $len);
$self->read(2) eq "\x0D\x0A"
or die(qq/Malformed chunk: missing CRLF after chunk data\n/);
}
$self->read_header_lines($response->{headers});
return;
}
sub write_chunked_body {
@_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n");
my ($self, $request) = @_;
my $len = 0;
while () {
my $data = $request->{cb}->();
defined $data && length $data
or last;
if ( $] ge '5.008' ) {
utf8::downgrade($data, 1)
or die(qq/Wide character in write_chunked_body()\n/);
}
$len += length $data;
my $chunk = sprintf '%X', length $data;
$chunk .= "\x0D\x0A";
$chunk .= $data;
$chunk .= "\x0D\x0A";
$self->write($chunk);
}
$self->write("0\x0D\x0A");
$self->write_header_lines($request->{trailer_cb}->())
if ref $request->{trailer_cb} eq 'CODE';
return $len;
}
sub read_response_header {
@_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n");
my ($self) = @_;
my $line = $self->readline;
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
or die(q/Malformed Status-Line: / . $Printable->($line). "\n");
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
die (qq/Unsupported HTTP protocol: $protocol\n/)
unless $version =~ /0*1\.0*[01]/;
return {
status => $status,
reason => $reason,
headers => $self->read_header_lines,
protocol => $protocol,
};
}
sub write_request_header {
@_ == 4 || die(q/Usage: $handle->write_request_header(method, request_uri, headers)/ . "\n");
my ($self, $method, $request_uri, $headers) = @_;
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
+ $self->write_header_lines($headers);
}
sub _do_timeout {
my ($self, $type, $timeout) = @_;
$timeout = $self->{timeout}
unless defined $timeout && $timeout >= 0;
my $fd = fileno $self->{fh};
defined $fd && $fd >= 0
or die(qq/select(2): 'Bad file descriptor'\n/);
my $initial = time;
my $pending = $timeout;
my $nfound;
vec(my $fdset = '', $fd, 1) = 1;
while () {
$nfound = ($type eq 'read')
? select($fdset, undef, undef, $pending)
: select(undef, $fdset, undef, $pending) ;
if ($nfound == -1) {
$! == EINTR
or die(qq/select(2): '$!'\n/);
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
$nfound = 0;
}
last;
}
$! = 0;
return $nfound;
}
sub can_read {
@_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n");
my $self = shift;
return $self->_do_timeout('read', @_)
}
sub can_write {
@_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n");
my $self = shift;
return $self->_do_timeout('write', @_)
}
# Try to find a CA bundle to validate the SSL cert,
# prefer Mozilla::CA or fallback to a system file
sub _find_CA_file {
my $self = shift();
return $self->{SSL_options}->{SSL_ca_file}
if $self->{SSL_options}->{SSL_ca_file} and -e $self->{SSL_options}->{SSL_ca_file};
return Mozilla::CA::SSL_ca_file()
if eval { require Mozilla::CA };
foreach my $ca_bundle (qw{
/etc/ssl/certs/ca-certificates.crt
/etc/pki/tls/certs/ca-bundle.crt
/etc/ssl/ca-bundle.pem
}
) {
return $ca_bundle if -e $ca_bundle;
}
die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/
. qq/Try installing Mozilla::CA from CPAN\n/;
}
sub _ssl_args {
my ($self, $host) = @_;
my %ssl_args = (
SSL_hostname => $host, # SNI
);
if ($self->{verify_SSL}) {
$ssl_args{SSL_verifycn_scheme} = 'http'; # enable CN validation
$ssl_args{SSL_verifycn_name} = $host; # set validation hostname
$ssl_args{SSL_verify_mode} = 0x01; # enable cert validation
$ssl_args{SSL_ca_file} = $self->_find_CA_file;
}
else {
$ssl_args{SSL_verifycn_scheme} = 'none'; # disable CN validation
$ssl_args{SSL_verify_mode} = 0x00; # disable cert validation
}
# user options override settings from verify_SSL
for my $k ( keys %{$self->{SSL_options}} ) {
$ssl_args{$k} = $self->{SSL_options}{$k} if $k =~ m/^SSL_/;
}
return \%ssl_args;
}
1;
__END__
=pod
=head1 NAME
HTTP::Tiny - A small, simple, correct HTTP/1.1 client
=head1 VERSION
version 0.028
=head1 SYNOPSIS
use HTTP::Tiny;
my $response = HTTP::Tiny->new->get('http://example.com/');
die "Failed!\n" unless $response->{success};
print "$response->{status} $response->{reason}\n";
while (my ($k, $v) = each %{$response->{headers}}) {
for (ref $v eq 'ARRAY' ? @$v : $v) {
print "$k: $_\n";
}
}
print $response->{content} if length $response->{content};
=head1 DESCRIPTION
This is a very simple HTTP/1.1 client, designed for doing simple GET
requests without the overhead of a large framework like L<LWP::UserAgent>.
It is more correct and more complete than L<HTTP::Lite>. It supports
proxies (currently only non-authenticating ones) and redirection. It
also correctly resumes after EINTR.
=head1 METHODS
=head2 new
$http = HTTP::Tiny->new( %attributes );
This constructor returns a new HTTP::Tiny object. Valid attributes include:
=over 4
=item *
C<agent>
A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> ends in a space character, the default user-agent string is appended.
=item *
C<cookie_jar>
An instance of L<HTTP::CookieJar> or equivalent class that supports the C<add> and C<cookie_header> methods
=item *
C<default_headers>
A hashref of default headers to apply to requests
=item *
C<local_address>
The local IP address to bind to
=item *
C<max_redirect>
Maximum number of redirects allowed (defaults to 5)
=item *
C<max_size>
Maximum response size (only when not using a data callback). If defined,
responses larger than this will return an exception.
=item *
C<proxy>
URL of a proxy server to use (default is C<$ENV{http_proxy}> if set)
=item *
C<timeout>
Request timeout in seconds (default is 60)
=item *
C<verify_SSL>
A boolean that indicates whether to validate the SSL certificate of an C<https>
connection (default is false)
=item *
C<SSL_options>
A hashref of C<SSL_*> options to pass through to L<IO::Socket::SSL>
=back
Exceptions from C<max_size>, C<timeout> or other errors will result in a
pseudo-HTTP status code of 599 and a reason of "Internal Exception". The
content field in the response will contain the text of the exception.
See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
=head2 get|head|put|post|delete
$response = $http->get($url);
$response = $http->get($url, \%options);
$response = $http->head($url);
These methods are shorthand for calling C<request()> for the given method. The
URL must have unsafe characters escaped and international domain names encoded.
See C<request()> for valid options and a description of the response.
The C<success> field of the response will be true if the status code is 2XX.
=head2 post_form
$response = $http->post_form($url, $form_data);
$response = $http->post_form($url, $form_data, \%options);
This method executes a C<POST> request and sends the key/value pairs from a
form data hash or array reference to the given URL with a C<content-type> of
C<application/x-www-form-urlencoded>. See documentation for the
C<www_form_urlencode> method for details on the encoding.
The URL must have unsafe characters escaped and international domain names
encoded. See C<request()> for valid options and a description of the response.
Any C<content-type> header or content in the options hashref will be ignored.
The C<success> field of the response will be true if the status code is 2XX.
=head2 mirror
$response = $http->mirror($url, $file, \%options)
if ( $response->{success} ) {
print "$file is up to date\n";
}
Executes a C<GET> request for the URL and saves the response body to the file
name provided. The URL must have unsafe characters escaped and international
domain names encoded. If the file already exists, the request will includes an
C<If-Modified-Since> header with the modification timestamp of the file. You
may specify a different C<If-Modified-Since> header yourself in the C<<
$options->{headers} >> hash.
The C<success> field of the response will be true if the status code is 2XX
or if the status code is 304 (unmodified).
If the file was modified and the server response includes a properly
formatted C<Last-Modified> header, the file modification time will
be updated accordingly.
=head2 request
$response = $http->request($method, $url);
$response = $http->request($method, $url, \%options);
Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
'PUT', etc.) on the given URL. The URL must have unsafe characters escaped and
international domain names encoded. A hashref of options may be appended to
modify the request.
Valid options are:
=over 4
=item *
C<headers>
A hashref containing headers to include with the request. If the value for
a header is an array reference, the header will be output multiple times with
each value in the array. These headers over-write any default headers.
=item *
C<content>
A scalar to include as the body of the request OR a code reference
that will be called iteratively to produce the body of the request
=item *
C<trailer_callback>
A code reference that will be called if it exists to provide a hashref
of trailing headers (only used with chunked transfer-encoding)
=item *
C<data_callback>
A code reference that will be called for each chunks of the response
body received.
=back
If the C<content> option is a code reference, it will be called iteratively
to provide the content body of the request. It should return the empty
string or undef when the iterator is exhausted.
If the C<data_callback> option is provided, it will be called iteratively until
the entire response body is received. The first argument will be a string
containing a chunk of the response body, the second argument will be the
in-progress response hash reference, as described below. (This allows
customizing the action of the callback based on the C<status> or C<headers>
received prior to the content body.)
The C<request> method returns a hashref containing the response. The hashref
will have the following keys:
=over 4
=item *
C<success>
Boolean indicating whether the operation returned a 2XX status code
=item *
C<url>
URL that provided the response. This is the URL of the request unless
there were redirections, in which case it is the last URL queried
in a redirection chain
=item *
C<status>
The HTTP status code of the response
=item *
C<reason>
The response phrase returned by the server
=item *
C<content>
The body of the response. If the response does not have any content
or if a data callback is provided to consume the response body,
this will be the empty string
=item *
C<headers>
A hashref of header fields. All header field names will be normalized
to be lower case. If a header is repeated, the value will be an arrayref;
it will otherwise be a scalar string containing the value
=back
On an exception during the execution of the request, the C<status> field will
contain 599, and the C<content> field will contain the text of the exception.
=head2 www_form_urlencode
$params = $http->www_form_urlencode( $data );
$response = $http->get("http://example.com/query?$params");
This method converts the key/value pairs from a data hash or array reference
into a C<x-www-form-urlencoded> string. The keys and values from the data
reference will be UTF-8 encoded and escaped per RFC 3986. If a value is an
array reference, the key will be repeated with each of the values of the array
reference. The key/value pairs in the resulting string will be sorted by key
and value.
=for Pod::Coverage agent
cookie_jar
default_headers
local_address
max_redirect
max_size
proxy
timeout
verify_SSL
SSL_options
=head1 SSL SUPPORT
Direct C<https> connections are supported only if L<IO::Socket::SSL> 1.56 or
greater and L<Net::SSLeay> 1.49 or greater are installed. An exception will be
thrown if a new enough versions of these modules not installed or if the SSL
encryption fails. There is no support for C<https> connections via proxy (i.e.
RFC 2817).
SSL provides two distinct capabilities:
=over 4
=item *
Encrypted communication channel
=item *
Verification of server identity
=back
B<By default, HTTP::Tiny does not verify server identity>.
Server identity verification is controversial and potentially tricky because it
depends on a (usually paid) third-party Certificate Authority (CA) trust model
to validate a certificate as legitimate. This discriminates against servers
with self-signed certificates or certificates signed by free, community-driven
CA's such as L<CAcert.org|http://cacert.org>.
By default, HTTP::Tiny does not make any assumptions about your trust model,
threat level or risk tolerance. It just aims to give you an encrypted channel
when you need one.
Setting the C<verify_SSL> attribute to a true value will make HTTP::Tiny verify
that an SSL connection has a valid SSL certificate corresponding to the host
name of the connection and that the SSL certificate has been verified by a CA.
Assuming you trust the CA, this will protect against a L<man-in-the-middle
attack|http://en.wikipedia.org/wiki/Man-in-the-middle_attack>. If you are
concerned about security, you should enable this option.
Certificate verification requires a file containing trusted CA certificates.
If the L<Mozilla::CA> module is installed, HTTP::Tiny will use the CA file
included with it as a source of trusted CA's. (This means you trust Mozilla,
the author of Mozilla::CA, the CPAN mirror where you got Mozilla::CA, the
toolchain used to install it, and your operating system security, right?)
If that module is not available, then HTTP::Tiny will search several
system-specific default locations for a CA certificate file:
=over 4
=item *
/etc/ssl/certs/ca-certificates.crt
=item *
/etc/pki/tls/certs/ca-bundle.crt
=item *
/etc/ssl/ca-bundle.pem
=back
An exception will be raised if C<verify_SSL> is true and no CA certificate file
is available.
If you desire complete control over SSL connections, the C<SSL_options> attribute
lets you provide a hash reference that will be passed through to
C<IO::Socket::SSL::start_SSL()>, overriding any options set by HTTP::Tiny. For
example, to provide your own trusted CA file:
SSL_options => {
SSL_ca_file => $file_path,
}
The C<SSL_options> attribute could also be used for such things as providing a
client certificate for authentication to a server or controlling the choice of
cipher used for the SSL connection. See L<IO::Socket::SSL> documentation for
details.
=head1 LIMITATIONS
HTTP::Tiny is I<conditionally compliant> with the
L<HTTP/1.1 specification|http://www.w3.org/Protocols/rfc2616/rfc2616.html>.
It attempts to meet all "MUST" requirements of the specification, but does not
implement all "SHOULD" requirements.
Some particular limitations of note include:
=over
=item *
HTTP::Tiny focuses on correct transport. Users are responsible for ensuring
that user-defined headers and content are compliant with the HTTP/1.1
specification.
=item *
Users must ensure that URLs are properly escaped for unsafe characters and that
international domain names are properly encoded to ASCII. See L<URI::Escape>,
L<URI::_punycode> and L<Net::IDN::Encode>.
=item *
Redirection is very strict against the specification. Redirection is only
automatic for response codes 301, 302 and 307 if the request method is 'GET' or
'HEAD'. Response code 303 is always converted into a 'GET' redirection, as
mandated by the specification. There is no automatic support for status 305
("Use proxy") redirections.
=item *
Persistent connections are not supported. The C<Connection> header will
always be set to C<close>.
=item *
Cookie support requires L<HTTP::CookieJar> or an equivalent class.
=item *
Only the C<http_proxy> environment variable is supported in the format
C<http://HOST:PORT/>. If a C<proxy> argument is passed to C<new> (including
undef), then the C<http_proxy> environment variable is ignored.
=item *
There is no provision for delaying a request body using an C<Expect> header.
Unexpected C<1XX> responses are silently ignored as per the specification.
=item *
Only 'chunked' C<Transfer-Encoding> is supported.
=item *
There is no support for a Request-URI of '*' for the 'OPTIONS' request.
=item *
There is no support for IPv6 of any kind.
=back
=head1 SEE ALSO
=over 4
=item *
L<LWP::UserAgent>
=item *
L<IO::Socket::SSL>
=item *
L<Mozilla::CA>
=item *
L<Net::SSLeay>
=back
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
at L<https://github.com/chansen/p5-http-tiny/issues>.
You will be notified automatically of any progress on your issue.
=head2 Source Code
This is open source software. The code repository is available for
public review and contribution under the terms of the license.
L<https://github.com/chansen/p5-http-tiny>
git clone git://github.com/chansen/p5-http-tiny.git
=head1 AUTHORS
=over 4
=item *
Christian Hansen <chansen@cpan.org>
=item *
David Golden <dagolden@cpan.org>
=back
=head1 CONTRIBUTORS
=over 4
=item *
Alan Gardner <gardner@pythian.com>
=item *
Mike Doherty <doherty@cpan.org>
=item *
Serguei Trouchelle <stro@cpan.org>
=item *
Tony Cook <tony@develop-help.com>
=item *
Alessandro Ghedini <al3xbio@gmail.com>
=item *
Chris Nehren <apeiron@cpan.org>
=item *
Chris Weyl <cweyl@alumni.drew.edu>
=item *
Claes Jakobsson <claes@surfar.nu>
=item *
Craig Berry <cberry@cpan.org>
=item *
David Mitchell <davem@iabyn.com>
=item *
Edward Zborowski <ed@rubensteintech.com>
=item *
Jess Robinson <castaway@desert-island.me.uk>
=item *
Lukas Eklund <leklund@gmail.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2013 by Christian Hansen.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
HTTP_TINY
$fatpacked{"JSON/PP/Compat5006.pm"} = <<'JSON_PP_COMPAT5006';
package JSON::PP::Compat5006;
use 5.006;
use strict;
BEGIN {
if ( $] >= 5.008 ) {
require Carp;
die( "JSON::PP::Compat5006 is for Perl 5.6" );
}
}
my @properties;
$JSON::PP::Compat5006::VERSION = '1.09';
BEGIN {
sub utf8::is_utf8 {
my $len = length $_[0]; # char length
{
use bytes; # byte length;
return $len != length $_[0]; # if !=, UTF8-flagged on.
}
}
sub utf8::upgrade {
; # noop;
}
sub utf8::downgrade ($;$) {
return 1 unless ( utf8::is_utf8( $_[0] ) );
if ( _is_valid_utf8( $_[0] ) ) {
my $downgrade;
for my $c ( unpack( "U*", $_[0] ) ) {
if ( $c < 256 ) {
$downgrade .= pack("C", $c);
}
else {
$downgrade .= pack("U", $c);
}
}
$_[0] = $downgrade;
return 1;
}
else {
Carp::croak("Wide character in subroutine entry") unless ( $_[1] );
0;
}
}
sub utf8::encode ($) { # UTF8 flag off
if ( utf8::is_utf8( $_[0] ) ) {
$_[0] = pack( "C*", unpack( "C*", $_[0] ) );
}
else {
$_[0] = pack( "U*", unpack( "C*", $_[0] ) );
$_[0] = pack( "C*", unpack( "C*", $_[0] ) );
}
}
sub utf8::decode ($) { # UTF8 flag on
if ( _is_valid_utf8( $_[0] ) ) {
utf8::downgrade( $_[0] );
$_[0] = pack( "U*", unpack( "U*", $_[0] ) );
}
}
*JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii;
*JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1;
*JSON::PP::JSON_PP_decode_surrogates = \&JSON::PP::_decode_surrogates;
*JSON::PP::JSON_PP_decode_unicode = \&JSON::PP::_decode_unicode;
unless ( defined &B::SVp_NOK ) { # missing in B module.
eval q{ sub B::SVp_NOK () { 0x02000000; } };
}
}
sub _encode_ascii {
join('',
map {
$_ <= 127 ?
chr($_) :
$_ <= 65535 ?
sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_));
} _unpack_emu($_[0])
);
}
sub _encode_latin1 {
join('',
map {
$_ <= 255 ?
chr($_) :
$_ <= 65535 ?
sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_));
} _unpack_emu($_[0])
);
}
sub _unpack_emu { # for Perl 5.6 unpack warnings
return !utf8::is_utf8($_[0]) ? unpack('C*', $_[0])
: _is_valid_utf8($_[0]) ? unpack('U*', $_[0])
: unpack('C*', $_[0]);
}
sub _is_valid_utf8 {
my $str = $_[0];
my $is_utf8;
while ($str =~ /(?:
(
[\x00-\x7F]
|[\xC2-\xDF][\x80-\xBF]
|[\xE0][\xA0-\xBF][\x80-\xBF]
|[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
|[\xED][\x80-\x9F][\x80-\xBF]
|[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
|[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
|[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
|[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
)
| (.)
)/xg)
{
if (defined $1) {
$is_utf8 = 1 if (!defined $is_utf8);
}
else {
$is_utf8 = 0 if (!defined $is_utf8);
if ($is_utf8) { # eventually, not utf8
return;
}
}
}
return $is_utf8;
}
1;
__END__
=pod
=head1 NAME
JSON::PP::Compat5006 - Helper module in using JSON::PP in Perl 5.6
=head1 DESCRIPTION
JSON::PP calls internally.
=head1 AUTHOR
Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright 2007-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
JSON_PP_COMPAT5006
$fatpacked{"Module/Pluggable.pm"} = <<'MODULE_PLUGGABLE';
package Module::Pluggable;
use strict;
use vars qw($VERSION $FORCE_SEARCH_ALL_PATHS);
use Module::Pluggable::Object;
use if $] > 5.017, 'deprecate';
# ObQuote:
# Bob Porter: Looks like you've been missing a lot of work lately.
# Peter Gibbons: I wouldn't say I've been missing it, Bob!
$VERSION = '4.7';
$FORCE_SEARCH_ALL_PATHS = 0;
sub import {
my $class = shift;
my %opts = @_;
my ($pkg, $file) = caller;
# the default name for the method is 'plugins'
my $sub = $opts{'sub_name'} || 'plugins';
# get our package
my ($package) = $opts{'package'} || $pkg;
$opts{filename} = $file;
$opts{package} = $package;
$opts{force_search_all_paths} = $FORCE_SEARCH_ALL_PATHS unless exists $opts{force_search_all_paths};
my $finder = Module::Pluggable::Object->new(%opts);
my $subroutine = sub { my $self = shift; return $finder->plugins(@_) };
my $searchsub = sub {
my $self = shift;
my ($action,@paths) = @_;
$finder->{'search_path'} = ["${package}::Plugin"] if ($action eq 'add' and not $finder->{'search_path'} );
push @{$finder->{'search_path'}}, @paths if ($action eq 'add');
$finder->{'search_path'} = \@paths if ($action eq 'new');
return $finder->{'search_path'};
};
my $onlysub = sub {
my ($self, $only) = @_;
if (defined $only) {
$finder->{'only'} = $only;
};
return $finder->{'only'};
};
my $exceptsub = sub {
my ($self, $except) = @_;
if (defined $except) {
$finder->{'except'} = $except;
};
return $finder->{'except'};
};
no strict 'refs';
no warnings qw(redefine prototype);
*{"$package\::$sub"} = $subroutine;
*{"$package\::search_path"} = $searchsub;
*{"$package\::only"} = $onlysub;
*{"$package\::except"} = $exceptsub;
}
1;
=pod
=head1 NAME
Module::Pluggable - automatically give your module the ability to have plugins
=head1 SYNOPSIS
Simple use Module::Pluggable -
package MyClass;
use Module::Pluggable;
and then later ...
use MyClass;
my $mc = MyClass->new();
# returns the names of all plugins installed under MyClass::Plugin::*
my @plugins = $mc->plugins();
=head1 EXAMPLE
Why would you want to do this? Say you have something that wants to pass an
object to a number of different plugins in turn. For example you may
want to extract meta-data from every email you get sent and do something
with it. Plugins make sense here because then you can keep adding new
meta data parsers and all the logic and docs for each one will be
self contained and new handlers are easy to add without changing the
core code. For that, you might do something like ...
package Email::Examiner;
use strict;
use Email::Simple;
use Module::Pluggable require => 1;
sub handle_email {
my $self = shift;
my $email = shift;
foreach my $plugin ($self->plugins) {
$plugin->examine($email);
}
return 1;
}
.. and all the plugins will get a chance in turn to look at it.
This can be trivally extended so that plugins could save the email
somewhere and then no other plugin should try and do that.
Simply have it so that the C<examine> method returns C<1> if
it has saved the email somewhere. You might also wnat to be paranoid
and check to see if the plugin has an C<examine> method.
foreach my $plugin ($self->plugins) {
next unless $plugin->can('examine');
last if $plugin->examine($email);
}
And so on. The sky's the limit.
=head1 DESCRIPTION
Provides a simple but, hopefully, extensible way of having 'plugins' for
your module. Obviously this isn't going to be the be all and end all of
solutions but it works for me.
Essentially all it does is export a method into your namespace that
looks through a search path for .pm files and turn those into class names.
Optionally it instantiates those classes for you.
=head1 ADVANCED USAGE
Alternatively, if you don't want to use 'plugins' as the method ...
package MyClass;
use Module::Pluggable sub_name => 'foo';
and then later ...
my @plugins = $mc->foo();
Or if you want to look in another namespace
package MyClass;
use Module::Pluggable search_path => ['Acme::MyClass::Plugin', 'MyClass::Extend'];
or directory
use Module::Pluggable search_dirs => ['mylibs/Foo'];
Or if you want to instantiate each plugin rather than just return the name
package MyClass;
use Module::Pluggable instantiate => 'new';
and then
# whatever is passed to 'plugins' will be passed
# to 'new' for each plugin
my @plugins = $mc->plugins(@options);
alternatively you can just require the module without instantiating it
package MyClass;
use Module::Pluggable require => 1;
since requiring automatically searches inner packages, which may not be desirable, you can turn this off
package MyClass;
use Module::Pluggable require => 1, inner => 0;
You can limit the plugins loaded using the except option, either as a string,
array ref or regex
package MyClass;
use Module::Pluggable except => 'MyClass::Plugin::Foo';
or
package MyClass;
use Module::Pluggable except => ['MyClass::Plugin::Foo', 'MyClass::Plugin::Bar'];
or
package MyClass;
use Module::Pluggable except => qr/^MyClass::Plugin::(Foo|Bar)$/;
and similarly for only which will only load plugins which match.
Remember you can use the module more than once
package MyClass;
use Module::Pluggable search_path => 'MyClass::Filters' sub_name => 'filters';
use Module::Pluggable search_path => 'MyClass::Plugins' sub_name => 'plugins';
and then later ...
my @filters = $self->filters;
my @plugins = $self->plugins;
=head1 PLUGIN SEARCHING
Every time you call 'plugins' the whole search path is walked again. This allows
for dynamically loading plugins even at run time. However this can get expensive
and so if you don't expect to want to add new plugins at run time you could do
package Foo;
use strict;
use Module::Pluggable sub_name => '_plugins';
our @PLUGINS;
sub plugins { @PLUGINS ||= shift->_plugins }
1;
=head1 INNER PACKAGES
If you have, for example, a file B<lib/Something/Plugin/Foo.pm> that
contains package definitions for both C<Something::Plugin::Foo> and
C<Something::Plugin::Bar> then as long as you either have either
the B<require> or B<instantiate> option set then we'll also find
C<Something::Plugin::Bar>. Nifty!
=head1 OPTIONS
You can pass a hash of options when importing this module.
The options can be ...
=head2 sub_name
The name of the subroutine to create in your namespace.
By default this is 'plugins'
=head2 search_path
An array ref of namespaces to look in.
=head2 search_dirs
An array ref of directorys to look in before @INC.
=head2 instantiate
Call this method on the class. In general this will probably be 'new'
but it can be whatever you want. Whatever arguments are passed to 'plugins'
will be passed to the method.
The default is 'undef' i.e just return the class name.
=head2 require
Just require the class, don't instantiate (overrides 'instantiate');
=head2 inner
If set to 0 will B<not> search inner packages.
If set to 1 will override C<require>.
=head2 only
Takes a string, array ref or regex describing the names of the only plugins to
return. Whilst this may seem perverse ... well, it is. But it also
makes sense. Trust me.
=head2 except
Similar to C<only> it takes a description of plugins to exclude
from returning. This is slightly less perverse.
=head2 package
This is for use by extension modules which build on C<Module::Pluggable>:
passing a C<package> option allows you to place the plugin method in a
different package other than your own.
=head2 file_regex
By default C<Module::Pluggable> only looks for I<.pm> files.
By supplying a new C<file_regex> then you can change this behaviour e.g
file_regex => qr/\.plugin$/
=head2 include_editor_junk
By default C<Module::Pluggable> ignores files that look like they were
left behind by editors. Currently this means files ending in F<~> (~),
the extensions F<.swp> or F<.swo>, or files beginning with F<.#>.
Setting C<include_editor_junk> changes C<Module::Pluggable> so it does
not ignore any files it finds.
=head2 follow_symlinks
Whether, when searching directories, to follow symlinks.
Defaults to 1 i.e do follow symlinks.
=head2 min_depth, max_depth
This will allow you to set what 'depth' of plugin will be allowed.
So, for example, C<MyClass::Plugin::Foo> will have a depth of 3 and
C<MyClass::Plugin::Foo::Bar> will have a depth of 4 so to only get the former
(i.e C<MyClass::Plugin::Foo>) do
package MyClass;
use Module::Pluggable max_depth => 3;
and to only get the latter (i.e C<MyClass::Plugin::Foo::Bar>)
package MyClass;
use Module::Pluggable min_depth => 4;
=head1 TRIGGERS
Various triggers can also be passed in to the options.
If any of these triggers return 0 then the plugin will not be returned.
=head2 before_require <plugin>
Gets passed the plugin name.
If 0 is returned then this plugin will not be required either.
=head2 on_require_error <plugin> <err>
Gets called when there's an error on requiring the plugin.
Gets passed the plugin name and the error.
The default on_require_error handler is to C<carp> the error and return 0.
=head2 on_instantiate_error <plugin> <err>
Gets called when there's an error on instantiating the plugin.
Gets passed the plugin name and the error.
The default on_instantiate_error handler is to C<carp> the error and return 0.
=head2 after_require <plugin>
Gets passed the plugin name.
If 0 is returned then this plugin will be required but not returned as a plugin.
=head1 METHODs
=head2 search_path
The method C<search_path> is exported into you namespace as well.
You can call that at any time to change or replace the
search_path.
$self->search_path( add => "New::Path" ); # add
$self->search_path( new => "New::Path" ); # replace
=head1 BEHAVIOUR UNDER TEST ENVIRONMENT
In order to make testing reliable we exclude anything not from blib if blib.pm is
in %INC.
However if the module being tested used another module that itself used C<Module::Pluggable>
then the second module would fail. This was fixed by checking to see if the caller
had (^|/)blib/ in their filename.
There's an argument that this is the wrong behaviour and that modules should explicitly
trigger this behaviour but that particular code has been around for 7 years now and I'm
reluctant to change the default behaviour.
You can now (as of version 4.1) force Module::Pluggable to look outside blib in a test environment by doing either
require Module::Pluggable;
$Module::Pluggable::FORCE_SEARCH_ALL_PATHS = 1;
import Module::Pluggable;
or
use Module::Pluggable force_search_all_paths => 1;
=head1 FUTURE PLANS
This does everything I need and I can't really think of any other
features I want to add. Famous last words of course
Recently tried fixed to find inner packages and to make it
'just work' with PAR but there are still some issues.
However suggestions (and patches) are welcome.
=head1 DEVELOPMENT
The master repo for this module is at
https://github.com/simonwistow/Module-Pluggable
=head1 AUTHOR
Simon Wistow <simon@thegestalt.org>
=head1 COPYING
Copyright, 2006 Simon Wistow
Distributed under the same terms as Perl itself.
=head1 BUGS
None known.
=head1 SEE ALSO
L<File::Spec>, L<File::Find>, L<File::Basename>, L<Class::Factory::Util>, L<Module::Pluggable::Ordered>
=cut
MODULE_PLUGGABLE
$fatpacked{"Module/Pluggable/Object.pm"} = <<'MODULE_PLUGGABLE_OBJECT';
package Module::Pluggable::Object;
use strict;
use File::Find ();
use File::Basename;
use File::Spec::Functions qw(splitdir catdir curdir catfile abs2rel);
use Carp qw(croak carp confess);
use Devel::InnerPackage;
use vars qw($VERSION);
use if $] > 5.017, 'deprecate';
$VERSION = '4.6';
sub new {
my $class = shift;
my %opts = @_;
return bless \%opts, $class;
}
### Eugggh, this code smells
### This is what happens when you keep adding patches
### *sigh*
sub plugins {
my $self = shift;
my @args = @_;
# override 'require'
$self->{'require'} = 1 if $self->{'inner'};
my $filename = $self->{'filename'};
my $pkg = $self->{'package'};
# Get the exception params instantiated
$self->_setup_exceptions;
# automatically turn a scalar search path or namespace into a arrayref
for (qw(search_path search_dirs)) {
$self->{$_} = [ $self->{$_} ] if exists $self->{$_} && !ref($self->{$_});
}
# default search path is '<Module>::<Name>::Plugin'
$self->{'search_path'} ||= ["${pkg}::Plugin"];
# default error handler
$self->{'on_require_error'} ||= sub { my ($plugin, $err) = @_; carp "Couldn't require $plugin : $err"; return 0 };
$self->{'on_instantiate_error'} ||= sub { my ($plugin, $err) = @_; carp "Couldn't instantiate $plugin: $err"; return 0 };
# default whether to follow symlinks
$self->{'follow_symlinks'} = 1 unless exists $self->{'follow_symlinks'};
# check to see if we're running under test
my @SEARCHDIR = exists $INC{"blib.pm"} && defined $filename && $filename =~ m!(^|/)blib/! && !$self->{'force_search_all_paths'} ? grep {/blib/} @INC : @INC;
# add any search_dir params
unshift @SEARCHDIR, @{$self->{'search_dirs'}} if defined $self->{'search_dirs'};
# set our @INC up to include and prefer our search_dirs if necessary
my @tmp = @INC;
unshift @tmp, @{$self->{'search_dirs'} || []};
local @INC = @tmp if defined $self->{'search_dirs'};
my @plugins = $self->search_directories(@SEARCHDIR);
push(@plugins, $self->handle_innerpackages($_)) for @{$self->{'search_path'}};
# return blank unless we've found anything
return () unless @plugins;
# remove duplicates
# probably not necessary but hey ho
my %plugins;
for(@plugins) {
next unless $self->_is_legit($_);
$plugins{$_} = 1;
}
# are we instantiating or requring?
if (defined $self->{'instantiate'}) {
my $method = $self->{'instantiate'};
my @objs = ();
foreach my $package (sort keys %plugins) {
next unless $package->can($method);
my $obj = eval { $package->$method(@_) };
$self->{'on_instantiate_error'}->($package, $@) if $@;
push @objs, $obj if $obj;
}
return @objs;
} else {
# no? just return the names
my @objs= sort keys %plugins;
return @objs;
}
}
sub _setup_exceptions {
my $self = shift;
my %only;
my %except;
my $only;
my $except;
if (defined $self->{'only'}) {
if (ref($self->{'only'}) eq 'ARRAY') {
%only = map { $_ => 1 } @{$self->{'only'}};
} elsif (ref($self->{'only'}) eq 'Regexp') {
$only = $self->{'only'}
} elsif (ref($self->{'only'}) eq '') {
$only{$self->{'only'}} = 1;
}
}
if (defined $self->{'except'}) {
if (ref($self->{'except'}) eq 'ARRAY') {
%except = map { $_ => 1 } @{$self->{'except'}};
} elsif (ref($self->{'except'}) eq 'Regexp') {
$except = $self->{'except'}
} elsif (ref($self->{'except'}) eq '') {
$except{$self->{'except'}} = 1;
}
}
$self->{_exceptions}->{only_hash} = \%only;
$self->{_exceptions}->{only} = $only;
$self->{_exceptions}->{except_hash} = \%except;
$self->{_exceptions}->{except} = $except;
}
sub _is_legit {
my $self = shift;
my $plugin = shift;
my %only = %{$self->{_exceptions}->{only_hash}||{}};
my %except = %{$self->{_exceptions}->{except_hash}||{}};
my $only = $self->{_exceptions}->{only};
my $except = $self->{_exceptions}->{except};
my $depth = () = split '::', $plugin, -1;
return 0 if (keys %only && !$only{$plugin} );
return 0 unless (!defined $only || $plugin =~ m!$only! );
return 0 if (keys %except && $except{$plugin} );
return 0 if (defined $except && $plugin =~ m!$except! );
return 0 if defined $self->{max_depth} && $depth>$self->{max_depth};
return 0 if defined $self->{min_depth} && $depth<$self->{min_depth};
return 1;
}
sub search_directories {
my $self = shift;
my @SEARCHDIR = @_;
my @plugins;
# go through our @INC
foreach my $dir (@SEARCHDIR) {
push @plugins, $self->search_paths($dir);
}
return @plugins;
}
sub search_paths {
my $self = shift;
my $dir = shift;
my @plugins;
my $file_regex = $self->{'file_regex'} || qr/\.pm$/;
# and each directory in our search path
foreach my $searchpath (@{$self->{'search_path'}}) {
# create the search directory in a cross platform goodness way
my $sp = catdir($dir, (split /::/, $searchpath));
# if it doesn't exist or it's not a dir then skip it
next unless ( -e $sp && -d _ ); # Use the cached stat the second time
my @files = $self->find_files($sp);
# foreach one we've found
foreach my $file (@files) {
# untaint the file; accept .pm only
next unless ($file) = ($file =~ /(.*$file_regex)$/);
# parse the file to get the name
my ($name, $directory, $suffix) = fileparse($file, $file_regex);
next if (!$self->{include_editor_junk} && $self->_is_editor_junk($name));
$directory = abs2rel($directory, $sp);
# If we have a mixed-case package name, assume case has been preserved
# correctly. Otherwise, root through the file to locate the case-preserved
# version of the package name.
my @pkg_dirs = ();
if ( $name eq lc($name) || $name eq uc($name) ) {
my $pkg_file = catfile($sp, $directory, "$name$suffix");
open PKGFILE, "<$pkg_file" or die "search_paths: Can't open $pkg_file: $!";
my $in_pod = 0;
while ( my $line = <PKGFILE> ) {
$in_pod = 1 if $line =~ m/^=\w/;
$in_pod = 0 if $line =~ /^=cut/;
next if ($in_pod || $line =~ /^=cut/); # skip pod text
next if $line =~ /^\s*#/; # and comments
if ( $line =~ m/^\s*package\s+(.*::)?($name)\s*;/i ) {
@pkg_dirs = split /::/, $1 if defined $1;;
$name = $2;
last;
}
}
close PKGFILE;
}
# then create the class name in a cross platform way
$directory =~ s/^[a-z]://i if($^O =~ /MSWin32|dos/); # remove volume
my @dirs = ();
if ($directory) {
($directory) = ($directory =~ /(.*)/);
@dirs = grep(length($_), splitdir($directory))
unless $directory eq curdir();
for my $d (reverse @dirs) {
my $pkg_dir = pop @pkg_dirs;
last unless defined $pkg_dir;
$d =~ s/\Q$pkg_dir\E/$pkg_dir/i; # Correct case
}
} else {
$directory = "";
}
my $plugin = join '::', $searchpath, @dirs, $name;
next unless $plugin =~ m!(?:[a-z\d]+)[a-z\d]!i;
$self->handle_finding_plugin($plugin, \@plugins)
}
# now add stuff that may have been in package
# NOTE we should probably use all the stuff we've been given already
# but then we can't unload it :(
push @plugins, $self->handle_innerpackages($searchpath);
} # foreach $searchpath
return @plugins;
}
sub _is_editor_junk {
my $self = shift;
my $name = shift;
# Emacs (and other Unix-y editors) leave temp files ending in a
# tilde as a backup.
return 1 if $name =~ /~$/;
# Emacs makes these files while a buffer is edited but not yet
# saved.
return 1 if $name =~ /^\.#/;
# Vim can leave these files behind if it crashes.
return 1 if $name =~ /\.sw[po]$/;
return 0;
}
sub handle_finding_plugin {
my $self = shift;
my $plugin = shift;
my $plugins = shift;
my $no_req = shift || 0;
return unless $self->_is_legit($plugin);
unless (defined $self->{'instantiate'} || $self->{'require'}) {
push @$plugins, $plugin;
return;
}
$self->{before_require}->($plugin) || return if defined $self->{before_require};
unless ($no_req) {
my $tmp = $@;
my $res = eval { $self->_require($plugin) };
my $err = $@;
$@ = $tmp;
if ($err) {
if (defined $self->{on_require_error}) {
$self->{on_require_error}->($plugin, $err) || return;
} else {
return;
}
}
}
$self->{after_require}->($plugin) || return if defined $self->{after_require};
push @$plugins, $plugin;
}
sub find_files {
my $self = shift;
my $search_path = shift;
my $file_regex = $self->{'file_regex'} || qr/\.pm$/;
# find all the .pm files in it
# this isn't perfect and won't find multiple plugins per file
#my $cwd = Cwd::getcwd;
my @files = ();
{ # for the benefit of perl 5.6.1's Find, localize topic
local $_;
File::Find::find( { no_chdir => 1,
follow => $self->{'follow_symlinks'},
wanted => sub {
# Inlined from File::Find::Rule C< name => '*.pm' >
return unless $File::Find::name =~ /$file_regex/;
(my $path = $File::Find::name) =~ s#^\\./##;
push @files, $path;
}
}, $search_path );
}
#chdir $cwd;
return @files;
}
sub handle_innerpackages {
my $self = shift;
return () if (exists $self->{inner} && !$self->{inner});
my $path = shift;
my @plugins;
foreach my $plugin (Devel::InnerPackage::list_packages($path)) {
$self->handle_finding_plugin($plugin, \@plugins, 1);
}
return @plugins;
}
sub _require {
my $self = shift;
my $pack = shift;
eval "CORE::require $pack";
die ($@) if $@;
return 1;
}
1;
=pod
=head1 NAME
Module::Pluggable::Object - automatically give your module the ability to have plugins
=head1 SYNOPSIS
Simple use Module::Pluggable -
package MyClass;
use Module::Pluggable::Object;
my $finder = Module::Pluggable::Object->new(%opts);
print "My plugins are: ".join(", ", $finder->plugins)."\n";
=head1 DESCRIPTION
Provides a simple but, hopefully, extensible way of having 'plugins' for
your module. Obviously this isn't going to be the be all and end all of
solutions but it works for me.
Essentially all it does is export a method into your namespace that
looks through a search path for .pm files and turn those into class names.
Optionally it instantiates those classes for you.
This object is wrapped by C<Module::Pluggable>. If you want to do something
odd or add non-general special features you're probably best to wrap this
and produce your own subclass.
=head1 OPTIONS
See the C<Module::Pluggable> docs.
=head1 AUTHOR
Simon Wistow <simon@thegestalt.org>
=head1 COPYING
Copyright, 2006 Simon Wistow
Distributed under the same terms as Perl itself.
=head1 BUGS
None known.
=head1 SEE ALSO
L<Module::Pluggable>
=cut
MODULE_PLUGGABLE_OBJECT
$fatpacked{"Perl/Build.pm"} = <<'PERL_BUILD';
package Perl::Build;
use strict;
use warnings;
use utf8;
use 5.008005;
our $VERSION = '0.08';
use Carp ();
use File::Basename;
use File::Spec::Functions qw(catfile catdir rel2abs);
use CPAN::Perl::Releases;
use File::pushd qw(pushd);
use File::Temp;
use HTTP::Tiny;
use Devel::PatchPerl;
our $CPAN_MIRROR = $ENV{PERL_BUILD_CPAN_MIRROR} || 'http://search.cpan.org/CPAN';
sub available_perls {
my ( $class, $dist ) = @_;
my $url = "http://www.cpan.org/src/README.html";
my $html = http_get( $url );
unless($html) {
die "\nERROR: Unable to retrieve the list of perls.\n\n";
}
my @available_versions;
for ( split "\n", $html ) {
push @available_versions, $1
if m|<td><a href="http://www.cpan.org/src/.+?">(.+?)</a></td>|;
}
s/\.tar\.gz// for @available_versions;
return @available_versions;
}
# @return extracted source directory
sub extract_tarball {
my ($class, $dist_tarball, $destdir) = @_;
# Was broken on Solaris, where GNU tar is probably
# installed as 'gtar' - RT #61042
my $tarx =
($^O eq 'solaris' ? 'gtar ' : 'tar ') .
( $dist_tarball =~ m/bz2$/ ? 'xjf' : 'xzf' );
my $extract_command = "cd @{[ $destdir ]}; $tarx @{[ File::Spec->rel2abs($dist_tarball) ]}";
system($extract_command) == 0
or die "Failed to extract $dist_tarball";
$dist_tarball =~ s{(?:.*/)?([^/]+)\.tar\.(?:gz|bz2)$}{$1};
return "$destdir/$dist_tarball"; # Note that this is incorrect for blead
}
sub perl_release {
my ($class, $version) = @_;
# TODO: switch to metacpan API?
my $tarballs = CPAN::Perl::Releases::perl_tarballs($version);
my $x = (values %$tarballs)[0];
if ($x) {
my $dist_tarball = (split("/", $x))[-1];
my $dist_tarball_url = $CPAN_MIRROR . "/authors/id/$x";
return ($dist_tarball, $dist_tarball_url);
}
my $html = http_get("http://search.cpan.org/dist/perl-${version}");
unless ($html) {
die "ERROR: Failed to download perl-${version} tarball.";
}
my ($dist_path, $dist_tarball) =
$html =~ m[<a href="(/CPAN/authors/id/.+/(perl-${version}.tar.(gz|bz2)))">Download</a>];
die "ERROR: Cannot find the tarball for perl-$version\n"
if !$dist_path and !$dist_tarball;
my $dist_tarball_url = "http://search.cpan.org${dist_path}";
return ($dist_tarball, $dist_tarball_url);
}
sub http_get {
my ($url) = @_;
my $http = HTTP::Tiny->new();
my $response = $http->get($url);
if ($response->{success}) {
return $response->{content};
} else {
return "Cannot get content from $url: $response->{status} $response->{reason}";
}
}
sub http_mirror {
my ($url, $path) = @_;
my $http = HTTP::Tiny->new();
my $response = $http->mirror($url, $path);
if ($response->{success}) {
print "Downloaded $url to $path.\n";
} else {
die "Cannot get file from $url: $response->{status} $response->{reason}";
}
}
sub install_from_cpan {
my ($class, $version, %args) = @_;
$args{patchperl} && Carp::croak "The patchperl argument was deprected.";
my $tarball_dir = $args{tarball_dir}
|| File::Temp::tempdir( CLEANUP => 1 );
my $build_dir = $args{build_dir}
|| File::Temp::tempdir( CLEANUP => 1 );
my $dst_path = $args{dst_path}
or die "Missing mandatory parameter: dst_path";
my $configure_options = $args{configure_options}
|| ['-de'];
# download tar ball
my ($dist_tarball, $dist_tarball_url) = Perl::Build->perl_release($version);
my $dist_tarball_path = catfile($tarball_dir, $dist_tarball);
if (-f $dist_tarball_path) {
print "Use the previously fetched ${dist_tarball}\n";
}
else {
print "Fetching $version as $dist_tarball_path ($dist_tarball_url)\n";
http_mirror( $dist_tarball_url, $dist_tarball_path );
}
# and extract tar ball.
my $dist_extracted_path = Perl::Build->extract_tarball($dist_tarball_path, $build_dir);
Perl::Build->install(
src_path => $dist_extracted_path,
dst_path => $dst_path,
configure_options => $configure_options,
test => $args{test},
);
}
sub install_from_tarball {
my ($class, $dist_tarball_path, %args) = @_;
$args{patchperl} && Carp::croak "The patchperl argument was deprected.";
my $build_dir = $args{build_dir}
|| File::Temp::tempdir( CLEANUP => 1 );
my $dst_path = $args{dst_path}
or die "Missing mandatory parameter: dst_path";
my $configure_options = $args{configure_options}
|| ['-de'];
my $dist_extracted_path = Perl::Build->extract_tarball($dist_tarball_path, $build_dir);
Perl::Build->install(
src_path => $dist_extracted_path,
dst_path => $dst_path,
configure_options => $configure_options,
test => $args{test},
);
}
sub install {
my ($class, %args) = @_;
$args{patchperl} && Carp::croak "The patchperl argument was deprected.";
my $src_path = $args{src_path}
or die "Missing mandatory parameter: src_path";
my $dst_path = $args{dst_path}
or die "Missing mandatory parameter: dst_path";
my $configure_options = $args{configure_options}
or die "Missing mandatory parameter: configure_options";
unshift @$configure_options, qq(-Dprefix=$dst_path);
# clean up environment
delete $ENV{$_} for qw(PERL5LIB PERL5OPT);
{
my $dir = pushd($src_path);
# clean up
$class->do_system("rm -f config.sh Policy.sh");
# apply patches
Devel::PatchPerl->patch_source();
# configure
$class->do_system(['sh', 'Configure', @$configure_options]);
# patch for older perls
# XXX is this needed? patchperl do this?
# if (Perl::Build->perl_version_to_integer($dist_version) < Perl::Build->perl_version_to_integer( '5.8.9' )) {
# $class->do_system("$^X -i -nle 'print unless /command-line/' makefile x2p/makefile");
# }
# build
$class->do_system('make');
if ($args{test}) {
$class->do_system('make test');
}
$class->do_system('make install');
}
}
sub do_system {
my ($class, $cmd) = @_;
if (ref $cmd eq 'ARRAY') {
$class->info(join(' ', @$cmd));
system(@$cmd) == 0
or die "Installation failure: @$cmd";
} else {
$class->info($cmd);
system($cmd) == 0
or die "Installation failure: $cmd";
}
}
sub symlink_devel_executables {
my ($class, $bin_dir) = @_;
for my $executable (glob("$bin_dir/*")) {
my ($name, $version) = $executable =~ m/bin\/(.+?)(5\.\d.*)?$/;
if ($version) {
my $cmd = "ln -fs $executable $bin_dir/$name";
$class->info($cmd);
system($cmd);
}
}
}
sub info {
my ($class, @msg) = @_;
print @msg, "\n";
}
1;
__END__
=encoding utf8
=head1 NAME
Perl::Build - perl builder
=head1 SYNOPSIS
=head1 CLI interface
% perl-build 5.16.2 /opt/perl-5.16/
=head2 Programmable interface
# install perl from CPAN
Perl::Build->install_from_cpan(
'5.16.2' => (
dst_path => '/path/to/perl-5.16.2/',
configure_options => ['-des'],
)
);
# install perl from tar ball
Perl::Build->install_from_cpan(
'path/to/perl-5.16.2.tar.gz' => (
dst_path => '/path/to/perl-5.16.2/',
configure_options => ['-des'],
)
);
=head1 DESCRIPTION
This is yet another perl builder module.
B<THIS IS A DEVELOPMENT RELEASE. API MAY CHANGE WITHOUT NOTICE>.
=head1 METHODS
=over 4
=item Perl::Build->install_from_cpan($version, %args)
Install $version perl from CPAN. This method fetches tar ball from CPAN, build, and install it.
You can pass following options in %args.
=over 4
=item dst_path
Destination directory to install perl.
=item configure_options : ArrayRef(Optional)
Command line arguments for ./Configure.
(Default: ['-de'])
=item tarball_dir(Optional)
Temporary directory to put tar ball.
=item build_dir(Optional)
Temporary directory to build binary.
=back
=item Perl::Build->install_from_tarball($dist_tarball_path, %args)
Install perl from tar ball. This method extracts tar ball, build, and install.
You can pass following options in %args.
=over 4
=item dst_path(Required)
Destination directory to install perl.
=item configure_options : ArrayRef(Optional)
Command line arguments for ./Configure.
(Default: ['-de'])
=item build_dir(Optional)
Temporary directory to build binary.
=back
=item Perl::Build->install(%args)
Build and install Perl5 from extracted source directory.
=over 4
=item src_path(Required)
Source code directory to build. That contains extracted Perl5 source code.
=item dst_path(Required)
Destination directory to install perl.
=item configure_options : ArrayRef(Optional)
Command line arguments for ./Configure.
(Default: ['-de'])
=item test: Bool(Optional)
If you set this value as true, Perl::Build runs C<< make test >> after building.
(Default: 0)
=back
=item Perl::Build->symlink_devel_executables($bin_dir:Str)
Perl5 binary generated with C< -Dusedevel >, is "perl-5.12.2" form. This method symlinks "perl-5.12.2" to "perl".
=back
=head1 FAQ
=over 4
=item How can I use patchperl plugins?
If you want to use patchperl plugins, please google "PERL5_PATCHPERL_PLUGIN".
=back
=head1 THANKS TO
Most of the code was taken from L<App::perlbrew>.
TYPESTER - suggests C<< --patches >> option
Thanks
=head1 AUTHOR
Tokuhiro Matsuno E<lt>tokuhirom AAJKLFJEF@ GMAIL COME<gt>
=head1 LICENSE
This software takes most of the code from L<App::perlbrew>.
Perl::Build uses same license with perlbrew.
PERL_BUILD
$fatpacked{"Pod/Find.pm"} = <<'POD_FIND';
#############################################################################
# Pod/Find.pm -- finds files containing POD documentation
#
# Author: Marek Rouchal <marekr@cpan.org>
#
# Copyright (C) 1999-2000 by Marek Rouchal (and borrowing code
# from Nick Ing-Simmon's PodToHtml). All rights reserved.
# This file is part of "PodParser". Pod::Find is free software;
# you can redistribute it and/or modify it under the same terms
# as Perl itself.
#############################################################################
package Pod::Find;
use strict;
use vars qw($VERSION);
$VERSION = '1.60'; ## Current version of this package
require 5.005; ## requires this Perl version or later
use Carp;
BEGIN {
if ($] < 5.006) {
require Symbol;
import Symbol;
}
}
#############################################################################
=head1 NAME
Pod::Find - find POD documents in directory trees
=head1 SYNOPSIS
use Pod::Find qw(pod_find simplify_name);
my %pods = pod_find({ -verbose => 1, -inc => 1 });
foreach(keys %pods) {
print "found library POD `$pods{$_}' in $_\n";
}
print "podname=",simplify_name('a/b/c/mymodule.pod'),"\n";
$location = pod_where( { -inc => 1 }, "Pod::Find" );
=head1 DESCRIPTION
B<Pod::Find> provides a set of functions to locate POD files. Note that
no function is exported by default to avoid pollution of your namespace,
so be sure to specify them in the B<use> statement if you need them:
use Pod::Find qw(pod_find);
From this version on the typical SCM (software configuration management)
files/directories like RCS, CVS, SCCS, .svn are ignored.
=cut
#use diagnostics;
use Exporter;
use File::Spec;
use File::Find;
use Cwd qw(abs_path cwd);
use vars qw(@ISA @EXPORT_OK $VERSION);
@ISA = qw(Exporter);
@EXPORT_OK = qw(&pod_find &simplify_name &pod_where &contains_pod);
# package global variables
my $SIMPLIFY_RX;
=head2 C<pod_find( { %opts } , @directories )>
The function B<pod_find> searches for POD documents in a given set of
files and/or directories. It returns a hash with the file names as keys
and the POD name as value. The POD name is derived from the file name
and its position in the directory tree.
E.g. when searching in F<$HOME/perl5lib>, the file
F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>,
whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be
I<Myclass::Subclass>. The name information can be used for POD
translators.
Only text files containing at least one valid POD command are found.
A warning is printed if more than one POD file with the same POD name
is found, e.g. F<CPAN.pm> in different directories. This usually
indicates duplicate occurrences of modules in the I<@INC> search path.
B<OPTIONS> The first argument for B<pod_find> may be a hash reference
with options. The rest are either directories that are searched
recursively or files. The POD names of files are the plain basenames
with any Perl-like extension (.pm, .pl, .pod) stripped.
=over 4
=item C<-verbose =E<gt> 1>
Print progress information while scanning.
=item C<-perl =E<gt> 1>
Apply Perl-specific heuristics to find the correct PODs. This includes
stripping Perl-like extensions, omitting subdirectories that are numeric
but do I<not> match the current Perl interpreter's version id, suppressing
F<site_perl> as a module hierarchy name etc.
=item C<-script =E<gt> 1>
Search for PODs in the current Perl interpreter's installation
B<scriptdir>. This is taken from the local L<Config|Config> module.
=item C<-inc =E<gt> 1>
Search for PODs in the current Perl interpreter's I<@INC> paths. This
automatically considers paths specified in the C<PERL5LIB> environment
as this is included in I<@INC> by the Perl interpreter itself.
=back
=cut
# return a hash of the POD files found
# first argument may be a hashref (options),
# rest is a list of directories to search recursively
sub pod_find
{
my %opts;
if(ref $_[0]) {
%opts = %{shift()};
}
$opts{-verbose} ||= 0;
$opts{-perl} ||= 0;
my (@search) = @_;
if($opts{-script}) {
require Config;
push(@search, $Config::Config{scriptdir})
if -d $Config::Config{scriptdir};
$opts{-perl} = 1;
}
if($opts{-inc}) {
if ($^O eq 'MacOS') {
# tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
my @new_INC = @INC;
for (@new_INC) {
if ( $_ eq '.' ) {
$_ = ':';
} elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) {
$_ = ':'. $_;
} else {
$_ =~ s{^\./}{:};
}
}
push(@search, grep($_ ne File::Spec->curdir, @new_INC));
} else {
my %seen;
my $curdir = File::Spec->curdir;
foreach(@INC) {
next if $_ eq $curdir;
my $path = abs_path($_);
push(@search, $path) unless $seen{$path}++;
}
}
$opts{-perl} = 1;
}
if($opts{-perl}) {
require Config;
# this code simplifies the POD name for Perl modules:
# * remove "site_perl"
# * remove e.g. "i586-linux" (from 'archname')
# * remove e.g. 5.00503
# * remove pod/ if followed by *.pod (e.g. in pod/perlfunc.pod)
# Mac OS:
# * remove ":?site_perl:"
# * remove :?pod: if followed by *.pod (e.g. in :pod:perlfunc.pod)
if ($^O eq 'MacOS') {
$SIMPLIFY_RX =
qq!^(?i:\:?site_perl\:|\:?pod\:(?=.*?\\.pod\\z))*!;
} else {
$SIMPLIFY_RX =
qq!^(?i:site(_perl)?/|\Q$Config::Config{archname}\E/|\\d+\\.\\d+([_.]?\\d+)?/|pod/(?=.*?\\.pod\\z))*!;
}
}
my %dirs_visited;
my %pods;
my %names;
my $pwd = cwd();
foreach my $try (@search) {
unless(File::Spec->file_name_is_absolute($try)) {
# make path absolute
$try = File::Spec->catfile($pwd,$try);
}
# simplify path
# on VMS canonpath will vmsify:[the.path], but File::Find::find
# wants /unixy/paths
if ($^O eq 'VMS') {
$try = VMS::Filespec::unixify($try);
}
else {
$try = File::Spec->canonpath($try);
}
my $name;
if(-f $try) {
if($name = _check_and_extract_name($try, $opts{-verbose})) {
_check_for_duplicates($try, $name, \%names, \%pods);
}
next;
}
my $root_rx = $^O eq 'MacOS' ? qq!^\Q$try\E! : qq!^\Q$try\E/!;
$root_rx=~ s|//$|/|; # remove trailing double slash
File::Find::find( sub {
my $item = $File::Find::name;
if(-d) {
if($item =~ m{/(?:RCS|CVS|SCCS|\.svn)$}) {
$File::Find::prune = 1;
return;
}
elsif($dirs_visited{$item}) {
warn "Directory '$item' already seen, skipping.\n"
if($opts{-verbose});
$File::Find::prune = 1;
return;
}
else {
$dirs_visited{$item} = 1;
}
if($opts{-perl} && /^(\d+\.[\d_]+)\z/s && eval "$1" != $]) {
$File::Find::prune = 1;
warn "Perl $] version mismatch on $_, skipping.\n"
if($opts{-verbose});
}
return;
}
if($name = _check_and_extract_name($item, $opts{-verbose}, $root_rx)) {
_check_for_duplicates($item, $name, \%names, \%pods);
}
}, $try); # end of File::Find::find
}
chdir $pwd;
return %pods;
}
sub _check_for_duplicates {
my ($file, $name, $names_ref, $pods_ref) = @_;
if($$names_ref{$name}) {
warn "Duplicate POD found (shadowing?): $name ($file)\n";
warn ' Already seen in ',
join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n";
}
else {
$$names_ref{$name} = 1;
}
return $$pods_ref{$file} = $name;
}
sub _check_and_extract_name {
my ($file, $verbose, $root_rx) = @_;
# check extension or executable flag
# this involves testing the .bat extension on Win32!
unless(-f $file && -T $file && ($file =~ /\.(pod|pm|plx?)\z/i || -x $file )) {
return;
}
return unless contains_pod($file,$verbose);
# strip non-significant path components
# TODO what happens on e.g. Win32?
my $name = $file;
if(defined $root_rx) {
$name =~ s/$root_rx//is;
$name =~ s/$SIMPLIFY_RX//is if(defined $SIMPLIFY_RX);
}
else {
if ($^O eq 'MacOS') {
$name =~ s/^.*://s;
} else {
$name =~ s{^.*/}{}s;
}
}
_simplify($name);
$name =~ s{/+}{::}g;
if ($^O eq 'MacOS') {
$name =~ s{:+}{::}g; # : -> ::
} else {
$name =~ s{/+}{::}g; # / -> ::
}
return $name;
}
=head2 C<simplify_name( $str )>
The function B<simplify_name> is equivalent to B<basename>, but also
strips Perl-like extensions (.pm, .pl, .pod) and extensions like
F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively.
=cut
# basic simplification of the POD name:
# basename & strip extension
sub simplify_name {
my ($str) = @_;
# remove all path components
if ($^O eq 'MacOS') {
$str =~ s/^.*://s;
} else {
$str =~ s{^.*/}{}s;
}
_simplify($str);
return $str;
}
# internal sub only
sub _simplify {
# strip Perl's own extensions
$_[0] =~ s/\.(pod|pm|plx?)\z//i;
# strip meaningless extensions on Win32 and OS/2
$_[0] =~ s/\.(bat|exe|cmd)\z//i if($^O =~ /mswin|os2/i);
# strip meaningless extensions on VMS
$_[0] =~ s/\.(com)\z//i if($^O eq 'VMS');
}
# contribution from Tim Jenness <t.jenness@jach.hawaii.edu>
=head2 C<pod_where( { %opts }, $pod )>
Returns the location of a pod document given a search directory
and a module (e.g. C<File::Find>) or script (e.g. C<perldoc>) name.
Options:
=over 4
=item C<-inc =E<gt> 1>
Search @INC for the pod and also the C<scriptdir> defined in the
L<Config|Config> module.
=item C<-dirs =E<gt> [ $dir1, $dir2, ... ]>
Reference to an array of search directories. These are searched in order
before looking in C<@INC> (if B<-inc>). Current directory is used if
none are specified.
=item C<-verbose =E<gt> 1>
List directories as they are searched
=back
Returns the full path of the first occurrence to the file.
Package names (eg 'A::B') are automatically converted to directory
names in the selected directory. (eg on unix 'A::B' is converted to
'A/B'). Additionally, '.pm', '.pl' and '.pod' are appended to the
search automatically if required.
A subdirectory F<pod/> is also checked if it exists in any of the given
search directories. This ensures that e.g. L<perlfunc|perlfunc> is
found.
It is assumed that if a module name is supplied, that that name
matches the file name. Pods are not opened to check for the 'NAME'
entry.
A check is made to make sure that the file that is found does
contain some pod documentation.
=cut
sub pod_where {
# default options
my %options = (
'-inc' => 0,
'-verbose' => 0,
'-dirs' => [ File::Spec->curdir ],
);
# Check for an options hash as first argument
if (defined $_[0] && ref($_[0]) eq 'HASH') {
my $opt = shift;
# Merge default options with supplied options
%options = (%options, %$opt);
}
# Check usage
carp 'Usage: pod_where({options}, $pod)' unless (scalar(@_));
# Read argument
my $pod = shift;
# Split on :: and then join the name together using File::Spec
my @parts = split (/::/, $pod);
# Get full directory list
my @search_dirs = @{ $options{'-dirs'} };
if ($options{'-inc'}) {
require Config;
# Add @INC
if ($^O eq 'MacOS' && $options{'-inc'}) {
# tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
my @new_INC = @INC;
for (@new_INC) {
if ( $_ eq '.' ) {
$_ = ':';
} elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) {
$_ = ':'. $_;
} else {
$_ =~ s{^\./}{:};
}
}
push (@search_dirs, @new_INC);
} elsif ($options{'-inc'}) {
push (@search_dirs, @INC);
}
# Add location of pod documentation for perl man pages (eg perlfunc)
# This is a pod directory in the private install tree
#my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'},
# 'pod');
#push (@search_dirs, $perlpoddir)
# if -d $perlpoddir;
# Add location of binaries such as pod2text
push (@search_dirs, $Config::Config{'scriptdir'})
if -d $Config::Config{'scriptdir'};
}
warn 'Search path is: '.join(' ', @search_dirs)."\n"
if $options{'-verbose'};
# Loop over directories
Dir: foreach my $dir ( @search_dirs ) {
# Don't bother if can't find the directory
if (-d $dir) {
warn "Looking in directory $dir\n"
if $options{'-verbose'};
# Now concatenate this directory with the pod we are searching for
my $fullname = File::Spec->catfile($dir, @parts);
$fullname = VMS::Filespec::unixify($fullname) if $^O eq 'VMS';
warn "Filename is now $fullname\n"
if $options{'-verbose'};
# Loop over possible extensions
foreach my $ext ('', '.pod', '.pm', '.pl') {
my $fullext = $fullname . $ext;
if (-f $fullext &&
contains_pod($fullext, $options{'-verbose'}) ) {
warn "FOUND: $fullext\n" if $options{'-verbose'};
return $fullext;
}
}
} else {
warn "Directory $dir does not exist\n"
if $options{'-verbose'};
next Dir;
}
# for some strange reason the path on MacOS/darwin/cygwin is
# 'pods' not 'pod'
# this could be the case also for other systems that
# have a case-tolerant file system, but File::Spec
# does not recognize 'darwin' yet. And cygwin also has "pods",
# but is not case tolerant. Oh well...
if((File::Spec->case_tolerant || $^O =~ /macos|darwin|cygwin/i)
&& -d File::Spec->catdir($dir,'pods')) {
$dir = File::Spec->catdir($dir,'pods');
redo Dir;
}
if(-d File::Spec->catdir($dir,'pod')) {
$dir = File::Spec->catdir($dir,'pod');
redo Dir;
}
}
# No match;
return;
}
=head2 C<contains_pod( $file , $verbose )>
Returns true if the supplied filename (not POD module) contains some pod
information.
=cut
sub contains_pod {
my $file = shift;
my $verbose = 0;
$verbose = shift if @_;
# check for one line of POD
my $podfh;
if ($] < 5.006) {
$podfh = gensym();
}
unless(open($podfh,"<$file")) {
warn "Error: $file is unreadable: $!\n";
return;
}
local $/ = undef;
my $pod = <$podfh>;
close($podfh) || die "Error closing $file: $!\n";
unless($pod =~ /^=(head\d|pod|over|item|cut)\b/m) {
warn "No POD in $file, skipping.\n"
if($verbose);
return 0;
}
return 1;
}
=head1 AUTHOR
Please report bugs using L<http://rt.cpan.org>.
Marek Rouchal E<lt>marekr@cpan.orgE<gt>,
heavily borrowing code from Nick Ing-Simmons' PodToHtml.
Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt> provided
C<pod_where> and C<contains_pod>.
B<Pod::Find> is part of the L<Pod::Parser> distribution.
=head1 SEE ALSO
L<Pod::Parser>, L<Pod::Checker>, L<perldoc>
=cut
1;
POD_FIND
$fatpacked{"Pod/InputObjects.pm"} = <<'POD_INPUTOBJECTS';
#############################################################################
# Pod/InputObjects.pm -- package which defines objects for input streams
# and paragraphs and commands when parsing POD docs.
#
# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.
# This file is part of "PodParser". PodParser is free software;
# you can redistribute it and/or modify it under the same terms
# as Perl itself.
#############################################################################
package Pod::InputObjects;
use strict;
use vars qw($VERSION);
$VERSION = '1.60'; ## Current version of this package
require 5.005; ## requires this Perl version or later
#############################################################################
=head1 NAME
Pod::InputObjects - objects representing POD input paragraphs, commands, etc.
=head1 SYNOPSIS
use Pod::InputObjects;
=head1 REQUIRES
perl5.004, Carp
=head1 EXPORTS
Nothing.
=head1 DESCRIPTION
This module defines some basic input objects used by B<Pod::Parser> when
reading and parsing POD text from an input source. The following objects
are defined:
=begin __PRIVATE__
=over 4
=item package B<Pod::InputSource>
An object corresponding to a source of POD input text. It is mostly a
wrapper around a filehandle or C<IO::Handle>-type object (or anything
that implements the C<getline()> method) which keeps track of some
additional information relevant to the parsing of PODs.
=back
=end __PRIVATE__
=over 4
=item package B<Pod::Paragraph>
An object corresponding to a paragraph of POD input text. It may be a
plain paragraph, a verbatim paragraph, or a command paragraph (see
L<perlpod>).
=item package B<Pod::InteriorSequence>
An object corresponding to an interior sequence command from the POD
input text (see L<perlpod>).
=item package B<Pod::ParseTree>
An object corresponding to a tree of parsed POD text. Each "node" in
a parse-tree (or I<ptree>) is either a text-string or a reference to
a B<Pod::InteriorSequence> object. The nodes appear in the parse-tree
in the order in which they were parsed from left-to-right.
=back
Each of these input objects are described in further detail in the
sections which follow.
=cut
#############################################################################
package Pod::InputSource;
##---------------------------------------------------------------------------
=begin __PRIVATE__
=head1 B<Pod::InputSource>
This object corresponds to an input source or stream of POD
documentation. When parsing PODs, it is necessary to associate and store
certain context information with each input source. All of this
information is kept together with the stream itself in one of these
C<Pod::InputSource> objects. Each such object is merely a wrapper around
an C<IO::Handle> object of some kind (or at least something that
implements the C<getline()> method). They have the following
methods/attributes:
=end __PRIVATE__
=cut
##---------------------------------------------------------------------------
=begin __PRIVATE__
=head2 B<new()>
my $pod_input1 = Pod::InputSource->new(-handle => $filehandle);
my $pod_input2 = new Pod::InputSource(-handle => $filehandle,
-name => $name);
my $pod_input3 = new Pod::InputSource(-handle => \*STDIN);
my $pod_input4 = Pod::InputSource->new(-handle => \*STDIN,
-name => "(STDIN)");
This is a class method that constructs a C<Pod::InputSource> object and
returns a reference to the new input source object. It takes one or more
keyword arguments in the form of a hash. The keyword C<-handle> is
required and designates the corresponding input handle. The keyword
C<-name> is optional and specifies the name associated with the input
handle (typically a file name).
=end __PRIVATE__
=cut
sub new {
## Determine if we were called via an object-ref or a classname
my $this = shift;
my $class = ref($this) || $this;
## Any remaining arguments are treated as initial values for the
## hash that is used to represent this object. Note that we default
## certain values by specifying them *before* the arguments passed.
## If they are in the argument list, they will override the defaults.
my $self = { -name => '(unknown)',
-handle => undef,
-was_cutting => 0,
@_ };
## Bless ourselves into the desired class and perform any initialization
bless $self, $class;
return $self;
}
##---------------------------------------------------------------------------
=begin __PRIVATE__
=head2 B<name()>
my $filename = $pod_input->name();
$pod_input->name($new_filename_to_use);
This method gets/sets the name of the input source (usually a filename).
If no argument is given, it returns a string containing the name of
the input source; otherwise it sets the name of the input source to the
contents of the given argument.
=end __PRIVATE__
=cut
sub name {
(@_ > 1) and $_[0]->{'-name'} = $_[1];
return $_[0]->{'-name'};
}
## allow 'filename' as an alias for 'name'
*filename = \&name;
##---------------------------------------------------------------------------
=begin __PRIVATE__
=head2 B<handle()>
my $handle = $pod_input->handle();
Returns a reference to the handle object from which input is read (the
one used to contructed this input source object).
=end __PRIVATE__
=cut
sub handle {
return $_[0]->{'-handle'};
}
##---------------------------------------------------------------------------
=begin __PRIVATE__
=head2 B<was_cutting()>
print "Yes.\n" if ($pod_input->was_cutting());
The value of the C<cutting> state (that the B<cutting()> method would
have returned) immediately before any input was read from this input
stream. After all input from this stream has been read, the C<cutting>
state is restored to this value.
=end __PRIVATE__
=cut
sub was_cutting {
(@_ > 1) and $_[0]->{-was_cutting} = $_[1];
return $_[0]->{-was_cutting};
}
##---------------------------------------------------------------------------
#############################################################################
package Pod::Paragraph;
##---------------------------------------------------------------------------
=head1 B<Pod::Paragraph>
An object representing a paragraph of POD input text.
It has the following methods/attributes:
=cut
##---------------------------------------------------------------------------
=head2 Pod::Paragraph-E<gt>B<new()>
my $pod_para1 = Pod::Paragraph->new(-text => $text);
my $pod_para2 = Pod::Paragraph->new(-name => $cmd,
-text => $text);
my $pod_para3 = new Pod::Paragraph(-text => $text);
my $pod_para4 = new Pod::Paragraph(-name => $cmd,
-text => $text);
my $pod_para5 = Pod::Paragraph->new(-name => $cmd,
-text => $text,
-file => $filename,
-line => $line_number);
This is a class method that constructs a C<Pod::Paragraph> object and
returns a reference to the new paragraph object. It may be given one or
two keyword arguments. The C<-text> keyword indicates the corresponding
text of the POD paragraph. The C<-name> keyword indicates the name of
the corresponding POD command, such as C<head1> or C<item> (it should
I<not> contain the C<=> prefix); this is needed only if the POD
paragraph corresponds to a command paragraph. The C<-file> and C<-line>
keywords indicate the filename and line number corresponding to the
beginning of the paragraph
=cut
sub new {
## Determine if we were called via an object-ref or a classname
my $this = shift;
my $class = ref($this) || $this;
## Any remaining arguments are treated as initial values for the
## hash that is used to represent this object. Note that we default
## certain values by specifying them *before* the arguments passed.
## If they are in the argument list, they will override the defaults.
my $self = {
-name => undef,
-text => (@_ == 1) ? shift : undef,
-file => '<unknown-file>',
-line => 0,
-prefix => '=',
-separator => ' ',
-ptree => [],
@_
};
## Bless ourselves into the desired class and perform any initialization
bless $self, $class;
return $self;
}
##---------------------------------------------------------------------------
=head2 $pod_para-E<gt>B<cmd_name()>
my $para_cmd = $pod_para->cmd_name();
If this paragraph is a command paragraph, then this method will return
the name of the command (I<without> any leading C<=> prefix).
=cut
sub cmd_name {
(@_ > 1) and $_[0]->{'-name'} = $_[1];
return $_[0]->{'-name'};
}
## let name() be an alias for cmd_name()
*name = \&cmd_name;
##---------------------------------------------------------------------------
=head2 $pod_para-E<gt>B<text()>
my $para_text = $pod_para->text();
This method will return the corresponding text of the paragraph.
=cut
sub text {
(@_ > 1) and $_[0]->{'-text'} = $_[1];
return $_[0]->{'-text'};
}
##---------------------------------------------------------------------------
=head2 $pod_para-E<gt>B<raw_text()>
my $raw_pod_para = $pod_para->raw_text();
This method will return the I<raw> text of the POD paragraph, exactly
as it appeared in the input.
=cut
sub raw_text {
return $_[0]->{'-text'} unless (defined $_[0]->{'-name'});
return $_[0]->{'-prefix'} . $_[0]->{'-name'} .
$_[0]->{'-separator'} . $_[0]->{'-text'};
}
##---------------------------------------------------------------------------
=head2 $pod_para-E<gt>B<cmd_prefix()>
my $prefix = $pod_para->cmd_prefix();
If this paragraph is a command paragraph, then this method will return
the prefix used to denote the command (which should be the string "="
or "==").
=cut
sub cmd_prefix {
return $_[0]->{'-prefix'};
}
##---------------------------------------------------------------------------
=head2 $pod_para-E<gt>B<cmd_separator()>
my $separator = $pod_para->cmd_separator();
If this paragraph is a command paragraph, then this method will return
the text used to separate the command name from the rest of the
paragraph (if any).
=cut
sub cmd_separator {
return $_[0]->{'-separator'};
}
##---------------------------------------------------------------------------
=head2 $pod_para-E<gt>B<parse_tree()>
my $ptree = $pod_parser->parse_text( $pod_para->text() );
$pod_para->parse_tree( $ptree );
$ptree = $pod_para->parse_tree();
This method will get/set the corresponding parse-tree of the paragraph's text.
=cut
sub parse_tree {
(@_ > 1) and $_[0]->{'-ptree'} = $_[1];
return $_[0]->{'-ptree'};
}
## let ptree() be an alias for parse_tree()
*ptree = \&parse_tree;
##---------------------------------------------------------------------------
=head2 $pod_para-E<gt>B<file_line()>
my ($filename, $line_number) = $pod_para->file_line();
my $position = $pod_para->file_line();
Returns the current filename and line number for the paragraph
object. If called in a list context, it returns a list of two
elements: first the filename, then the line number. If called in
a scalar context, it returns a string containing the filename, followed
by a colon (':'), followed by the line number.
=cut
sub file_line {
my @loc = ($_[0]->{'-file'} || '<unknown-file>',
$_[0]->{'-line'} || 0);
return (wantarray) ? @loc : join(':', @loc);
}
##---------------------------------------------------------------------------
#############################################################################
package Pod::InteriorSequence;
##---------------------------------------------------------------------------
=head1 B<Pod::InteriorSequence>
An object representing a POD interior sequence command.
It has the following methods/attributes:
=cut
##---------------------------------------------------------------------------
=head2 Pod::InteriorSequence-E<gt>B<new()>
my $pod_seq1 = Pod::InteriorSequence->new(-name => $cmd
-ldelim => $delimiter);
my $pod_seq2 = new Pod::InteriorSequence(-name => $cmd,
-ldelim => $delimiter);
my $pod_seq3 = new Pod::InteriorSequence(-name => $cmd,
-ldelim => $delimiter,
-file => $filename,
-line => $line_number);
my $pod_seq4 = new Pod::InteriorSequence(-name => $cmd, $ptree);
my $pod_seq5 = new Pod::InteriorSequence($cmd, $ptree);
This is a class method that constructs a C<Pod::InteriorSequence> object
and returns a reference to the new interior sequence object. It should
be given two keyword arguments. The C<-ldelim> keyword indicates the
corresponding left-delimiter of the interior sequence (e.g. 'E<lt>').
The C<-name> keyword indicates the name of the corresponding interior
sequence command, such as C<I> or C<B> or C<C>. The C<-file> and
C<-line> keywords indicate the filename and line number corresponding
to the beginning of the interior sequence. If the C<$ptree> argument is
given, it must be the last argument, and it must be either string, or
else an array-ref suitable for passing to B<Pod::ParseTree::new> (or
it may be a reference to a Pod::ParseTree object).
=cut
sub new {
## Determine if we were called via an object-ref or a classname
my $this = shift;
my $class = ref($this) || $this;
## See if first argument has no keyword
if (((@_ <= 2) or (@_ % 2)) and $_[0] !~ /^-\w/) {
## Yup - need an implicit '-name' before first parameter
unshift @_, '-name';
}
## See if odd number of args
if ((@_ % 2) != 0) {
## Yup - need an implicit '-ptree' before the last parameter
splice @_, $#_, 0, '-ptree';
}
## Any remaining arguments are treated as initial values for the
## hash that is used to represent this object. Note that we default
## certain values by specifying them *before* the arguments passed.
## If they are in the argument list, they will override the defaults.
my $self = {
-name => (@_ == 1) ? $_[0] : undef,
-file => '<unknown-file>',
-line => 0,
-ldelim => '<',
-rdelim => '>',
@_
};
## Initialize contents if they havent been already
my $ptree = $self->{'-ptree'} || new Pod::ParseTree();
if ( ref $ptree =~ /^(ARRAY)?$/ ) {
## We have an array-ref, or a normal scalar. Pass it as an
## an argument to the ptree-constructor
$ptree = new Pod::ParseTree($1 ? [$ptree] : $ptree);
}
$self->{'-ptree'} = $ptree;
## Bless ourselves into the desired class and perform any initialization
bless $self, $class;
return $self;
}
##---------------------------------------------------------------------------
=head2 $pod_seq-E<gt>B<cmd_name()>
my $seq_cmd = $pod_seq->cmd_name();
The name of the interior sequence command.
=cut
sub cmd_name {
(@_ > 1) and $_[0]->{'-name'} = $_[1];
return $_[0]->{'-name'};
}
## let name() be an alias for cmd_name()
*name = \&cmd_name;
##---------------------------------------------------------------------------
## Private subroutine to set the parent pointer of all the given
## children that are interior-sequences to be $self
sub _set_child2parent_links {
my ($self, @children) = @_;
## Make sure any sequences know who their parent is
for (@children) {
next unless (length and ref and ref ne 'SCALAR');
if (UNIVERSAL::isa($_, 'Pod::InteriorSequence') or
UNIVERSAL::can($_, 'nested'))
{
$_->nested($self);
}
}
}
## Private subroutine to unset child->parent links
sub _unset_child2parent_links {
my $self = shift;
$self->{'-parent_sequence'} = undef;
my $ptree = $self->{'-ptree'};
for (@$ptree) {
next unless (length and ref and ref ne 'SCALAR');
$_->_unset_child2parent_links()
if UNIVERSAL::isa($_, 'Pod::InteriorSequence');
}
}
##---------------------------------------------------------------------------
=head2 $pod_seq-E<gt>B<prepend()>
$pod_seq->prepend($text);
$pod_seq1->prepend($pod_seq2);
Prepends the given string or parse-tree or sequence object to the parse-tree
of this interior sequence.
=cut
sub prepend {
my $self = shift;
$self->{'-ptree'}->prepend(@_);
_set_child2parent_links($self, @_);
return $self;
}
##---------------------------------------------------------------------------
=head2 $pod_seq-E<gt>B<append()>
$pod_seq->append($text);
$pod_seq1->append($pod_seq2);
Appends the given string or parse-tree or sequence object to the parse-tree
of this interior sequence.
=cut
sub append {
my $self = shift;
$self->{'-ptree'}->append(@_);
_set_child2parent_links($self, @_);
return $self;
}
##---------------------------------------------------------------------------
=head2 $pod_seq-E<gt>B<nested()>
$outer_seq = $pod_seq->nested || print "not nested";
If this interior sequence is nested inside of another interior
sequence, then the outer/parent sequence that contains it is
returned. Otherwise C<undef> is returned.
=cut
sub nested {
my $self = shift;
(@_ == 1) and $self->{'-parent_sequence'} = shift;
return $self->{'-parent_sequence'} || undef;
}
##---------------------------------------------------------------------------
=head2 $pod_seq-E<gt>B<raw_text()>
my $seq_raw_text = $pod_seq->raw_text();
This method will return the I<raw> text of the POD interior sequence,
exactly as it appeared in the input.
=cut
sub raw_text {
my $self = shift;
my $text = $self->{'-name'} . $self->{'-ldelim'};
for ( $self->{'-ptree'}->children ) {
$text .= (ref $_) ? $_->raw_text : $_;
}
$text .= $self->{'-rdelim'};
return $text;
}
##---------------------------------------------------------------------------
=head2 $pod_seq-E<gt>B<left_delimiter()>
my $ldelim = $pod_seq->left_delimiter();
The leftmost delimiter beginning the argument text to the interior
sequence (should be "<").
=cut
sub left_delimiter {
(@_ > 1) and $_[0]->{'-ldelim'} = $_[1];
return $_[0]->{'-ldelim'};
}
## let ldelim() be an alias for left_delimiter()
*ldelim = \&left_delimiter;
##---------------------------------------------------------------------------
=head2 $pod_seq-E<gt>B<right_delimiter()>
The rightmost delimiter beginning the argument text to the interior
sequence (should be ">").
=cut
sub right_delimiter {
(@_ > 1) and $_[0]->{'-rdelim'} = $_[1];
return $_[0]->{'-rdelim'};
}
## let rdelim() be an alias for right_delimiter()
*rdelim = \&right_delimiter;
##---------------------------------------------------------------------------
=head2 $pod_seq-E<gt>B<parse_tree()>
my $ptree = $pod_parser->parse_text($paragraph_text);
$pod_seq->parse_tree( $ptree );
$ptree = $pod_seq->parse_tree();
This method will get/set the corresponding parse-tree of the interior
sequence's text.
=cut
sub parse_tree {
(@_ > 1) and $_[0]->{'-ptree'} = $_[1];
return $_[0]->{'-ptree'};
}
## let ptree() be an alias for parse_tree()
*ptree = \&parse_tree;
##---------------------------------------------------------------------------
=head2 $pod_seq-E<gt>B<file_line()>
my ($filename, $line_number) = $pod_seq->file_line();
my $position = $pod_seq->file_line();
Returns the current filename and line number for the interior sequence
object. If called in a list context, it returns a list of two
elements: first the filename, then the line number. If called in
a scalar context, it returns a string containing the filename, followed
by a colon (':'), followed by the line number.
=cut
sub file_line {
my @loc = ($_[0]->{'-file'} || '<unknown-file>',
$_[0]->{'-line'} || 0);
return (wantarray) ? @loc : join(':', @loc);
}
##---------------------------------------------------------------------------
=head2 Pod::InteriorSequence::B<DESTROY()>
This method performs any necessary cleanup for the interior-sequence.
If you override this method then it is B<imperative> that you invoke
the parent method from within your own method, otherwise
I<interior-sequence storage will not be reclaimed upon destruction!>
=cut
sub DESTROY {
## We need to get rid of all child->parent pointers throughout the
## tree so their reference counts will go to zero and they can be
## garbage-collected
_unset_child2parent_links(@_);
}
##---------------------------------------------------------------------------
#############################################################################
package Pod::ParseTree;
##---------------------------------------------------------------------------
=head1 B<Pod::ParseTree>
This object corresponds to a tree of parsed POD text. As POD text is
scanned from left to right, it is parsed into an ordered list of
text-strings and B<Pod::InteriorSequence> objects (in order of
appearance). A B<Pod::ParseTree> object corresponds to this list of
strings and sequences. Each interior sequence in the parse-tree may
itself contain a parse-tree (since interior sequences may be nested).
=cut
##---------------------------------------------------------------------------
=head2 Pod::ParseTree-E<gt>B<new()>
my $ptree1 = Pod::ParseTree->new;
my $ptree2 = new Pod::ParseTree;
my $ptree4 = Pod::ParseTree->new($array_ref);
my $ptree3 = new Pod::ParseTree($array_ref);
This is a class method that constructs a C<Pod::Parse_tree> object and
returns a reference to the new parse-tree. If a single-argument is given,
it must be a reference to an array, and is used to initialize the root
(top) of the parse tree.
=cut
sub new {
## Determine if we were called via an object-ref or a classname
my $this = shift;
my $class = ref($this) || $this;
my $self = (@_ == 1 and ref $_[0]) ? $_[0] : [];
## Bless ourselves into the desired class and perform any initialization
bless $self, $class;
return $self;
}
##---------------------------------------------------------------------------
=head2 $ptree-E<gt>B<top()>
my $top_node = $ptree->top();
$ptree->top( $top_node );
$ptree->top( @children );
This method gets/sets the top node of the parse-tree. If no arguments are
given, it returns the topmost node in the tree (the root), which is also
a B<Pod::ParseTree>. If it is given a single argument that is a reference,
then the reference is assumed to a parse-tree and becomes the new top node.
Otherwise, if arguments are given, they are treated as the new list of
children for the top node.
=cut
sub top {
my $self = shift;
if (@_ > 0) {
@{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_;
}
return $self;
}
## let parse_tree() & ptree() be aliases for the 'top' method
*parse_tree = *ptree = \⊤
##---------------------------------------------------------------------------
=head2 $ptree-E<gt>B<children()>
This method gets/sets the children of the top node in the parse-tree.
If no arguments are given, it returns the list (array) of children
(each of which should be either a string or a B<Pod::InteriorSequence>.
Otherwise, if arguments are given, they are treated as the new list of
children for the top node.
=cut
sub children {
my $self = shift;
if (@_ > 0) {
@{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_;
}
return @{ $self };
}
##---------------------------------------------------------------------------
=head2 $ptree-E<gt>B<prepend()>
This method prepends the given text or parse-tree to the current parse-tree.
If the first item on the parse-tree is text and the argument is also text,
then the text is prepended to the first item (not added as a separate string).
Otherwise the argument is added as a new string or parse-tree I<before>
the current one.
=cut
use vars qw(@ptree); ## an alias used for performance reasons
sub prepend {
my $self = shift;
local *ptree = $self;
for (@_) {
next unless length;
if (@ptree && !(ref $ptree[0]) && !(ref $_)) {
$ptree[0] = $_ . $ptree[0];
}
else {
unshift @ptree, $_;
}
}
}
##---------------------------------------------------------------------------
=head2 $ptree-E<gt>B<append()>
This method appends the given text or parse-tree to the current parse-tree.
If the last item on the parse-tree is text and the argument is also text,
then the text is appended to the last item (not added as a separate string).
Otherwise the argument is added as a new string or parse-tree I<after>
the current one.
=cut
sub append {
my $self = shift;
local *ptree = $self;
my $can_append = @ptree && !(ref $ptree[-1]);
for (@_) {
if (ref) {
push @ptree, $_;
}
elsif(!length) {
next;
}
elsif ($can_append) {
$ptree[-1] .= $_;
}
else {
push @ptree, $_;
}
}
}
=head2 $ptree-E<gt>B<raw_text()>
my $ptree_raw_text = $ptree->raw_text();
This method will return the I<raw> text of the POD parse-tree
exactly as it appeared in the input.
=cut
sub raw_text {
my $self = shift;
my $text = '';
for ( @$self ) {
$text .= (ref $_) ? $_->raw_text : $_;
}
return $text;
}
##---------------------------------------------------------------------------
## Private routines to set/unset child->parent links
sub _unset_child2parent_links {
my $self = shift;
local *ptree = $self;
for (@ptree) {
next unless (defined and length and ref and ref ne 'SCALAR');
$_->_unset_child2parent_links()
if UNIVERSAL::isa($_, 'Pod::InteriorSequence');
}
}
sub _set_child2parent_links {
## nothing to do, Pod::ParseTrees cant have parent pointers
}
=head2 Pod::ParseTree::B<DESTROY()>
This method performs any necessary cleanup for the parse-tree.
If you override this method then it is B<imperative>
that you invoke the parent method from within your own method,
otherwise I<parse-tree storage will not be reclaimed upon destruction!>
=cut
sub DESTROY {
## We need to get rid of all child->parent pointers throughout the
## tree so their reference counts will go to zero and they can be
## garbage-collected
_unset_child2parent_links(@_);
}
#############################################################################
=head1 SEE ALSO
B<Pod::InputObjects> is part of the L<Pod::Parser> distribution.
See L<Pod::Parser>, L<Pod::Select>
=head1 AUTHOR
Please report bugs using L<http://rt.cpan.org>.
Brad Appleton E<lt>bradapp@enteract.comE<gt>
=cut
1;
POD_INPUTOBJECTS
$fatpacked{"Pod/Man.pm"} = <<'POD_MAN';
# Pod::Man -- Convert POD data to formatted *roff input.
#
# This module translates POD documentation into *roff markup using the man
# macro set, and is intended for converting POD documents written as Unix
# manual pages to manual pages that can be read by the man(1) command. It is
# a replacement for the pod2man command distributed with versions of Perl
# prior to 5.6.
#
# Perl core hackers, please note that this module is also separately
# maintained outside of the Perl core as part of the podlators. Please send
# me any patches at the address above in addition to sending them to the
# standard Perl mailing lists.
#
# Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
# 2010, 2012, 2013 Russ Allbery <rra@stanford.edu>
# Substantial contributions by Sean Burke <sburke@cpan.org>
#
# This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
##############################################################################
# Modules and declarations
##############################################################################
package Pod::Man;
require 5.005;
use strict;
use subs qw(makespace);
use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION);
use Carp qw(croak);
use Encode qw(encode);
use Pod::Simple ();
@ISA = qw(Pod::Simple);
$VERSION = '2.27';
# Set the debugging level. If someone has inserted a debug function into this
# class already, use that. Otherwise, use any Pod::Simple debug function
# that's defined, and failing that, define a debug level of 10.
BEGIN {
my $parent = defined (&Pod::Simple::DEBUG) ? \&Pod::Simple::DEBUG : undef;
unless (defined &DEBUG) {
*DEBUG = $parent || sub () { 10 };
}
}
# Import the ASCII constant from Pod::Simple. This is true iff we're in an
# ASCII-based universe (including such things as ISO 8859-1 and UTF-8), and is
# generally only false for EBCDIC.
BEGIN { *ASCII = \&Pod::Simple::ASCII }
# Pretty-print a data structure. Only used for debugging.
BEGIN { *pretty = \&Pod::Simple::pretty }
##############################################################################
# Object initialization
##############################################################################
# Initialize the object and set various Pod::Simple options that we need.
# Here, we also process any additional options passed to the constructor or
# set up defaults if none were given. Note that all internal object keys are
# in all-caps, reserving all lower-case object keys for Pod::Simple and user
# arguments.
sub new {
my $class = shift;
my $self = $class->SUPER::new;
# Tell Pod::Simple not to handle S<> by automatically inserting .
$self->nbsp_for_S (1);
# Tell Pod::Simple to keep whitespace whenever possible.
if ($self->can ('preserve_whitespace')) {
$self->preserve_whitespace (1);
} else {
$self->fullstop_space_harden (1);
}
# The =for and =begin targets that we accept.
$self->accept_targets (qw/man MAN roff ROFF/);
# Ensure that contiguous blocks of code are merged together. Otherwise,
# some of the guesswork heuristics don't work right.
$self->merge_text (1);
# Pod::Simple doesn't do anything useful with our arguments, but we want
# to put them in our object as hash keys and values. This could cause
# problems if we ever clash with Pod::Simple's own internal class
# variables.
%$self = (%$self, @_);
# Send errors to stderr if requested.
if ($$self{stderr} and not $$self{errors}) {
$$self{errors} = 'stderr';
}
delete $$self{stderr};
# Validate the errors parameter and act on it.
if (not defined $$self{errors}) {
$$self{errors} = 'pod';
}
if ($$self{errors} eq 'stderr' || $$self{errors} eq 'die') {
$self->no_errata_section (1);
$self->complain_stderr (1);
if ($$self{errors} eq 'die') {
$$self{complain_die} = 1;
}
} elsif ($$self{errors} eq 'pod') {
$self->no_errata_section (0);
$self->complain_stderr (0);
} elsif ($$self{errors} eq 'none') {
$self->no_whining (1);
} else {
croak (qq(Invalid errors setting: "$$self{errors}"));
}
delete $$self{errors};
# Initialize various other internal constants based on our arguments.
$self->init_fonts;
$self->init_quotes;
$self->init_page;
# For right now, default to turning on all of the magic.
$$self{MAGIC_CPP} = 1;
$$self{MAGIC_EMDASH} = 1;
$$self{MAGIC_FUNC} = 1;
$$self{MAGIC_MANREF} = 1;
$$self{MAGIC_SMALLCAPS} = 1;
$$self{MAGIC_VARS} = 1;
return $self;
}
# Translate a font string into an escape.
sub toescape { (length ($_[0]) > 1 ? '\f(' : '\f') . $_[0] }
# Determine which fonts the user wishes to use and store them in the object.
# Regular, italic, bold, and bold-italic are constants, but the fixed width
# fonts may be set by the user. Sets the internal hash key FONTS which is
# used to map our internal font escapes to actual *roff sequences later.
sub init_fonts {
my ($self) = @_;
# Figure out the fixed-width font. If user-supplied, make sure that they
# are the right length.
for (qw/fixed fixedbold fixeditalic fixedbolditalic/) {
my $font = $$self{$_};
if (defined ($font) && (length ($font) < 1 || length ($font) > 2)) {
croak qq(roff font should be 1 or 2 chars, not "$font");
}
}
# Set the default fonts. We can't be sure portably across different
# implementations what fixed bold-italic may be called (if it's even
# available), so default to just bold.
$$self{fixed} ||= 'CW';
$$self{fixedbold} ||= 'CB';
$$self{fixeditalic} ||= 'CI';
$$self{fixedbolditalic} ||= 'CB';
# Set up a table of font escapes. First number is fixed-width, second is
# bold, third is italic.
$$self{FONTS} = { '000' => '\fR', '001' => '\fI',
'010' => '\fB', '011' => '\f(BI',
'100' => toescape ($$self{fixed}),
'101' => toescape ($$self{fixeditalic}),
'110' => toescape ($$self{fixedbold}),
'111' => toescape ($$self{fixedbolditalic}) };
}
# Initialize the quotes that we'll be using for C<> text. This requires some
# special handling, both to parse the user parameter if given and to make sure
# that the quotes will be safe against *roff. Sets the internal hash keys
# LQUOTE and RQUOTE.
sub init_quotes {
my ($self) = (@_);
$$self{quotes} ||= '"';
if ($$self{quotes} eq 'none') {
$$self{LQUOTE} = $$self{RQUOTE} = '';
} elsif (length ($$self{quotes}) == 1) {
$$self{LQUOTE} = $$self{RQUOTE} = $$self{quotes};
} elsif ($$self{quotes} =~ /^(.)(.)$/
|| $$self{quotes} =~ /^(..)(..)$/) {
$$self{LQUOTE} = $1;
$$self{RQUOTE} = $2;
} else {
croak(qq(Invalid quote specification "$$self{quotes}"))
}
# Double the first quote; note that this should not be s///g as two double
# quotes is represented in *roff as three double quotes, not four. Weird,
# I know.
$$self{LQUOTE} =~ s/\"/\"\"/;
$$self{RQUOTE} =~ s/\"/\"\"/;
}
# Initialize the page title information and indentation from our arguments.
sub init_page {
my ($self) = @_;
# We used to try first to get the version number from a local binary, but
# we shouldn't need that any more. Get the version from the running Perl.
# Work a little magic to handle subversions correctly under both the
# pre-5.6 and the post-5.6 version numbering schemes.
my @version = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/);
$version[2] ||= 0;
$version[2] *= 10 ** (3 - length $version[2]);
for (@version) { $_ += 0 }
my $version = join ('.', @version);
# Set the defaults for page titles and indentation if the user didn't
# override anything.
$$self{center} = 'User Contributed Perl Documentation'
unless defined $$self{center};
$$self{release} = 'perl v' . $version
unless defined $$self{release};
$$self{indent} = 4
unless defined $$self{indent};
# Double quotes in things that will be quoted.
for (qw/center release/) {
$$self{$_} =~ s/\"/\"\"/g if $$self{$_};
}
}
##############################################################################
# Core parsing
##############################################################################
# This is the glue that connects the code below with Pod::Simple itself. The
# goal is to convert the event stream coming from the POD parser into method
# calls to handlers once the complete content of a tag has been seen. Each
# paragraph or POD command will have textual content associated with it, and
# as soon as all of a paragraph or POD command has been seen, that content
# will be passed in to the corresponding method for handling that type of
# object. The exceptions are handlers for lists, which have opening tag
# handlers and closing tag handlers that will be called right away.
#
# The internal hash key PENDING is used to store the contents of a tag until
# all of it has been seen. It holds a stack of open tags, each one
# represented by a tuple of the attributes hash for the tag, formatting
# options for the tag (which are inherited), and the contents of the tag.
# Add a block of text to the contents of the current node, formatting it
# according to the current formatting instructions as we do.
sub _handle_text {
my ($self, $text) = @_;
DEBUG > 3 and print "== $text\n";
my $tag = $$self{PENDING}[-1];
$$tag[2] .= $self->format_text ($$tag[1], $text);
}
# Given an element name, get the corresponding method name.
sub method_for_element {
my ($self, $element) = @_;
$element =~ tr/-/_/;
$element =~ tr/A-Z/a-z/;
$element =~ tr/_a-z0-9//cd;
return $element;
}
# Handle the start of a new element. If cmd_element is defined, assume that
# we need to collect the entire tree for this element before passing it to the
# element method, and create a new tree into which we'll collect blocks of
# text and nested elements. Otherwise, if start_element is defined, call it.
sub _handle_element_start {
my ($self, $element, $attrs) = @_;
DEBUG > 3 and print "++ $element (<", join ('> <', %$attrs), ">)\n";
my $method = $self->method_for_element ($element);
# If we have a command handler, we need to accumulate the contents of the
# tag before calling it. Turn off IN_NAME for any command other than
# <Para> and the formatting codes so that IN_NAME isn't still set for the
# first heading after the NAME heading.
if ($self->can ("cmd_$method")) {
DEBUG > 2 and print "<$element> starts saving a tag\n";
$$self{IN_NAME} = 0 if ($element ne 'Para' && length ($element) > 1);
# How we're going to format embedded text blocks depends on the tag
# and also depends on our parent tags. Thankfully, inside tags that
# turn off guesswork and reformatting, nothing else can turn it back
# on, so this can be strictly inherited.
my $formatting = $$self{PENDING}[-1][1];
$formatting = $self->formatting ($formatting, $element);
push (@{ $$self{PENDING} }, [ $attrs, $formatting, '' ]);
DEBUG > 4 and print "Pending: [", pretty ($$self{PENDING}), "]\n";
} elsif ($self->can ("start_$method")) {
my $method = 'start_' . $method;
$self->$method ($attrs, '');
} else {
DEBUG > 2 and print "No $method start method, skipping\n";
}
}
# Handle the end of an element. If we had a cmd_ method for this element,
# this is where we pass along the tree that we built. Otherwise, if we have
# an end_ method for the element, call that.
sub _handle_element_end {
my ($self, $element) = @_;
DEBUG > 3 and print "-- $element\n";
my $method = $self->method_for_element ($element);
# If we have a command handler, pull off the pending text and pass it to
# the handler along with the saved attribute hash.
if ($self->can ("cmd_$method")) {
DEBUG > 2 and print "</$element> stops saving a tag\n";
my $tag = pop @{ $$self{PENDING} };
DEBUG > 4 and print "Popped: [", pretty ($tag), "]\n";
DEBUG > 4 and print "Pending: [", pretty ($$self{PENDING}), "]\n";
my $method = 'cmd_' . $method;
my $text = $self->$method ($$tag[0], $$tag[2]);
if (defined $text) {
if (@{ $$self{PENDING} } > 1) {
$$self{PENDING}[-1][2] .= $text;
} else {
$self->output ($text);
}
}
} elsif ($self->can ("end_$method")) {
my $method = 'end_' . $method;
$self->$method ();
} else {
DEBUG > 2 and print "No $method end method, skipping\n";
}
}
##############################################################################
# General formatting
##############################################################################
# Return formatting instructions for a new block. Takes the current
# formatting and the new element. Formatting inherits negatively, in the
# sense that if the parent has turned off guesswork, all child elements should
# leave it off. We therefore return a copy of the same formatting
# instructions but possibly with more things turned off depending on the
# element.
sub formatting {
my ($self, $current, $element) = @_;
my %options;
if ($current) {
%options = %$current;
} else {
%options = (guesswork => 1, cleanup => 1, convert => 1);
}
if ($element eq 'Data') {
$options{guesswork} = 0;
$options{cleanup} = 0;
$options{convert} = 0;
} elsif ($element eq 'X') {
$options{guesswork} = 0;
$options{cleanup} = 0;
} elsif ($element eq 'Verbatim' || $element eq 'C') {
$options{guesswork} = 0;
$options{literal} = 1;
}
return \%options;
}
# Format a text block. Takes a hash of formatting options and the text to
# format. Currently, the only formatting options are guesswork, cleanup, and
# convert, all of which are boolean.
sub format_text {
my ($self, $options, $text) = @_;
my $guesswork = $$options{guesswork} && !$$self{IN_NAME};
my $cleanup = $$options{cleanup};
my $convert = $$options{convert};
my $literal = $$options{literal};
# Cleanup just tidies up a few things, telling *roff that the hyphens are
# hard, putting a bit of space between consecutive underscores, and
# escaping backslashes. Be careful not to mangle our character
# translations by doing this before processing character translation.
if ($cleanup) {
$text =~ s/\\/\\e/g;
$text =~ s/-/\\-/g;
$text =~ s/_(?=_)/_\\|/g;
}
# Normally we do character translation, but we won't even do that in
# <Data> blocks or if UTF-8 output is desired.
if ($convert && !$$self{utf8} && ASCII) {
$text =~ s/([^\x00-\x7F])/$ESCAPES{ord ($1)} || "X"/eg;
}
# Ensure that *roff doesn't convert literal quotes to UTF-8 single quotes,
# but don't mess up our accept escapes.
if ($literal) {
$text =~ s/(?<!\\\*)\'/\\*\(Aq/g;
$text =~ s/(?<!\\\*)\`/\\\`/g;
}
# If guesswork is asked for, do that. This involves more substantial
# formatting based on various heuristics that may only be appropriate for
# particular documents.
if ($guesswork) {
$text = $self->guesswork ($text);
}
return $text;
}
# Handles C<> text, deciding whether to put \*C` around it or not. This is a
# whole bunch of messy heuristics to try to avoid overquoting, originally from
# Barrie Slaymaker. This largely duplicates similar code in Pod::Text.
sub quote_literal {
my $self = shift;
local $_ = shift;
# A regex that matches the portion of a variable reference that's the
# array or hash index, separated out just because we want to use it in
# several places in the following regex.
my $index = '(?: \[.*\] | \{.*\} )?';
# If in NAME section, just return an ASCII quoted string to avoid
# confusing tools like whatis.
return qq{"$_"} if $$self{IN_NAME};
# Check for things that we don't want to quote, and if we find any of
# them, return the string with just a font change and no quoting.
m{
^\s*
(?:
( [\'\`\"] ) .* \1 # already quoted
| \\\*\(Aq .* \\\*\(Aq # quoted and escaped
| \\?\` .* ( \' | \\\*\(Aq ) # `quoted'
| \$+ [\#^]? \S $index # special ($^Foo, $")
| [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func
| [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call
| [-+]? ( \d[\d.]* | \.\d+ ) (?: [eE][-+]?\d+ )? # a number
| 0x [a-fA-F\d]+ # a hex constant
)
\s*\z
}xso and return '\f(FS' . $_ . '\f(FE';
# If we didn't return, go ahead and quote the text.
return '\f(FS\*(C`' . $_ . "\\*(C'\\f(FE";
}
# Takes a text block to perform guesswork on. Returns the text block with
# formatting codes added. This is the code that marks up various Perl
# constructs and things commonly used in man pages without requiring the user
# to add any explicit markup, and is applied to all non-literal text. We're
# guaranteed that the text we're applying guesswork to does not contain any
# *roff formatting codes. Note that the inserted font sequences must be
# treated later with mapfonts or textmapfonts.
#
# This method is very fragile, both in the regular expressions it uses and in
# the ordering of those modifications. Care and testing is required when
# modifying it.
sub guesswork {
my $self = shift;
local $_ = shift;
DEBUG > 5 and print " Guesswork called on [$_]\n";
# By the time we reach this point, all hypens will be escaped by adding a
# backslash. We want to undo that escaping if they're part of regular
# words and there's only a single dash, since that's a real hyphen that
# *roff gets to consider a possible break point. Make sure that a dash
# after the first character of a word stays non-breaking, however.
#
# Note that this is not user-controllable; we pretty much have to do this
# transformation or *roff will mangle the output in unacceptable ways.
s{
( (?:\G|^|\s) [\(\"]* [a-zA-Z] ) ( \\- )?
( (?: [a-zA-Z\']+ \\-)+ )
( [a-zA-Z\']+ ) (?= [\)\".?!,;:]* (?:\s|\Z|\\\ ) )
\b
} {
my ($prefix, $hyphen, $main, $suffix) = ($1, $2, $3, $4);
$hyphen ||= '';
$main =~ s/\\-/-/g;
$prefix . $hyphen . $main . $suffix;
}egx;
# Translate "--" into a real em-dash if it's used like one. This means
# that it's either surrounded by whitespace, it follows a regular word, or
# it occurs between two regular words.
if ($$self{MAGIC_EMDASH}) {
s{ (\s) \\-\\- (\s) } { $1 . '\*(--' . $2 }egx;
s{ (\b[a-zA-Z]+) \\-\\- (\s|\Z|[a-zA-Z]+\b) } { $1 . '\*(--' . $2 }egx;
}
# Make words in all-caps a little bit smaller; they look better that way.
# However, we don't want to change Perl code (like @ARGV), nor do we want
# to fix the MIME in MIME-Version since it looks weird with the
# full-height V.
#
# We change only a string of all caps (2) either at the beginning of the
# line or following regular punctuation (like quotes) or whitespace (1),
# and followed by either similar punctuation, an em-dash, or the end of
# the line (3).
#
# Allow the text we're changing to small caps to include double quotes,
# commas, newlines, and periods as long as it doesn't otherwise interrupt
# the string of small caps and still fits the criteria. This lets us turn
# entire warranty disclaimers in man page output into small caps.
if ($$self{MAGIC_SMALLCAPS}) {
s{
( ^ | [\s\(\"\'\`\[\{<>] | \\[ ] ) # (1)
( [A-Z] [A-Z] (?: [/A-Z+:\d_\$&] | \\- | [.,\"\s] )* ) # (2)
(?= [\s>\}\]\(\)\'\".?!,;] | \\*\(-- | \\[ ] | $ ) # (3)
} {
$1 . '\s-1' . $2 . '\s0'
}egx;
}
# Note that from this point forward, we have to adjust for \s-1 and \s-0
# strings inserted around things that we've made small-caps if later
# transforms should work on those strings.
# Italize functions in the form func(), including functions that are in
# all capitals, but don't italize if there's anything between the parens.
# The function must start with an alphabetic character or underscore and
# then consist of word characters or colons.
if ($$self{MAGIC_FUNC}) {
s{
( \b | \\s-1 )
( [A-Za-z_] ([:\w] | \\s-?[01])+ \(\) )
} {
$1 . '\f(IS' . $2 . '\f(IE'
}egx;
}
# Change references to manual pages to put the page name in italics but
# the number in the regular font, with a thin space between the name and
# the number. Only recognize func(n) where func starts with an alphabetic
# character or underscore and contains only word characters, periods (for
# configuration file man pages), or colons, and n is a single digit,
# optionally followed by some number of lowercase letters. Note that this
# does not recognize man page references like perl(l) or socket(3SOCKET).
if ($$self{MAGIC_MANREF}) {
s{
( \b | \\s-1 )
( [A-Za-z_] (?:[.:\w] | \\- | \\s-?[01])+ )
( \( \d [a-z]* \) )
} {
$1 . '\f(IS' . $2 . '\f(IE\|' . $3
}egx;
}
# Convert simple Perl variable references to a fixed-width font. Be
# careful not to convert functions, though; there are too many subtleties
# with them to want to perform this transformation.
if ($$self{MAGIC_VARS}) {
s{
( ^ | \s+ )
( [\$\@%] [\w:]+ )
(?! \( )
} {
$1 . '\f(FS' . $2 . '\f(FE'
}egx;
}
# Fix up double quotes. Unfortunately, we miss this transformation if the
# quoted text contains any code with formatting codes and there's not much
# we can effectively do about that, which makes it somewhat unclear if
# this is really a good idea.
s{ \" ([^\"]+) \" } { '\*(L"' . $1 . '\*(R"' }egx;
# Make C++ into \*(C+, which is a squinched version.
if ($$self{MAGIC_CPP}) {
s{ \b C\+\+ } {\\*\(C+}gx;
}
# Done.
DEBUG > 5 and print " Guesswork returning [$_]\n";
return $_;
}
##############################################################################
# Output
##############################################################################
# When building up the *roff code, we don't use real *roff fonts. Instead, we
# embed font codes of the form \f(<font>[SE] where <font> is one of B, I, or
# F, S stands for start, and E stands for end. This method turns these into
# the right start and end codes.
#
# We add this level of complexity because the old pod2man didn't get code like
# B<someI<thing> else> right; after I<> it switched back to normal text rather
# than bold. We take care of this by using variables that state whether bold,
# italic, or fixed are turned on as a combined pointer to our current font
# sequence, and set each to the number of current nestings of start tags for
# that font.
#
# \fP changes to the previous font, but only one previous font is kept. We
# don't know what the outside level font is; normally it's R, but if we're
# inside a heading it could be something else. So arrange things so that the
# outside font is always the "previous" font and end with \fP instead of \fR.
# Idea from Zack Weinberg.
sub mapfonts {
my ($self, $text) = @_;
my ($fixed, $bold, $italic) = (0, 0, 0);
my %magic = (F => \$fixed, B => \$bold, I => \$italic);
my $last = '\fR';
$text =~ s<
\\f\((.)(.)
> <
my $sequence = '';
my $f;
if ($last ne '\fR') { $sequence = '\fP' }
${ $magic{$1} } += ($2 eq 'S') ? 1 : -1;
$f = $$self{FONTS}{ ($fixed && 1) . ($bold && 1) . ($italic && 1) };
if ($f eq $last) {
'';
} else {
if ($f ne '\fR') { $sequence .= $f }
$last = $f;
$sequence;
}
>gxe;
return $text;
}
# Unfortunately, there is a bug in Solaris 2.6 nroff (not present in GNU
# groff) where the sequence \fB\fP\f(CW\fP leaves the font set to B rather
# than R, presumably because \f(CW doesn't actually do a font change. To work
# around this, use a separate textmapfonts for text blocks where the default
# font is always R and only use the smart mapfonts for headings.
sub textmapfonts {
my ($self, $text) = @_;
my ($fixed, $bold, $italic) = (0, 0, 0);
my %magic = (F => \$fixed, B => \$bold, I => \$italic);
$text =~ s<
\\f\((.)(.)
> <
${ $magic{$1} } += ($2 eq 'S') ? 1 : -1;
$$self{FONTS}{ ($fixed && 1) . ($bold && 1) . ($italic && 1) };
>gxe;
return $text;
}
# Given a command and a single argument that may or may not contain double
# quotes, handle double-quote formatting for it. If there are no double
# quotes, just return the command followed by the argument in double quotes.
# If there are double quotes, use an if statement to test for nroff, and for
# nroff output the command followed by the argument in double quotes with
# embedded double quotes doubled. For other formatters, remap paired double
# quotes to LQUOTE and RQUOTE.
sub switchquotes {
my ($self, $command, $text, $extra) = @_;
$text =~ s/\\\*\([LR]\"/\"/g;
# We also have to deal with \*C` and \*C', which are used to add the
# quotes around C<> text, since they may expand to " and if they do this
# confuses the .SH macros and the like no end. Expand them ourselves.
# Also separate troff from nroff if there are any fixed-width fonts in use
# to work around problems with Solaris nroff.
my $c_is_quote = ($$self{LQUOTE} =~ /\"/) || ($$self{RQUOTE} =~ /\"/);
my $fixedpat = join '|', @{ $$self{FONTS} }{'100', '101', '110', '111'};
$fixedpat =~ s/\\/\\\\/g;
$fixedpat =~ s/\(/\\\(/g;
if ($text =~ m/\"/ || $text =~ m/$fixedpat/) {
$text =~ s/\"/\"\"/g;
my $nroff = $text;
my $troff = $text;
$troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g;
if ($c_is_quote and $text =~ m/\\\*\(C[\'\`]/) {
$nroff =~ s/\\\*\(C\`/$$self{LQUOTE}/g;
$nroff =~ s/\\\*\(C\'/$$self{RQUOTE}/g;
$troff =~ s/\\\*\(C[\'\`]//g;
}
$nroff = qq("$nroff") . ($extra ? " $extra" : '');
$troff = qq("$troff") . ($extra ? " $extra" : '');
# Work around the Solaris nroff bug where \f(CW\fP leaves the font set
# to Roman rather than the actual previous font when used in headings.
# troff output may still be broken, but at least we can fix nroff by
# just switching the font changes to the non-fixed versions.
$nroff =~ s/\Q$$self{FONTS}{100}\E(.*?)\\f[PR]/$1/g;
$nroff =~ s/\Q$$self{FONTS}{101}\E(.*?)\\f([PR])/\\fI$1\\f$2/g;
$nroff =~ s/\Q$$self{FONTS}{110}\E(.*?)\\f([PR])/\\fB$1\\f$2/g;
$nroff =~ s/\Q$$self{FONTS}{111}\E(.*?)\\f([PR])/\\f\(BI$1\\f$2/g;
# Now finally output the command. Bother with .ie only if the nroff
# and troff output aren't the same.
if ($nroff ne $troff) {
return ".ie n $command $nroff\n.el $command $troff\n";
} else {
return "$command $nroff\n";
}
} else {
$text = qq("$text") . ($extra ? " $extra" : '');
return "$command $text\n";
}
}
# Protect leading quotes and periods against interpretation as commands. Also
# protect anything starting with a backslash, since it could expand or hide
# something that *roff would interpret as a command. This is overkill, but
# it's much simpler than trying to parse *roff here.
sub protect {
my ($self, $text) = @_;
$text =~ s/^([.\'\\])/\\&$1/mg;
return $text;
}
# Make vertical whitespace if NEEDSPACE is set, appropriate to the indentation
# level the situation. This function is needed since in *roff one has to
# create vertical whitespace after paragraphs and between some things, but
# other macros create their own whitespace. Also close out a sequence of
# repeated =items, since calling makespace means we're about to begin the item
# body.
sub makespace {
my ($self) = @_;
$self->output (".PD\n") if $$self{ITEMS} > 1;
$$self{ITEMS} = 0;
$self->output ($$self{INDENT} > 0 ? ".Sp\n" : ".PP\n")
if $$self{NEEDSPACE};
}
# Output any pending index entries, and optionally an index entry given as an
# argument. Support multiple index entries in X<> separated by slashes, and
# strip special escapes from index entries.
sub outindex {
my ($self, $section, $index) = @_;
my @entries = map { split m%\s*/\s*% } @{ $$self{INDEX} };
return unless ($section || @entries);
# We're about to output all pending entries, so clear our pending queue.
$$self{INDEX} = [];
# Build the output. Regular index entries are marked Xref, and headings
# pass in their own section. Undo some *roff formatting on headings.
my @output;
if (@entries) {
push @output, [ 'Xref', join (' ', @entries) ];
}
if ($section) {
$index =~ s/\\-/-/g;
$index =~ s/\\(?:s-?\d|.\(..|.)//g;
push @output, [ $section, $index ];
}
# Print out the .IX commands.
for (@output) {
my ($type, $entry) = @$_;
$entry =~ s/\s+/ /g;
$entry =~ s/\"/\"\"/g;
$entry =~ s/\\/\\\\/g;
$self->output (".IX $type " . '"' . $entry . '"' . "\n");
}
}
# Output some text, without any additional changes.
sub output {
my ($self, @text) = @_;
if ($$self{ENCODE}) {
print { $$self{output_fh} } encode ('UTF-8', join ('', @text));
} else {
print { $$self{output_fh} } @text;
}
}
##############################################################################
# Document initialization
##############################################################################
# Handle the start of the document. Here we handle empty documents, as well
# as setting up our basic macros in a preamble and building the page title.
sub start_document {
my ($self, $attrs) = @_;
if ($$attrs{contentless} && !$$self{ALWAYS_EMIT_SOMETHING}) {
DEBUG and print "Document is contentless\n";
$$self{CONTENTLESS} = 1;
return;
} else {
delete $$self{CONTENTLESS};
}
# When UTF-8 output is set, check whether our output file handle already
# has a PerlIO encoding layer set. If it does not, we'll need to encode
# our output before printing it (handled in the output() sub). Wrap the
# check in an eval to handle versions of Perl without PerlIO.
$$self{ENCODE} = 0;
if ($$self{utf8}) {
$$self{ENCODE} = 1;
eval {
my @options = (output => 1, details => 1);
my $flag = (PerlIO::get_layers ($$self{output_fh}, @options))[-1];
if ($flag & PerlIO::F_UTF8 ()) {
$$self{ENCODE} = 0;
}
}
}
# Determine information for the preamble and then output it.
my ($name, $section);
if (defined $$self{name}) {
$name = $$self{name};
$section = $$self{section} || 1;
} else {
($name, $section) = $self->devise_title;
}
my $date = $$self{date} || $self->devise_date;
$self->preamble ($name, $section, $date)
unless $self->bare_output or DEBUG > 9;
# Initialize a few per-document variables.
$$self{INDENT} = 0; # Current indentation level.
$$self{INDENTS} = []; # Stack of indentations.
$$self{INDEX} = []; # Index keys waiting to be printed.
$$self{IN_NAME} = 0; # Whether processing the NAME section.
$$self{ITEMS} = 0; # The number of consecutive =items.
$$self{ITEMTYPES} = []; # Stack of =item types, one per list.
$$self{SHIFTWAIT} = 0; # Whether there is a shift waiting.
$$self{SHIFTS} = []; # Stack of .RS shifts.
$$self{PENDING} = [[]]; # Pending output.
}
# Handle the end of the document. This handles dying on POD errors, since
# Pod::Parser currently doesn't. Otherwise, does nothing but print out a
# final comment at the end of the document under debugging.
sub end_document {
my ($self) = @_;
if ($$self{complain_die} && $self->errors_seen) {
croak ("POD document had syntax errors");
}
return if $self->bare_output;
return if ($$self{CONTENTLESS} && !$$self{ALWAYS_EMIT_SOMETHING});
$self->output (q(.\" [End document]) . "\n") if DEBUG;
}
# Try to figure out the name and section from the file name and return them as
# a list, returning an empty name and section 1 if we can't find any better
# information. Uses File::Basename and File::Spec as necessary.
sub devise_title {
my ($self) = @_;
my $name = $self->source_filename || '';
my $section = $$self{section} || 1;
$section = 3 if (!$$self{section} && $name =~ /\.pm\z/i);
$name =~ s/\.p(od|[lm])\z//i;
# If the section isn't 3, then the name defaults to just the basename of
# the file. Otherwise, assume we're dealing with a module. We want to
# figure out the full module name from the path to the file, but we don't
# want to include too much of the path into the module name. Lose
# anything up to the first off:
#
# */lib/*perl*/ standard or site_perl module
# */*perl*/lib/ from -Dprefix=/opt/perl
# */*perl*/ random module hierarchy
#
# which works. Also strip off a leading site, site_perl, or vendor_perl
# component, any OS-specific component, and any version number component,
# and strip off an initial component of "lib" or "blib/lib" since that's
# what ExtUtils::MakeMaker creates. splitdir requires at least File::Spec
# 0.8.
if ($section !~ /^3/) {
require File::Basename;
$name = uc File::Basename::basename ($name);
} else {
require File::Spec;
my ($volume, $dirs, $file) = File::Spec->splitpath ($name);
my @dirs = File::Spec->splitdir ($dirs);
my $cut = 0;
my $i;
for ($i = 0; $i < @dirs; $i++) {
if ($dirs[$i] =~ /perl/) {
$cut = $i + 1;
$cut++ if ($dirs[$i + 1] && $dirs[$i + 1] eq 'lib');
last;
}
}
if ($cut > 0) {
splice (@dirs, 0, $cut);
shift @dirs if ($dirs[0] =~ /^(site|vendor)(_perl)?$/);
shift @dirs if ($dirs[0] =~ /^[\d.]+$/);
shift @dirs if ($dirs[0] =~ /^(.*-$^O|$^O-.*|$^O)$/);
}
shift @dirs if $dirs[0] eq 'lib';
splice (@dirs, 0, 2) if ($dirs[0] eq 'blib' && $dirs[1] eq 'lib');
# Remove empty directories when building the module name; they
# occur too easily on Unix by doubling slashes.
$name = join ('::', (grep { $_ ? $_ : () } @dirs), $file);
}
return ($name, $section);
}
# Determine the modification date and return that, properly formatted in ISO
# format. If we can't get the modification date of the input, instead use the
# current time. Pod::Simple returns a completely unuseful stringified file
# handle as the source_filename for input from a file handle, so we have to
# deal with that as well.
sub devise_date {
my ($self) = @_;
my $input = $self->source_filename;
my $time;
if ($input) {
$time = (stat $input)[9] || time;
} else {
$time = time;
}
# Can't use POSIX::strftime(), which uses Fcntl, because MakeMaker
# uses this and it has to work in the core which can't load dynamic
# libraries.
my ($year, $month, $day) = (localtime $time)[5,4,3];
return sprintf ("%04d-%02d-%02d", $year + 1900, $month + 1, $day);
}
# Print out the preamble and the title. The meaning of the arguments to .TH
# unfortunately vary by system; some systems consider the fourth argument to
# be a "source" and others use it as a version number. Generally it's just
# presented as the left-side footer, though, so it doesn't matter too much if
# a particular system gives it another interpretation.
#
# The order of date and release used to be reversed in older versions of this
# module, but this order is correct for both Solaris and Linux.
sub preamble {
my ($self, $name, $section, $date) = @_;
my $preamble = $self->preamble_template (!$$self{utf8});
# Build the index line and make sure that it will be syntactically valid.
my $index = "$name $section";
$index =~ s/\"/\"\"/g;
# If name or section contain spaces, quote them (section really never
# should, but we may as well be cautious).
for ($name, $section) {
if (/\s/) {
s/\"/\"\"/g;
$_ = '"' . $_ . '"';
}
}
# Double quotes in date, since it will be quoted.
$date =~ s/\"/\"\"/g;
# Substitute into the preamble the configuration options.
$preamble =~ s/\@CFONT\@/$$self{fixed}/;
$preamble =~ s/\@LQUOTE\@/$$self{LQUOTE}/;
$preamble =~ s/\@RQUOTE\@/$$self{RQUOTE}/;
chomp $preamble;
# Get the version information.
my $version = $self->version_report;
# Finally output everything.
$self->output (<<"----END OF HEADER----");
.\\" Automatically generated by $version
.\\"
.\\" Standard preamble:
.\\" ========================================================================
$preamble
.\\" ========================================================================
.\\"
.IX Title "$index"
.TH $name $section "$date" "$$self{release}" "$$self{center}"
.\\" For nroff, turn off justification. Always turn off hyphenation; it makes
.\\" way too many mistakes in technical documents.
.if n .ad l
.nh
----END OF HEADER----
$self->output (".\\\" [End of preamble]\n") if DEBUG;
}
##############################################################################
# Text blocks
##############################################################################
# Handle a basic block of text. The only tricky part of this is if this is
# the first paragraph of text after an =over, in which case we have to change
# indentations for *roff.
sub cmd_para {
my ($self, $attrs, $text) = @_;
my $line = $$attrs{start_line};
# Output the paragraph. We also have to handle =over without =item. If
# there's an =over without =item, SHIFTWAIT will be set, and we need to
# handle creation of the indent here. Add the shift to SHIFTS so that it
# will be cleaned up on =back.
$self->makespace;
if ($$self{SHIFTWAIT}) {
$self->output (".RS $$self{INDENT}\n");
push (@{ $$self{SHIFTS} }, $$self{INDENT});
$$self{SHIFTWAIT} = 0;
}
# Add the line number for debugging, but not in the NAME section just in
# case the comment would confuse apropos.
$self->output (".\\\" [At source line $line]\n")
if defined ($line) && DEBUG && !$$self{IN_NAME};
# Force exactly one newline at the end and strip unwanted trailing
# whitespace at the end, but leave "\ " backslashed space from an S< >
# at the end of a line.
$text =~ s/((?:\\ )*)\s*$/$1\n/;
# Output the paragraph.
$self->output ($self->protect ($self->textmapfonts ($text)));
$self->outindex;
$$self{NEEDSPACE} = 1;
return '';
}
# Handle a verbatim paragraph. Put a null token at the beginning of each line
# to protect against commands and wrap in .Vb/.Ve (which we define in our
# prelude).
sub cmd_verbatim {
my ($self, $attrs, $text) = @_;
# Ignore an empty verbatim paragraph.
return unless $text =~ /\S/;
# Force exactly one newline at the end and strip unwanted trailing
# whitespace at the end.
$text =~ s/\s*$/\n/;
# Get a count of the number of lines before the first blank line, which
# we'll pass to .Vb as its parameter. This tells *roff to keep that many
# lines together. We don't want to tell *roff to keep huge blocks
# together.
my @lines = split (/\n/, $text);
my $unbroken = 0;
for (@lines) {
last if /^\s*$/;
$unbroken++;
}
$unbroken = 10 if ($unbroken > 12 && !$$self{MAGIC_VNOPAGEBREAK_LIMIT});
# Prepend a null token to each line.
$text =~ s/^/\\&/gm;
# Output the results.
$self->makespace;
$self->output (".Vb $unbroken\n$text.Ve\n");
$$self{NEEDSPACE} = 1;
return '';
}
# Handle literal text (produced by =for and similar constructs). Just output
# it with the minimum of changes.
sub cmd_data {
my ($self, $attrs, $text) = @_;
$text =~ s/^\n+//;
$text =~ s/\n{0,2}$/\n/;
$self->output ($text);
return '';
}
##############################################################################
# Headings
##############################################################################
# Common code for all headings. This is called before the actual heading is
# output. It returns the cleaned up heading text (putting the heading all on
# one line) and may do other things, like closing bad =item blocks.
sub heading_common {
my ($self, $text, $line) = @_;
$text =~ s/\s+$//;
$text =~ s/\s*\n\s*/ /g;
# This should never happen; it means that we have a heading after =item
# without an intervening =back. But just in case, handle it anyway.
if ($$self{ITEMS} > 1) {
$$self{ITEMS} = 0;
$self->output (".PD\n");
}
# Output the current source line.
$self->output ( ".\\\" [At source line $line]\n" )
if defined ($line) && DEBUG;
return $text;
}
# First level heading. We can't output .IX in the NAME section due to a bug
# in some versions of catman, so don't output a .IX for that section. .SH
# already uses small caps, so remove \s0 and \s-1. Maintain IN_NAME as
# appropriate.
sub cmd_head1 {
my ($self, $attrs, $text) = @_;
$text =~ s/\\s-?\d//g;
$text = $self->heading_common ($text, $$attrs{start_line});
my $isname = ($text eq 'NAME' || $text =~ /\(NAME\)/);
$self->output ($self->switchquotes ('.SH', $self->mapfonts ($text)));
$self->outindex ('Header', $text) unless $isname;
$$self{NEEDSPACE} = 0;
$$self{IN_NAME} = $isname;
return '';
}
# Second level heading.
sub cmd_head2 {
my ($self, $attrs, $text) = @_;
$text = $self->heading_common ($text, $$attrs{start_line});
$self->output ($self->switchquotes ('.SS', $self->mapfonts ($text)));
$self->outindex ('Subsection', $text);
$$self{NEEDSPACE} = 0;
return '';
}
# Third level heading. *roff doesn't have this concept, so just put the
# heading in italics as a normal paragraph.
sub cmd_head3 {
my ($self, $attrs, $text) = @_;
$text = $self->heading_common ($text, $$attrs{start_line});
$self->makespace;
$self->output ($self->textmapfonts ('\f(IS' . $text . '\f(IE') . "\n");
$self->outindex ('Subsection', $text);
$$self{NEEDSPACE} = 1;
return '';
}
# Fourth level heading. *roff doesn't have this concept, so just put the
# heading as a normal paragraph.
sub cmd_head4 {
my ($self, $attrs, $text) = @_;
$text = $self->heading_common ($text, $$attrs{start_line});
$self->makespace;
$self->output ($self->textmapfonts ($text) . "\n");
$self->outindex ('Subsection', $text);
$$self{NEEDSPACE} = 1;
return '';
}
##############################################################################
# Formatting codes
##############################################################################
# All of the formatting codes that aren't handled internally by the parser,
# other than L<> and X<>.
sub cmd_b { return $_[0]->{IN_NAME} ? $_[2] : '\f(BS' . $_[2] . '\f(BE' }
sub cmd_i { return $_[0]->{IN_NAME} ? $_[2] : '\f(IS' . $_[2] . '\f(IE' }
sub cmd_f { return $_[0]->{IN_NAME} ? $_[2] : '\f(IS' . $_[2] . '\f(IE' }
sub cmd_c { return $_[0]->quote_literal ($_[2]) }
# Index entries are just added to the pending entries.
sub cmd_x {
my ($self, $attrs, $text) = @_;
push (@{ $$self{INDEX} }, $text);
return '';
}
# Links reduce to the text that we're given, wrapped in angle brackets if it's
# a URL, followed by the URL. We take an option to suppress the URL if anchor
# text is given. We need to format the "to" value of the link before
# comparing it to the text since we may escape hyphens.
sub cmd_l {
my ($self, $attrs, $text) = @_;
if ($$attrs{type} eq 'url') {
my $to = $$attrs{to};
if (defined $to) {
my $tag = $$self{PENDING}[-1];
$to = $self->format_text ($$tag[1], $to);
}
if (not defined ($to) or $to eq $text) {
return "<$text>";
} elsif ($$self{nourls}) {
return $text;
} else {
return "$text <$$attrs{to}>";
}
} else {
return $text;
}
}
##############################################################################
# List handling
##############################################################################
# Handle the beginning of an =over block. Takes the type of the block as the
# first argument, and then the attr hash. This is called by the handlers for
# the four different types of lists (bullet, number, text, and block).
sub over_common_start {
my ($self, $type, $attrs) = @_;
my $line = $$attrs{start_line};
my $indent = $$attrs{indent};
DEBUG > 3 and print " Starting =over $type (line $line, indent ",
($indent || '?'), "\n";
# Find the indentation level.
unless (defined ($indent) && $indent =~ /^[-+]?\d{1,4}\s*$/) {
$indent = $$self{indent};
}
# If we've gotten multiple indentations in a row, we need to emit the
# pending indentation for the last level that we saw and haven't acted on
# yet. SHIFTS is the stack of indentations that we've actually emitted
# code for.
if (@{ $$self{SHIFTS} } < @{ $$self{INDENTS} }) {
$self->output (".RS $$self{INDENT}\n");
push (@{ $$self{SHIFTS} }, $$self{INDENT});
}
# Now, do record-keeping. INDENTS is a stack of indentations that we've
# seen so far, and INDENT is the current level of indentation. ITEMTYPES
# is a stack of list types that we've seen.
push (@{ $$self{INDENTS} }, $$self{INDENT});
push (@{ $$self{ITEMTYPES} }, $type);
$$self{INDENT} = $indent + 0;
$$self{SHIFTWAIT} = 1;
}
# End an =over block. Takes no options other than the class pointer.
# Normally, once we close a block and therefore remove something from INDENTS,
# INDENTS will now be longer than SHIFTS, indicating that we also need to emit
# *roff code to close the indent. This isn't *always* true, depending on the
# circumstance. If we're still inside an indentation, we need to emit another
# .RE and then a new .RS to unconfuse *roff.
sub over_common_end {
my ($self) = @_;
DEBUG > 3 and print " Ending =over\n";
$$self{INDENT} = pop @{ $$self{INDENTS} };
pop @{ $$self{ITEMTYPES} };
# If we emitted code for that indentation, end it.
if (@{ $$self{SHIFTS} } > @{ $$self{INDENTS} }) {
$self->output (".RE\n");
pop @{ $$self{SHIFTS} };
}
# If we're still in an indentation, *roff will have now lost track of the
# right depth of that indentation, so fix that.
if (@{ $$self{INDENTS} } > 0) {
$self->output (".RE\n");
$self->output (".RS $$self{INDENT}\n");
}
$$self{NEEDSPACE} = 1;
$$self{SHIFTWAIT} = 0;
}
# Dispatch the start and end calls as appropriate.
sub start_over_bullet { my $s = shift; $s->over_common_start ('bullet', @_) }
sub start_over_number { my $s = shift; $s->over_common_start ('number', @_) }
sub start_over_text { my $s = shift; $s->over_common_start ('text', @_) }
sub start_over_block { my $s = shift; $s->over_common_start ('block', @_) }
sub end_over_bullet { $_[0]->over_common_end }
sub end_over_number { $_[0]->over_common_end }
sub end_over_text { $_[0]->over_common_end }
sub end_over_block { $_[0]->over_common_end }
# The common handler for all item commands. Takes the type of the item, the
# attributes, and then the text of the item.
#
# Emit an index entry for anything that's interesting, but don't emit index
# entries for things like bullets and numbers. Newlines in an item title are
# turned into spaces since *roff can't handle them embedded.
sub item_common {
my ($self, $type, $attrs, $text) = @_;
my $line = $$attrs{start_line};
DEBUG > 3 and print " $type item (line $line): $text\n";
# Clean up the text. We want to end up with two variables, one ($text)
# which contains any body text after taking out the item portion, and
# another ($item) which contains the actual item text.
$text =~ s/\s+$//;
my ($item, $index);
if ($type eq 'bullet') {
$item = "\\\(bu";
$text =~ s/\n*$/\n/;
} elsif ($type eq 'number') {
$item = $$attrs{number} . '.';
} else {
$item = $text;
$item =~ s/\s*\n\s*/ /g;
$text = '';
$index = $item if ($item =~ /\w/);
}
# Take care of the indentation. If shifts and indents are equal, close
# the top shift, since we're about to create an indentation with .IP.
# Also output .PD 0 to turn off spacing between items if this item is
# directly following another one. We only have to do that once for a
# whole chain of items so do it for the second item in the change. Note
# that makespace is what undoes this.
if (@{ $$self{SHIFTS} } == @{ $$self{INDENTS} }) {
$self->output (".RE\n");
pop @{ $$self{SHIFTS} };
}
$self->output (".PD 0\n") if ($$self{ITEMS} == 1);
# Now, output the item tag itself.
$item = $self->textmapfonts ($item);
$self->output ($self->switchquotes ('.IP', $item, $$self{INDENT}));
$$self{NEEDSPACE} = 0;
$$self{ITEMS}++;
$$self{SHIFTWAIT} = 0;
# If body text for this item was included, go ahead and output that now.
if ($text) {
$text =~ s/\s*$/\n/;
$self->makespace;
$self->output ($self->protect ($self->textmapfonts ($text)));
$$self{NEEDSPACE} = 1;
}
$self->outindex ($index ? ('Item', $index) : ());
}
# Dispatch the item commands to the appropriate place.
sub cmd_item_bullet { my $self = shift; $self->item_common ('bullet', @_) }
sub cmd_item_number { my $self = shift; $self->item_common ('number', @_) }
sub cmd_item_text { my $self = shift; $self->item_common ('text', @_) }
sub cmd_item_block { my $self = shift; $self->item_common ('block', @_) }
##############################################################################
# Backward compatibility
##############################################################################
# Reset the underlying Pod::Simple object between calls to parse_from_file so
# that the same object can be reused to convert multiple pages.
sub parse_from_file {
my $self = shift;
$self->reinit;
# Fake the old cutting option to Pod::Parser. This fiddings with internal
# Pod::Simple state and is quite ugly; we need a better approach.
if (ref ($_[0]) eq 'HASH') {
my $opts = shift @_;
if (defined ($$opts{-cutting}) && !$$opts{-cutting}) {
$$self{in_pod} = 1;
$$self{last_was_blank} = 1;
}
}
# Do the work.
my $retval = $self->SUPER::parse_from_file (@_);
# Flush output, since Pod::Simple doesn't do this. Ideally we should also
# close the file descriptor if we had to open one, but we can't easily
# figure this out.
my $fh = $self->output_fh ();
my $oldfh = select $fh;
my $oldflush = $|;
$| = 1;
print $fh '';
$| = $oldflush;
select $oldfh;
return $retval;
}
# Pod::Simple failed to provide this backward compatibility function, so
# implement it ourselves. File handles are one of the inputs that
# parse_from_file supports.
sub parse_from_filehandle {
my $self = shift;
return $self->parse_from_file (@_);
}
# Pod::Simple's parse_file doesn't set output_fh. Wrap the call and do so
# ourself unless it was already set by the caller, since our documentation has
# always said that this should work.
sub parse_file {
my ($self, $in) = @_;
unless (defined $$self{output_fh}) {
$self->output_fh (\*STDOUT);
}
return $self->SUPER::parse_file ($in);
}
##############################################################################
# Translation tables
##############################################################################
# The following table is adapted from Tom Christiansen's pod2man. It assumes
# that the standard preamble has already been printed, since that's what
# defines all of the accent marks. We really want to do something better than
# this when *roff actually supports other character sets itself, since these
# results are pretty poor.
#
# This only works in an ASCII world. What to do in a non-ASCII world is very
# unclear -- hopefully we can assume UTF-8 and just leave well enough alone.
@ESCAPES{0xA0 .. 0xFF} = (
"\\ ", undef, undef, undef, undef, undef, undef, undef,
undef, undef, undef, undef, undef, "\\%", undef, undef,
undef, undef, undef, undef, undef, undef, undef, undef,
undef, undef, undef, undef, undef, undef, undef, undef,
"A\\*`", "A\\*'", "A\\*^", "A\\*~", "A\\*:", "A\\*o", "\\*(Ae", "C\\*,",
"E\\*`", "E\\*'", "E\\*^", "E\\*:", "I\\*`", "I\\*'", "I\\*^", "I\\*:",
"\\*(D-", "N\\*~", "O\\*`", "O\\*'", "O\\*^", "O\\*~", "O\\*:", undef,
"O\\*/", "U\\*`", "U\\*'", "U\\*^", "U\\*:", "Y\\*'", "\\*(Th", "\\*8",
"a\\*`", "a\\*'", "a\\*^", "a\\*~", "a\\*:", "a\\*o", "\\*(ae", "c\\*,",
"e\\*`", "e\\*'", "e\\*^", "e\\*:", "i\\*`", "i\\*'", "i\\*^", "i\\*:",
"\\*(d-", "n\\*~", "o\\*`", "o\\*'", "o\\*^", "o\\*~", "o\\*:", undef,
"o\\*/" , "u\\*`", "u\\*'", "u\\*^", "u\\*:", "y\\*'", "\\*(th", "y\\*:",
) if ASCII;
##############################################################################
# Premable
##############################################################################
# The following is the static preamble which starts all *roff output we
# generate. Most is static except for the font to use as a fixed-width font,
# which is designed by @CFONT@, and the left and right quotes to use for C<>
# text, designated by @LQOUTE@ and @RQUOTE@. However, the second part, which
# defines the accent marks, is only used if $escapes is set to true.
sub preamble_template {
my ($self, $accents) = @_;
my $preamble = <<'----END OF PREAMBLE----';
.de Sp \" Vertical space (when we can't use .PP)
.if t .sp .5v
.if n .sp
..
.de Vb \" Begin verbatim text
.ft @CFONT@
.nf
.ne \\$1
..
.de Ve \" End verbatim text
.ft R
.fi
..
.\" Set up some character translations and predefined strings. \*(-- will
.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left
.\" double quote, and \*(R" will give a right double quote. \*(C+ will
.\" give a nicer C++. Capital omega is used to do unbreakable dashes and
.\" therefore won't be available. \*(C` and \*(C' expand to `' in nroff,
.\" nothing in troff, for use with C<>.
.tr \(*W-
.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p'
.ie n \{\
. ds -- \(*W-
. ds PI pi
. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
. ds L" ""
. ds R" ""
. ds C` @LQUOTE@
. ds C' @RQUOTE@
'br\}
.el\{\
. ds -- \|\(em\|
. ds PI \(*p
. ds L" ``
. ds R" ''
. ds C`
. ds C'
'br\}
.\"
.\" Escape single quotes in literal strings from groff's Unicode transform.
.ie \n(.g .ds Aq \(aq
.el .ds Aq '
.\"
.\" If the F register is turned on, we'll generate index entries on stderr for
.\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index
.\" entries marked with X<> in POD. Of course, you'll have to process the
.\" output yourself in some meaningful fashion.
.\"
.\" Avoid warning from groff about undefined register 'F'.
.de IX
..
.nr rF 0
.if \n(.g .if rF .nr rF 1
.if (\n(rF:(\n(.g==0)) \{
. if \nF \{
. de IX
. tm Index:\\$1\t\\n%\t"\\$2"
..
. if !\nF==2 \{
. nr % 0
. nr F 2
. \}
. \}
.\}
.rr rF
----END OF PREAMBLE----
#'# for cperl-mode
if ($accents) {
$preamble .= <<'----END OF PREAMBLE----'
.\"
.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2).
.\" Fear. Run. Save yourself. No user-serviceable parts.
. \" fudge factors for nroff and troff
.if n \{\
. ds #H 0
. ds #V .8m
. ds #F .3m
. ds #[ \f1
. ds #] \fP
.\}
.if t \{\
. ds #H ((1u-(\\\\n(.fu%2u))*.13m)
. ds #V .6m
. ds #F 0
. ds #[ \&
. ds #] \&
.\}
. \" simple accents for nroff and troff
.if n \{\
. ds ' \&
. ds ` \&
. ds ^ \&
. ds , \&
. ds ~ ~
. ds /
.\}
.if t \{\
. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u"
. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u'
. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u'
. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u'
. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u'
. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u'
.\}
. \" troff and (daisy-wheel) nroff accents
.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V'
.ds 8 \h'\*(#H'\(*b\h'-\*(#H'
.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#]
.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H'
.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u'
.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#]
.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#]
.ds ae a\h'-(\w'a'u*4/10)'e
.ds Ae A\h'-(\w'A'u*4/10)'E
. \" corrections for vroff
.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u'
.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u'
. \" for low resolution devices (crt and lpr)
.if \n(.H>23 .if \n(.V>19 \
\{\
. ds : e
. ds 8 ss
. ds o a
. ds d- d\h'-1'\(ga
. ds D- D\h'-1'\(hy
. ds th \o'bp'
. ds Th \o'LP'
. ds ae ae
. ds Ae AE
.\}
.rm #[ #] #H #V #F C
----END OF PREAMBLE----
#`# for cperl-mode
}
return $preamble;
}
##############################################################################
# Module return value and documentation
##############################################################################
1;
__END__
=for stopwords
en em ALLCAPS teeny fixedbold fixeditalic fixedbolditalic stderr utf8
UTF-8 Allbery Sean Burke Ossanna Solaris formatters troff uppercased
Christiansen nourls
=head1 NAME
Pod::Man - Convert POD data to formatted *roff input
=head1 SYNOPSIS
use Pod::Man;
my $parser = Pod::Man->new (release => $VERSION, section => 8);
# Read POD from STDIN and write to STDOUT.
$parser->parse_file (\*STDIN);
# Read POD from file.pod and write to file.1.
$parser->parse_from_file ('file.pod', 'file.1');
=head1 DESCRIPTION
Pod::Man is a module to convert documentation in the POD format (the
preferred language for documenting Perl) into *roff input using the man
macro set. The resulting *roff code is suitable for display on a terminal
using L<nroff(1)>, normally via L<man(1)>, or printing using L<troff(1)>.
It is conventionally invoked using the driver script B<pod2man>, but it can
also be used directly.
As a derived class from Pod::Simple, Pod::Man supports the same methods and
interfaces. See L<Pod::Simple> for all the details.
new() can take options, in the form of key/value pairs that control the
behavior of the parser. See below for details.
If no options are given, Pod::Man uses the name of the input file with any
trailing C<.pod>, C<.pm>, or C<.pl> stripped as the man page title, to
section 1 unless the file ended in C<.pm> in which case it defaults to
section 3, to a centered title of "User Contributed Perl Documentation", to
a centered footer of the Perl version it is run with, and to a left-hand
footer of the modification date of its input (or the current date if given
C<STDIN> for input).
Pod::Man assumes that your *roff formatters have a fixed-width font named
C<CW>. If yours is called something else (like C<CR>), use the C<fixed>
option 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 also takes care of
formatting func(), func(3), 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," makes C++
look right, puts a little space between double underscores, makes ALLCAPS
a teeny bit smaller in B<troff>, and escapes stuff that *roff treats as
special so that you don't have to.
The recognized options to new() are as follows. All options take a single
argument.
=over 4
=item center
Sets the centered page header to use instead of "User Contributed Perl
Documentation".
=item errors
How to report errors. 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<output>.
=item date
Sets the left-hand footer. By default, the modification date of the input
file will be used, or the current date if stat() can't find that file (the
case if the input is from C<STDIN>), and the date will be formatted as
C<YYYY-MM-DD>.
=item fixed
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 B<troff>
output.
=item fixedbold
Bold version of the fixed-width font. Defaults to C<CB>. Only matters
for B<troff> output.
=item fixeditalic
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 B<troff> output.
=item fixedbolditalic
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 B<troff> output.
=item name
Set the name of the manual page. 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.
=item 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 option, if set to a true value, 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 quotes
Sets the quote marks used to surround CE<lt>> text. If the value is a
single character, it is used as both the left and right quote; if it is two
characters, the first character is used as the left quote and the second as
the right quoted; and if it is four characters, the first two are used as
the left quote and the second two as the right quote.
This 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).
=item release
Set the centered footer. By default, this is the version of Perl you run
Pod::Man under. Note that some system 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, you may want to set C<release> to
the last modified date and C<date> to the version number.
=item section
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 stderr
Send error messages about invalid POD to standard error instead of
appending a POD ERRORS section to the generated *roff output. This is
equivalent to setting C<errors> to C<stderr> if C<errors> is not already
set. It is supported for backward compatibility.
=item utf8
By default, Pod::Man 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>.
If this option is set, Pod::Man will instead output UTF-8. 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 must be properly declared unless it is US-ASCII or Latin-1. POD
input without an C<=encoding> command will be assumed to be in Latin-1,
and if it's actually in UTF-8, the output will be double-encoded. See
L<perlpod(1)> for more information on the C<=encoding> command.
=back
The standard Pod::Simple method parse_file() takes one argument naming the
POD file to read from. By default, the output is sent to C<STDOUT>, but
this can be changed with the output_fd() method.
The standard Pod::Simple method parse_from_file() takes up to two
arguments, the first being the input file to read POD from and the second
being the file to write the formatted output to.
You can also call parse_lines() to parse an array of lines or
parse_string_document() to parse a document already in memory. To put the
output into a string instead of a file handle, call the output_string()
method. See L<Pod::Simple> for the specific details.
=head1 DIAGNOSTICS
=over 4
=item roff font should be 1 or 2 chars, not "%s"
(F) You specified a *roff font (using C<fixed>, C<fixedbold>, etc.) that
wasn't either one or two characters. Pod::Man doesn't support *roff fonts
longer than two characters, although some *roff extensions do (the
canonical versions of B<nroff> and B<troff> don't either).
=item Invalid errors setting "%s"
(F) The C<errors> parameter to the constructor was set to an unknown value.
=item Invalid quote specification "%s"
(F) The quote specification given (the C<quotes> option to the
constructor) was invalid. A quote specification must be one, two, or four
characters long.
=item POD document had syntax errors
(F) The POD document being formatted had syntax errors and the C<errors>
option was set to C<die>.
=back
=head1 BUGS
Encoding handling assumes that PerlIO is available and does not work
properly if it isn't. The C<utf8> option is therefore not supported
unless Perl is built with PerlIO support.
There is currently no way to turn off the guesswork that tries to format
unmarked text appropriately, and sometimes it isn't wanted (particularly
when using POD to document something other than Perl). Most of the work
toward fixing this has now been done, however, and all that's still needed
is a user interface.
The NAME section should be recognized specially and index entries emitted
for everything in that section. This would have to be deferred until the
next section, since extraneous things in NAME tends to confuse various man
page processors. Currently, no index entries are emitted for anything in
NAME.
Pod::Man doesn't handle font names longer than two characters. Neither do
most B<troff> implementations, but GNU troff does as an extension. It would
be nice to support as an option for those who want to use it.
The preamble added to each output file is rather verbose, and most of it
is only necessary in the presence of non-ASCII characters. It would
ideally be nice if all of those definitions were only output if needed,
perhaps on the fly as the characters are used.
Pod::Man is excessively slow.
=head1 CAVEATS
If Pod::Man is given the C<utf8> option, the encoding of its output file
handle will be forced to UTF-8 if possible, overriding any existing
encoding. This will be done even if the file handle is not created by
Pod::Man and was passed in from outside. This maintains consistency
regardless of PERL_UNICODE and other settings.
The handling of hyphens and em dashes is somewhat fragile, and one may get
the wrong one under some circumstances. This should only matter for
B<troff> output.
When and whether to use small caps is somewhat tricky, and Pod::Man doesn't
necessarily get it right.
Converting neutral double quotes to properly matched double quotes doesn't
work unless there are no formatting codes between the quote marks. This
only matters for troff output.
=head1 AUTHOR
Russ Allbery <rra@stanford.edu>, based I<very> heavily on the original
B<pod2man> by Tom Christiansen <tchrist@mox.perl.com>. The modifications to
work with Pod::Simple instead of Pod::Parser were originally contributed by
Sean Burke (but I've since hacked them beyond recognition and all bugs are
mine).
=head1 COPYRIGHT AND LICENSE
Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
2009, 2010, 2012, 2013 Russ Allbery <rra@stanford.edu>.
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::Simple>, L<perlpod(1)>, L<pod2man(1)>, L<nroff(1)>, L<troff(1)>,
L<man(1)>, L<man(7)>
Ossanna, Joseph F., and Brian W. Kernighan. "Troff User's Manual,"
Computing Science Technical Report No. 54, AT&T Bell Laboratories. This is
the best documentation of standard B<nroff> and B<troff>. At the time of
this writing, it's available at
L<http://www.cs.bell-labs.com/cm/cs/cstr.html>.
The man page documenting the man macro set may be L<man(5)> instead of
L<man(7)> on your system. Also, please see L<pod2man(1)> for extensive
documentation on writing manual pages if you've not done it before and
aren't familiar with the conventions.
The current version of this module is always available from its web site at
L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
Perl core distribution as of 5.6.0.
=cut
POD_MAN
$fatpacked{"Pod/ParseLink.pm"} = <<'POD_PARSELINK';
# Pod::ParseLink -- Parse an L<> formatting code in POD text.
#
# Copyright 2001, 2008, 2009 by Russ Allbery <rra@stanford.edu>
#
# This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
#
# This module implements parsing of the text of an L<> formatting code as
# defined in perlpodspec. It should be suitable for any POD formatter. It
# exports only one function, parselink(), which returns the five-item parse
# defined in perlpodspec.
#
# Perl core hackers, please note that this module is also separately
# maintained outside of the Perl core as part of the podlators. Please send
# me any patches at the address above in addition to sending them to the
# standard Perl mailing lists.
##############################################################################
# Modules and declarations
##############################################################################
package Pod::ParseLink;
require 5.004;
use strict;
use vars qw(@EXPORT @ISA $VERSION);
use Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(parselink);
$VERSION = '1.10';
##############################################################################
# Implementation
##############################################################################
# Parse the name and section portion of a link into a name and section.
sub _parse_section {
my ($link) = @_;
$link =~ s/^\s+//;
$link =~ s/\s+$//;
# If the whole link is enclosed in quotes, interpret it all as a section
# even if it contains a slash.
return (undef, $1) if ($link =~ /^"\s*(.*?)\s*"$/);
# Split into page and section on slash, and then clean up quoting in the
# section. If there is no section and the name contains spaces, also
# guess that it's an old section link.
my ($page, $section) = split (/\s*\/\s*/, $link, 2);
$section =~ s/^"\s*(.*?)\s*"$/$1/ if $section;
if ($page && $page =~ / / && !defined ($section)) {
$section = $page;
$page = undef;
} else {
$page = undef unless $page;
$section = undef unless $section;
}
return ($page, $section);
}
# Infer link text from the page and section.
sub _infer_text {
my ($page, $section) = @_;
my $inferred;
if ($page && !$section) {
$inferred = $page;
} elsif (!$page && $section) {
$inferred = '"' . $section . '"';
} elsif ($page && $section) {
$inferred = '"' . $section . '" in ' . $page;
}
return $inferred;
}
# Given the contents of an L<> formatting code, parse it into the link text,
# the possibly inferred link text, the name or URL, the section, and the type
# of link (pod, man, or url).
sub parselink {
my ($link) = @_;
$link =~ s/\s+/ /g;
my $text;
if ($link =~ /\|/) {
($text, $link) = split (/\|/, $link, 2);
}
if ($link =~ /\A\w+:[^:\s]\S*\Z/) {
my $inferred;
if (defined ($text) && length ($text) > 0) {
return ($text, $text, $link, undef, 'url');
} else {
return ($text, $link, $link, undef, 'url');
}
} else {
my ($name, $section) = _parse_section ($link);
my $inferred;
if (defined ($text) && length ($text) > 0) {
$inferred = $text;
} else {
$inferred = _infer_text ($name, $section);
}
my $type = ($name && $name =~ /\(\S*\)/) ? 'man' : 'pod';
return ($text, $inferred, $name, $section, $type);
}
}
##############################################################################
# Module return value and documentation
##############################################################################
# Ensure we evaluate to true.
1;
__END__
=head1 NAME
Pod::ParseLink - Parse an LE<lt>E<gt> formatting code in POD text
=for stopwords
markup Allbery URL
=head1 SYNOPSIS
use Pod::ParseLink;
my ($text, $inferred, $name, $section, $type) = parselink ($link);
=head1 DESCRIPTION
This module only provides a single function, parselink(), which takes the
text of an LE<lt>E<gt> formatting code and parses it. It returns the
anchor text for the link (if any was given), the anchor text possibly
inferred from the name and section, the name or URL, the section if any,
and the type of link. The type will be one of C<url>, C<pod>, or C<man>,
indicating a URL, a link to a POD page, or a link to a Unix manual page.
Parsing is implemented per L<perlpodspec>. For backward compatibility,
links where there is no section and name contains spaces, or links where the
entirety of the link (except for the anchor text if given) is enclosed in
double-quotes are interpreted as links to a section (LE<lt>/sectionE<gt>).
The inferred anchor text is implemented per L<perlpodspec>:
L<name> => L<name|name>
L</section> => L<"section"|/section>
L<name/section> => L<"section" in name|name/section>
The name may contain embedded EE<lt>E<gt> and ZE<lt>E<gt> formatting codes,
and the section, anchor text, and inferred anchor text may contain any
formatting codes. Any double quotes around the section are removed as part
of the parsing, as is any leading or trailing whitespace.
If the text of the LE<lt>E<gt> escape is entirely enclosed in double
quotes, it's interpreted as a link to a section for backward
compatibility.
No attempt is made to resolve formatting codes. This must be done after
calling parselink() (since EE<lt>E<gt> formatting codes can be used to
escape characters that would otherwise be significant to the parser and
resolving them before parsing would result in an incorrect parse of a
formatting code like:
L<verticalE<verbar>barE<sol>slash>
which should be interpreted as a link to the C<vertical|bar/slash> POD page
and not as a link to the C<slash> section of the C<bar> POD page with an
anchor text of C<vertical>. Note that not only the anchor text will need to
have formatting codes expanded, but so will the target of the link (to deal
with EE<lt>E<gt> and ZE<lt>E<gt> formatting codes), and special handling of
the section may be necessary depending on whether the translator wants to
consider markup in sections to be significant when resolving links. See
L<perlpodspec> for more information.
=head1 SEE ALSO
L<Pod::Parser>
The current version of this module is always available from its web site at
L<http://www.eyrie.org/~eagle/software/podlators/>.
=head1 AUTHOR
Russ Allbery <rra@stanford.edu>.
=head1 COPYRIGHT AND LICENSE
Copyright 2001, 2008, 2009 Russ Allbery <rra@stanford.edu>.
This program is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.
=cut
POD_PARSELINK
$fatpacked{"Pod/ParseUtils.pm"} = <<'POD_PARSEUTILS';
#############################################################################
# Pod/ParseUtils.pm -- helpers for POD parsing and conversion
#
# Copyright (C) 1999-2000 by Marek Rouchal. All rights reserved.
# This file is part of "PodParser". PodParser is free software;
# you can redistribute it and/or modify it under the same terms
# as Perl itself.
#############################################################################
package Pod::ParseUtils;
use strict;
use vars qw($VERSION);
$VERSION = '1.60'; ## Current version of this package
require 5.005; ## requires this Perl version or later
=head1 NAME
Pod::ParseUtils - helpers for POD parsing and conversion
=head1 SYNOPSIS
use Pod::ParseUtils;
my $list = new Pod::List;
my $link = Pod::Hyperlink->new('Pod::Parser');
=head1 DESCRIPTION
B<Pod::ParseUtils> contains a few object-oriented helper packages for
POD parsing and processing (i.e. in POD formatters and translators).
=cut
#-----------------------------------------------------------------------------
# Pod::List
#
# class to hold POD list info (=over, =item, =back)
#-----------------------------------------------------------------------------
package Pod::List;
use Carp;
=head2 Pod::List
B<Pod::List> can be used to hold information about POD lists
(written as =over ... =item ... =back) for further processing.
The following methods are available:
=over 4
=item Pod::List-E<gt>new()
Create a new list object. Properties may be specified through a hash
reference like this:
my $list = Pod::List->new({ -start => $., -indent => 4 });
See the individual methods/properties for details.
=cut
sub new {
my $this = shift;
my $class = ref($this) || $this;
my %params = @_;
my $self = {%params};
bless $self, $class;
$self->initialize();
return $self;
}
sub initialize {
my $self = shift;
$self->{-file} ||= 'unknown';
$self->{-start} ||= 'unknown';
$self->{-indent} ||= 4; # perlpod: "should be the default"
$self->{_items} = [];
$self->{-type} ||= '';
}
=item $list-E<gt>file()
Without argument, retrieves the file name the list is in. This must
have been set before by either specifying B<-file> in the B<new()>
method or by calling the B<file()> method with a scalar argument.
=cut
# The POD file name the list appears in
sub file {
return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file};
}
=item $list-E<gt>start()
Without argument, retrieves the line number where the list started.
This must have been set before by either specifying B<-start> in the
B<new()> method or by calling the B<start()> method with a scalar
argument.
=cut
# The line in the file the node appears
sub start {
return (@_ > 1) ? ($_[0]->{-start} = $_[1]) : $_[0]->{-start};
}
=item $list-E<gt>indent()
Without argument, retrieves the indent level of the list as specified
in C<=over n>. This must have been set before by either specifying
B<-indent> in the B<new()> method or by calling the B<indent()> method
with a scalar argument.
=cut
# indent level
sub indent {
return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent};
}
=item $list-E<gt>type()
Without argument, retrieves the list type, which can be an arbitrary value,
e.g. C<OL>, C<UL>, ... when thinking the HTML way.
This must have been set before by either specifying
B<-type> in the B<new()> method or by calling the B<type()> method
with a scalar argument.
=cut
# The type of the list (UL, OL, ...)
sub type {
return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type};
}
=item $list-E<gt>rx()
Without argument, retrieves a regular expression for simplifying the
individual item strings once the list type has been determined. Usage:
E.g. when converting to HTML, one might strip the leading number in
an ordered list as C<E<lt>OLE<gt>> already prints numbers itself.
This must have been set before by either specifying
B<-rx> in the B<new()> method or by calling the B<rx()> method
with a scalar argument.
=cut
# The regular expression to simplify the items
sub rx {
return (@_ > 1) ? ($_[0]->{-rx} = $_[1]) : $_[0]->{-rx};
}
=item $list-E<gt>item()
Without argument, retrieves the array of the items in this list.
The items may be represented by any scalar.
If an argument has been given, it is pushed on the list of items.
=cut
# The individual =items of this list
sub item {
my ($self,$item) = @_;
if(defined $item) {
push(@{$self->{_items}}, $item);
return $item;
}
else {
return @{$self->{_items}};
}
}
=item $list-E<gt>parent()
Without argument, retrieves information about the parent holding this
list, which is represented as an arbitrary scalar.
This must have been set before by either specifying
B<-parent> in the B<new()> method or by calling the B<parent()> method
with a scalar argument.
=cut
# possibility for parsers/translators to store information about the
# lists's parent object
sub parent {
return (@_ > 1) ? ($_[0]->{-parent} = $_[1]) : $_[0]->{-parent};
}
=item $list-E<gt>tag()
Without argument, retrieves information about the list tag, which can be
any scalar.
This must have been set before by either specifying
B<-tag> in the B<new()> method or by calling the B<tag()> method
with a scalar argument.
=back
=cut
# possibility for parsers/translators to store information about the
# list's object
sub tag {
return (@_ > 1) ? ($_[0]->{-tag} = $_[1]) : $_[0]->{-tag};
}
#-----------------------------------------------------------------------------
# Pod::Hyperlink
#
# class to manipulate POD hyperlinks (L<>)
#-----------------------------------------------------------------------------
package Pod::Hyperlink;
=head2 Pod::Hyperlink
B<Pod::Hyperlink> is a class for manipulation of POD hyperlinks. Usage:
my $link = Pod::Hyperlink->new('alternative text|page/"section in page"');
The B<Pod::Hyperlink> class is mainly designed to parse the contents of the
C<LE<lt>...E<gt>> sequence, providing a simple interface for accessing the
different parts of a POD hyperlink for further processing. It can also be
used to construct hyperlinks.
=over 4
=item Pod::Hyperlink-E<gt>new()
The B<new()> method can either be passed a set of key/value pairs or a single
scalar value, namely the contents of a C<LE<lt>...E<gt>> sequence. An object
of the class C<Pod::Hyperlink> is returned. The value C<undef> indicates a
failure, the error message is stored in C<$@>.
=cut
use Carp;
sub new {
my $this = shift;
my $class = ref($this) || $this;
my $self = +{};
bless $self, $class;
$self->initialize();
if(defined $_[0]) {
if(ref($_[0])) {
# called with a list of parameters
%$self = %{$_[0]};
$self->_construct_text();
}
else {
# called with L<> contents
return unless($self->parse($_[0]));
}
}
return $self;
}
sub initialize {
my $self = shift;
$self->{-line} ||= 'undef';
$self->{-file} ||= 'undef';
$self->{-page} ||= '';
$self->{-node} ||= '';
$self->{-alttext} ||= '';
$self->{-type} ||= 'undef';
$self->{_warnings} = [];
}
=item $link-E<gt>parse($string)
This method can be used to (re)parse a (new) hyperlink, i.e. the contents
of a C<LE<lt>...E<gt>> sequence. The result is stored in the current object.
Warnings are stored in the B<warnings> property.
E.g. sections like C<LE<lt>open(2)E<gt>> are deprecated, as they do not point
to Perl documents. C<LE<lt>DBI::foo(3p)E<gt>> is wrong as well, the manpage
section can simply be dropped.
=cut
sub parse {
my $self = shift;
local($_) = $_[0];
# syntax check the link and extract destination
my ($alttext,$page,$node,$type,$quoted) = (undef,'','','',0);
$self->{_warnings} = [];
# collapse newlines with whitespace
s/\s*\n+\s*/ /g;
# strip leading/trailing whitespace
if(s/^[\s\n]+//) {
$self->warning('ignoring leading whitespace in link');
}
if(s/[\s\n]+$//) {
$self->warning('ignoring trailing whitespace in link');
}
unless(length($_)) {
_invalid_link('empty link');
return;
}
## Check for different possibilities. This is tedious and error-prone
# we match all possibilities (alttext, page, section/item)
#warn "DEBUG: link=$_\n";
# only page
# problem: a lot of people use (), or (1) or the like to indicate
# man page sections. But this collides with L<func()> that is supposed
# to point to an internal funtion...
my $page_rx = '[\w.-]+(?:::[\w.-]+)*(?:[(](?:\d\w*|)[)]|)';
# page name only
if(/^($page_rx)$/o) {
$page = $1;
$type = 'page';
}
# alttext, page and "section"
elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*"(.+)"$}o) {
($alttext, $page, $node) = ($1, $2, $3);
$type = 'section';
$quoted = 1; #... therefore | and / are allowed
}
# alttext and page
elsif(/^(.*?)\s*[|]\s*($page_rx)$/o) {
($alttext, $page) = ($1, $2);
$type = 'page';
}
# alttext and "section"
elsif(m{^(.*?)\s*[|]\s*(?:/\s*|)"(.+)"$}) {
($alttext, $node) = ($1,$2);
$type = 'section';
$quoted = 1;
}
# page and "section"
elsif(m{^($page_rx)\s*/\s*"(.+)"$}o) {
($page, $node) = ($1, $2);
$type = 'section';
$quoted = 1;
}
# page and item
elsif(m{^($page_rx)\s*/\s*(.+)$}o) {
($page, $node) = ($1, $2);
$type = 'item';
}
# only "section"
elsif(m{^/?"(.+)"$}) {
$node = $1;
$type = 'section';
$quoted = 1;
}
# only item
elsif(m{^\s*/(.+)$}) {
$node = $1;
$type = 'item';
}
# non-standard: Hyperlink with alt-text - doesn't remove protocol prefix, maybe it should?
elsif(/^ \s* (.*?) \s* [|] \s* (\w+:[^:\s] [^\s|]*?) \s* $/ix) {
($alttext,$node) = ($1,$2);
$type = 'hyperlink';
}
# non-standard: Hyperlink
elsif(/^(\w+:[^:\s]\S*)$/i) {
$node = $1;
$type = 'hyperlink';
}
# alttext, page and item
elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*(.+)$}o) {
($alttext, $page, $node) = ($1, $2, $3);
$type = 'item';
}
# alttext and item
elsif(m{^(.*?)\s*[|]\s*/(.+)$}) {
($alttext, $node) = ($1,$2);
}
# must be an item or a "malformed" section (without "")
else {
$node = $_;
$type = 'item';
}
# collapse whitespace in nodes
$node =~ s/\s+/ /gs;
# empty alternative text expands to node name
if(defined $alttext) {
if(!length($alttext)) {
$alttext = $node || $page;
}
}
else {
$alttext = '';
}
if($page =~ /[(]\w*[)]$/) {
$self->warning("(section) in '$page' deprecated");
}
if(!$quoted && $node =~ m{[|/]} && $type ne 'hyperlink') {
$self->warning("node '$node' contains non-escaped | or /");
}
if($alttext =~ m{[|/]}) {
$self->warning("alternative text '$node' contains non-escaped | or /");
}
$self->{-page} = $page;
$self->{-node} = $node;
$self->{-alttext} = $alttext;
#warn "DEBUG: page=$page section=$section item=$item alttext=$alttext\n";
$self->{-type} = $type;
$self->_construct_text();
1;
}
sub _construct_text {
my $self = shift;
my $alttext = $self->alttext();
my $type = $self->type();
my $section = $self->node();
my $page = $self->page();
my $page_ext = '';
$page =~ s/([(]\w*[)])$// && ($page_ext = $1);
if($alttext) {
$self->{_text} = $alttext;
}
elsif($type eq 'hyperlink') {
$self->{_text} = $section;
}
else {
$self->{_text} = ($section || '') .
(($page && $section) ? ' in ' : '') .
"$page$page_ext";
}
# for being marked up later
# use the non-standard markers P<> and Q<>, so that the resulting
# text can be parsed by the translators. It's their job to put
# the correct hypertext around the linktext
if($alttext) {
$self->{_markup} = "Q<$alttext>";
}
elsif($type eq 'hyperlink') {
$self->{_markup} = "Q<$section>";
}
else {
$self->{_markup} = (!$section ? '' : "Q<$section>") .
($page ? ($section ? ' in ':'') . "P<$page>$page_ext" : '');
}
}
=item $link-E<gt>markup($string)
Set/retrieve the textual value of the link. This string contains special
markers C<PE<lt>E<gt>> and C<QE<lt>E<gt>> that should be expanded by the
translator's interior sequence expansion engine to the
formatter-specific code to highlight/activate the hyperlink. The details
have to be implemented in the translator.
=cut
#' retrieve/set markuped text
sub markup {
return (@_ > 1) ? ($_[0]->{_markup} = $_[1]) : $_[0]->{_markup};
}
=item $link-E<gt>text()
This method returns the textual representation of the hyperlink as above,
but without markers (read only). Depending on the link type this is one of
the following alternatives (the + and * denote the portions of the text
that are marked up):
+perl+ L<perl>
*$|* in +perlvar+ L<perlvar/$|>
*OPTIONS* in +perldoc+ L<perldoc/"OPTIONS">
*DESCRIPTION* L<"DESCRIPTION">
=cut
# The complete link's text
sub text {
return $_[0]->{_text};
}
=item $link-E<gt>warning()
After parsing, this method returns any warnings encountered during the
parsing process.
=cut
# Set/retrieve warnings
sub warning {
my $self = shift;
if(@_) {
push(@{$self->{_warnings}}, @_);
return @_;
}
return @{$self->{_warnings}};
}
=item $link-E<gt>file()
=item $link-E<gt>line()
Just simple slots for storing information about the line and the file
the link was encountered in. Has to be filled in manually.
=cut
# The line in the file the link appears
sub line {
return (@_ > 1) ? ($_[0]->{-line} = $_[1]) : $_[0]->{-line};
}
# The POD file name the link appears in
sub file {
return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file};
}
=item $link-E<gt>page()
This method sets or returns the POD page this link points to.
=cut
# The POD page the link appears on
sub page {
if (@_ > 1) {
$_[0]->{-page} = $_[1];
$_[0]->_construct_text();
}
return $_[0]->{-page};
}
=item $link-E<gt>node()
As above, but the destination node text of the link.
=cut
# The link destination
sub node {
if (@_ > 1) {
$_[0]->{-node} = $_[1];
$_[0]->_construct_text();
}
return $_[0]->{-node};
}
=item $link-E<gt>alttext()
Sets or returns an alternative text specified in the link.
=cut
# Potential alternative text
sub alttext {
if (@_ > 1) {
$_[0]->{-alttext} = $_[1];
$_[0]->_construct_text();
}
return $_[0]->{-alttext};
}
=item $link-E<gt>type()
The node type, either C<section> or C<item>. As an unofficial type,
there is also C<hyperlink>, derived from e.g. C<LE<lt>http://perl.comE<gt>>
=cut
# The type: item or headn
sub type {
return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type};
}
=item $link-E<gt>link()
Returns the link as contents of C<LE<lt>E<gt>>. Reciprocal to B<parse()>.
=back
=cut
# The link itself
sub link {
my $self = shift;
my $link = $self->page() || '';
if($self->node()) {
my $node = $self->node();
$node =~ s/\|/E<verbar>/g;
$node =~ s{/}{E<sol>}g;
if($self->type() eq 'section') {
$link .= ($link ? '/' : '') . '"' . $node . '"';
}
elsif($self->type() eq 'hyperlink') {
$link = $self->node();
}
else { # item
$link .= '/' . $node;
}
}
if($self->alttext()) {
my $text = $self->alttext();
$text =~ s/\|/E<verbar>/g;
$text =~ s{/}{E<sol>}g;
$link = "$text|$link";
}
return $link;
}
sub _invalid_link {
my ($msg) = @_;
# this sets @_
#eval { die "$msg\n" };
#chomp $@;
$@ = $msg; # this seems to work, too!
return;
}
#-----------------------------------------------------------------------------
# Pod::Cache
#
# class to hold POD page details
#-----------------------------------------------------------------------------
package Pod::Cache;
=head2 Pod::Cache
B<Pod::Cache> holds information about a set of POD documents,
especially the nodes for hyperlinks.
The following methods are available:
=over 4
=item Pod::Cache-E<gt>new()
Create a new cache object. This object can hold an arbitrary number of
POD documents of class Pod::Cache::Item.
=cut
sub new {
my $this = shift;
my $class = ref($this) || $this;
my $self = [];
bless $self, $class;
return $self;
}
=item $cache-E<gt>item()
Add a new item to the cache. Without arguments, this method returns a
list of all cache elements.
=cut
sub item {
my ($self,%param) = @_;
if(%param) {
my $item = Pod::Cache::Item->new(%param);
push(@$self, $item);
return $item;
}
else {
return @{$self};
}
}
=item $cache-E<gt>find_page($name)
Look for a POD document named C<$name> in the cache. Returns the
reference to the corresponding Pod::Cache::Item object or undef if
not found.
=back
=cut
sub find_page {
my ($self,$page) = @_;
foreach(@$self) {
if($_->page() eq $page) {
return $_;
}
}
return;
}
package Pod::Cache::Item;
=head2 Pod::Cache::Item
B<Pod::Cache::Item> holds information about individual POD documents,
that can be grouped in a Pod::Cache object.
It is intended to hold information about the hyperlink nodes of POD
documents.
The following methods are available:
=over 4
=item Pod::Cache::Item-E<gt>new()
Create a new object.
=cut
sub new {
my $this = shift;
my $class = ref($this) || $this;
my %params = @_;
my $self = {%params};
bless $self, $class;
$self->initialize();
return $self;
}
sub initialize {
my $self = shift;
$self->{-nodes} = [] unless(defined $self->{-nodes});
}
=item $cacheitem-E<gt>page()
Set/retrieve the POD document name (e.g. "Pod::Parser").
=cut
# The POD page
sub page {
return (@_ > 1) ? ($_[0]->{-page} = $_[1]) : $_[0]->{-page};
}
=item $cacheitem-E<gt>description()
Set/retrieve the POD short description as found in the C<=head1 NAME>
section.
=cut
# The POD description, taken out of NAME if present
sub description {
return (@_ > 1) ? ($_[0]->{-description} = $_[1]) : $_[0]->{-description};
}
=item $cacheitem-E<gt>path()
Set/retrieve the POD file storage path.
=cut
# The file path
sub path {
return (@_ > 1) ? ($_[0]->{-path} = $_[1]) : $_[0]->{-path};
}
=item $cacheitem-E<gt>file()
Set/retrieve the POD file name.
=cut
# The POD file name
sub file {
return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file};
}
=item $cacheitem-E<gt>nodes()
Add a node (or a list of nodes) to the document's node list. Note that
the order is kept, i.e. start with the first node and end with the last.
If no argument is given, the current list of nodes is returned in the
same order the nodes have been added.
A node can be any scalar, but usually is a pair of node string and
unique id for the C<find_node> method to work correctly.
=cut
# The POD nodes
sub nodes {
my ($self,@nodes) = @_;
if(@nodes) {
push(@{$self->{-nodes}}, @nodes);
return @nodes;
}
else {
return @{$self->{-nodes}};
}
}
=item $cacheitem-E<gt>find_node($name)
Look for a node or index entry named C<$name> in the object.
Returns the unique id of the node (i.e. the second element of the array
stored in the node array) or undef if not found.
=cut
sub find_node {
my ($self,$node) = @_;
my @search;
push(@search, @{$self->{-nodes}}) if($self->{-nodes});
push(@search, @{$self->{-idx}}) if($self->{-idx});
foreach(@search) {
if($_->[0] eq $node) {
return $_->[1]; # id
}
}
return;
}
=item $cacheitem-E<gt>idx()
Add an index entry (or a list of them) to the document's index list. Note that
the order is kept, i.e. start with the first node and end with the last.
If no argument is given, the current list of index entries is returned in the
same order the entries have been added.
An index entry can be any scalar, but usually is a pair of string and
unique id.
=back
=cut
# The POD index entries
sub idx {
my ($self,@idx) = @_;
if(@idx) {
push(@{$self->{-idx}}, @idx);
return @idx;
}
else {
return @{$self->{-idx}};
}
}
=head1 AUTHOR
Please report bugs using L<http://rt.cpan.org>.
Marek Rouchal E<lt>marekr@cpan.orgE<gt>, borrowing
a lot of things from L<pod2man> and L<pod2roff> as well as other POD
processing tools by Tom Christiansen, Brad Appleton and Russ Allbery.
B<Pod::ParseUtils> is part of the L<Pod::Parser> distribution.
=head1 SEE ALSO
L<pod2man>, L<pod2roff>, L<Pod::Parser>, L<Pod::Checker>,
L<pod2html>
=cut
1;
POD_PARSEUTILS
$fatpacked{"Pod/Parser.pm"} = <<'POD_PARSER';
#############################################################################
# Pod/Parser.pm -- package which defines a base class for parsing POD docs.
#
# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.
# This file is part of "PodParser". PodParser is free software;
# you can redistribute it and/or modify it under the same terms
# as Perl itself.
#############################################################################
package Pod::Parser;
use strict;
## These "variables" are used as local "glob aliases" for performance
use vars qw($VERSION @ISA %myData %myOpts @input_stack);
$VERSION = '1.60'; ## Current version of this package
require 5.005; ## requires this Perl version or later
#############################################################################
=head1 NAME
Pod::Parser - base class for creating POD filters and translators
=head1 SYNOPSIS
use Pod::Parser;
package MyParser;
@ISA = qw(Pod::Parser);
sub command {
my ($parser, $command, $paragraph, $line_num) = @_;
## Interpret the command and its text; sample actions might be:
if ($command eq 'head1') { ... }
elsif ($command eq 'head2') { ... }
## ... other commands and their actions
my $out_fh = $parser->output_handle();
my $expansion = $parser->interpolate($paragraph, $line_num);
print $out_fh $expansion;
}
sub verbatim {
my ($parser, $paragraph, $line_num) = @_;
## Format verbatim paragraph; sample actions might be:
my $out_fh = $parser->output_handle();
print $out_fh $paragraph;
}
sub textblock {
my ($parser, $paragraph, $line_num) = @_;
## Translate/Format this block of text; sample actions might be:
my $out_fh = $parser->output_handle();
my $expansion = $parser->interpolate($paragraph, $line_num);
print $out_fh $expansion;
}
sub interior_sequence {
my ($parser, $seq_command, $seq_argument) = @_;
## Expand an interior sequence; sample actions might be:
return "*$seq_argument*" if ($seq_command eq 'B');
return "`$seq_argument'" if ($seq_command eq 'C');
return "_${seq_argument}_'" if ($seq_command eq 'I');
## ... other sequence commands and their resulting text
}
package main;
## Create a parser object and have it parse file whose name was
## given on the command-line (use STDIN if no files were given).
$parser = new MyParser();
$parser->parse_from_filehandle(\*STDIN) if (@ARGV == 0);
for (@ARGV) { $parser->parse_from_file($_); }
=head1 REQUIRES
perl5.005, Pod::InputObjects, Exporter, Symbol, Carp
=head1 EXPORTS
Nothing.
=head1 DESCRIPTION
B<Pod::Parser> is a base class for creating POD filters and translators.
It handles most of the effort involved with parsing the POD sections
from an input stream, leaving subclasses free to be concerned only with
performing the actual translation of text.
B<Pod::Parser> parses PODs, and makes method calls to handle the various
components of the POD. Subclasses of B<Pod::Parser> override these methods
to translate the POD into whatever output format they desire.
Note: This module is considered as legacy; modern Perl releases (5.18 and
higher) are going to remove Pod::Parser from core and use L<Pod::Simple>
for all things POD.
=head1 QUICK OVERVIEW
To create a POD filter for translating POD documentation into some other
format, you create a subclass of B<Pod::Parser> which typically overrides
just the base class implementation for the following methods:
=over 2
=item *
B<command()>
=item *
B<verbatim()>
=item *
B<textblock()>
=item *
B<interior_sequence()>
=back
You may also want to override the B<begin_input()> and B<end_input()>
methods for your subclass (to perform any needed per-file and/or
per-document initialization or cleanup).
If you need to perform any preprocessing of input before it is parsed
you may want to override one or more of B<preprocess_line()> and/or
B<preprocess_paragraph()>.
Sometimes it may be necessary to make more than one pass over the input
files. If this is the case you have several options. You can make the
first pass using B<Pod::Parser> and override your methods to store the
intermediate results in memory somewhere for the B<end_pod()> method to
process. You could use B<Pod::Parser> for several passes with an
appropriate state variable to control the operation for each pass. If
your input source can't be reset to start at the beginning, you can
store it in some other structure as a string or an array and have that
structure implement a B<getline()> method (which is all that
B<parse_from_filehandle()> uses to read input).
Feel free to add any member data fields you need to keep track of things
like current font, indentation, horizontal or vertical position, or
whatever else you like. Be sure to read L<"PRIVATE METHODS AND DATA">
to avoid name collisions.
For the most part, the B<Pod::Parser> base class should be able to
do most of the input parsing for you and leave you free to worry about
how to interpret the commands and translate the result.
Note that all we have described here in this quick overview is the
simplest most straightforward use of B<Pod::Parser> to do stream-based
parsing. It is also possible to use the B<Pod::Parser::parse_text> function
to do more sophisticated tree-based parsing. See L<"TREE-BASED PARSING">.
=head1 PARSING OPTIONS
A I<parse-option> is simply a named option of B<Pod::Parser> with a
value that corresponds to a certain specified behavior. These various
behaviors of B<Pod::Parser> may be enabled/disabled by setting
or unsetting one or more I<parse-options> using the B<parseopts()> method.
The set of currently accepted parse-options is as follows:
=over 3
=item B<-want_nonPODs> (default: unset)
Normally (by default) B<Pod::Parser> will only provide access to
the POD sections of the input. Input paragraphs that are not part
of the POD-format documentation are not made available to the caller
(not even using B<preprocess_paragraph()>). Setting this option to a
non-empty, non-zero value will allow B<preprocess_paragraph()> to see
non-POD sections of the input as well as POD sections. The B<cutting()>
method can be used to determine if the corresponding paragraph is a POD
paragraph, or some other input paragraph.
=item B<-process_cut_cmd> (default: unset)
Normally (by default) B<Pod::Parser> handles the C<=cut> POD directive
by itself and does not pass it on to the caller for processing. Setting
this option to a non-empty, non-zero value will cause B<Pod::Parser> to
pass the C<=cut> directive to the caller just like any other POD command
(and hence it may be processed by the B<command()> method).
B<Pod::Parser> will still interpret the C<=cut> directive to mean that
"cutting mode" has been (re)entered, but the caller will get a chance
to capture the actual C<=cut> paragraph itself for whatever purpose
it desires.
=item B<-warnings> (default: unset)
Normally (by default) B<Pod::Parser> recognizes a bare minimum of
pod syntax errors and warnings and issues diagnostic messages
for errors, but not for warnings. (Use B<Pod::Checker> to do more
thorough checking of POD syntax.) Setting this option to a non-empty,
non-zero value will cause B<Pod::Parser> to issue diagnostics for
the few warnings it recognizes as well as the errors.
=back
Please see L<"parseopts()"> for a complete description of the interface
for the setting and unsetting of parse-options.
=cut
#############################################################################
#use diagnostics;
use Pod::InputObjects;
use Carp;
use Exporter;
BEGIN {
if ($] < 5.006) {
require Symbol;
import Symbol;
}
}
@ISA = qw(Exporter);
#############################################################################
=head1 RECOMMENDED SUBROUTINE/METHOD OVERRIDES
B<Pod::Parser> provides several methods which most subclasses will probably
want to override. These methods are as follows:
=cut
##---------------------------------------------------------------------------
=head1 B<command()>
$parser->command($cmd,$text,$line_num,$pod_para);
This method should be overridden by subclasses to take the appropriate
action when a POD command paragraph (denoted by a line beginning with
"=") is encountered. When such a POD directive is seen in the input,
this method is called and is passed:
=over 3
=item C<$cmd>
the name of the command for this POD paragraph
=item C<$text>
the paragraph text for the given POD paragraph command.
=item C<$line_num>
the line-number of the beginning of the paragraph
=item C<$pod_para>
a reference to a C<Pod::Paragraph> object which contains further
information about the paragraph command (see L<Pod::InputObjects>
for details).
=back
B<Note> that this method I<is> called for C<=pod> paragraphs.
The base class implementation of this method simply treats the raw POD
command as normal block of paragraph text (invoking the B<textblock()>
method with the command paragraph).
=cut
sub command {
my ($self, $cmd, $text, $line_num, $pod_para) = @_;
## Just treat this like a textblock
$self->textblock($pod_para->raw_text(), $line_num, $pod_para);
}
##---------------------------------------------------------------------------
=head1 B<verbatim()>
$parser->verbatim($text,$line_num,$pod_para);
This method may be overridden by subclasses to take the appropriate
action when a block of verbatim text is encountered. It is passed the
following parameters:
=over 3
=item C<$text>
the block of text for the verbatim paragraph
=item C<$line_num>
the line-number of the beginning of the paragraph
=item C<$pod_para>
a reference to a C<Pod::Paragraph> object which contains further
information about the paragraph (see L<Pod::InputObjects>
for details).
=back
The base class implementation of this method simply prints the textblock
(unmodified) to the output filehandle.
=cut
sub verbatim {
my ($self, $text, $line_num, $pod_para) = @_;
my $out_fh = $self->{_OUTPUT};
print $out_fh $text;
}
##---------------------------------------------------------------------------
=head1 B<textblock()>
$parser->textblock($text,$line_num,$pod_para);
This method may be overridden by subclasses to take the appropriate
action when a normal block of POD text is encountered (although the base
class method will usually do what you want). It is passed the following
parameters:
=over 3
=item C<$text>
the block of text for the a POD paragraph
=item C<$line_num>
the line-number of the beginning of the paragraph
=item C<$pod_para>
a reference to a C<Pod::Paragraph> object which contains further
information about the paragraph (see L<Pod::InputObjects>
for details).
=back
In order to process interior sequences, subclasses implementations of
this method will probably want to invoke either B<interpolate()> or
B<parse_text()>, passing it the text block C<$text>, and the corresponding
line number in C<$line_num>, and then perform any desired processing upon
the returned result.
The base class implementation of this method simply prints the text block
as it occurred in the input stream).
=cut
sub textblock {
my ($self, $text, $line_num, $pod_para) = @_;
my $out_fh = $self->{_OUTPUT};
print $out_fh $self->interpolate($text, $line_num);
}
##---------------------------------------------------------------------------
=head1 B<interior_sequence()>
$parser->interior_sequence($seq_cmd,$seq_arg,$pod_seq);
This method should be overridden by subclasses to take the appropriate
action when an interior sequence is encountered. An interior sequence is
an embedded command within a block of text which appears as a command
name (usually a single uppercase character) followed immediately by a
string of text which is enclosed in angle brackets. This method is
passed the sequence command C<$seq_cmd> and the corresponding text
C<$seq_arg>. It is invoked by the B<interpolate()> method for each interior
sequence that occurs in the string that it is passed. It should return
the desired text string to be used in place of the interior sequence.
The C<$pod_seq> argument is a reference to a C<Pod::InteriorSequence>
object which contains further information about the interior sequence.
Please see L<Pod::InputObjects> for details if you need to access this
additional information.
Subclass implementations of this method may wish to invoke the
B<nested()> method of C<$pod_seq> to see if it is nested inside
some other interior-sequence (and if so, which kind).
The base class implementation of the B<interior_sequence()> method
simply returns the raw text of the interior sequence (as it occurred
in the input) to the caller.
=cut
sub interior_sequence {
my ($self, $seq_cmd, $seq_arg, $pod_seq) = @_;
## Just return the raw text of the interior sequence
return $pod_seq->raw_text();
}
#############################################################################
=head1 OPTIONAL SUBROUTINE/METHOD OVERRIDES
B<Pod::Parser> provides several methods which subclasses may want to override
to perform any special pre/post-processing. These methods do I<not> have to
be overridden, but it may be useful for subclasses to take advantage of them.
=cut
##---------------------------------------------------------------------------
=head1 B<new()>
my $parser = Pod::Parser->new();
This is the constructor for B<Pod::Parser> and its subclasses. You
I<do not> need to override this method! It is capable of constructing
subclass objects as well as base class objects, provided you use
any of the following constructor invocation styles:
my $parser1 = MyParser->new();
my $parser2 = new MyParser();
my $parser3 = $parser2->new();
where C<MyParser> is some subclass of B<Pod::Parser>.
Using the syntax C<MyParser::new()> to invoke the constructor is I<not>
recommended, but if you insist on being able to do this, then the
subclass I<will> need to override the B<new()> constructor method. If
you do override the constructor, you I<must> be sure to invoke the
B<initialize()> method of the newly blessed object.
Using any of the above invocations, the first argument to the
constructor is always the corresponding package name (or object
reference). No other arguments are required, but if desired, an
associative array (or hash-table) my be passed to the B<new()>
constructor, as in:
my $parser1 = MyParser->new( MYDATA => $value1, MOREDATA => $value2 );
my $parser2 = new MyParser( -myflag => 1 );
All arguments passed to the B<new()> constructor will be treated as
key/value pairs in a hash-table. The newly constructed object will be
initialized by copying the contents of the given hash-table (which may
have been empty). The B<new()> constructor for this class and all of its
subclasses returns a blessed reference to the initialized object (hash-table).
=cut
sub new {
## Determine if we were called via an object-ref or a classname
my ($this,%params) = @_;
my $class = ref($this) || $this;
## Any remaining arguments are treated as initial values for the
## hash that is used to represent this object.
my $self = { %params };
## Bless ourselves into the desired class and perform any initialization
bless $self, $class;
$self->initialize();
return $self;
}
##---------------------------------------------------------------------------
=head1 B<initialize()>
$parser->initialize();
This method performs any necessary object initialization. It takes no
arguments (other than the object instance of course, which is typically
copied to a local variable named C<$self>). If subclasses override this
method then they I<must> be sure to invoke C<$self-E<gt>SUPER::initialize()>.
=cut
sub initialize {
#my $self = shift;
#return;
}
##---------------------------------------------------------------------------
=head1 B<begin_pod()>
$parser->begin_pod();
This method is invoked at the beginning of processing for each POD
document that is encountered in the input. Subclasses should override
this method to perform any per-document initialization.
=cut
sub begin_pod {
#my $self = shift;
#return;
}
##---------------------------------------------------------------------------
=head1 B<begin_input()>
$parser->begin_input();
This method is invoked by B<parse_from_filehandle()> immediately I<before>
processing input from a filehandle. The base class implementation does
nothing, however, subclasses may override it to perform any per-file
initializations.
Note that if multiple files are parsed for a single POD document
(perhaps the result of some future C<=include> directive) this method
is invoked for every file that is parsed. If you wish to perform certain
initializations once per document, then you should use B<begin_pod()>.
=cut
sub begin_input {
#my $self = shift;
#return;
}
##---------------------------------------------------------------------------
=head1 B<end_input()>
$parser->end_input();
This method is invoked by B<parse_from_filehandle()> immediately I<after>
processing input from a filehandle. The base class implementation does
nothing, however, subclasses may override it to perform any per-file
cleanup actions.
Please note that if multiple files are parsed for a single POD document
(perhaps the result of some kind of C<=include> directive) this method
is invoked for every file that is parsed. If you wish to perform certain
cleanup actions once per document, then you should use B<end_pod()>.
=cut
sub end_input {
#my $self = shift;
#return;
}
##---------------------------------------------------------------------------
=head1 B<end_pod()>
$parser->end_pod();
This method is invoked at the end of processing for each POD document
that is encountered in the input. Subclasses should override this method
to perform any per-document finalization.
=cut
sub end_pod {
#my $self = shift;
#return;
}
##---------------------------------------------------------------------------
=head1 B<preprocess_line()>
$textline = $parser->preprocess_line($text, $line_num);
This method should be overridden by subclasses that wish to perform
any kind of preprocessing for each I<line> of input (I<before> it has
been determined whether or not it is part of a POD paragraph). The
parameter C<$text> is the input line; and the parameter C<$line_num> is
the line number of the corresponding text line.
The value returned should correspond to the new text to use in its
place. If the empty string or an undefined value is returned then no
further processing will be performed for this line.
Please note that the B<preprocess_line()> method is invoked I<before>
the B<preprocess_paragraph()> method. After all (possibly preprocessed)
lines in a paragraph have been assembled together and it has been
determined that the paragraph is part of the POD documentation from one
of the selected sections, then B<preprocess_paragraph()> is invoked.
The base class implementation of this method returns the given text.
=cut
sub preprocess_line {
my ($self, $text, $line_num) = @_;
return $text;
}
##---------------------------------------------------------------------------
=head1 B<preprocess_paragraph()>
$textblock = $parser->preprocess_paragraph($text, $line_num);
This method should be overridden by subclasses that wish to perform any
kind of preprocessing for each block (paragraph) of POD documentation
that appears in the input stream. The parameter C<$text> is the POD
paragraph from the input file; and the parameter C<$line_num> is the
line number for the beginning of the corresponding paragraph.
The value returned should correspond to the new text to use in its
place If the empty string is returned or an undefined value is
returned, then the given C<$text> is ignored (not processed).
This method is invoked after gathering up all the lines in a paragraph
and after determining the cutting state of the paragraph,
but before trying to further parse or interpret them. After
B<preprocess_paragraph()> returns, the current cutting state (which
is returned by C<$self-E<gt>cutting()>) is examined. If it evaluates
to true then input text (including the given C<$text>) is cut (not
processed) until the next POD directive is encountered.
Please note that the B<preprocess_line()> method is invoked I<before>
the B<preprocess_paragraph()> method. After all (possibly preprocessed)
lines in a paragraph have been assembled together and either it has been
determined that the paragraph is part of the POD documentation from one
of the selected sections or the C<-want_nonPODs> option is true,
then B<preprocess_paragraph()> is invoked.
The base class implementation of this method returns the given text.
=cut
sub preprocess_paragraph {
my ($self, $text, $line_num) = @_;
return $text;
}
#############################################################################
=head1 METHODS FOR PARSING AND PROCESSING
B<Pod::Parser> provides several methods to process input text. These
methods typically won't need to be overridden (and in some cases they
can't be overridden), but subclasses may want to invoke them to exploit
their functionality.
=cut
##---------------------------------------------------------------------------
=head1 B<parse_text()>
$ptree1 = $parser->parse_text($text, $line_num);
$ptree2 = $parser->parse_text({%opts}, $text, $line_num);
$ptree3 = $parser->parse_text(\%opts, $text, $line_num);
This method is useful if you need to perform your own interpolation
of interior sequences and can't rely upon B<interpolate> to expand
them in simple bottom-up order.
The parameter C<$text> is a string or block of text to be parsed
for interior sequences; and the parameter C<$line_num> is the
line number corresponding to the beginning of C<$text>.
B<parse_text()> will parse the given text into a parse-tree of "nodes."
and interior-sequences. Each "node" in the parse tree is either a
text-string, or a B<Pod::InteriorSequence>. The result returned is a
parse-tree of type B<Pod::ParseTree>. Please see L<Pod::InputObjects>
for more information about B<Pod::InteriorSequence> and B<Pod::ParseTree>.
If desired, an optional hash-ref may be specified as the first argument
to customize certain aspects of the parse-tree that is created and
returned. The set of recognized option keywords are:
=over 3
=item B<-expand_seq> =E<gt> I<code-ref>|I<method-name>
Normally, the parse-tree returned by B<parse_text()> will contain an
unexpanded C<Pod::InteriorSequence> object for each interior-sequence
encountered. Specifying B<-expand_seq> tells B<parse_text()> to "expand"
every interior-sequence it sees by invoking the referenced function
(or named method of the parser object) and using the return value as the
expanded result.
If a subroutine reference was given, it is invoked as:
&$code_ref( $parser, $sequence )
and if a method-name was given, it is invoked as:
$parser->method_name( $sequence )
where C<$parser> is a reference to the parser object, and C<$sequence>
is a reference to the interior-sequence object.
[I<NOTE>: If the B<interior_sequence()> method is specified, then it is
invoked according to the interface specified in L<"interior_sequence()">].
=item B<-expand_text> =E<gt> I<code-ref>|I<method-name>
Normally, the parse-tree returned by B<parse_text()> will contain a
text-string for each contiguous sequence of characters outside of an
interior-sequence. Specifying B<-expand_text> tells B<parse_text()> to
"preprocess" every such text-string it sees by invoking the referenced
function (or named method of the parser object) and using the return value
as the preprocessed (or "expanded") result. [Note that if the result is
an interior-sequence, then it will I<not> be expanded as specified by the
B<-expand_seq> option; Any such recursive expansion needs to be handled by
the specified callback routine.]
If a subroutine reference was given, it is invoked as:
&$code_ref( $parser, $text, $ptree_node )
and if a method-name was given, it is invoked as:
$parser->method_name( $text, $ptree_node )
where C<$parser> is a reference to the parser object, C<$text> is the
text-string encountered, and C<$ptree_node> is a reference to the current
node in the parse-tree (usually an interior-sequence object or else the
top-level node of the parse-tree).
=item B<-expand_ptree> =E<gt> I<code-ref>|I<method-name>
Rather than returning a C<Pod::ParseTree>, pass the parse-tree as an
argument to the referenced subroutine (or named method of the parser
object) and return the result instead of the parse-tree object.
If a subroutine reference was given, it is invoked as:
&$code_ref( $parser, $ptree )
and if a method-name was given, it is invoked as:
$parser->method_name( $ptree )
where C<$parser> is a reference to the parser object, and C<$ptree>
is a reference to the parse-tree object.
=back
=cut
sub parse_text {
my $self = shift;
local $_ = '';
## Get options and set any defaults
my %opts = (ref $_[0]) ? %{ shift() } : ();
my $expand_seq = $opts{'-expand_seq'} || undef;
my $expand_text = $opts{'-expand_text'} || undef;
my $expand_ptree = $opts{'-expand_ptree'} || undef;
my $text = shift;
my $line = shift;
my $file = $self->input_file();
my $cmd = "";
## Convert method calls into closures, for our convenience
my $xseq_sub = $expand_seq;
my $xtext_sub = $expand_text;
my $xptree_sub = $expand_ptree;
if (defined $expand_seq and $expand_seq eq 'interior_sequence') {
## If 'interior_sequence' is the method to use, we have to pass
## more than just the sequence object, we also need to pass the
## sequence name and text.
$xseq_sub = sub {
my ($sself, $iseq) = @_;
my $args = join('', $iseq->parse_tree->children);
return $sself->interior_sequence($iseq->name, $args, $iseq);
};
}
ref $xseq_sub or $xseq_sub = sub { shift()->$expand_seq(@_) };
ref $xtext_sub or $xtext_sub = sub { shift()->$expand_text(@_) };
ref $xptree_sub or $xptree_sub = sub { shift()->$expand_ptree(@_) };
## Keep track of the "current" interior sequence, and maintain a stack
## of "in progress" sequences.
##
## NOTE that we push our own "accumulator" at the very beginning of the
## stack. It's really a parse-tree, not a sequence; but it implements
## the methods we need so we can use it to gather-up all the sequences
## and strings we parse. Thus, by the end of our parsing, it should be
## the only thing left on our stack and all we have to do is return it!
##
my $seq = Pod::ParseTree->new();
my @seq_stack = ($seq);
my ($ldelim, $rdelim) = ('', '');
## Iterate over all sequence starts text (NOTE: split with
## capturing parens keeps the delimiters)
$_ = $text;
my @tokens = split /([A-Z]<(?:<+(?:\r?\n|[ \t]))?)/;
while ( @tokens ) {
$_ = shift @tokens;
## Look for the beginning of a sequence
if ( /^([A-Z])(<(?:<+(?:\r?\n|[ \t]))?)$/ ) {
## Push a new sequence onto the stack of those "in-progress"
my $ldelim_orig;
($cmd, $ldelim_orig) = ($1, $2);
($ldelim = $ldelim_orig) =~ s/\s+$//;
($rdelim = $ldelim) =~ tr/</>/;
$seq = Pod::InteriorSequence->new(
-name => $cmd,
-ldelim => $ldelim_orig, -rdelim => $rdelim,
-file => $file, -line => $line
);
(@seq_stack > 1) and $seq->nested($seq_stack[-1]);
push @seq_stack, $seq;
}
## Look for sequence ending
elsif ( @seq_stack > 1 ) {
## Make sure we match the right kind of closing delimiter
my ($seq_end, $post_seq) = ('', '');
if ( ($ldelim eq '<' and /\A(.*?)(>)/s)
or /\A(.*?)(\s+$rdelim)/s )
{
## Found end-of-sequence, capture the interior and the
## closing the delimiter, and put the rest back on the
## token-list
$post_seq = substr($_, length($1) + length($2));
($_, $seq_end) = ($1, $2);
(length $post_seq) and unshift @tokens, $post_seq;
}
if (length) {
## In the middle of a sequence, append this text to it, and
## dont forget to "expand" it if that's what the caller wanted
$seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_);
$_ .= $seq_end;
}
if (length $seq_end) {
## End of current sequence, record terminating delimiter
$seq->rdelim($seq_end);
## Pop it off the stack of "in progress" sequences
pop @seq_stack;
## Append result to its parent in current parse tree
$seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq)
: $seq);
## Remember the current cmd-name and left-delimiter
if(@seq_stack > 1) {
$cmd = $seq_stack[-1]->name;
$ldelim = $seq_stack[-1]->ldelim;
$rdelim = $seq_stack[-1]->rdelim;
} else {
$cmd = $ldelim = $rdelim = '';
}
}
}
elsif (length) {
## In the middle of a sequence, append this text to it, and
## dont forget to "expand" it if that's what the caller wanted
$seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_);
}
## Keep track of line count
$line += /\n/;
## Remember the "current" sequence
$seq = $seq_stack[-1];
}
## Handle unterminated sequences
my $errorsub = (@seq_stack > 1) ? $self->errorsub() : undef;
while (@seq_stack > 1) {
($cmd, $file, $line) = ($seq->name, $seq->file_line);
$ldelim = $seq->ldelim;
($rdelim = $ldelim) =~ tr/</>/;
$rdelim =~ s/^(\S+)(\s*)$/$2$1/;
pop @seq_stack;
my $errmsg = "*** ERROR: unterminated ${cmd}${ldelim}...${rdelim}".
" at line $line in file $file\n";
(ref $errorsub) and &{$errorsub}($errmsg)
or (defined $errorsub) and $self->$errorsub($errmsg)
or carp($errmsg);
$seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) : $seq);
$seq = $seq_stack[-1];
}
## Return the resulting parse-tree
my $ptree = (pop @seq_stack)->parse_tree;
return $expand_ptree ? &$xptree_sub($self, $ptree) : $ptree;
}
##---------------------------------------------------------------------------
=head1 B<interpolate()>
$textblock = $parser->interpolate($text, $line_num);
This method translates all text (including any embedded interior sequences)
in the given text string C<$text> and returns the interpolated result. The
parameter C<$line_num> is the line number corresponding to the beginning
of C<$text>.
B<interpolate()> merely invokes a private method to recursively expand
nested interior sequences in bottom-up order (innermost sequences are
expanded first). If there is a need to expand nested sequences in
some alternate order, use B<parse_text> instead.
=cut
sub interpolate {
my($self, $text, $line_num) = @_;
my %parse_opts = ( -expand_seq => 'interior_sequence' );
my $ptree = $self->parse_text( \%parse_opts, $text, $line_num );
return join '', $ptree->children();
}
##---------------------------------------------------------------------------
=begin __PRIVATE__
=head1 B<parse_paragraph()>
$parser->parse_paragraph($text, $line_num);
This method takes the text of a POD paragraph to be processed, along
with its corresponding line number, and invokes the appropriate method
(one of B<command()>, B<verbatim()>, or B<textblock()>).
For performance reasons, this method is invoked directly without any
dynamic lookup; Hence subclasses may I<not> override it!
=end __PRIVATE__
=cut
sub parse_paragraph {
my ($self, $text, $line_num) = @_;
local *myData = $self; ## alias to avoid deref-ing overhead
local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options
local $_;
## See if we want to preprocess nonPOD paragraphs as well as POD ones.
my $wantNonPods = $myOpts{'-want_nonPODs'};
## Update cutting status
$myData{_CUTTING} = 0 if $text =~ /^={1,2}\S/;
## Perform any desired preprocessing if we wanted it this early
$wantNonPods and $text = $self->preprocess_paragraph($text, $line_num);
## Ignore up until next POD directive if we are cutting
return if $myData{_CUTTING};
## Now we know this is block of text in a POD section!
##-----------------------------------------------------------------
## This is a hook (hack ;-) for Pod::Select to do its thing without
## having to override methods, but also without Pod::Parser assuming
## $self is an instance of Pod::Select (if the _SELECTED_SECTIONS
## field exists then we assume there is an is_selected() method for
## us to invoke (calling $self->can('is_selected') could verify this
## but that is more overhead than I want to incur)
##-----------------------------------------------------------------
## Ignore this block if it isnt in one of the selected sections
if (exists $myData{_SELECTED_SECTIONS}) {
$self->is_selected($text) or return ($myData{_CUTTING} = 1);
}
## If we havent already, perform any desired preprocessing and
## then re-check the "cutting" state
unless ($wantNonPods) {
$text = $self->preprocess_paragraph($text, $line_num);
return 1 unless ((defined $text) and (length $text));
return 1 if ($myData{_CUTTING});
}
## Look for one of the three types of paragraphs
my ($pfx, $cmd, $arg, $sep) = ('', '', '', '');
my $pod_para = undef;
if ($text =~ /^(={1,2})(?=\S)/) {
## Looks like a command paragraph. Capture the command prefix used
## ("=" or "=="), as well as the command-name, its paragraph text,
## and whatever sequence of characters was used to separate them
$pfx = $1;
$_ = substr($text, length $pfx);
($cmd, $sep, $text) = split /(\s+)/, $_, 2;
$sep = '' unless defined $sep;
$text = '' unless defined $text;
## If this is a "cut" directive then we dont need to do anything
## except return to "cutting" mode.
if ($cmd eq 'cut') {
$myData{_CUTTING} = 1;
return unless $myOpts{'-process_cut_cmd'};
}
}
## Save the attributes indicating how the command was specified.
$pod_para = new Pod::Paragraph(
-name => $cmd,
-text => $text,
-prefix => $pfx,
-separator => $sep,
-file => $myData{_INFILE},
-line => $line_num
);
# ## Invoke appropriate callbacks
# if (exists $myData{_CALLBACKS}) {
# ## Look through the callback list, invoke callbacks,
# ## then see if we need to do the default actions
# ## (invoke_callbacks will return true if we do).
# return 1 unless $self->invoke_callbacks($cmd, $text, $line_num, $pod_para);
# }
# If the last paragraph ended in whitespace, and we're not between verbatim blocks, carp
if ($myData{_WHITESPACE} and $myOpts{'-warnings'}
and not ($text =~ /^\s+/ and ($myData{_PREVIOUS}||"") eq "verbatim")) {
my $errorsub = $self->errorsub();
my $line = $line_num - 1;
my $errmsg = "*** WARNING: line containing nothing but whitespace".
" in paragraph at line $line in file $myData{_INFILE}\n";
(ref $errorsub) and &{$errorsub}($errmsg)
or (defined $errorsub) and $self->$errorsub($errmsg)
or carp($errmsg);
}
if (length $cmd) {
## A command paragraph
$self->command($cmd, $text, $line_num, $pod_para);
$myData{_PREVIOUS} = $cmd;
}
elsif ($text =~ /^\s+/) {
## Indented text - must be a verbatim paragraph
$self->verbatim($text, $line_num, $pod_para);
$myData{_PREVIOUS} = "verbatim";
}
else {
## Looks like an ordinary block of text
$self->textblock($text, $line_num, $pod_para);
$myData{_PREVIOUS} = "textblock";
}
# Update the whitespace for the next time around
#$myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\Z/m ? 1 : 0;
$myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\r*\Z/m ? 1 : 0;
return 1;
}
##---------------------------------------------------------------------------
=head1 B<parse_from_filehandle()>
$parser->parse_from_filehandle($in_fh,$out_fh);
This method takes an input filehandle (which is assumed to already be
opened for reading) and reads the entire input stream looking for blocks
(paragraphs) of POD documentation to be processed. If no first argument
is given the default input filehandle C<STDIN> is used.
The C<$in_fh> parameter may be any object that provides a B<getline()>
method to retrieve a single line of input text (hence, an appropriate
wrapper object could be used to parse PODs from a single string or an
array of strings).
Using C<$in_fh-E<gt>getline()>, input is read line-by-line and assembled
into paragraphs or "blocks" (which are separated by lines containing
nothing but whitespace). For each block of POD documentation
encountered it will invoke a method to parse the given paragraph.
If a second argument is given then it should correspond to a filehandle where
output should be sent (otherwise the default output filehandle is
C<STDOUT> if no output filehandle is currently in use).
B<NOTE:> For performance reasons, this method caches the input stream at
the top of the stack in a local variable. Any attempts by clients to
change the stack contents during processing when in the midst executing
of this method I<will not affect> the input stream used by the current
invocation of this method.
This method does I<not> usually need to be overridden by subclasses.
=cut
sub parse_from_filehandle {
my $self = shift;
my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : ();
my ($in_fh, $out_fh) = @_;
$in_fh = \*STDIN unless ($in_fh);
local *myData = $self; ## alias to avoid deref-ing overhead
local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options
local $_;
## Put this stream at the top of the stack and do beginning-of-input
## processing. NOTE that $in_fh might be reset during this process.
my $topstream = $self->_push_input_stream($in_fh, $out_fh);
(exists $opts{-cutting}) and $self->cutting( $opts{-cutting} );
## Initialize line/paragraph
my ($textline, $paragraph) = ('', '');
my ($nlines, $plines) = (0, 0);
## Use <$fh> instead of $fh->getline where possible (for speed)
$_ = ref $in_fh;
my $tied_fh = (/^(?:GLOB|FileHandle|IO::\w+)$/ or tied $in_fh);
## Read paragraphs line-by-line
while (defined ($textline = $tied_fh ? <$in_fh> : $in_fh->getline)) {
$textline = $self->preprocess_line($textline, ++$nlines);
next unless ((defined $textline) && (length $textline));
if ((! length $paragraph) && ($textline =~ /^==/)) {
## '==' denotes a one-line command paragraph
$paragraph = $textline;
$plines = 1;
$textline = '';
} else {
## Append this line to the current paragraph
$paragraph .= $textline;
++$plines;
}
## See if this line is blank and ends the current paragraph.
## If it isnt, then keep iterating until it is.
next unless (($textline =~ /^[^\S\r\n]*[\r\n]*$/)
&& (length $paragraph));
## Now process the paragraph
parse_paragraph($self, $paragraph, ($nlines - $plines) + 1);
$paragraph = '';
$plines = 0;
}
## Dont forget about the last paragraph in the file
if (length $paragraph) {
parse_paragraph($self, $paragraph, ($nlines - $plines) + 1)
}
## Now pop the input stream off the top of the input stack.
$self->_pop_input_stream();
}
##---------------------------------------------------------------------------
=head1 B<parse_from_file()>
$parser->parse_from_file($filename,$outfile);
This method takes a filename and does the following:
=over 2
=item *
opens the input and output files for reading
(creating the appropriate filehandles)
=item *
invokes the B<parse_from_filehandle()> method passing it the
corresponding input and output filehandles.
=item *
closes the input and output files.
=back
If the special input filename "-" or "<&STDIN" is given then the STDIN
filehandle is used for input (and no open or close is performed). If no
input filename is specified then "-" is implied. Filehandle references,
or objects that support the regular IO operations (like C<E<lt>$fhE<gt>>
or C<$fh-<Egt>getline>) are also accepted; the handles must already be
opened.
If a second argument is given then it should be the name of the desired
output file. If the special output filename "-" or ">&STDOUT" is given
then the STDOUT filehandle is used for output (and no open or close is
performed). If the special output filename ">&STDERR" is given then the
STDERR filehandle is used for output (and no open or close is
performed). If no output filehandle is currently in use and no output
filename is specified, then "-" is implied.
Alternatively, filehandle references or objects that support the regular
IO operations (like C<print>, e.g. L<IO::String>) are also accepted;
the object must already be opened.
This method does I<not> usually need to be overridden by subclasses.
=cut
sub parse_from_file {
my $self = shift;
my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : ();
my ($infile, $outfile) = @_;
my ($in_fh, $out_fh);
if ($] < 5.006) {
($in_fh, $out_fh) = (gensym(), gensym());
}
my ($close_input, $close_output) = (0, 0);
local *myData = $self;
local *_;
## Is $infile a filename or a (possibly implied) filehandle
if (defined $infile && ref $infile) {
if (ref($infile) =~ /^(SCALAR|ARRAY|HASH|CODE|REF)$/) {
croak "Input from $1 reference not supported!\n";
}
## Must be a filehandle-ref (or else assume its a ref to an object
## that supports the common IO read operations).
$myData{_INFILE} = ${$infile};
$in_fh = $infile;
}
elsif (!defined($infile) || !length($infile) || ($infile eq '-')
|| ($infile =~ /^<&(?:STDIN|0)$/i))
{
## Not a filename, just a string implying STDIN
$infile ||= '-';
$myData{_INFILE} = '<standard input>';
$in_fh = \*STDIN;
}
else {
## We have a filename, open it for reading
$myData{_INFILE} = $infile;
open($in_fh, "< $infile") or
croak "Can't open $infile for reading: $!\n";
$close_input = 1;
}
## NOTE: we need to be *very* careful when "defaulting" the output
## file. We only want to use a default if this is the beginning of
## the entire document (but *not* if this is an included file). We
## determine this by seeing if the input stream stack has been set-up
## already
## Is $outfile a filename, a (possibly implied) filehandle, maybe a ref?
if (ref $outfile) {
## we need to check for ref() first, as other checks involve reading
if (ref($outfile) =~ /^(ARRAY|HASH|CODE)$/) {
croak "Output to $1 reference not supported!\n";
}
elsif (ref($outfile) eq 'SCALAR') {
# # NOTE: IO::String isn't a part of the perl distribution,
# # so probably we shouldn't support this case...
# require IO::String;
# $myData{_OUTFILE} = "$outfile";
# $out_fh = IO::String->new($outfile);
croak "Output to SCALAR reference not supported!\n";
}
else {
## Must be a filehandle-ref (or else assume its a ref to an
## object that supports the common IO write operations).
$myData{_OUTFILE} = ${$outfile};
$out_fh = $outfile;
}
}
elsif (!defined($outfile) || !length($outfile) || ($outfile eq '-')
|| ($outfile =~ /^>&?(?:STDOUT|1)$/i))
{
if (defined $myData{_TOP_STREAM}) {
$out_fh = $myData{_OUTPUT};
}
else {
## Not a filename, just a string implying STDOUT
$outfile ||= '-';
$myData{_OUTFILE} = '<standard output>';
$out_fh = \*STDOUT;
}
}
elsif ($outfile =~ /^>&(STDERR|2)$/i) {
## Not a filename, just a string implying STDERR
$myData{_OUTFILE} = '<standard error>';
$out_fh = \*STDERR;
}
else {
## We have a filename, open it for writing
$myData{_OUTFILE} = $outfile;
(-d $outfile) and croak "$outfile is a directory, not POD input!\n";
open($out_fh, "> $outfile") or
croak "Can't open $outfile for writing: $!\n";
$close_output = 1;
}
## Whew! That was a lot of work to set up reasonably/robust behavior
## in the case of a non-filename for reading and writing. Now we just
## have to parse the input and close the handles when we're finished.
$self->parse_from_filehandle(\%opts, $in_fh, $out_fh);
$close_input and
close($in_fh) || croak "Can't close $infile after reading: $!\n";
$close_output and
close($out_fh) || croak "Can't close $outfile after writing: $!\n";
}
#############################################################################
=head1 ACCESSOR METHODS
Clients of B<Pod::Parser> should use the following methods to access
instance data fields:
=cut
##---------------------------------------------------------------------------
=head1 B<errorsub()>
$parser->errorsub("method_name");
$parser->errorsub(\&warn_user);
$parser->errorsub(sub { print STDERR, @_ });
Specifies the method or subroutine to use when printing error messages
about POD syntax. The supplied method/subroutine I<must> return TRUE upon
successful printing of the message. If C<undef> is given, then the B<carp>
builtin is used to issue error messages (this is the default behavior).
my $errorsub = $parser->errorsub()
my $errmsg = "This is an error message!\n"
(ref $errorsub) and &{$errorsub}($errmsg)
or (defined $errorsub) and $parser->$errorsub($errmsg)
or carp($errmsg);
Returns a method name, or else a reference to the user-supplied subroutine
used to print error messages. Returns C<undef> if the B<carp> builtin
is used to issue error messages (this is the default behavior).
=cut
sub errorsub {
return (@_ > 1) ? ($_[0]->{_ERRORSUB} = $_[1]) : $_[0]->{_ERRORSUB};
}
##---------------------------------------------------------------------------
=head1 B<cutting()>
$boolean = $parser->cutting();
Returns the current C<cutting> state: a boolean-valued scalar which
evaluates to true if text from the input file is currently being "cut"
(meaning it is I<not> considered part of the POD document).
$parser->cutting($boolean);
Sets the current C<cutting> state to the given value and returns the
result.
=cut
sub cutting {
return (@_ > 1) ? ($_[0]->{_CUTTING} = $_[1]) : $_[0]->{_CUTTING};
}
##---------------------------------------------------------------------------
##---------------------------------------------------------------------------
=head1 B<parseopts()>
When invoked with no additional arguments, B<parseopts> returns a hashtable
of all the current parsing options.
## See if we are parsing non-POD sections as well as POD ones
my %opts = $parser->parseopts();
$opts{'-want_nonPODs}' and print "-want_nonPODs\n";
When invoked using a single string, B<parseopts> treats the string as the
name of a parse-option and returns its corresponding value if it exists
(returns C<undef> if it doesn't).
## Did we ask to see '=cut' paragraphs?
my $want_cut = $parser->parseopts('-process_cut_cmd');
$want_cut and print "-process_cut_cmd\n";
When invoked with multiple arguments, B<parseopts> treats them as
key/value pairs and the specified parse-option names are set to the
given values. Any unspecified parse-options are unaffected.
## Set them back to the default
$parser->parseopts(-warnings => 0);
When passed a single hash-ref, B<parseopts> uses that hash to completely
reset the existing parse-options, all previous parse-option values
are lost.
## Reset all options to default
$parser->parseopts( { } );
See L<"PARSING OPTIONS"> for more information on the name and meaning of each
parse-option currently recognized.
=cut
sub parseopts {
local *myData = shift;
local *myOpts = ($myData{_PARSEOPTS} ||= {});
return %myOpts if (@_ == 0);
if (@_ == 1) {
local $_ = shift;
return ref($_) ? $myData{_PARSEOPTS} = $_ : $myOpts{$_};
}
my @newOpts = (%myOpts, @_);
$myData{_PARSEOPTS} = { @newOpts };
}
##---------------------------------------------------------------------------
=head1 B<output_file()>
$fname = $parser->output_file();
Returns the name of the output file being written.
=cut
sub output_file {
return $_[0]->{_OUTFILE};
}
##---------------------------------------------------------------------------
=head1 B<output_handle()>
$fhandle = $parser->output_handle();
Returns the output filehandle object.
=cut
sub output_handle {
return $_[0]->{_OUTPUT};
}
##---------------------------------------------------------------------------
=head1 B<input_file()>
$fname = $parser->input_file();
Returns the name of the input file being read.
=cut
sub input_file {
return $_[0]->{_INFILE};
}
##---------------------------------------------------------------------------
=head1 B<input_handle()>
$fhandle = $parser->input_handle();
Returns the current input filehandle object.
=cut
sub input_handle {
return $_[0]->{_INPUT};
}
##---------------------------------------------------------------------------
=begin __PRIVATE__
=head1 B<input_streams()>
$listref = $parser->input_streams();
Returns a reference to an array which corresponds to the stack of all
the input streams that are currently in the middle of being parsed.
While parsing an input stream, it is possible to invoke
B<parse_from_file()> or B<parse_from_filehandle()> to parse a new input
stream and then return to parsing the previous input stream. Each input
stream to be parsed is pushed onto the end of this input stack
before any of its input is read. The input stream that is currently
being parsed is always at the end (or top) of the input stack. When an
input stream has been exhausted, it is popped off the end of the
input stack.
Each element on this input stack is a reference to C<Pod::InputSource>
object. Please see L<Pod::InputObjects> for more details.
This method might be invoked when printing diagnostic messages, for example,
to obtain the name and line number of the all input files that are currently
being processed.
=end __PRIVATE__
=cut
sub input_streams {
return $_[0]->{_INPUT_STREAMS};
}
##---------------------------------------------------------------------------
=begin __PRIVATE__
=head1 B<top_stream()>
$hashref = $parser->top_stream();
Returns a reference to the hash-table that represents the element
that is currently at the top (end) of the input stream stack
(see L<"input_streams()">). The return value will be the C<undef>
if the input stack is empty.
This method might be used when printing diagnostic messages, for example,
to obtain the name and line number of the current input file.
=end __PRIVATE__
=cut
sub top_stream {
return $_[0]->{_TOP_STREAM} || undef;
}
#############################################################################
=head1 PRIVATE METHODS AND DATA
B<Pod::Parser> makes use of several internal methods and data fields
which clients should not need to see or use. For the sake of avoiding
name collisions for client data and methods, these methods and fields
are briefly discussed here. Determined hackers may obtain further
information about them by reading the B<Pod::Parser> source code.
Private data fields are stored in the hash-object whose reference is
returned by the B<new()> constructor for this class. The names of all
private methods and data-fields used by B<Pod::Parser> begin with a
prefix of "_" and match the regular expression C</^_\w+$/>.
=cut
##---------------------------------------------------------------------------
=begin _PRIVATE_
=head1 B<_push_input_stream()>
$hashref = $parser->_push_input_stream($in_fh,$out_fh);
This method will push the given input stream on the input stack and
perform any necessary beginning-of-document or beginning-of-file
processing. The argument C<$in_fh> is the input stream filehandle to
push, and C<$out_fh> is the corresponding output filehandle to use (if
it is not given or is undefined, then the current output stream is used,
which defaults to standard output if it doesnt exist yet).
The value returned will be reference to the hash-table that represents
the new top of the input stream stack. I<Please Note> that it is
possible for this method to use default values for the input and output
file handles. If this happens, you will need to look at the C<INPUT>
and C<OUTPUT> instance data members to determine their new values.
=end _PRIVATE_
=cut
sub _push_input_stream {
my ($self, $in_fh, $out_fh) = @_;
local *myData = $self;
## Initialize stuff for the entire document if this is *not*
## an included file.
##
## NOTE: we need to be *very* careful when "defaulting" the output
## filehandle. We only want to use a default value if this is the
## beginning of the entire document (but *not* if this is an included
## file).
unless (defined $myData{_TOP_STREAM}) {
$out_fh = \*STDOUT unless (defined $out_fh);
$myData{_CUTTING} = 1; ## current "cutting" state
$myData{_INPUT_STREAMS} = []; ## stack of all input streams
}
## Initialize input indicators
$myData{_OUTFILE} = '(unknown)' unless (defined $myData{_OUTFILE});
$myData{_OUTPUT} = $out_fh if (defined $out_fh);
$in_fh = \*STDIN unless (defined $in_fh);
$myData{_INFILE} = '(unknown)' unless (defined $myData{_INFILE});
$myData{_INPUT} = $in_fh;
my $input_top = $myData{_TOP_STREAM}
= new Pod::InputSource(
-name => $myData{_INFILE},
-handle => $in_fh,
-was_cutting => $myData{_CUTTING}
);
local *input_stack = $myData{_INPUT_STREAMS};
push(@input_stack, $input_top);
## Perform beginning-of-document and/or beginning-of-input processing
$self->begin_pod() if (@input_stack == 1);
$self->begin_input();
return $input_top;
}
##---------------------------------------------------------------------------
=begin _PRIVATE_
=head1 B<_pop_input_stream()>
$hashref = $parser->_pop_input_stream();
This takes no arguments. It will perform any necessary end-of-file or
end-of-document processing and then pop the current input stream from
the top of the input stack.
The value returned will be reference to the hash-table that represents
the new top of the input stream stack.
=end _PRIVATE_
=cut
sub _pop_input_stream {
my ($self) = @_;
local *myData = $self;
local *input_stack = $myData{_INPUT_STREAMS};
## Perform end-of-input and/or end-of-document processing
$self->end_input() if (@input_stack > 0);
$self->end_pod() if (@input_stack == 1);
## Restore cutting state to whatever it was before we started
## parsing this file.
my $old_top = pop(@input_stack);
$myData{_CUTTING} = $old_top->was_cutting();
## Dont forget to reset the input indicators
my $input_top = undef;
if (@input_stack > 0) {
$input_top = $myData{_TOP_STREAM} = $input_stack[-1];
$myData{_INFILE} = $input_top->name();
$myData{_INPUT} = $input_top->handle();
} else {
delete $myData{_TOP_STREAM};
delete $myData{_INPUT_STREAMS};
}
return $input_top;
}
#############################################################################
=head1 TREE-BASED PARSING
If straightforward stream-based parsing wont meet your needs (as is
likely the case for tasks such as translating PODs into structured
markup languages like HTML and XML) then you may need to take the
tree-based approach. Rather than doing everything in one pass and
calling the B<interpolate()> method to expand sequences into text, it
may be desirable to instead create a parse-tree using the B<parse_text()>
method to return a tree-like structure which may contain an ordered
list of children (each of which may be a text-string, or a similar
tree-like structure).
Pay special attention to L<"METHODS FOR PARSING AND PROCESSING"> and
to the objects described in L<Pod::InputObjects>. The former describes
the gory details and parameters for how to customize and extend the
parsing behavior of B<Pod::Parser>. B<Pod::InputObjects> provides
several objects that may all be used interchangeably as parse-trees. The
most obvious one is the B<Pod::ParseTree> object. It defines the basic
interface and functionality that all things trying to be a POD parse-tree
should do. A B<Pod::ParseTree> is defined such that each "node" may be a
text-string, or a reference to another parse-tree. Each B<Pod::Paragraph>
object and each B<Pod::InteriorSequence> object also supports the basic
parse-tree interface.
The B<parse_text()> method takes a given paragraph of text, and
returns a parse-tree that contains one or more children, each of which
may be a text-string, or an InteriorSequence object. There are also
callback-options that may be passed to B<parse_text()> to customize
the way it expands or transforms interior-sequences, as well as the
returned result. These callbacks can be used to create a parse-tree
with custom-made objects (which may or may not support the parse-tree
interface, depending on how you choose to do it).
If you wish to turn an entire POD document into a parse-tree, that process
is fairly straightforward. The B<parse_text()> method is the key to doing
this successfully. Every paragraph-callback (i.e. the polymorphic methods
for B<command()>, B<verbatim()>, and B<textblock()> paragraphs) takes
a B<Pod::Paragraph> object as an argument. Each paragraph object has a
B<parse_tree()> method that can be used to get or set a corresponding
parse-tree. So for each of those paragraph-callback methods, simply call
B<parse_text()> with the options you desire, and then use the returned
parse-tree to assign to the given paragraph object.
That gives you a parse-tree for each paragraph - so now all you need is
an ordered list of paragraphs. You can maintain that yourself as a data
element in the object/hash. The most straightforward way would be simply
to use an array-ref, with the desired set of custom "options" for each
invocation of B<parse_text>. Let's assume the desired option-set is
given by the hash C<%options>. Then we might do something like the
following:
package MyPodParserTree;
@ISA = qw( Pod::Parser );
...
sub begin_pod {
my $self = shift;
$self->{'-paragraphs'} = []; ## initialize paragraph list
}
sub command {
my ($parser, $command, $paragraph, $line_num, $pod_para) = @_;
my $ptree = $parser->parse_text({%options}, $paragraph, ...);
$pod_para->parse_tree( $ptree );
push @{ $self->{'-paragraphs'} }, $pod_para;
}
sub verbatim {
my ($parser, $paragraph, $line_num, $pod_para) = @_;
push @{ $self->{'-paragraphs'} }, $pod_para;
}
sub textblock {
my ($parser, $paragraph, $line_num, $pod_para) = @_;
my $ptree = $parser->parse_text({%options}, $paragraph, ...);
$pod_para->parse_tree( $ptree );
push @{ $self->{'-paragraphs'} }, $pod_para;
}
...
package main;
...
my $parser = new MyPodParserTree(...);
$parser->parse_from_file(...);
my $paragraphs_ref = $parser->{'-paragraphs'};
Of course, in this module-author's humble opinion, I'd be more inclined to
use the existing B<Pod::ParseTree> object than a simple array. That way
everything in it, paragraphs and sequences, all respond to the same core
interface for all parse-tree nodes. The result would look something like:
package MyPodParserTree2;
...
sub begin_pod {
my $self = shift;
$self->{'-ptree'} = new Pod::ParseTree; ## initialize parse-tree
}
sub parse_tree {
## convenience method to get/set the parse-tree for the entire POD
(@_ > 1) and $_[0]->{'-ptree'} = $_[1];
return $_[0]->{'-ptree'};
}
sub command {
my ($parser, $command, $paragraph, $line_num, $pod_para) = @_;
my $ptree = $parser->parse_text({<<options>>}, $paragraph, ...);
$pod_para->parse_tree( $ptree );
$parser->parse_tree()->append( $pod_para );
}
sub verbatim {
my ($parser, $paragraph, $line_num, $pod_para) = @_;
$parser->parse_tree()->append( $pod_para );
}
sub textblock {
my ($parser, $paragraph, $line_num, $pod_para) = @_;
my $ptree = $parser->parse_text({<<options>>}, $paragraph, ...);
$pod_para->parse_tree( $ptree );
$parser->parse_tree()->append( $pod_para );
}
...
package main;
...
my $parser = new MyPodParserTree2(...);
$parser->parse_from_file(...);
my $ptree = $parser->parse_tree;
...
Now you have the entire POD document as one great big parse-tree. You
can even use the B<-expand_seq> option to B<parse_text> to insert
whole different kinds of objects. Just don't expect B<Pod::Parser>
to know what to do with them after that. That will need to be in your
code. Or, alternatively, you can insert any object you like so long as
it conforms to the B<Pod::ParseTree> interface.
One could use this to create subclasses of B<Pod::Paragraphs> and
B<Pod::InteriorSequences> for specific commands (or to create your own
custom node-types in the parse-tree) and add some kind of B<emit()>
method to each custom node/subclass object in the tree. Then all you'd
need to do is recursively walk the tree in the desired order, processing
the children (most likely from left to right) by formatting them if
they are text-strings, or by calling their B<emit()> method if they
are objects/references.
=head1 CAVEATS
Please note that POD has the notion of "paragraphs": this is something
starting I<after> a blank (read: empty) line, with the single exception
of the file start, which is also starting a paragraph. That means that
especially a command (e.g. C<=head1>) I<must> be preceded with a blank
line; C<__END__> is I<not> a blank line.
=head1 SEE ALSO
L<Pod::InputObjects>, L<Pod::Select>
B<Pod::InputObjects> defines POD input objects corresponding to
command paragraphs, parse-trees, and interior-sequences.
B<Pod::Select> is a subclass of B<Pod::Parser> which provides the ability
to selectively include and/or exclude sections of a POD document from being
translated based upon the current heading, subheading, subsubheading, etc.
=for __PRIVATE__
B<Pod::Callbacks> is a subclass of B<Pod::Parser> which gives its users
the ability the employ I<callback functions> instead of, or in addition
to, overriding methods of the base class.
=for __PRIVATE__
B<Pod::Select> and B<Pod::Callbacks> do not override any
methods nor do they define any new methods with the same name. Because
of this, they may I<both> be used (in combination) as a base class of
the same subclass in order to combine their functionality without
causing any namespace clashes due to multiple inheritance.
=head1 AUTHOR
Please report bugs using L<http://rt.cpan.org>.
Brad Appleton E<lt>bradapp@enteract.comE<gt>
Based on code for B<Pod::Text> written by
Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
=head1 LICENSE
Pod-Parser is free software; you can redistribute it and/or modify it
under the terms of the Artistic License distributed with Perl version
5.000 or (at your option) any later version. Please refer to the
Artistic License that came with your Perl distribution for more
details. If your version of Perl was not distributed under the
terms of the Artistic License, than you may distribute PodParser
under the same terms as Perl itself.
=cut
1;
# vim: ts=4 sw=4 et
POD_PARSER
$fatpacked{"Pod/PlainText.pm"} = <<'POD_PLAINTEXT';
# Pod::PlainText -- Convert POD data to formatted ASCII text.
# $Id: Text.pm,v 2.1 1999/09/20 11:53:33 eagle Exp $
#
# Copyright 1999-2000 by Russ Allbery <rra@stanford.edu>
#
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
# This module is intended to be a replacement for Pod::Text, and attempts to
# match its output except for some specific circumstances where other
# decisions seemed to produce better output. It uses Pod::Parser and is
# designed to be very easy to subclass.
############################################################################
# Modules and declarations
############################################################################
package Pod::PlainText;
use strict;
require 5.005;
use Carp qw(carp croak);
use Pod::Select ();
use vars qw(@ISA %ESCAPES $VERSION);
# We inherit from Pod::Select instead of Pod::Parser so that we can be used
# by Pod::Usage.
@ISA = qw(Pod::Select);
$VERSION = '2.06';
BEGIN {
if ($] < 5.006) {
require Symbol;
import Symbol;
}
}
############################################################################
# Table of supported E<> escapes
############################################################################
# This table is taken near verbatim from Pod::PlainText in Pod::Parser,
# which got it near verbatim from the original Pod::Text. It is therefore
# credited to Tom Christiansen, and I'm glad I didn't have to write it. :)
%ESCAPES = (
'amp' => '&', # ampersand
'lt' => '<', # left chevron, less-than
'gt' => '>', # right chevron, greater-than
'quot' => '"', # double quote
"Aacute" => "\xC1", # capital A, acute accent
"aacute" => "\xE1", # small a, acute accent
"Acirc" => "\xC2", # capital A, circumflex accent
"acirc" => "\xE2", # small a, circumflex accent
"AElig" => "\xC6", # capital AE diphthong (ligature)
"aelig" => "\xE6", # small ae diphthong (ligature)
"Agrave" => "\xC0", # capital A, grave accent
"agrave" => "\xE0", # small a, grave accent
"Aring" => "\xC5", # capital A, ring
"aring" => "\xE5", # small a, ring
"Atilde" => "\xC3", # capital A, tilde
"atilde" => "\xE3", # small a, tilde
"Auml" => "\xC4", # capital A, dieresis or umlaut mark
"auml" => "\xE4", # small a, dieresis or umlaut mark
"Ccedil" => "\xC7", # capital C, cedilla
"ccedil" => "\xE7", # small c, cedilla
"Eacute" => "\xC9", # capital E, acute accent
"eacute" => "\xE9", # small e, acute accent
"Ecirc" => "\xCA", # capital E, circumflex accent
"ecirc" => "\xEA", # small e, circumflex accent
"Egrave" => "\xC8", # capital E, grave accent
"egrave" => "\xE8", # small e, grave accent
"ETH" => "\xD0", # capital Eth, Icelandic
"eth" => "\xF0", # small eth, Icelandic
"Euml" => "\xCB", # capital E, dieresis or umlaut mark
"euml" => "\xEB", # small e, dieresis or umlaut mark
"Iacute" => "\xCD", # capital I, acute accent
"iacute" => "\xED", # small i, acute accent
"Icirc" => "\xCE", # capital I, circumflex accent
"icirc" => "\xEE", # small i, circumflex accent
"Igrave" => "\xCD", # capital I, grave accent
"igrave" => "\xED", # small i, grave accent
"Iuml" => "\xCF", # capital I, dieresis or umlaut mark
"iuml" => "\xEF", # small i, dieresis or umlaut mark
"Ntilde" => "\xD1", # capital N, tilde
"ntilde" => "\xF1", # small n, tilde
"Oacute" => "\xD3", # capital O, acute accent
"oacute" => "\xF3", # small o, acute accent
"Ocirc" => "\xD4", # capital O, circumflex accent
"ocirc" => "\xF4", # small o, circumflex accent
"Ograve" => "\xD2", # capital O, grave accent
"ograve" => "\xF2", # small o, grave accent
"Oslash" => "\xD8", # capital O, slash
"oslash" => "\xF8", # small o, slash
"Otilde" => "\xD5", # capital O, tilde
"otilde" => "\xF5", # small o, tilde
"Ouml" => "\xD6", # capital O, dieresis or umlaut mark
"ouml" => "\xF6", # small o, dieresis or umlaut mark
"szlig" => "\xDF", # small sharp s, German (sz ligature)
"THORN" => "\xDE", # capital THORN, Icelandic
"thorn" => "\xFE", # small thorn, Icelandic
"Uacute" => "\xDA", # capital U, acute accent
"uacute" => "\xFA", # small u, acute accent
"Ucirc" => "\xDB", # capital U, circumflex accent
"ucirc" => "\xFB", # small u, circumflex accent
"Ugrave" => "\xD9", # capital U, grave accent
"ugrave" => "\xF9", # small u, grave accent
"Uuml" => "\xDC", # capital U, dieresis or umlaut mark
"uuml" => "\xFC", # small u, dieresis or umlaut mark
"Yacute" => "\xDD", # capital Y, acute accent
"yacute" => "\xFD", # small y, acute accent
"yuml" => "\xFF", # small y, dieresis or umlaut mark
"lchevron" => "\xAB", # left chevron (double less than)
"rchevron" => "\xBB", # right chevron (double greater than)
);
############################################################################
# Initialization
############################################################################
# Initialize the object. Must be sure to call our parent initializer.
sub initialize {
my $self = shift;
$$self{alt} = 0 unless defined $$self{alt};
$$self{indent} = 4 unless defined $$self{indent};
$$self{loose} = 0 unless defined $$self{loose};
$$self{sentence} = 0 unless defined $$self{sentence};
$$self{width} = 76 unless defined $$self{width};
$$self{INDENTS} = []; # Stack of indentations.
$$self{MARGIN} = $$self{indent}; # Current left margin in spaces.
return $self->SUPER::initialize;
}
############################################################################
# Core overrides
############################################################################
# Called for each command paragraph. Gets the command, the associated
# paragraph, the line number, and a Pod::Paragraph object. Just dispatches
# the command to a method named the same as the command. =cut is handled
# internally by Pod::Parser.
sub command {
my $self = shift;
my $command = shift;
return if $command eq 'pod';
return if ($$self{EXCLUDE} && $command ne 'end');
if (defined $$self{ITEM}) {
$self->item ("\n");
local $_ = "\n";
$self->output($_) if($command eq 'back');
}
$command = 'cmd_' . $command;
return $self->$command (@_);
}
# Called for a verbatim paragraph. Gets the paragraph, the line number, and
# a Pod::Paragraph object. Just output it verbatim, but with tabs converted
# to spaces.
sub verbatim {
my $self = shift;
return if $$self{EXCLUDE};
$self->item if defined $$self{ITEM};
local $_ = shift;
return if /^\s*$/;
s/^(\s*\S+)/(' ' x $$self{MARGIN}) . $1/gme;
return $self->output($_);
}
# Called for a regular text block. Gets the paragraph, the line number, and
# a Pod::Paragraph object. Perform interpolation and output the results.
sub textblock {
my $self = shift;
return if $$self{EXCLUDE};
if($$self{VERBATIM}) {
$self->output($_[0]);
return;
}
local $_ = shift;
my $line = shift;
# Perform a little magic to collapse multiple L<> references. This is
# here mostly for backwards-compatibility. We'll just rewrite the whole
# thing into actual text at this part, bypassing the whole internal
# sequence parsing thing.
s{
(
L< # A link of the form L</something>.
/
(
[:\w]+ # The item has to be a simple word...
(\(\))? # ...or simple function.
)
>
(
,?\s+(and\s+)? # Allow lots of them, conjuncted.
L<
/
(
[:\w]+
(\(\))?
)
>
)+
)
} {
local $_ = $1;
s%L</([^>]+)>%$1%g;
my @items = split /(?:,?\s+(?:and\s+)?)/;
my $string = "the ";
my $i;
for ($i = 0; $i < @items; $i++) {
$string .= $items[$i];
$string .= ", " if @items > 2 && $i != $#items;
$string .= " and " if ($i == $#items - 1);
}
$string .= " entries elsewhere in this document";
$string;
}gex;
# Now actually interpolate and output the paragraph.
$_ = $self->interpolate ($_, $line);
s/\s*$/\n/s;
if (defined $$self{ITEM}) {
$self->item ($_ . "\n");
} else {
$self->output ($self->reformat ($_ . "\n"));
}
}
# Called for an interior sequence. Gets the command, argument, and a
# Pod::InteriorSequence object and is expected to return the resulting text.
# Calls code, bold, italic, file, and link to handle those types of
# sequences, and handles S<>, E<>, X<>, and Z<> directly.
sub interior_sequence {
my $self = shift;
my $command = shift;
local $_ = shift;
return '' if ($command eq 'X' || $command eq 'Z');
# Expand escapes into the actual character now, carping if invalid.
if ($command eq 'E') {
return $ESCAPES{$_} if defined $ESCAPES{$_};
carp "Unknown escape: E<$_>";
return "E<$_>";
}
# For all the other sequences, empty content produces no output.
return if $_ eq '';
# For S<>, compress all internal whitespace and then map spaces to \01.
# When we output the text, we'll map this back.
if ($command eq 'S') {
s/\s{2,}/ /g;
tr/ /\01/;
return $_;
}
# Anything else needs to get dispatched to another method.
if ($command eq 'B') { return $self->seq_b ($_) }
elsif ($command eq 'C') { return $self->seq_c ($_) }
elsif ($command eq 'F') { return $self->seq_f ($_) }
elsif ($command eq 'I') { return $self->seq_i ($_) }
elsif ($command eq 'L') { return $self->seq_l ($_) }
else { carp "Unknown sequence $command<$_>" }
}
# Called for each paragraph that's actually part of the POD. We take
# advantage of this opportunity to untabify the input.
sub preprocess_paragraph {
my $self = shift;
local $_ = shift;
1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me;
return $_;
}
############################################################################
# Command paragraphs
############################################################################
# All command paragraphs take the paragraph and the line number.
# First level heading.
sub cmd_head1 {
my $self = shift;
local $_ = shift;
s/\s+$//s;
$_ = $self->interpolate ($_, shift);
if ($$self{alt}) {
$self->output ("\n==== $_ ====\n\n");
} else {
$_ .= "\n" if $$self{loose};
$self->output ($_ . "\n");
}
}
# Second level heading.
sub cmd_head2 {
my $self = shift;
local $_ = shift;
s/\s+$//s;
$_ = $self->interpolate ($_, shift);
if ($$self{alt}) {
$self->output ("\n== $_ ==\n\n");
} else {
$_ .= "\n" if $$self{loose};
$self->output (' ' x ($$self{indent} / 2) . $_ . "\n");
}
}
# third level heading - not strictly perlpodspec compliant
sub cmd_head3 {
my $self = shift;
local $_ = shift;
s/\s+$//s;
$_ = $self->interpolate ($_, shift);
if ($$self{alt}) {
$self->output ("\n= $_ =\n");
} else {
$_ .= "\n" if $$self{loose};
$self->output (' ' x ($$self{indent}) . $_ . "\n");
}
}
# fourth level heading - not strictly perlpodspec compliant
# just like head3
*cmd_head4 = \&cmd_head3;
# Start a list.
sub cmd_over {
my $self = shift;
local $_ = shift;
unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} }
push (@{ $$self{INDENTS} }, $$self{MARGIN});
$$self{MARGIN} += ($_ + 0);
}
# End a list.
sub cmd_back {
my $self = shift;
$$self{MARGIN} = pop @{ $$self{INDENTS} };
unless (defined $$self{MARGIN}) {
carp 'Unmatched =back';
$$self{MARGIN} = $$self{indent};
}
}
# An individual list item.
sub cmd_item {
my $self = shift;
if (defined $$self{ITEM}) { $self->item }
local $_ = shift;
s/\s+$//s;
$$self{ITEM} = $self->interpolate ($_);
}
# Begin a block for a particular translator. Setting VERBATIM triggers
# special handling in textblock().
sub cmd_begin {
my $self = shift;
local $_ = shift;
my ($kind) = /^(\S+)/ or return;
if ($kind eq 'text') {
$$self{VERBATIM} = 1;
} else {
$$self{EXCLUDE} = 1;
}
}
# End a block for a particular translator. We assume that all =begin/=end
# pairs are properly closed.
sub cmd_end {
my $self = shift;
$$self{EXCLUDE} = 0;
$$self{VERBATIM} = 0;
}
# One paragraph for a particular translator. Ignore it unless it's intended
# for text, in which case we treat it as a verbatim text block.
sub cmd_for {
my $self = shift;
local $_ = shift;
my $line = shift;
return unless s/^text\b[ \t]*\r?\n?//;
$self->verbatim ($_, $line);
}
# just a dummy method for the time being
sub cmd_encoding {
return;
}
############################################################################
# Interior sequences
############################################################################
# The simple formatting ones. These are here mostly so that subclasses can
# override them and do more complicated things.
sub seq_b { return $_[0]{alt} ? "``$_[1]''" : $_[1] }
sub seq_c { return $_[0]{alt} ? "``$_[1]''" : "`$_[1]'" }
sub seq_f { return $_[0]{alt} ? "\"$_[1]\"" : $_[1] }
sub seq_i { return '*' . $_[1] . '*' }
# The complicated one. Handle links. Since this is plain text, we can't
# actually make any real links, so this is all to figure out what text we
# print out.
sub seq_l {
my $self = shift;
local $_ = shift;
# Smash whitespace in case we were split across multiple lines.
s/\s+/ /g;
# If we were given any explicit text, just output it.
if (/^([^|]+)\|/) { return $1 }
# Okay, leading and trailing whitespace isn't important; get rid of it.
s/^\s+//;
s/\s+$//;
# Default to using the whole content of the link entry as a section
# name. Note that L<manpage/> forces a manpage interpretation, as does
# something looking like L<manpage(section)>. The latter is an
# enhancement over the original Pod::Text.
my ($manpage, $section) = ('', $_);
if (/^(?:https?|ftp|news):/) {
# a URL
return $_;
} elsif (/^"\s*(.*?)\s*"$/) {
$section = '"' . $1 . '"';
} elsif (m/^[-:.\w]+(?:\(\S+\))?$/) {
($manpage, $section) = ($_, '');
} elsif (m{/}) {
($manpage, $section) = split (/\s*\/\s*/, $_, 2);
}
my $text = '';
# Now build the actual output text.
if (!length $section) {
$text = "the $manpage manpage" if length $manpage;
} elsif ($section =~ /^[:\w]+(?:\(\))?/) {
$text .= 'the ' . $section . ' entry';
$text .= (length $manpage) ? " in the $manpage manpage"
: ' elsewhere in this document';
} else {
$section =~ s/^\"\s*//;
$section =~ s/\s*\"$//;
$text .= 'the section on "' . $section . '"';
$text .= " in the $manpage manpage" if length $manpage;
}
return $text;
}
############################################################################
# List handling
############################################################################
# This method is called whenever an =item command is complete (in other
# words, we've seen its associated paragraph or know for certain that it
# doesn't have one). It gets the paragraph associated with the item as an
# argument. If that argument is empty, just output the item tag; if it
# contains a newline, output the item tag followed by the newline.
# Otherwise, see if there's enough room for us to output the item tag in the
# margin of the text or if we have to put it on a separate line.
sub item {
my $self = shift;
local $_ = shift;
my $tag = $$self{ITEM};
unless (defined $tag) {
carp 'item called without tag';
return;
}
undef $$self{ITEM};
my $indent = $$self{INDENTS}[-1];
unless (defined $indent) { $indent = $$self{indent} }
my $space = ' ' x $indent;
$space =~ s/^ /:/ if $$self{alt};
if (!$_ || /^\s+$/ || ($$self{MARGIN} - $indent < length ($tag) + 1)) {
my $margin = $$self{MARGIN};
$$self{MARGIN} = $indent;
my $output = $self->reformat ($tag);
$output =~ s/[\r\n]*$/\n/;
$self->output ($output);
$$self{MARGIN} = $margin;
$self->output ($self->reformat ($_)) if /\S/;
} else {
$_ = $self->reformat ($_);
s/^ /:/ if ($$self{alt} && $indent > 0);
my $tagspace = ' ' x length $tag;
s/^($space)$tagspace/$1$tag/ or carp 'Bizarre space in item';
$self->output ($_);
}
}
############################################################################
# Output formatting
############################################################################
# Wrap a line, indenting by the current left margin. We can't use
# Text::Wrap because it plays games with tabs. We can't use formline, even
# though we'd really like to, because it screws up non-printing characters.
# So we have to do the wrapping ourselves.
sub wrap {
my $self = shift;
local $_ = shift;
my $output = '';
my $spaces = ' ' x $$self{MARGIN};
my $width = $$self{width} - $$self{MARGIN};
while (length > $width) {
if (s/^([^\r\n]{0,$width})\s+// || s/^([^\r\n]{$width})//) {
$output .= $spaces . $1 . "\n";
} else {
last;
}
}
$output .= $spaces . $_;
$output =~ s/\s+$/\n\n/;
return $output;
}
# Reformat a paragraph of text for the current margin. Takes the text to
# reformat and returns the formatted text.
sub reformat {
my $self = shift;
local $_ = shift;
# If we're trying to preserve two spaces after sentences, do some
# munging to support that. Otherwise, smash all repeated whitespace.
if ($$self{sentence}) {
s/ +$//mg;
s/\.\r?\n/. \n/g;
s/[\r\n]+/ /g;
s/ +/ /g;
} else {
s/\s+/ /g;
}
return $self->wrap($_);
}
# Output text to the output device.
sub output { $_[1] =~ tr/\01/ /; print { $_[0]->output_handle } $_[1] }
############################################################################
# Backwards compatibility
############################################################################
# The old Pod::Text module did everything in a pod2text() function. This
# tries to provide the same interface for legacy applications.
sub pod2text {
my @args;
# This is really ugly; I hate doing option parsing in the middle of a
# module. But the old Pod::Text module supported passing flags to its
# entry function, so handle -a and -<number>.
while ($_[0] =~ /^-/) {
my $flag = shift;
if ($flag eq '-a') { push (@args, alt => 1) }
elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) }
else {
unshift (@_, $flag);
last;
}
}
# Now that we know what arguments we're using, create the parser.
my $parser = Pod::PlainText->new (@args);
# If two arguments were given, the second argument is going to be a file
# handle. That means we want to call parse_from_filehandle(), which
# means we need to turn the first argument into a file handle. Magic
# open will handle the <&STDIN case automagically.
if (defined $_[1]) {
my $infh;
if ($] < 5.006) {
$infh = gensym();
}
unless (open ($infh, $_[0])) {
croak ("Can't open $_[0] for reading: $!\n");
}
$_[0] = $infh;
return $parser->parse_from_filehandle (@_);
} else {
return $parser->parse_from_file (@_);
}
}
############################################################################
# Module return value and documentation
############################################################################
1;
__END__
=head1 NAME
Pod::PlainText - Convert POD data to formatted ASCII text
=head1 SYNOPSIS
use Pod::PlainText;
my $parser = Pod::PlainText->new (sentence => 0, width => 78);
# Read POD from STDIN and write to STDOUT.
$parser->parse_from_filehandle;
# Read POD from file.pod and write to file.txt.
$parser->parse_from_file ('file.pod', 'file.txt');
=head1 DESCRIPTION
Pod::PlainText is a module that can convert documentation in the POD format (the
preferred language for documenting Perl) into formatted ASCII. It uses no
special formatting controls or codes whatsoever, and its output is therefore
suitable for nearly any device.
As a derived class from Pod::Parser, Pod::PlainText supports the same methods and
interfaces. See L<Pod::Parser> for all the details; briefly, one creates a
new parser with C<Pod::PlainText-E<gt>new()> and then calls either
parse_from_filehandle() or parse_from_file().
new() can take options, in the form of key/value pairs, that control the
behavior of the parser. The currently recognized options are:
=over 4
=item alt
If set to a true value, selects 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. Defaults to false.
=item indent
The number of spaces to indent regular text, and the default indentation for
C<=over> blocks. Defaults to 4.
=item loose
If set to a true value, a blank line is printed after a C<=headN> headings.
If set to false (the default), no blank line is printed after C<=headN>.
This is the default because it's the expected formatting for manual pages;
if you're formatting arbitrary text documents, setting this to true may
result in more pleasing output.
=item sentence
If set to a true value, Pod::PlainText will assume that each sentence ends in two
spaces, and will try to preserve that spacing. If set to false, all
consecutive whitespace in non-verbatim paragraphs is compressed into a
single space. Defaults to true.
=item width
The column at which to wrap text on the right-hand side. Defaults to 76.
=back
The standard Pod::Parser method parse_from_filehandle() takes up to two
arguments, the first being the file handle to read POD from and the second
being the file handle to write the formatted output to. The first defaults
to STDIN if not given, and the second defaults to STDOUT. The method
parse_from_file() is almost identical, except that its two arguments are the
input and output disk files instead. See L<Pod::Parser> for the specific
details.
=head1 DIAGNOSTICS
=over 4
=item Bizarre space in item
(W) Something has gone wrong in internal C<=item> processing. This message
indicates a bug in Pod::PlainText; you should never see it.
=item Can't open %s for reading: %s
(F) Pod::PlainText was invoked via the compatibility mode pod2text() interface
and the input file it was given could not be opened.
=item Unknown escape: %s
(W) The POD source contained an C<EE<lt>E<gt>> escape that Pod::PlainText didn't
know about.
=item Unknown sequence: %s
(W) The POD source contained a non-standard internal sequence (something of
the form C<XE<lt>E<gt>>) that Pod::PlainText didn't know about.
=item Unmatched =back
(W) Pod::PlainText encountered a C<=back> command that didn't correspond to an
C<=over> command.
=back
=head1 RESTRICTIONS
Embedded Ctrl-As (octal 001) in the input will be mapped to spaces on
output, due to an internal implementation detail.
=head1 NOTES
This is a replacement for an earlier Pod::Text module written by Tom
Christiansen. It has a revamped interface, since it now uses Pod::Parser,
but an interface roughly compatible with the old Pod::Text::pod2text()
function is still available. Please change to the new calling convention,
though.
The original Pod::Text contained code to do formatting via termcap
sequences, although it wasn't turned on by default and it was problematic to
get it to work at all. This rewrite doesn't even try to do that, but a
subclass of it does. Look for L<Pod::Text::Termcap|Pod::Text::Termcap>.
=head1 SEE ALSO
B<Pod::PlainText> is part of the L<Pod::Parser> distribution.
L<Pod::Parser|Pod::Parser>, L<Pod::Text::Termcap|Pod::Text::Termcap>,
pod2text(1)
=head1 AUTHOR
Please report bugs using L<http://rt.cpan.org>.
Russ Allbery E<lt>rra@stanford.eduE<gt>, based I<very> heavily on the
original Pod::Text by Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> and
its conversion to Pod::Parser by Brad Appleton
E<lt>bradapp@enteract.comE<gt>.
=cut
POD_PLAINTEXT
$fatpacked{"Pod/Select.pm"} = <<'POD_SELECT';
#############################################################################
# Pod/Select.pm -- function to select portions of POD docs
#
# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.
# This file is part of "PodParser". PodParser is free software;
# you can redistribute it and/or modify it under the same terms
# as Perl itself.
#############################################################################
package Pod::Select;
use strict;
use vars qw($VERSION @ISA @EXPORT $MAX_HEADING_LEVEL %myData @section_headings @selected_sections);
$VERSION = '1.60'; ## Current version of this package
require 5.005; ## requires this Perl version or later
#############################################################################
=head1 NAME
Pod::Select, podselect() - extract selected sections of POD from input
=head1 SYNOPSIS
use Pod::Select;
## Select all the POD sections for each file in @filelist
## and print the result on standard output.
podselect(@filelist);
## Same as above, but write to tmp.out
podselect({-output => "tmp.out"}, @filelist):
## Select from the given filelist, only those POD sections that are
## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS.
podselect({-sections => ["NAME|SYNOPSIS", "OPTIONS"]}, @filelist):
## Select the "DESCRIPTION" section of the PODs from STDIN and write
## the result to STDERR.
podselect({-output => ">&STDERR", -sections => ["DESCRIPTION"]}, \*STDIN);
or
use Pod::Select;
## Create a parser object for selecting POD sections from the input
$parser = new Pod::Select();
## Select all the POD sections for each file in @filelist
## and print the result to tmp.out.
$parser->parse_from_file("<&STDIN", "tmp.out");
## Select from the given filelist, only those POD sections that are
## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS.
$parser->select("NAME|SYNOPSIS", "OPTIONS");
for (@filelist) { $parser->parse_from_file($_); }
## Select the "DESCRIPTION" and "SEE ALSO" sections of the PODs from
## STDIN and write the result to STDERR.
$parser->select("DESCRIPTION");
$parser->add_selection("SEE ALSO");
$parser->parse_from_filehandle(\*STDIN, \*STDERR);
=head1 REQUIRES
perl5.005, Pod::Parser, Exporter, Carp
=head1 EXPORTS
podselect()
=head1 DESCRIPTION
B<podselect()> is a function which will extract specified sections of
pod documentation from an input stream. This ability is provided by the
B<Pod::Select> module which is a subclass of B<Pod::Parser>.
B<Pod::Select> provides a method named B<select()> to specify the set of
POD sections to select for processing/printing. B<podselect()> merely
creates a B<Pod::Select> object and then invokes the B<podselect()>
followed by B<parse_from_file()>.
=head1 SECTION SPECIFICATIONS
B<podselect()> and B<Pod::Select::select()> may be given one or more
"section specifications" to restrict the text processed to only the
desired set of sections and their corresponding subsections. A section
specification is a string containing one or more Perl-style regular
expressions separated by forward slashes ("/"). If you need to use a
forward slash literally within a section title you can escape it with a
backslash ("\/").
The formal syntax of a section specification is:
=over 4
=item *
I<head1-title-regex>/I<head2-title-regex>/...
=back
Any omitted or empty regular expressions will default to ".*".
Please note that each regular expression given is implicitly
anchored by adding "^" and "$" to the beginning and end. Also, if a
given regular expression starts with a "!" character, then the
expression is I<negated> (so C<!foo> would match anything I<except>
C<foo>).
Some example section specifications follow.
=over 4
=item *
Match the C<NAME> and C<SYNOPSIS> sections and all of their subsections:
C<NAME|SYNOPSIS>
=item *
Match only the C<Question> and C<Answer> subsections of the C<DESCRIPTION>
section:
C<DESCRIPTION/Question|Answer>
=item *
Match the C<Comments> subsection of I<all> sections:
C</Comments>
=item *
Match all subsections of C<DESCRIPTION> I<except> for C<Comments>:
C<DESCRIPTION/!Comments>
=item *
Match the C<DESCRIPTION> section but do I<not> match any of its subsections:
C<DESCRIPTION/!.+>
=item *
Match all top level sections but none of their subsections:
C</!.+>
=back
=begin _NOT_IMPLEMENTED_
=head1 RANGE SPECIFICATIONS
B<podselect()> and B<Pod::Select::select()> may be given one or more
"range specifications" to restrict the text processed to only the
desired ranges of paragraphs in the desired set of sections. A range
specification is a string containing a single Perl-style regular
expression (a regex), or else two Perl-style regular expressions
(regexs) separated by a ".." (Perl's "range" operator is "..").
The regexs in a range specification are delimited by forward slashes
("/"). If you need to use a forward slash literally within a regex you
can escape it with a backslash ("\/").
The formal syntax of a range specification is:
=over 4
=item *
/I<start-range-regex>/[../I<end-range-regex>/]
=back
Where each the item inside square brackets (the ".." followed by the
end-range-regex) is optional. Each "range-regex" is of the form:
=cmd-expr text-expr
Where I<cmd-expr> is intended to match the name of one or more POD
commands, and I<text-expr> is intended to match the paragraph text for
the command. If a range-regex is supposed to match a POD command, then
the first character of the regex (the one after the initial '/')
absolutely I<must> be a single '=' character; it may not be anything
else (not even a regex meta-character) if it is supposed to match
against the name of a POD command.
If no I<=cmd-expr> is given then the text-expr will be matched against
plain textblocks unless it is preceded by a space, in which case it is
matched against verbatim text-blocks. If no I<text-expr> is given then
only the command-portion of the paragraph is matched against.
Note that these two expressions are each implicitly anchored. This
means that when matching against the command-name, there will be an
implicit '^' and '$' around the given I<=cmd-expr>; and when matching
against the paragraph text there will be an implicit '\A' and '\Z'
around the given I<text-expr>.
Unlike with section-specs, the '!' character does I<not> have any special
meaning (negation or otherwise) at the beginning of a range-spec!
Some example range specifications follow.
=over 4
=item
Match all C<=for html> paragraphs:
C</=for html/>
=item
Match all paragraphs between C<=begin html> and C<=end html>
(note that this will I<not> work correctly if such sections
are nested):
C</=begin html/../=end html/>
=item
Match all paragraphs between the given C<=item> name until the end of the
current section:
C</=item mine/../=head\d/>
=item
Match all paragraphs between the given C<=item> until the next item, or
until the end of the itemized list (note that this will I<not> work as
desired if the item contains an itemized list nested within it):
C</=item mine/../=(item|back)/>
=back
=end _NOT_IMPLEMENTED_
=cut
#############################################################################
#use diagnostics;
use Carp;
use Pod::Parser 1.04;
@ISA = qw(Pod::Parser);
@EXPORT = qw(&podselect);
## Maximum number of heading levels supported for '=headN' directives
*MAX_HEADING_LEVEL = \3;
#############################################################################
=head1 OBJECT METHODS
The following methods are provided in this module. Each one takes a
reference to the object itself as an implicit first parameter.
=cut
##---------------------------------------------------------------------------
## =begin _PRIVATE_
##
## =head1 B<_init_headings()>
##
## Initialize the current set of active section headings.
##
## =cut
##
## =end _PRIVATE_
sub _init_headings {
my $self = shift;
local *myData = $self;
## Initialize current section heading titles if necessary
unless (defined $myData{_SECTION_HEADINGS}) {
local *section_headings = $myData{_SECTION_HEADINGS} = [];
for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
$section_headings[$i] = '';
}
}
}
##---------------------------------------------------------------------------
=head1 B<curr_headings()>
($head1, $head2, $head3, ...) = $parser->curr_headings();
$head1 = $parser->curr_headings(1);
This method returns a list of the currently active section headings and
subheadings in the document being parsed. The list of headings returned
corresponds to the most recently parsed paragraph of the input.
If an argument is given, it must correspond to the desired section
heading number, in which case only the specified section heading is
returned. If there is no current section heading at the specified
level, then C<undef> is returned.
=cut
sub curr_headings {
my $self = shift;
$self->_init_headings() unless (defined $self->{_SECTION_HEADINGS});
my @headings = @{ $self->{_SECTION_HEADINGS} };
return (@_ > 0 and $_[0] =~ /^\d+$/) ? $headings[$_[0] - 1] : @headings;
}
##---------------------------------------------------------------------------
=head1 B<select()>
$parser->select($section_spec1,$section_spec2,...);
This method is used to select the particular sections and subsections of
POD documentation that are to be printed and/or processed. The existing
set of selected sections is I<replaced> with the given set of sections.
See B<add_selection()> for adding to the current set of selected
sections.
Each of the C<$section_spec> arguments should be a section specification
as described in L<"SECTION SPECIFICATIONS">. The section specifications
are parsed by this method and the resulting regular expressions are
stored in the invoking object.
If no C<$section_spec> arguments are given, then the existing set of
selected sections is cleared out (which means C<all> sections will be
processed).
This method should I<not> normally be overridden by subclasses.
=cut
sub select {
my ($self, @sections) = @_;
local *myData = $self;
local $_;
### NEED TO DISCERN A SECTION-SPEC FROM A RANGE-SPEC (look for m{^/.+/$}?)
##---------------------------------------------------------------------
## The following is a blatant hack for backward compatibility, and for
## implementing add_selection(). If the *first* *argument* is the
## string "+", then the remaining section specifications are *added*
## to the current set of selections; otherwise the given section
## specifications will *replace* the current set of selections.
##
## This should probably be fixed someday, but for the present time,
## it seems incredibly unlikely that "+" would ever correspond to
## a legitimate section heading
##---------------------------------------------------------------------
my $add = ($sections[0] eq '+') ? shift(@sections) : '';
## Reset the set of sections to use
unless (@sections) {
delete $myData{_SELECTED_SECTIONS} unless ($add);
return;
}
$myData{_SELECTED_SECTIONS} = []
unless ($add && exists $myData{_SELECTED_SECTIONS});
local *selected_sections = $myData{_SELECTED_SECTIONS};
## Compile each spec
for my $spec (@sections) {
if ( defined($_ = _compile_section_spec($spec)) ) {
## Store them in our sections array
push(@selected_sections, $_);
}
else {
carp qq{Ignoring section spec "$spec"!\n};
}
}
}
##---------------------------------------------------------------------------
=head1 B<add_selection()>
$parser->add_selection($section_spec1,$section_spec2,...);
This method is used to add to the currently selected sections and
subsections of POD documentation that are to be printed and/or
processed. See <select()> for replacing the currently selected sections.
Each of the C<$section_spec> arguments should be a section specification
as described in L<"SECTION SPECIFICATIONS">. The section specifications
are parsed by this method and the resulting regular expressions are
stored in the invoking object.
This method should I<not> normally be overridden by subclasses.
=cut
sub add_selection {
my $self = shift;
return $self->select('+', @_);
}
##---------------------------------------------------------------------------
=head1 B<clear_selections()>
$parser->clear_selections();
This method takes no arguments, it has the exact same effect as invoking
<select()> with no arguments.
=cut
sub clear_selections {
my $self = shift;
return $self->select();
}
##---------------------------------------------------------------------------
=head1 B<match_section()>
$boolean = $parser->match_section($heading1,$heading2,...);
Returns a value of true if the given section and subsection heading
titles match any of the currently selected section specifications in
effect from prior calls to B<select()> and B<add_selection()> (or if
there are no explicitly selected/deselected sections).
The arguments C<$heading1>, C<$heading2>, etc. are the heading titles of
the corresponding sections, subsections, etc. to try and match. If
C<$headingN> is omitted then it defaults to the current corresponding
section heading title in the input.
This method should I<not> normally be overridden by subclasses.
=cut
sub match_section {
my $self = shift;
my (@headings) = @_;
local *myData = $self;
## Return true if no restrictions were explicitly specified
my $selections = (exists $myData{_SELECTED_SECTIONS})
? $myData{_SELECTED_SECTIONS} : undef;
return 1 unless ((defined $selections) && @{$selections});
## Default any unspecified sections to the current one
my @current_headings = $self->curr_headings();
for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
(defined $headings[$i]) or $headings[$i] = $current_headings[$i];
}
## Look for a match against the specified section expressions
for my $section_spec ( @{$selections} ) {
##------------------------------------------------------
## Each portion of this spec must match in order for
## the spec to be matched. So we will start with a
## match-value of 'true' and logically 'and' it with
## the results of matching a given element of the spec.
##------------------------------------------------------
my $match = 1;
for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
my $regex = $section_spec->[$i];
my $negated = ($regex =~ s/^\!//);
$match &= ($negated ? ($headings[$i] !~ /${regex}/)
: ($headings[$i] =~ /${regex}/));
last unless ($match);
}
return 1 if ($match);
}
return 0; ## no match
}
##---------------------------------------------------------------------------
=head1 B<is_selected()>
$boolean = $parser->is_selected($paragraph);
This method is used to determine if the block of text given in
C<$paragraph> falls within the currently selected set of POD sections
and subsections to be printed or processed. This method is also
responsible for keeping track of the current input section and
subsections. It is assumed that C<$paragraph> is the most recently read
(but not yet processed) input paragraph.
The value returned will be true if the C<$paragraph> and the rest of the
text in the same section as C<$paragraph> should be selected (included)
for processing; otherwise a false value is returned.
=cut
sub is_selected {
my ($self, $paragraph) = @_;
local $_;
local *myData = $self;
$self->_init_headings() unless (defined $myData{_SECTION_HEADINGS});
## Keep track of current sections levels and headings
$_ = $paragraph;
if (/^=((?:sub)*)(?:head(?:ing)?|sec(?:tion)?)(\d*)\s+(.*?)\s*$/)
{
## This is a section heading command
my ($level, $heading) = ($2, $3);
$level = 1 + (length($1) / 3) if ((! length $level) || (length $1));
## Reset the current section heading at this level
$myData{_SECTION_HEADINGS}->[$level - 1] = $heading;
## Reset subsection headings of this one to empty
for (my $i = $level; $i < $MAX_HEADING_LEVEL; ++$i) {
$myData{_SECTION_HEADINGS}->[$i] = '';
}
}
return $self->match_section();
}
#############################################################################
=head1 EXPORTED FUNCTIONS
The following functions are exported by this module. Please note that
these are functions (not methods) and therefore C<do not> take an
implicit first argument.
=cut
##---------------------------------------------------------------------------
=head1 B<podselect()>
podselect(\%options,@filelist);
B<podselect> will print the raw (untranslated) POD paragraphs of all
POD sections in the given input files specified by C<@filelist>
according to the given options.
If any argument to B<podselect> is a reference to a hash
(associative array) then the values with the following keys are
processed as follows:
=over 4
=item B<-output>
A string corresponding to the desired output file (or ">&STDOUT"
or ">&STDERR"). The default is to use standard output.
=item B<-sections>
A reference to an array of sections specifications (as described in
L<"SECTION SPECIFICATIONS">) which indicate the desired set of POD
sections and subsections to be selected from input. If no section
specifications are given, then all sections of the PODs are used.
=begin _NOT_IMPLEMENTED_
=item B<-ranges>
A reference to an array of range specifications (as described in
L<"RANGE SPECIFICATIONS">) which indicate the desired range of POD
paragraphs to be selected from the desired input sections. If no range
specifications are given, then all paragraphs of the desired sections
are used.
=end _NOT_IMPLEMENTED_
=back
All other arguments should correspond to the names of input files
containing POD sections. A file name of "-" or "<&STDIN" will
be interpreted to mean standard input (which is the default if no
filenames are given).
=cut
sub podselect {
my(@argv) = @_;
my %defaults = ();
my $pod_parser = new Pod::Select(%defaults);
my $num_inputs = 0;
my $output = '>&STDOUT';
my %opts;
local $_;
for (@argv) {
if (ref($_)) {
next unless (ref($_) eq 'HASH');
%opts = (%defaults, %{$_});
##-------------------------------------------------------------
## Need this for backward compatibility since we formerly used
## options that were all uppercase words rather than ones that
## looked like Unix command-line options.
## to be uppercase keywords)
##-------------------------------------------------------------
%opts = map {
my ($key, $val) = (lc $_, $opts{$_});
$key =~ s/^(?=\w)/-/;
$key =~ /^-se[cl]/ and $key = '-sections';
#! $key eq '-range' and $key .= 's';
($key => $val);
} (keys %opts);
## Process the options
(exists $opts{'-output'}) and $output = $opts{'-output'};
## Select the desired sections
$pod_parser->select(@{ $opts{'-sections'} })
if ( (defined $opts{'-sections'})
&& ((ref $opts{'-sections'}) eq 'ARRAY') );
#! ## Select the desired paragraph ranges
#! $pod_parser->select(@{ $opts{'-ranges'} })
#! if ( (defined $opts{'-ranges'})
#! && ((ref $opts{'-ranges'}) eq 'ARRAY') );
}
else {
$pod_parser->parse_from_file($_, $output);
++$num_inputs;
}
}
$pod_parser->parse_from_file('-') unless ($num_inputs > 0);
}
#############################################################################
=head1 PRIVATE METHODS AND DATA
B<Pod::Select> makes uses a number of internal methods and data fields
which clients should not need to see or use. For the sake of avoiding
name collisions with client data and methods, these methods and fields
are briefly discussed here. Determined hackers may obtain further
information about them by reading the B<Pod::Select> source code.
Private data fields are stored in the hash-object whose reference is
returned by the B<new()> constructor for this class. The names of all
private methods and data-fields used by B<Pod::Select> begin with a
prefix of "_" and match the regular expression C</^_\w+$/>.
=cut
##---------------------------------------------------------------------------
=begin _PRIVATE_
=head1 B<_compile_section_spec()>
$listref = $parser->_compile_section_spec($section_spec);
This function (note it is a function and I<not> a method) takes a
section specification (as described in L<"SECTION SPECIFICATIONS">)
given in C<$section_sepc>, and compiles it into a list of regular
expressions. If C<$section_spec> has no syntax errors, then a reference
to the list (array) of corresponding regular expressions is returned;
otherwise C<undef> is returned and an error message is printed (using
B<carp>) for each invalid regex.
=end _PRIVATE_
=cut
sub _compile_section_spec {
my ($section_spec) = @_;
my (@regexs, $negated);
## Compile the spec into a list of regexs
local $_ = $section_spec;
s{\\\\}{\001}g; ## handle escaped backward slashes
s{\\/}{\002}g; ## handle escaped forward slashes
## Parse the regexs for the heading titles
@regexs = split(/\//, $_, $MAX_HEADING_LEVEL);
## Set default regex for ommitted levels
for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
$regexs[$i] = '.*' unless ((defined $regexs[$i])
&& (length $regexs[$i]));
}
## Modify the regexs as needed and validate their syntax
my $bad_regexs = 0;
for (@regexs) {
$_ .= '.+' if ($_ eq '!');
s{\001}{\\\\}g; ## restore escaped backward slashes
s{\002}{\\/}g; ## restore escaped forward slashes
$negated = s/^\!//; ## check for negation
eval "m{$_}"; ## check regex syntax
if ($@) {
++$bad_regexs;
carp qq{Bad regular expression /$_/ in "$section_spec": $@\n};
}
else {
## Add the forward and rear anchors (and put the negator back)
$_ = '^' . $_ unless (/^\^/);
$_ = $_ . '$' unless (/\$$/);
$_ = '!' . $_ if ($negated);
}
}
return (! $bad_regexs) ? [ @regexs ] : undef;
}
##---------------------------------------------------------------------------
=begin _PRIVATE_
=head2 $self->{_SECTION_HEADINGS}
A reference to an array of the current section heading titles for each
heading level (note that the first heading level title is at index 0).
=end _PRIVATE_
=cut
##---------------------------------------------------------------------------
=begin _PRIVATE_
=head2 $self->{_SELECTED_SECTIONS}
A reference to an array of references to arrays. Each subarray is a list
of anchored regular expressions (preceded by a "!" if the expression is to
be negated). The index of the expression in the subarray should correspond
to the index of the heading title in C<$self-E<gt>{_SECTION_HEADINGS}>
that it is to be matched against.
=end _PRIVATE_
=cut
#############################################################################
=head1 SEE ALSO
L<Pod::Parser>
=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> written by
Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
B<Pod::Select> is part of the L<Pod::Parser> distribution.
=cut
1;
# vim: ts=4 sw=4 et
POD_SELECT
$fatpacked{"Pod/Simple.pm"} = <<'POD_SIMPLE';
require 5;
package Pod::Simple;
use strict;
use Carp ();
BEGIN { *DEBUG = sub () {0} unless defined &DEBUG }
use integer;
use Pod::Escapes 1.04 ();
use Pod::Simple::LinkSection ();
use Pod::Simple::BlackBox ();
#use utf8;
use vars qw(
$VERSION @ISA
@Known_formatting_codes @Known_directives
%Known_formatting_codes %Known_directives
$NL
);
@ISA = ('Pod::Simple::BlackBox');
$VERSION = '3.26';
@Known_formatting_codes = qw(I B C L E F S X Z);
%Known_formatting_codes = map(($_=>1), @Known_formatting_codes);
@Known_directives = qw(head1 head2 head3 head4 item over back);
%Known_directives = map(($_=>'Plain'), @Known_directives);
$NL = $/ unless defined $NL;
#-----------------------------------------------------------------------------
# Set up some constants:
BEGIN {
if(defined &ASCII) { }
elsif(chr(65) eq 'A') { *ASCII = sub () {1} }
else { *ASCII = sub () {''} }
unless(defined &MANY_LINES) { *MANY_LINES = sub () {20} }
DEBUG > 4 and print "MANY_LINES is ", MANY_LINES(), "\n";
unless(MANY_LINES() >= 1) {
die "MANY_LINES is too small (", MANY_LINES(), ")!\nAborting";
}
if(defined &UNICODE) { }
elsif($] >= 5.008) { *UNICODE = sub() {1} }
else { *UNICODE = sub() {''} }
}
if(DEBUG > 2) {
print "# We are ", ASCII ? '' : 'not ', "in ASCII-land\n";
print "# We are under a Unicode-safe Perl.\n";
}
# Design note:
# This is a parser for Pod. It is not a parser for the set of Pod-like
# languages which happens to contain Pod -- it is just for Pod, plus possibly
# some extensions.
# @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @
#@ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
__PACKAGE__->_accessorize(
'nbsp_for_S', # Whether to map S<...>'s to \xA0 characters
'source_filename', # Filename of the source, for use in warnings
'source_dead', # Whether to consider this parser's source dead
'output_fh', # The filehandle we're writing to, if applicable.
# Used only in some derived classes.
'hide_line_numbers', # For some dumping subclasses: whether to pointedly
# suppress the start_line attribute
'line_count', # the current line number
'pod_para_count', # count of pod paragraphs seen so far
'no_whining', # whether to suppress whining
'no_errata_section', # whether to suppress the errata section
'complain_stderr', # whether to complain to stderr
'doc_has_started', # whether we've fired the open-Document event yet
'bare_output', # For some subclasses: whether to prepend
# header-code and postpend footer-code
'nix_X_codes', # whether to ignore X<...> codes
'merge_text', # whether to avoid breaking a single piece of
# text up into several events
'preserve_whitespace', # whether to try to keep whitespace as-is
'strip_verbatim_indent', # What indent to strip from verbatim
'parse_characters', # Whether parser should expect chars rather than octets
'content_seen', # whether we've seen any real Pod content
'errors_seen', # TODO: document. whether we've seen any errors (fatal or not)
'codes_in_verbatim', # for PseudoPod extensions
'code_handler', # coderef to call when a code (non-pod) line is seen
'cut_handler', # ... when a =cut line is seen
'pod_handler', # ... when a =pod line is seen
'whiteline_handler', # ... when a line with only whitespace is seen
#Called like:
# $code_handler->($line, $self->{'line_count'}, $self) if $code_handler;
# $cut_handler->($line, $self->{'line_count'}, $self) if $cut_handler;
# $pod_handler->($line, $self->{'line_count'}, $self) if $pod_handler;
# $wl_handler->($line, $self->{'line_count'}, $self) if $wl_handler;
'parse_empty_lists', # whether to acknowledge empty =over/=back blocks
);
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub any_errata_seen { # good for using as an exit() value...
return shift->{'errors_seen'} || 0;
}
# Returns the encoding only if it was recognized as being handled and set
sub detected_encoding {
return shift->{'detected_encoding'};
}
sub encoding {
my $this = shift;
return $this->{'encoding'} unless @_; # GET.
$this->_handle_encoding_line("=encoding $_[0]");
if ($this->{'_processed_encoding'}) {
delete $this->{'_processed_encoding'};
if(! $this->{'encoding_command_statuses'} ) {
DEBUG > 2 and print " CRAZY ERROR: encoding wasn't really handled?!\n";
} elsif( $this->{'encoding_command_statuses'}[-1] ) {
$this->scream( "=encoding $_[0]",
sprintf "Couldn't do %s: %s",
$this->{'encoding_command_reqs' }[-1],
$this->{'encoding_command_statuses'}[-1],
);
} else {
DEBUG > 2 and print " (encoding successfully handled.)\n";
}
return $this->{'encoding'};
} else {
return undef;
}
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Pull in some functions that, for some reason, I expect to see here too:
BEGIN {
*pretty = \&Pod::Simple::BlackBox::pretty;
*stringify_lol = \&Pod::Simple::BlackBox::stringify_lol;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub version_report {
my $class = ref($_[0]) || $_[0];
if($class eq __PACKAGE__) {
return "$class $VERSION";
} else {
my $v = $class->VERSION;
return "$class $v (" . __PACKAGE__ . " $VERSION)";
}
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#sub curr_open { # read-only list accessor
# return @{ $_[0]{'curr_open'} || return() };
#}
#sub _curr_open_listref { $_[0]{'curr_open'} ||= [] }
sub output_string {
# Works by faking out output_fh. Simplifies our code.
#
my $this = shift;
return $this->{'output_string'} unless @_; # GET.
require Pod::Simple::TiedOutFH;
my $x = (defined($_[0]) and ref($_[0])) ? $_[0] : \( $_[0] );
$$x = '' unless defined $$x;
DEBUG > 4 and print "# Output string set to $x ($$x)\n";
$this->{'output_fh'} = Pod::Simple::TiedOutFH->handle_on($_[0]);
return
$this->{'output_string'} = $_[0];
#${ ${ $this->{'output_fh'} } };
}
sub abandon_output_string { $_[0]->abandon_output_fh; delete $_[0]{'output_string'} }
sub abandon_output_fh { $_[0]->output_fh(undef) }
# These don't delete the string or close the FH -- they just delete our
# references to it/them.
# TODO: document these
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub new {
# takes no parameters
my $class = ref($_[0]) || $_[0];
#Carp::croak(__PACKAGE__ . " is a virtual base class -- see perldoc "
# . __PACKAGE__ );
return bless {
'accept_codes' => { map( ($_=>$_), @Known_formatting_codes ) },
'accept_directives' => { %Known_directives },
'accept_targets' => {},
}, $class;
}
# TODO: an option for whether to interpolate E<...>'s, or just resolve to codes.
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub _handle_element_start { # OVERRIDE IN DERIVED CLASS
my($self, $element_name, $attr_hash_r) = @_;
return;
}
sub _handle_element_end { # OVERRIDE IN DERIVED CLASS
my($self, $element_name) = @_;
return;
}
sub _handle_text { # OVERRIDE IN DERIVED CLASS
my($self, $text) = @_;
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#
# And now directives (not targets)
sub accept_directive_as_verbatim { shift->_accept_directives('Verbatim', @_) }
sub accept_directive_as_data { shift->_accept_directives('Data', @_) }
sub accept_directive_as_processed { shift->_accept_directives('Plain', @_) }
sub _accept_directives {
my($this, $type) = splice @_,0,2;
foreach my $d (@_) {
next unless defined $d and length $d;
Carp::croak "\"$d\" isn't a valid directive name"
unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s;
Carp::croak "\"$d\" is already a reserved Pod directive name"
if exists $Known_directives{$d};
$this->{'accept_directives'}{$d} = $type;
DEBUG > 2 and print "Learning to accept \"=$d\" as directive of type $type\n";
}
DEBUG > 6 and print "$this\'s accept_directives : ",
pretty($this->{'accept_directives'}), "\n";
return sort keys %{ $this->{'accept_directives'} } if wantarray;
return;
}
#--------------------------------------------------------------------------
# TODO: document these:
sub unaccept_directive { shift->unaccept_directives(@_) };
sub unaccept_directives {
my $this = shift;
foreach my $d (@_) {
next unless defined $d and length $d;
Carp::croak "\"$d\" isn't a valid directive name"
unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s;
Carp::croak "But you must accept \"$d\" directives -- it's a builtin!"
if exists $Known_directives{$d};
delete $this->{'accept_directives'}{$d};
DEBUG > 2 and print "OK, won't accept \"=$d\" as directive.\n";
}
return sort keys %{ $this->{'accept_directives'} } if wantarray;
return
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#
# And now targets (not directives)
sub accept_target { shift->accept_targets(@_) } # alias
sub accept_target_as_text { shift->accept_targets_as_text(@_) } # alias
sub accept_targets { shift->_accept_targets('1', @_) }
sub accept_targets_as_text { shift->_accept_targets('force_resolve', @_) }
# forces them to be processed, even when there's no ":".
sub _accept_targets {
my($this, $type) = splice @_,0,2;
foreach my $t (@_) {
next unless defined $t and length $t;
# TODO: enforce some limitations on what a target name can be?
$this->{'accept_targets'}{$t} = $type;
DEBUG > 2 and print "Learning to accept \"$t\" as target of type $type\n";
}
return sort keys %{ $this->{'accept_targets'} } if wantarray;
return;
}
#--------------------------------------------------------------------------
sub unaccept_target { shift->unaccept_targets(@_) }
sub unaccept_targets {
my $this = shift;
foreach my $t (@_) {
next unless defined $t and length $t;
# TODO: enforce some limitations on what a target name can be?
delete $this->{'accept_targets'}{$t};
DEBUG > 2 and print "OK, won't accept \"$t\" as target.\n";
}
return sort keys %{ $this->{'accept_targets'} } if wantarray;
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#
# And now codes (not targets or directives)
sub accept_code { shift->accept_codes(@_) } # alias
sub accept_codes { # Add some codes
my $this = shift;
foreach my $new_code (@_) {
next unless defined $new_code and length $new_code;
if(ASCII) {
# A good-enough check that it's good as an XML Name symbol:
Carp::croak "\"$new_code\" isn't a valid element name"
if $new_code =~
m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/
# Characters under 0x80 that aren't legal in an XML Name.
or $new_code =~ m/^[-\.0-9]/s
or $new_code =~ m/:[-\.0-9]/s;
# The legal under-0x80 Name characters that
# an XML Name still can't start with.
}
$this->{'accept_codes'}{$new_code} = $new_code;
# Yes, map to itself -- just so that when we
# see "=extend W [whatever] thatelementname", we say that W maps
# to whatever $this->{accept_codes}{thatelementname} is,
# i.e., "thatelementname". Then when we go re-mapping,
# a "W" in the treelet turns into "thatelementname". We only
# remap once.
# If we say we accept "W", then a "W" in the treelet simply turns
# into "W".
}
return;
}
#--------------------------------------------------------------------------
sub unaccept_code { shift->unaccept_codes(@_) }
sub unaccept_codes { # remove some codes
my $this = shift;
foreach my $new_code (@_) {
next unless defined $new_code and length $new_code;
if(ASCII) {
# A good-enough check that it's good as an XML Name symbol:
Carp::croak "\"$new_code\" isn't a valid element name"
if $new_code =~
m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/
# Characters under 0x80 that aren't legal in an XML Name.
or $new_code =~ m/^[-\.0-9]/s
or $new_code =~ m/:[-\.0-9]/s;
# The legal under-0x80 Name characters that
# an XML Name still can't start with.
}
Carp::croak "But you must accept \"$new_code\" codes -- it's a builtin!"
if grep $new_code eq $_, @Known_formatting_codes;
delete $this->{'accept_codes'}{$new_code};
DEBUG > 2 and print "OK, won't accept the code $new_code<...>.\n";
}
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub parse_string_document {
my $self = shift;
my @lines;
foreach my $line_group (@_) {
next unless defined $line_group and length $line_group;
pos($line_group) = 0;
while($line_group =~
m/([^\n\r]*)(\r?\n?)/g # supports \r, \n ,\r\n
#m/([^\n\r]*)((?:\r?\n)?)/g
) {
#print(">> $1\n"),
$self->parse_lines($1)
if length($1) or length($2)
or pos($line_group) != length($line_group);
# I.e., unless it's a zero-length "empty line" at the very
# end of "foo\nbar\n" (i.e., between the \n and the EOS).
}
}
$self->parse_lines(undef); # to signal EOF
return $self;
}
sub _init_fh_source {
my($self, $source) = @_;
#DEBUG > 1 and print "Declaring $source as :raw for starters\n";
#$self->_apply_binmode($source, ':raw');
#binmode($source, ":raw");
return;
}
#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
#
sub parse_file {
my($self, $source) = (@_);
if(!defined $source) {
Carp::croak("Can't use empty-string as a source for parse_file");
} elsif(ref(\$source) eq 'GLOB') {
$self->{'source_filename'} = '' . ($source);
} elsif(ref $source) {
$self->{'source_filename'} = '' . ($source);
} elsif(!length $source) {
Carp::croak("Can't use empty-string as a source for parse_file");
} else {
{
local *PODSOURCE;
open(PODSOURCE, "<$source") || Carp::croak("Can't open $source: $!");
$self->{'source_filename'} = $source;
$source = *PODSOURCE{IO};
}
$self->_init_fh_source($source);
}
# By here, $source is a FH.
$self->{'source_fh'} = $source;
my($i, @lines);
until( $self->{'source_dead'} ) {
splice @lines;
for($i = MANY_LINES; $i--;) { # read those many lines at a time
local $/ = $NL;
push @lines, scalar(<$source>); # readline
last unless defined $lines[-1];
# but pass thru the undef, which will set source_dead to true
}
my $at_eof = ! $lines[-1]; # keep track of the undef
pop @lines if $at_eof; # silence warnings
# be eol agnostic
s/\r\n?/\n/g for @lines;
# make sure there are only one line elements for parse_lines
@lines = split(/(?<=\n)/, join('', @lines));
# push the undef back after popping it to set source_dead to true
push @lines, undef if $at_eof;
$self->parse_lines(@lines);
}
delete($self->{'source_fh'}); # so it can be GC'd
return $self;
}
#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
sub parse_from_file {
# An emulation of Pod::Parser's interface, for the sake of Perldoc.
# Basically just a wrapper around parse_file.
my($self, $source, $to) = @_;
$self = $self->new unless ref($self); # so we tolerate being a class method
if(!defined $source) { $source = *STDIN{IO}
} elsif(ref(\$source) eq 'GLOB') { # stet
} elsif(ref($source) ) { # stet
} elsif(!length $source
or $source eq '-' or $source =~ m/^<&(STDIN|0)$/i
) {
$source = *STDIN{IO};
}
if(!defined $to) { $self->output_fh( *STDOUT{IO} );
} elsif(ref(\$to) eq 'GLOB') { $self->output_fh( $to );
} elsif(ref($to)) { $self->output_fh( $to );
} elsif(!length $to
or $to eq '-' or $to =~ m/^>&?(?:STDOUT|1)$/i
) {
$self->output_fh( *STDOUT{IO} );
} else {
require Symbol;
my $out_fh = Symbol::gensym();
DEBUG and print "Write-opening to $to\n";
open($out_fh, ">$to") or Carp::croak "Can't write-open $to: $!";
binmode($out_fh)
if $self->can('write_with_binmode') and $self->write_with_binmode;
$self->output_fh($out_fh);
}
return $self->parse_file($source);
}
#-----------------------------------------------------------------------------
sub whine {
#my($self,$line,$complaint) = @_;
my $self = shift(@_);
++$self->{'errors_seen'};
if($self->{'no_whining'}) {
DEBUG > 9 and print "Discarding complaint (at line $_[0]) $_[1]\n because no_whining is on.\n";
return;
}
return $self->_complain_warn(@_) if $self->{'complain_stderr'};
return $self->_complain_errata(@_);
}
sub scream { # like whine, but not suppressible
#my($self,$line,$complaint) = @_;
my $self = shift(@_);
++$self->{'errors_seen'};
return $self->_complain_warn(@_) if $self->{'complain_stderr'};
return $self->_complain_errata(@_);
}
sub _complain_warn {
my($self,$line,$complaint) = @_;
return printf STDERR "%s around line %s: %s\n",
$self->{'source_filename'} || 'Pod input', $line, $complaint;
}
sub _complain_errata {
my($self,$line,$complaint) = @_;
if( $self->{'no_errata_section'} ) {
DEBUG > 9 and print "Discarding erratum (at line $line) $complaint\n because no_errata_section is on.\n";
} else {
DEBUG > 9 and print "Queuing erratum (at line $line) $complaint\n";
push @{$self->{'errata'}{$line}}, $complaint
# for a report to be generated later!
}
return 1;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub _get_initial_item_type {
# A hack-wrapper here for when you have like "=over\n\n=item 456\n\n"
my($self, $para) = @_;
return $para->[1]{'~type'} if $para->[1]{'~type'};
return $para->[1]{'~type'} = 'text'
if join("\n", @{$para}[2 .. $#$para]) =~ m/^\s*(\d+)\.?\s*$/s and $1 ne '1';
# Else fall thru to the general case:
return $self->_get_item_type($para);
}
sub _get_item_type { # mutates the item!!
my($self, $para) = @_;
return $para->[1]{'~type'} if $para->[1]{'~type'};
# Otherwise we haven't yet been to this node. Maybe alter it...
my $content = join "\n", @{$para}[2 .. $#$para];
if($content =~ m/^\s*\*\s*$/s or $content =~ m/^\s*$/s) {
# Like: "=item *", "=item * ", "=item"
splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
$para->[1]{'~orig_content'} = $content;
return $para->[1]{'~type'} = 'bullet';
} elsif($content =~ m/^\s*\*\s+(.+)/s) { # tolerance
# Like: "=item * Foo bar baz";
$para->[1]{'~orig_content'} = $content;
$para->[1]{'~_freaky_para_hack'} = $1;
DEBUG > 2 and print " Tolerating $$para[2] as =item *\\n\\n$1\n";
splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
return $para->[1]{'~type'} = 'bullet';
} elsif($content =~ m/^\s*(\d+)\.?\s*$/s) {
# Like: "=item 1.", "=item 123412"
$para->[1]{'~orig_content'} = $content;
$para->[1]{'number'} = $1; # Yes, stores the number there!
splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
return $para->[1]{'~type'} = 'number';
} else {
# It's anything else.
return $para->[1]{'~type'} = 'text';
}
}
#-----------------------------------------------------------------------------
sub _make_treelet {
my $self = shift; # and ($para, $start_line)
my $treelet;
if(!@_) {
return [''];
} if(ref $_[0] and ref $_[0][0] and $_[0][0][0] eq '~Top') {
# Hack so we can pass in fake-o pre-cooked paragraphs:
# just have the first line be a reference to a ['~Top', {}, ...]
# We use this feechure in gen_errata and stuff.
DEBUG and print "Applying precooked treelet hack to $_[0][0]\n";
$treelet = $_[0][0];
splice @$treelet, 0, 2; # lop the top off
return $treelet;
} else {
$treelet = $self->_treelet_from_formatting_codes(@_);
}
if( $self->_remap_sequences($treelet) ) {
$self->_treat_Zs($treelet); # Might as well nix these first
$self->_treat_Ls($treelet); # L has to precede E and S
$self->_treat_Es($treelet);
$self->_treat_Ss($treelet); # S has to come after E
$self->_wrap_up($treelet); # Nix X's and merge texties
} else {
DEBUG and print "Formatless treelet gets fast-tracked.\n";
# Very common case!
}
splice @$treelet, 0, 2; # lop the top off
return $treelet;
}
#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
sub _wrap_up {
my($self, @stack) = @_;
my $nixx = $self->{'nix_X_codes'};
my $merge = $self->{'merge_text' };
return unless $nixx or $merge;
DEBUG > 2 and print "\nStarting _wrap_up traversal.\n",
$merge ? (" Merge mode on\n") : (),
$nixx ? (" Nix-X mode on\n") : (),
;
my($i, $treelet);
while($treelet = shift @stack) {
DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n";
for($i = 2; $i < @$treelet; ++$i) { # iterate over children
DEBUG > 3 and print " Considering child at $i ", pretty($treelet->[$i]), "\n";
if($nixx and ref $treelet->[$i] and $treelet->[$i][0] eq 'X') {
DEBUG > 3 and print " Nixing X node at $i\n";
splice(@$treelet, $i, 1); # just nix this node (and its descendants)
# no need to back-update the counter just yet
redo;
} elsif($merge and $i != 2 and # non-initial
!ref $treelet->[$i] and !ref $treelet->[$i - 1]
) {
DEBUG > 3 and print " Merging ", $i-1,
":[$treelet->[$i-1]] and $i\:[$treelet->[$i]]\n";
$treelet->[$i-1] .= ( splice(@$treelet, $i, 1) )[0];
DEBUG > 4 and print " Now: ", $i-1, ":[$treelet->[$i-1]]\n";
--$i;
next;
# since we just pulled the possibly last node out from under
# ourselves, we can't just redo()
} elsif( ref $treelet->[$i] ) {
DEBUG > 4 and print " Enqueuing ", pretty($treelet->[$i]), " for traversal.\n";
push @stack, $treelet->[$i];
if($treelet->[$i][0] eq 'L') {
my $thing;
foreach my $attrname ('section', 'to') {
if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) {
unshift @stack, $thing;
DEBUG > 4 and print " +Enqueuing ",
pretty( $treelet->[$i][1]{$attrname} ),
" as an attribute value to tweak.\n";
}
}
}
}
}
}
DEBUG > 2 and print "End of _wrap_up traversal.\n\n";
return;
}
#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
sub _remap_sequences {
my($self,@stack) = @_;
if(@stack == 1 and @{ $stack[0] } == 3 and !ref $stack[0][2]) {
# VERY common case: abort it.
DEBUG and print "Skipping _remap_sequences: formatless treelet.\n";
return 0;
}
my $map = ($self->{'accept_codes'} || die "NO accept_codes in $self?!?");
my $start_line = $stack[0][1]{'start_line'};
DEBUG > 2 and printf
"\nAbout to start _remap_sequences on treelet from line %s.\n",
$start_line || '[?]'
;
DEBUG > 3 and print " Map: ",
join('; ', map "$_=" . (
ref($map->{$_}) ? join(",", @{$map->{$_}}) : $map->{$_}
),
sort keys %$map ),
("B~C~E~F~I~L~S~X~Z" eq join '~', sort keys %$map)
? " (all normal)\n" : "\n"
;
# A recursive algorithm implemented iteratively! Whee!
my($is, $was, $i, $treelet); # scratch
while($treelet = shift @stack) {
DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n";
for($i = 2; $i < @$treelet; ++$i) { # iterate over children
next unless ref $treelet->[$i]; # text nodes are uninteresting
DEBUG > 4 and print " Noting child $i : $treelet->[$i][0]<...>\n";
$is = $treelet->[$i][0] = $map->{ $was = $treelet->[$i][0] };
if( DEBUG > 3 ) {
if(!defined $is) {
print " Code $was<> is UNKNOWN!\n";
} elsif($is eq $was) {
DEBUG > 4 and print " Code $was<> stays the same.\n";
} else {
print " Code $was<> maps to ",
ref($is)
? ( "tags ", map("$_<", @$is), '...', map('>', @$is), "\n" )
: "tag $is<...>.\n";
}
}
if(!defined $is) {
$self->whine($start_line, "Deleting unknown formatting code $was<>");
$is = $treelet->[$i][0] = '1'; # But saving the children!
# I could also insert a leading "$was<" and tailing ">" as
# children of this node, but something about that seems icky.
}
if(ref $is) {
my @dynasty = @$is;
DEBUG > 4 and print " Renaming $was node to $dynasty[-1]\n";
$treelet->[$i][0] = pop @dynasty;
my $nugget;
while(@dynasty) {
DEBUG > 4 and printf
" Grafting a new %s node between %s and %s\n",
$dynasty[-1], $treelet->[0], $treelet->[$i][0],
;
#$nugget = ;
splice @$treelet, $i, 1, [pop(@dynasty), {}, $treelet->[$i]];
# relace node with a new parent
}
} elsif($is eq '0') {
splice(@$treelet, $i, 1); # just nix this node (and its descendants)
--$i; # back-update the counter
} elsif($is eq '1') {
splice(@$treelet, $i, 1 # replace this node with its children!
=> splice @{ $treelet->[$i] },2
# (not catching its first two (non-child) items)
);
--$i; # back up for new stuff
} else {
# otherwise it's unremarkable
unshift @stack, $treelet->[$i]; # just recurse
}
}
}
DEBUG > 2 and print "End of _remap_sequences traversal.\n\n";
if(@_ == 2 and @{ $_[1] } == 3 and !ref $_[1][2]) {
DEBUG and print "Noting that the treelet is now formatless.\n";
return 0;
}
return 1;
}
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
sub _ponder_extend {
# "Go to an extreme, move back to a more comfortable place"
# -- /Oblique Strategies/, Brian Eno and Peter Schmidt
my($self, $para) = @_;
my $content = join ' ', splice @$para, 2;
$content =~ s/^\s+//s;
$content =~ s/\s+$//s;
DEBUG > 2 and print "Ogling extensor: =extend $content\n";
if($content =~
m/^
(\S+) # 1 : new item
\s+
(\S+) # 2 : fallback(s)
(?:\s+(\S+))? # 3 : element name(s)
\s*
$
/xs
) {
my $new_letter = $1;
my $fallbacks_one = $2;
my $elements_one;
$elements_one = defined($3) ? $3 : $1;
DEBUG > 2 and print "Extensor has good syntax.\n";
unless($new_letter =~ m/^[A-Z]$/s or $new_letter) {
DEBUG > 2 and print " $new_letter isn't a valid thing to entend.\n";
$self->whine(
$para->[1]{'start_line'},
"You can extend only formatting codes A-Z, not like \"$new_letter\""
);
return;
}
if(grep $new_letter eq $_, @Known_formatting_codes) {
DEBUG > 2 and print " $new_letter isn't a good thing to extend, because known.\n";
$self->whine(
$para->[1]{'start_line'},
"You can't extend an established code like \"$new_letter\""
);
#TODO: or allow if last bit is same?
return;
}
unless($fallbacks_one =~ m/^[A-Z](,[A-Z])*$/s # like "B", "M,I", etc.
or $fallbacks_one eq '0' or $fallbacks_one eq '1'
) {
$self->whine(
$para->[1]{'start_line'},
"Format for second =extend parameter must be like"
. " M or 1 or 0 or M,N or M,N,O but you have it like "
. $fallbacks_one
);
return;
}
unless($elements_one =~ m/^[^ ,]+(,[^ ,]+)*$/s) { # like "B", "M,I", etc.
$self->whine(
$para->[1]{'start_line'},
"Format for third =extend parameter: like foo or bar,Baz,qu:ux but not like "
. $elements_one
);
return;
}
my @fallbacks = split ',', $fallbacks_one, -1;
my @elements = split ',', $elements_one, -1;
foreach my $f (@fallbacks) {
next if exists $Known_formatting_codes{$f} or $f eq '0' or $f eq '1';
DEBUG > 2 and print " Can't fall back on unknown code $f\n";
$self->whine(
$para->[1]{'start_line'},
"Can't use unknown formatting code '$f' as a fallback for '$new_letter'"
);
return;
}
DEBUG > 3 and printf "Extensor: Fallbacks <%s> Elements <%s>.\n",
@fallbacks, @elements;
my $canonical_form;
foreach my $e (@elements) {
if(exists $self->{'accept_codes'}{$e}) {
DEBUG > 1 and print " Mapping '$new_letter' to known extension '$e'\n";
$canonical_form = $e;
last; # first acceptable elementname wins!
} else {
DEBUG > 1 and print " Can't map '$new_letter' to unknown extension '$e'\n";
}
}
if( defined $canonical_form ) {
# We found a good N => elementname mapping
$self->{'accept_codes'}{$new_letter} = $canonical_form;
DEBUG > 2 and print
"Extensor maps $new_letter => known element $canonical_form.\n";
} else {
# We have to use the fallback(s), which might be '0', or '1'.
$self->{'accept_codes'}{$new_letter}
= (@fallbacks == 1) ? $fallbacks[0] : \@fallbacks;
DEBUG > 2 and print
"Extensor maps $new_letter => fallbacks @fallbacks.\n";
}
} else {
DEBUG > 2 and print "Extensor has bad syntax.\n";
$self->whine(
$para->[1]{'start_line'},
"Unknown =extend syntax: $content"
)
}
return;
}
#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
sub _treat_Zs { # Nix Z<...>'s
my($self,@stack) = @_;
my($i, $treelet);
my $start_line = $stack[0][1]{'start_line'};
# A recursive algorithm implemented iteratively! Whee!
while($treelet = shift @stack) {
for($i = 2; $i < @$treelet; ++$i) { # iterate over children
next unless ref $treelet->[$i]; # text nodes are uninteresting
unless($treelet->[$i][0] eq 'Z') {
unshift @stack, $treelet->[$i]; # recurse
next;
}
DEBUG > 1 and print "Nixing Z node @{$treelet->[$i]}\n";
# bitch UNLESS it's empty
unless( @{$treelet->[$i]} == 2
or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '')
) {
$self->whine( $start_line, "A non-empty Z<>" );
} # but kill it anyway
splice(@$treelet, $i, 1); # thereby just nix this node.
--$i;
}
}
return;
}
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
# Quoting perlpodspec:
# In parsing an L<...> code, Pod parsers must distinguish at least four
# attributes:
############# Not used. Expressed via the element children plus
############# the value of the "content-implicit" flag.
# First:
# The link-text. If there is none, this must be undef. (E.g., in "L<Perl
# Functions|perlfunc>", the link-text is "Perl Functions". In
# "L<Time::HiRes>" and even "L<|Time::HiRes>", there is no link text. Note
# that link text may contain formatting.)
#
############# The element children
# Second:
# The possibly inferred link-text -- i.e., if there was no real link text,
# then this is the text that we'll infer in its place. (E.g., for
# "L<Getopt::Std>", the inferred link text is "Getopt::Std".)
#
############# The "to" attribute (which might be text, or a treelet)
# Third:
# The name or URL, or undef if none. (E.g., in "L<Perl
# Functions|perlfunc>", the name -- also sometimes called the page -- is
# "perlfunc". In "L</CAVEATS>", the name is undef.)
#
############# The "section" attribute (which might be next, or a treelet)
# Fourth:
# The section (AKA "item" in older perlpods), or undef if none. E.g., in
# Getopt::Std/DESCRIPTION, "DESCRIPTION" is the section. (Note that this
# is not the same as a manpage section like the "5" in "man 5 crontab".
# "Section Foo" in the Pod sense means the part of the text that's
# introduced by the heading or item whose text is "Foo".)
#
# Pod parsers may also note additional attributes including:
#
############# The "type" attribute.
# Fifth:
# A flag for whether item 3 (if present) is a URL (like
# "http://lists.perl.org" is), in which case there should be no section
# attribute; a Pod name (like "perldoc" and "Getopt::Std" are); or
# possibly a man page name (like "crontab(5)" is).
#
############# The "raw" attribute that is already there.
# Sixth:
# The raw original L<...> content, before text is split on "|", "/", etc,
# and before E<...> codes are expanded.
# For L<...> codes without a "name|" part, only E<...> and Z<> codes may
# occur -- no other formatting codes. That is, authors should not use
# "L<B<Foo::Bar>>".
#
# Note, however, that formatting codes and Z<>'s can occur in any and all
# parts of an L<...> (i.e., in name, section, text, and url).
sub _treat_Ls { # Process our dear dear friends, the L<...> sequences
# L<name>
# L<name/"sec"> or L<name/sec>
# L</"sec"> or L</sec> or L<"sec">
# L<text|name>
# L<text|name/"sec"> or L<text|name/sec>
# L<text|/"sec"> or L<text|/sec> or L<text|"sec">
# L<scheme:...>
# L<text|scheme:...>
my($self,@stack) = @_;
my($i, $treelet);
my $start_line = $stack[0][1]{'start_line'};
# A recursive algorithm implemented iteratively! Whee!
while($treelet = shift @stack) {
for(my $i = 2; $i < @$treelet; ++$i) {
# iterate over children of current tree node
next unless ref $treelet->[$i]; # text nodes are uninteresting
unless($treelet->[$i][0] eq 'L') {
unshift @stack, $treelet->[$i]; # recurse
next;
}
# By here, $treelet->[$i] is definitely an L node
my $ell = $treelet->[$i];
DEBUG > 1 and print "Ogling L node $ell\n";
# bitch if it's empty
if( @{$ell} == 2
or (@{$ell} == 3 and $ell->[2] eq '')
) {
$self->whine( $start_line, "An empty L<>" );
$treelet->[$i] = 'L<>'; # just make it a text node
next; # and move on
}
# Catch URLs:
# there are a number of possible cases:
# 1) text node containing url: http://foo.com
# -> [ 'http://foo.com' ]
# 2) text node containing url and text: foo|http://foo.com
# -> [ 'foo|http://foo.com' ]
# 3) text node containing url start: mailto:xE<at>foo.com
# -> [ 'mailto:x', [ E ... ], 'foo.com' ]
# 4) text node containing url start and text: foo|mailto:xE<at>foo.com
# -> [ 'foo|mailto:x', [ E ... ], 'foo.com' ]
# 5) other nodes containing text and url start: OE<39>Malley|http://foo.com
# -> [ 'O', [ E ... ], 'Malley', '|http://foo.com' ]
# ... etc.
# anything before the url is part of the text.
# anything after it is part of the url.
# the url text node itself may contain parts of both.
if (my ($url_index, $text_part, $url_part) =
# grep is no good here; we want to bail out immediately so that we can
# use $1, $2, etc. without having to do the match twice.
sub {
for (2..$#$ell) {
next if ref $ell->[$_];
next unless $ell->[$_] =~ m/^(?:([^|]*)\|)?(\w+:[^:\s]\S*)$/s;
return ($_, $1, $2);
}
return;
}->()
) {
$ell->[1]{'type'} = 'url';
my @text = @{$ell}[2..$url_index-1];
push @text, $text_part if defined $text_part;
my @url = @{$ell}[$url_index+1..$#$ell];
unshift @url, $url_part;
unless (@text) {
$ell->[1]{'content-implicit'} = 'yes';
@text = @url;
}
$ell->[1]{to} = Pod::Simple::LinkSection->new(
@url == 1
? $url[0]
: [ '', {}, @url ],
);
splice @$ell, 2, $#$ell, @text;
next;
}
# Catch some very simple and/or common cases
if(@{$ell} == 3 and ! ref $ell->[2]) {
my $it = $ell->[2];
if($it =~ m{^[^/|]+[(][-a-zA-Z0-9]+[)]$}s) { # man sections
# Hopefully neither too broad nor too restrictive a RE
DEBUG > 1 and print "Catching \"$it\" as manpage link.\n";
$ell->[1]{'type'} = 'man';
# This's the only place where man links can get made.
$ell->[1]{'content-implicit'} = 'yes';
$ell->[1]{'to' } =
Pod::Simple::LinkSection->new( $it ); # treelet!
next;
}
if($it =~ m/^[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+(\:\:[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+)*$/s) {
# Extremely forgiving idea of what constitutes a bare
# modulename link like L<Foo::Bar> or even L<Thing::1.0::Docs::Tralala>
DEBUG > 1 and print "Catching \"$it\" as ho-hum L<Modulename> link.\n";
$ell->[1]{'type'} = 'pod';
$ell->[1]{'content-implicit'} = 'yes';
$ell->[1]{'to' } =
Pod::Simple::LinkSection->new( $it ); # treelet!
next;
}
# else fall thru...
}
# ...Uhoh, here's the real L<...> parsing stuff...
# "With the ill behavior, with the ill behavior, with the ill behavior..."
DEBUG > 1 and print "Running a real parse on this non-trivial L\n";
my $link_text; # set to an arrayref if found
my @ell_content = @$ell;
splice @ell_content,0,2; # Knock off the 'L' and {} bits
DEBUG > 3 and print " Ell content to start: ",
pretty(@ell_content), "\n";
# Look for the "|" -- only in CHILDREN (not all underlings!)
# Like L<I like the strictness|strict>
DEBUG > 3 and
print " Peering at L content for a '|' ...\n";
for(my $j = 0; $j < @ell_content; ++$j) {
next if ref $ell_content[$j];
DEBUG > 3 and
print " Peering at L-content text bit \"$ell_content[$j]\" for a '|'.\n";
if($ell_content[$j] =~ m/^([^\|]*)\|(.*)$/s) {
my @link_text = ($1); # might be 0-length
$ell_content[$j] = $2; # might be 0-length
DEBUG > 3 and
print " FOUND a '|' in it. Splitting into [$1] + [$2]\n";
unshift @link_text, splice @ell_content, 0, $j;
# leaving only things at J and after
@ell_content = grep ref($_)||length($_), @ell_content ;
$link_text = [grep ref($_)||length($_), @link_text ];
DEBUG > 3 and printf
" So link text is %s\n and remaining ell content is %s\n",
pretty($link_text), pretty(@ell_content);
last;
}
}
# Now look for the "/" -- only in CHILDREN (not all underlings!)
# And afterward, anything left in @ell_content will be the raw name
# Like L<Foo::Bar/Object Methods>
my $section_name; # set to arrayref if found
DEBUG > 3 and print " Peering at L-content for a '/' ...\n";
for(my $j = 0; $j < @ell_content; ++$j) {
next if ref $ell_content[$j];
DEBUG > 3 and
print " Peering at L-content text bit \"$ell_content[$j]\" for a '/'.\n";
if($ell_content[$j] =~ m/^([^\/]*)\/(.*)$/s) {
my @section_name = ($2); # might be 0-length
$ell_content[$j] = $1; # might be 0-length
DEBUG > 3 and
print " FOUND a '/' in it.",
" Splitting to page [...$1] + section [$2...]\n";
push @section_name, splice @ell_content, 1+$j;
# leaving only things before and including J
@ell_content = grep ref($_)||length($_), @ell_content ;
@section_name = grep ref($_)||length($_), @section_name ;
# Turn L<.../"foo"> into L<.../foo>
if(@section_name
and !ref($section_name[0]) and !ref($section_name[-1])
and $section_name[ 0] =~ m/^\"/s
and $section_name[-1] =~ m/\"$/s
and !( # catch weird degenerate case of L<"> !
@section_name == 1 and $section_name[0] eq '"'
)
) {
$section_name[ 0] =~ s/^\"//s;
$section_name[-1] =~ s/\"$//s;
DEBUG > 3 and
print " Quotes removed: ", pretty(@section_name), "\n";
} else {
DEBUG > 3 and
print " No need to remove quotes in ", pretty(@section_name), "\n";
}
$section_name = \@section_name;
last;
}
}
# Turn L<"Foo Bar"> into L</Foo Bar>
if(!$section_name and @ell_content
and !ref($ell_content[0]) and !ref($ell_content[-1])
and $ell_content[ 0] =~ m/^\"/s
and $ell_content[-1] =~ m/\"$/s
and !( # catch weird degenerate case of L<"> !
@ell_content == 1 and $ell_content[0] eq '"'
)
) {
$section_name = [splice @ell_content];
$section_name->[ 0] =~ s/^\"//s;
$section_name->[-1] =~ s/\"$//s;
}
# Turn L<Foo Bar> into L</Foo Bar>.
if(!$section_name and !$link_text and @ell_content
and grep !ref($_) && m/ /s, @ell_content
) {
$section_name = [splice @ell_content];
# That's support for the now-deprecated syntax.
# (Maybe generate a warning eventually?)
# Note that it deliberately won't work on L<...|Foo Bar>
}
# Now make up the link_text
# L<Foo> -> L<Foo|Foo>
# L</Bar> -> L<"Bar"|Bar>
# L<Foo/Bar> -> L<"Bar" in Foo/Foo>
unless($link_text) {
$ell->[1]{'content-implicit'} = 'yes';
$link_text = [];
push @$link_text, '"', @$section_name, '"' if $section_name;
if(@ell_content) {
$link_text->[-1] .= ' in ' if $section_name;
push @$link_text, @ell_content;
}
}
# And the E resolver will have to deal with all our treeletty things:
if(@ell_content == 1 and !ref($ell_content[0])
and $ell_content[0] =~ m{^[^/]+[(][-a-zA-Z0-9]+[)]$}s
) {
$ell->[1]{'type'} = 'man';
DEBUG > 3 and print "Considering this ($ell_content[0]) a man link.\n";
} else {
$ell->[1]{'type'} = 'pod';
DEBUG > 3 and print "Considering this a pod link (not man or url).\n";
}
if( defined $section_name ) {
$ell->[1]{'section'} = Pod::Simple::LinkSection->new(
['', {}, @$section_name]
);
DEBUG > 3 and print "L-section content: ", pretty($ell->[1]{'section'}), "\n";
}
if( @ell_content ) {
$ell->[1]{'to'} = Pod::Simple::LinkSection->new(
['', {}, @ell_content]
);
DEBUG > 3 and print "L-to content: ", pretty($ell->[1]{'to'}), "\n";
}
# And update children to be the link-text:
@$ell = (@$ell[0,1], defined($link_text) ? splice(@$link_text) : '');
DEBUG > 2 and print "End of L-parsing for this node $treelet->[$i]\n";
unshift @stack, $treelet->[$i]; # might as well recurse
}
}
return;
}
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
sub _treat_Es {
my($self,@stack) = @_;
my($i, $treelet, $content, $replacer, $charnum);
my $start_line = $stack[0][1]{'start_line'};
# A recursive algorithm implemented iteratively! Whee!
# Has frightening side effects on L nodes' attributes.
#my @ells_to_tweak;
while($treelet = shift @stack) {
for(my $i = 2; $i < @$treelet; ++$i) { # iterate over children
next unless ref $treelet->[$i]; # text nodes are uninteresting
if($treelet->[$i][0] eq 'L') {
# SPECIAL STUFF for semi-processed L<>'s
my $thing;
foreach my $attrname ('section', 'to') {
if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) {
unshift @stack, $thing;
DEBUG > 2 and print " Enqueuing ",
pretty( $treelet->[$i][1]{$attrname} ),
" as an attribute value to tweak.\n";
}
}
unshift @stack, $treelet->[$i]; # recurse
next;
} elsif($treelet->[$i][0] ne 'E') {
unshift @stack, $treelet->[$i]; # recurse
next;
}
DEBUG > 1 and print "Ogling E node ", pretty($treelet->[$i]), "\n";
# bitch if it's empty
if( @{$treelet->[$i]} == 2
or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '')
) {
$self->whine( $start_line, "An empty E<>" );
$treelet->[$i] = 'E<>'; # splice in a literal
next;
}
# bitch if content is weird
unless(@{$treelet->[$i]} == 3 and !ref($content = $treelet->[$i][2])) {
$self->whine( $start_line, "An E<...> surrounding strange content" );
$replacer = $treelet->[$i]; # scratch
splice(@$treelet, $i, 1, # fake out a literal
'E<',
splice(@$replacer,2), # promote its content
'>'
);
# Don't need to do --$i, as the 'E<' we just added isn't interesting.
next;
}
DEBUG > 1 and print "Ogling E<$content>\n";
# XXX E<>'s contents *should* be a valid char in the scope of the current
# =encoding directive. Defaults to iso-8859-1, I believe. Fix this in the
# future sometime.
$charnum = Pod::Escapes::e2charnum($content);
DEBUG > 1 and print " Considering E<$content> with char ",
defined($charnum) ? $charnum : "undef", ".\n";
if(!defined( $charnum )) {
DEBUG > 1 and print "I don't know how to deal with E<$content>.\n";
$self->whine( $start_line, "Unknown E content in E<$content>" );
$replacer = "E<$content>"; # better than nothing
} elsif($charnum >= 255 and !UNICODE) {
$replacer = ASCII ? "\xA4" : "?";
DEBUG > 1 and print "This Perl version can't handle ",
"E<$content> (chr $charnum), so replacing with $replacer\n";
} else {
$replacer = Pod::Escapes::e2char($content);
DEBUG > 1 and print " Replacing E<$content> with $replacer\n";
}
splice(@$treelet, $i, 1, $replacer); # no need to back up $i, tho
}
}
return;
}
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
sub _treat_Ss {
my($self,$treelet) = @_;
_change_S_to_nbsp($treelet,0) if $self->{'nbsp_for_S'};
# TODO: or a change_nbsp_to_S
# Normalizing nbsp's to S is harder: for each text node, make S content
# out of anything matching m/([^ \xA0]*(?:\xA0+[^ \xA0]*)+)/
return;
}
sub _change_S_to_nbsp { # a recursive function
# Sanely assumes that the top node in the excursion won't be an S node.
my($treelet, $in_s) = @_;
my $is_s = ('S' eq $treelet->[0]);
$in_s ||= $is_s; # So in_s is on either by this being an S element,
# or by an ancestor being an S element.
for(my $i = 2; $i < @$treelet; ++$i) {
if(ref $treelet->[$i]) {
if( _change_S_to_nbsp( $treelet->[$i], $in_s ) ) {
my $to_pull_up = $treelet->[$i];
splice @$to_pull_up,0,2; # ...leaving just its content
splice @$treelet, $i, 1, @$to_pull_up; # Pull up content
$i += @$to_pull_up - 1; # Make $i skip the pulled-up stuff
}
} else {
$treelet->[$i] =~ s/\s/\xA0/g if ASCII and $in_s;
# (If not in ASCIIland, we can't assume that \xA0 == nbsp.)
# Note that if you apply nbsp_for_S to text, and so turn
# "foo S<bar baz> quux" into "foo bar faz quux", you
# end up with something that fails to say "and don't hyphenate
# any part of 'bar baz'". However, hyphenation is such a vexing
# problem anyway, that most Pod renderers just don't render it
# at all. But if you do want to implement hyphenation, I guess
# that you'd better have nbsp_for_S off.
}
}
return $is_s;
}
#-----------------------------------------------------------------------------
sub _accessorize { # A simple-minded method-maker
no strict 'refs';
foreach my $attrname (@_) {
next if $attrname =~ m/::/; # a hack
*{caller() . '::' . $attrname} = sub {
use strict;
$Carp::CarpLevel = 1, Carp::croak(
"Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)"
) unless (@_ == 1 or @_ == 2) and ref $_[0];
(@_ == 1) ? $_[0]->{$attrname}
: ($_[0]->{$attrname} = $_[1]);
};
}
# Ya know, they say accessories make the ensemble!
return;
}
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
#=============================================================================
sub filter {
my($class, $source) = @_;
my $new = $class->new;
$new->output_fh(*STDOUT{IO});
if(ref($source || '') eq 'SCALAR') {
$new->parse_string_document( $$source );
} elsif(ref($source)) { # it's a file handle
$new->parse_file($source);
} else { # it's a filename
$new->parse_file($source);
}
return $new;
}
#-----------------------------------------------------------------------------
sub _out {
# For use in testing: Class->_out($source)
# returns the transformation of $source
my $class = shift(@_);
my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE';
DEBUG and print "\n\n", '#' x 76,
"\nAbout to parse source: {{\n$_[0]\n}}\n\n";
my $parser = ref $class && $class->isa(__PACKAGE__) ? $class : $class->new;
$parser->hide_line_numbers(1);
my $out = '';
$parser->output_string( \$out );
DEBUG and print " _out to ", \$out, "\n";
$mutor->($parser) if $mutor;
$parser->parse_string_document( $_[0] );
# use Data::Dumper; print Dumper($parser), "\n";
return $out;
}
sub _duo {
# For use in testing: Class->_duo($source1, $source2)
# returns the parse trees of $source1 and $source2.
# Good in things like: &ok( Class->duo(... , ...) );
my $class = shift(@_);
Carp::croak "But $class->_duo is useful only in list context!"
unless wantarray;
my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE';
Carp::croak "But $class->_duo takes two parameters, not: @_"
unless @_ == 2;
my(@out);
while( @_ ) {
my $parser = $class->new;
push @out, '';
$parser->output_string( \( $out[-1] ) );
DEBUG and print " _duo out to ", $parser->output_string(),
" = $parser->{'output_string'}\n";
$parser->hide_line_numbers(1);
$mutor->($parser) if $mutor;
$parser->parse_string_document( shift( @_ ) );
# use Data::Dumper; print Dumper($parser), "\n";
}
return @out;
}
#-----------------------------------------------------------------------------
1;
__END__
TODO:
A start_formatting_code and end_formatting_code methods, which in the
base class call start_L, end_L, start_C, end_C, etc., if they are
defined.
have the POD FORMATTING ERRORS section note the localtime, and the
version of Pod::Simple.
option to delete all E<shy>s?
option to scream if under-0x20 literals are found in the input, or
under-E<32> E codes are found in the tree. And ditto \x7f-\x9f
Option to turn highbit characters into their compromised form? (applies
to E parsing too)
TODO: BOM/encoding things.
TODO: ascii-compat things in the XML classes?
POD_SIMPLE
$fatpacked{"Pod/Simple/BlackBox.pm"} = <<'POD_SIMPLE_BLACKBOX';
package Pod::Simple::BlackBox;
#
# "What's in the box?" "Pain."
#
###########################################################################
#
# This is where all the scary things happen: parsing lines into
# paragraphs; and then into directives, verbatims, and then also
# turning formatting sequences into treelets.
#
# Are you really sure you want to read this code?
#
#-----------------------------------------------------------------------------
#
# The basic work of this module Pod::Simple::BlackBox is doing the dirty work
# of parsing Pod into treelets (generally one per non-verbatim paragraph), and
# to call the proper callbacks on the treelets.
#
# Every node in a treelet is a ['name', {attrhash}, ...children...]
use integer; # vroom!
use strict;
use Carp ();
use vars qw($VERSION );
$VERSION = '3.26';
#use constant DEBUG => 7;
BEGIN {
require Pod::Simple;
*DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub parse_line { shift->parse_lines(@_) } # alias
# - - - Turn back now! Run away! - - -
sub parse_lines { # Usage: $parser->parse_lines(@lines)
# an undef means end-of-stream
my $self = shift;
my $code_handler = $self->{'code_handler'};
my $cut_handler = $self->{'cut_handler'};
my $wl_handler = $self->{'whiteline_handler'};
$self->{'line_count'} ||= 0;
my $scratch;
DEBUG > 4 and
print "# Parsing starting at line ", $self->{'line_count'}, ".\n";
DEBUG > 5 and
print "# About to parse lines: ",
join(' ', map defined($_) ? "[$_]" : "EOF", @_), "\n";
my $paras = ($self->{'paras'} ||= []);
# paragraph buffer. Because we need to defer processing of =over
# directives and verbatim paragraphs. We call _ponder_paragraph_buffer
# to process this.
$self->{'pod_para_count'} ||= 0;
my $line;
foreach my $source_line (@_) {
if( $self->{'source_dead'} ) {
DEBUG > 4 and print "# Source is dead.\n";
last;
}
unless( defined $source_line ) {
DEBUG > 4 and print "# Undef-line seen.\n";
push @$paras, ['~end', {'start_line' => $self->{'line_count'}}];
push @$paras, $paras->[-1], $paras->[-1];
# So that it definitely fills the buffer.
$self->{'source_dead'} = 1;
$self->_ponder_paragraph_buffer;
next;
}
if( $self->{'line_count'}++ ) {
($line = $source_line) =~ tr/\n\r//d;
# If we don't have two vars, we'll end up with that there
# tr/// modding the (potentially read-only) original source line!
} else {
DEBUG > 2 and print "First line: [$source_line]\n";
if( ($line = $source_line) =~ s/^\xEF\xBB\xBF//s ) {
DEBUG and print "UTF-8 BOM seen. Faking a '=encoding utf8'.\n";
$self->_handle_encoding_line( "=encoding utf8" );
delete $self->{'_processed_encoding'};
$line =~ tr/\n\r//d;
} elsif( $line =~ s/^\xFE\xFF//s ) {
DEBUG and print "Big-endian UTF-16 BOM seen. Aborting parsing.\n";
$self->scream(
$self->{'line_count'},
"UTF16-BE Byte Encoding Mark found; but Pod::Simple v$Pod::Simple::VERSION doesn't implement UTF16 yet."
);
splice @_;
push @_, undef;
next;
# TODO: implement somehow?
} elsif( $line =~ s/^\xFF\xFE//s ) {
DEBUG and print "Little-endian UTF-16 BOM seen. Aborting parsing.\n";
$self->scream(
$self->{'line_count'},
"UTF16-LE Byte Encoding Mark found; but Pod::Simple v$Pod::Simple::VERSION doesn't implement UTF16 yet."
);
splice @_;
push @_, undef;
next;
# TODO: implement somehow?
} else {
DEBUG > 2 and print "First line is BOM-less.\n";
($line = $source_line) =~ tr/\n\r//d;
}
}
# Try to guess encoding. Inlined for performance reasons.
if(!$self->{'parse_characters'} && !$self->{'encoding'}
&& ($self->{'in_pod'} || $line =~ /^=/s)
&& $line =~ /[^\x00-\x7f]/
) {
my $encoding = $line =~ /^[\x00-\x7f]*[\xC0-\xFD][\x80-\xBF]/ ? 'UTF-8' : 'ISO8859-1';
$self->_handle_encoding_line( "=encoding $encoding" );
$self->{'_transcoder'} && $self->{'_transcoder'}->($line);
my ($word) = $line =~ /(\S*[^\x00-\x7f]\S*)/;
$self->whine(
$self->{'line_count'},
"Non-ASCII character seen before =encoding in '$word'. Assuming $encoding"
);
}
DEBUG > 5 and print "# Parsing line: [$line]\n";
if(!$self->{'in_pod'}) {
if($line =~ m/^=([a-zA-Z]+)/s) {
if($1 eq 'cut') {
$self->scream(
$self->{'line_count'},
"=cut found outside a pod block. Skipping to next block."
);
## Before there were errata sections in the world, it was
## least-pessimal to abort processing the file. But now we can
## just barrel on thru (but still not start a pod block).
#splice @_;
#push @_, undef;
next;
} else {
$self->{'in_pod'} = $self->{'start_of_pod_block'}
= $self->{'last_was_blank'} = 1;
# And fall thru to the pod-mode block further down
}
} else {
DEBUG > 5 and print "# It's a code-line.\n";
$code_handler->(map $_, $line, $self->{'line_count'}, $self)
if $code_handler;
# Note: this may cause code to be processed out of order relative
# to pods, but in order relative to cuts.
# Note also that we haven't yet applied the transcoding to $line
# by time we call $code_handler!
if( $line =~ m/^#\s*line\s+(\d+)\s*(?:\s"([^"]+)")?\s*$/ ) {
# That RE is from perlsyn, section "Plain Old Comments (Not!)",
#$fname = $2 if defined $2;
#DEBUG > 1 and defined $2 and print "# Setting fname to \"$fname\"\n";
DEBUG > 1 and print "# Setting nextline to $1\n";
$self->{'line_count'} = $1 - 1;
}
next;
}
}
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
# Else we're in pod mode:
# Apply any necessary transcoding:
$self->{'_transcoder'} && $self->{'_transcoder'}->($line);
# HERE WE CATCH =encoding EARLY!
if( $line =~ m/^=encoding\s+\S+\s*$/s ) {
next if $self->parse_characters; # Ignore this line
$line = $self->_handle_encoding_line( $line );
}
if($line =~ m/^=cut/s) {
# here ends the pod block, and therefore the previous pod para
DEBUG > 1 and print "Noting =cut at line ${$self}{'line_count'}\n";
$self->{'in_pod'} = 0;
# ++$self->{'pod_para_count'};
$self->_ponder_paragraph_buffer();
# by now it's safe to consider the previous paragraph as done.
$cut_handler->(map $_, $line, $self->{'line_count'}, $self)
if $cut_handler;
# TODO: add to docs: Note: this may cause cuts to be processed out
# of order relative to pods, but in order relative to code.
} elsif($line =~ m/^(\s*)$/s) { # it's a blank line
if (defined $1 and $1 =~ /[^\S\r\n]/) { # it's a white line
$wl_handler->(map $_, $line, $self->{'line_count'}, $self)
if $wl_handler;
}
if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') {
DEBUG > 1 and print "Saving blank line at line ${$self}{'line_count'}\n";
push @{$paras->[-1]}, $line;
} # otherwise it's not interesting
if(!$self->{'start_of_pod_block'} and !$self->{'last_was_blank'}) {
DEBUG > 1 and print "Noting para ends with blank line at ${$self}{'line_count'}\n";
}
$self->{'last_was_blank'} = 1;
} elsif($self->{'last_was_blank'}) { # A non-blank line starting a new para...
if($line =~ m/^(=[a-zA-Z][a-zA-Z0-9]*)(?:\s+|$)(.*)/s) {
# THIS IS THE ONE PLACE WHERE WE CONSTRUCT NEW DIRECTIVE OBJECTS
my $new = [$1, {'start_line' => $self->{'line_count'}}, $2];
# Note that in "=head1 foo", the WS is lost.
# Example: ['=head1', {'start_line' => 123}, ' foo']
++$self->{'pod_para_count'};
$self->_ponder_paragraph_buffer();
# by now it's safe to consider the previous paragraph as done.
push @$paras, $new; # the new incipient paragraph
DEBUG > 1 and print "Starting new ${$paras}[-1][0] para at line ${$self}{'line_count'}\n";
} elsif($line =~ m/^\s/s) {
if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') {
DEBUG > 1 and print "Resuming verbatim para at line ${$self}{'line_count'}\n";
push @{$paras->[-1]}, $line;
} else {
++$self->{'pod_para_count'};
$self->_ponder_paragraph_buffer();
# by now it's safe to consider the previous paragraph as done.
DEBUG > 1 and print "Starting verbatim para at line ${$self}{'line_count'}\n";
push @$paras, ['~Verbatim', {'start_line' => $self->{'line_count'}}, $line];
}
} else {
++$self->{'pod_para_count'};
$self->_ponder_paragraph_buffer();
# by now it's safe to consider the previous paragraph as done.
push @$paras, ['~Para', {'start_line' => $self->{'line_count'}}, $line];
DEBUG > 1 and print "Starting plain para at line ${$self}{'line_count'}\n";
}
$self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0;
} else {
# It's a non-blank line /continuing/ the current para
if(@$paras) {
DEBUG > 2 and print "Line ${$self}{'line_count'} continues current paragraph\n";
push @{$paras->[-1]}, $line;
} else {
# Unexpected case!
die "Continuing a paragraph but \@\$paras is empty?";
}
$self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0;
}
} # ends the big while loop
DEBUG > 1 and print(pretty(@$paras), "\n");
return $self;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub _handle_encoding_line {
my($self, $line) = @_;
return if $self->parse_characters;
# The point of this routine is to set $self->{'_transcoder'} as indicated.
return $line unless $line =~ m/^=encoding\s+(\S+)\s*$/s;
DEBUG > 1 and print "Found an encoding line \"=encoding $1\"\n";
my $e = $1;
my $orig = $e;
push @{ $self->{'encoding_command_reqs'} }, "=encoding $orig";
my $enc_error;
# Cf. perldoc Encode and perldoc Encode::Supported
require Pod::Simple::Transcode;
if( $self->{'encoding'} ) {
my $norm_current = $self->{'encoding'};
my $norm_e = $e;
foreach my $that ($norm_current, $norm_e) {
$that = lc($that);
$that =~ s/[-_]//g;
}
if($norm_current eq $norm_e) {
DEBUG > 1 and print "The '=encoding $orig' line is ",
"redundant. ($norm_current eq $norm_e). Ignoring.\n";
$enc_error = '';
# But that doesn't necessarily mean that the earlier one went okay
} else {
$enc_error = "Encoding is already set to " . $self->{'encoding'};
DEBUG > 1 and print $enc_error;
}
} elsif (
# OK, let's turn on the encoding
do {
DEBUG > 1 and print " Setting encoding to $e\n";
$self->{'encoding'} = $e;
1;
}
and $e eq 'HACKRAW'
) {
DEBUG and print " Putting in HACKRAW (no-op) encoding mode.\n";
} elsif( Pod::Simple::Transcode::->encoding_is_available($e) ) {
die($enc_error = "WHAT? _transcoder is already set?!")
if $self->{'_transcoder'}; # should never happen
require Pod::Simple::Transcode;
$self->{'_transcoder'} = Pod::Simple::Transcode::->make_transcoder($e);
eval {
my @x = ('', "abc", "123");
$self->{'_transcoder'}->(@x);
};
$@ && die( $enc_error =
"Really unexpected error setting up encoding $e: $@\nAborting"
);
$self->{'detected_encoding'} = $e;
} else {
my @supported = Pod::Simple::Transcode::->all_encodings;
# Note unsupported, and complain
DEBUG and print " Encoding [$e] is unsupported.",
"\nSupporteds: @supported\n";
my $suggestion = '';
# Look for a near match:
my $norm = lc($e);
$norm =~ tr[-_][]d;
my $n;
foreach my $enc (@supported) {
$n = lc($enc);
$n =~ tr[-_][]d;
next unless $n eq $norm;
$suggestion = " (Maybe \"$e\" should be \"$enc\"?)";
last;
}
my $encmodver = Pod::Simple::Transcode::->encmodver;
$enc_error = join '' =>
"This document probably does not appear as it should, because its ",
"\"=encoding $e\" line calls for an unsupported encoding.",
$suggestion, " [$encmodver\'s supported encodings are: @supported]"
;
$self->scream( $self->{'line_count'}, $enc_error );
}
push @{ $self->{'encoding_command_statuses'} }, $enc_error;
if (defined($self->{'_processed_encoding'})) {
# Should never happen
die "Nested processed encoding.";
}
$self->{'_processed_encoding'} = $orig;
return $line;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _handle_encoding_second_level {
# By time this is called, the encoding (if well formed) will already
# have been acted one.
my($self, $para) = @_;
my @x = @$para;
my $content = join ' ', splice @x, 2;
$content =~ s/^\s+//s;
$content =~ s/\s+$//s;
DEBUG > 2 and print "Ogling encoding directive: =encoding $content\n";
if (defined($self->{'_processed_encoding'})) {
#if($content ne $self->{'_processed_encoding'}) {
# Could it happen?
#}
delete $self->{'_processed_encoding'};
# It's already been handled. Check for errors.
if(! $self->{'encoding_command_statuses'} ) {
DEBUG > 2 and print " CRAZY ERROR: It wasn't really handled?!\n";
} elsif( $self->{'encoding_command_statuses'}[-1] ) {
$self->whine( $para->[1]{'start_line'},
sprintf "Couldn't do %s: %s",
$self->{'encoding_command_reqs' }[-1],
$self->{'encoding_command_statuses'}[-1],
);
} else {
DEBUG > 2 and print " (Yup, it was successfully handled already.)\n";
}
} else {
# Otherwise it's a syntax error
$self->whine( $para->[1]{'start_line'},
"Invalid =encoding syntax: $content"
);
}
return;
}
#~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`
{
my $m = -321; # magic line number
sub _gen_errata {
my $self = $_[0];
# Return 0 or more fake-o paragraphs explaining the accumulated
# errors on this document.
return() unless $self->{'errata'} and keys %{$self->{'errata'}};
my @out;
foreach my $line (sort {$a <=> $b} keys %{$self->{'errata'}}) {
push @out,
['=item', {'start_line' => $m}, "Around line $line:"],
map( ['~Para', {'start_line' => $m, '~cooked' => 1},
#['~Top', {'start_line' => $m},
$_
#]
],
@{$self->{'errata'}{$line}}
)
;
}
# TODO: report of unknown entities? unrenderable characters?
unshift @out,
['=head1', {'start_line' => $m, 'errata' => 1}, 'POD ERRORS'],
['~Para', {'start_line' => $m, '~cooked' => 1, 'errata' => 1},
"Hey! ",
['B', {},
'The above document had some coding errors, which are explained below:'
]
],
['=over', {'start_line' => $m, 'errata' => 1}, ''],
;
push @out,
['=back', {'start_line' => $m, 'errata' => 1}, ''],
;
DEBUG and print "\n<<\n", pretty(\@out), "\n>>\n\n";
return @out;
}
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
##############################################################################
##
## stop reading now stop reading now stop reading now stop reading now stop
##
## HERE IT BECOMES REALLY SCARY
##
## stop reading now stop reading now stop reading now stop reading now stop
##
##############################################################################
sub _ponder_paragraph_buffer {
# Para-token types as found in the buffer.
# ~Verbatim, ~Para, ~end, =head1..4, =for, =begin, =end,
# =over, =back, =item
# and the null =pod (to be complained about if over one line)
#
# "~data" paragraphs are something we generate at this level, depending on
# a currently open =over region
# Events fired: Begin and end for:
# directivename (like head1 .. head4), item, extend,
# for (from =begin...=end, =for),
# over-bullet, over-number, over-text, over-block,
# item-bullet, item-number, item-text,
# Document,
# Data, Para, Verbatim
# B, C, longdirname (TODO -- wha?), etc. for all directives
#
my $self = $_[0];
my $paras;
return unless @{$paras = $self->{'paras'}};
my $curr_open = ($self->{'curr_open'} ||= []);
my $scratch;
DEBUG > 10 and print "# Paragraph buffer: <<", pretty($paras), ">>\n";
# We have something in our buffer. So apparently the document has started.
unless($self->{'doc_has_started'}) {
$self->{'doc_has_started'} = 1;
my $starting_contentless;
$starting_contentless =
(
!@$curr_open
and @$paras and ! grep $_->[0] ne '~end', @$paras
# i.e., if the paras is all ~ends
)
;
DEBUG and print "# Starting ",
$starting_contentless ? 'contentless' : 'contentful',
" document\n"
;
$self->_handle_element_start(
($scratch = 'Document'),
{
'start_line' => $paras->[0][1]{'start_line'},
$starting_contentless ? ( 'contentless' => 1 ) : (),
},
);
}
my($para, $para_type);
while(@$paras) {
last if @$paras == 1 and
( $paras->[0][0] eq '=over' or $paras->[0][0] eq '~Verbatim'
or $paras->[0][0] eq '=item' )
;
# Those're the three kinds of paragraphs that require lookahead.
# Actually, an "=item Foo" inside an <over type=text> region
# and any =item inside an <over type=block> region (rare)
# don't require any lookahead, but all others (bullets
# and numbers) do.
# TODO: whinge about many kinds of directives in non-resolving =for regions?
# TODO: many? like what? =head1 etc?
$para = shift @$paras;
$para_type = $para->[0];
DEBUG > 1 and print "Pondering a $para_type paragraph, given the stack: (",
$self->_dump_curr_open(), ")\n";
if($para_type eq '=for') {
next if $self->_ponder_for($para,$curr_open,$paras);
} elsif($para_type eq '=begin') {
next if $self->_ponder_begin($para,$curr_open,$paras);
} elsif($para_type eq '=end') {
next if $self->_ponder_end($para,$curr_open,$paras);
} elsif($para_type eq '~end') { # The virtual end-document signal
next if $self->_ponder_doc_end($para,$curr_open,$paras);
}
# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
#~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
if(grep $_->[1]{'~ignore'}, @$curr_open) {
DEBUG > 1 and
print "Skipping $para_type paragraph because in ignore mode.\n";
next;
}
#~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
if($para_type eq '=pod') {
$self->_ponder_pod($para,$curr_open,$paras);
} elsif($para_type eq '=over') {
next if $self->_ponder_over($para,$curr_open,$paras);
} elsif($para_type eq '=back') {
next if $self->_ponder_back($para,$curr_open,$paras);
} else {
# All non-magical codes!!!
# Here we start using $para_type for our own twisted purposes, to
# mean how it should get treated, not as what the element name
# should be.
DEBUG > 1 and print "Pondering non-magical $para_type\n";
my $i;
# Enforce some =headN discipline
if($para_type =~ m/^=head\d$/s
and ! $self->{'accept_heads_anywhere'}
and @$curr_open
and $curr_open->[-1][0] eq '=over'
) {
DEBUG > 2 and print "'=$para_type' inside an '=over'!\n";
$self->whine(
$para->[1]{'start_line'},
"You forgot a '=back' before '$para_type'"
);
unshift @$paras, ['=back', {}, ''], $para; # close the =over
next;
}
if($para_type eq '=item') {
my $over;
unless(@$curr_open and
$over = (grep { $_->[0] eq '=over' } @$curr_open)[-1]) {
$self->whine(
$para->[1]{'start_line'},
"'=item' outside of any '=over'"
);
unshift @$paras,
['=over', {'start_line' => $para->[1]{'start_line'}}, ''],
$para
;
next;
}
my $over_type = $over->[1]{'~type'};
if(!$over_type) {
# Shouldn't happen1
die "Typeless over in stack, starting at line "
. $over->[1]{'start_line'};
} elsif($over_type eq 'block') {
unless($curr_open->[-1][1]{'~bitched_about'}) {
$curr_open->[-1][1]{'~bitched_about'} = 1;
$self->whine(
$curr_open->[-1][1]{'start_line'},
"You can't have =items (as at line "
. $para->[1]{'start_line'}
. ") unless the first thing after the =over is an =item"
);
}
# Just turn it into a paragraph and reconsider it
$para->[0] = '~Para';
unshift @$paras, $para;
next;
} elsif($over_type eq 'text') {
my $item_type = $self->_get_item_type($para);
# That kills the content of the item if it's a number or bullet.
DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
if($item_type eq 'text') {
# Nothing special needs doing for 'text'
} elsif($item_type eq 'number' or $item_type eq 'bullet') {
$self->whine(
$para->[1]{'start_line'},
"Expected text after =item, not a $item_type"
);
# Undo our clobbering:
push @$para, $para->[1]{'~orig_content'};
delete $para->[1]{'number'};
# Only a PROPER item-number element is allowed
# to have a number attribute.
} else {
die "Unhandled item type $item_type"; # should never happen
}
# =item-text thingies don't need any assimilation, it seems.
} elsif($over_type eq 'number') {
my $item_type = $self->_get_item_type($para);
# That kills the content of the item if it's a number or bullet.
DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
my $expected_value = ++ $curr_open->[-1][1]{'~counter'};
if($item_type eq 'bullet') {
# Hm, it's not numeric. Correct for this.
$para->[1]{'number'} = $expected_value;
$self->whine(
$para->[1]{'start_line'},
"Expected '=item $expected_value'"
);
push @$para, $para->[1]{'~orig_content'};
# restore the bullet, blocking the assimilation of next para
} elsif($item_type eq 'text') {
# Hm, it's not numeric. Correct for this.
$para->[1]{'number'} = $expected_value;
$self->whine(
$para->[1]{'start_line'},
"Expected '=item $expected_value'"
);
# Text content will still be there and will block next ~Para
} elsif($item_type ne 'number') {
die "Unknown item type $item_type"; # should never happen
} elsif($expected_value == $para->[1]{'number'}) {
DEBUG > 1 and print " Numeric item has the expected value of $expected_value\n";
} else {
DEBUG > 1 and print " Numeric item has ", $para->[1]{'number'},
" instead of the expected value of $expected_value\n";
$self->whine(
$para->[1]{'start_line'},
"You have '=item " . $para->[1]{'number'} .
"' instead of the expected '=item $expected_value'"
);
$para->[1]{'number'} = $expected_value; # correcting!!
}
if(@$para == 2) {
# For the cases where we /didn't/ push to @$para
if($paras->[0][0] eq '~Para') {
DEBUG and print "Assimilating following ~Para content into $over_type item\n";
push @$para, splice @{shift @$paras},2;
} else {
DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
push @$para, ''; # Just so it's not contentless
}
}
} elsif($over_type eq 'bullet') {
my $item_type = $self->_get_item_type($para);
# That kills the content of the item if it's a number or bullet.
DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
if($item_type eq 'bullet') {
# as expected!
if( $para->[1]{'~_freaky_para_hack'} ) {
DEBUG and print "Accomodating '=item * Foo' tolerance hack.\n";
push @$para, delete $para->[1]{'~_freaky_para_hack'};
}
} elsif($item_type eq 'number') {
$self->whine(
$para->[1]{'start_line'},
"Expected '=item *'"
);
push @$para, $para->[1]{'~orig_content'};
# and block assimilation of the next paragraph
delete $para->[1]{'number'};
# Only a PROPER item-number element is allowed
# to have a number attribute.
} elsif($item_type eq 'text') {
$self->whine(
$para->[1]{'start_line'},
"Expected '=item *'"
);
# But doesn't need processing. But it'll block assimilation
# of the next para.
} else {
die "Unhandled item type $item_type"; # should never happen
}
if(@$para == 2) {
# For the cases where we /didn't/ push to @$para
if($paras->[0][0] eq '~Para') {
DEBUG and print "Assimilating following ~Para content into $over_type item\n";
push @$para, splice @{shift @$paras},2;
} else {
DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
push @$para, ''; # Just so it's not contentless
}
}
} else {
die "Unhandled =over type \"$over_type\"?";
# Shouldn't happen!
}
$para_type = 'Plain';
$para->[0] .= '-' . $over_type;
# Whew. Now fall thru and process it.
} elsif($para_type eq '=extend') {
# Well, might as well implement it here.
$self->_ponder_extend($para);
next; # and skip
} elsif($para_type eq '=encoding') {
# Not actually acted on here, but we catch errors here.
$self->_handle_encoding_second_level($para);
$para_type = 'Plain';
} elsif($para_type eq '~Verbatim') {
$para->[0] = 'Verbatim';
$para_type = '?Verbatim';
} elsif($para_type eq '~Para') {
$para->[0] = 'Para';
$para_type = '?Plain';
} elsif($para_type eq 'Data') {
$para->[0] = 'Data';
$para_type = '?Data';
} elsif( $para_type =~ s/^=//s
and defined( $para_type = $self->{'accept_directives'}{$para_type} )
) {
DEBUG > 1 and print " Pondering known directive ${$para}[0] as $para_type\n";
} else {
# An unknown directive!
DEBUG > 1 and printf "Unhandled directive %s (Handled: %s)\n",
$para->[0], join(' ', sort keys %{$self->{'accept_directives'}} )
;
$self->whine(
$para->[1]{'start_line'},
"Unknown directive: $para->[0]"
);
# And maybe treat it as text instead of just letting it go?
next;
}
if($para_type =~ s/^\?//s) {
if(! @$curr_open) { # usual case
DEBUG and print "Treating $para_type paragraph as such because stack is empty.\n";
} else {
my @fors = grep $_->[0] eq '=for', @$curr_open;
DEBUG > 1 and print "Containing fors: ",
join(',', map $_->[1]{'target'}, @fors), "\n";
if(! @fors) {
DEBUG and print "Treating $para_type paragraph as such because stack has no =for's\n";
#} elsif(grep $_->[1]{'~resolve'}, @fors) {
#} elsif(not grep !$_->[1]{'~resolve'}, @fors) {
} elsif( $fors[-1][1]{'~resolve'} ) {
# Look to the immediately containing for
if($para_type eq 'Data') {
DEBUG and print "Treating Data paragraph as Plain/Verbatim because the containing =for ($fors[-1][1]{'target'}) is a resolver\n";
$para->[0] = 'Para';
$para_type = 'Plain';
} else {
DEBUG and print "Treating $para_type paragraph as such because the containing =for ($fors[-1][1]{'target'}) is a resolver\n";
}
} else {
DEBUG and print "Treating $para_type paragraph as Data because the containing =for ($fors[-1][1]{'target'}) is a non-resolver\n";
$para->[0] = $para_type = 'Data';
}
}
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if($para_type eq 'Plain') {
$self->_ponder_Plain($para);
} elsif($para_type eq 'Verbatim') {
$self->_ponder_Verbatim($para);
} elsif($para_type eq 'Data') {
$self->_ponder_Data($para);
} else {
die "\$para type is $para_type -- how did that happen?";
# Shouldn't happen.
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
$para->[0] =~ s/^[~=]//s;
DEBUG and print "\n", pretty($para), "\n";
# traverse the treelet (which might well be just one string scalar)
$self->{'content_seen'} ||= 1;
$self->_traverse_treelet_bit(@$para);
}
}
return;
}
###########################################################################
# The sub-ponderers...
sub _ponder_for {
my ($self,$para,$curr_open,$paras) = @_;
# Fake it out as a begin/end
my $target;
if(grep $_->[1]{'~ignore'}, @$curr_open) {
DEBUG > 1 and print "Ignoring ignorable =for\n";
return 1;
}
for(my $i = 2; $i < @$para; ++$i) {
if($para->[$i] =~ s/^\s*(\S+)\s*//s) {
$target = $1;
last;
}
}
unless(defined $target) {
$self->whine(
$para->[1]{'start_line'},
"=for without a target?"
);
return 1;
}
DEBUG > 1 and
print "Faking out a =for $target as a =begin $target / =end $target\n";
$para->[0] = 'Data';
unshift @$paras,
['=begin',
{'start_line' => $para->[1]{'start_line'}, '~really' => '=for'},
$target,
],
$para,
['=end',
{'start_line' => $para->[1]{'start_line'}, '~really' => '=for'},
$target,
],
;
return 1;
}
sub _ponder_begin {
my ($self,$para,$curr_open,$paras) = @_;
my $content = join ' ', splice @$para, 2;
$content =~ s/^\s+//s;
$content =~ s/\s+$//s;
unless(length($content)) {
$self->whine(
$para->[1]{'start_line'},
"=begin without a target?"
);
DEBUG and print "Ignoring targetless =begin\n";
return 1;
}
my ($target, $title) = $content =~ m/^(\S+)\s*(.*)$/;
$para->[1]{'title'} = $title if ($title);
$para->[1]{'target'} = $target; # without any ':'
$content = $target; # strip off the title
$content =~ s/^:!/!:/s;
my $neg; # whether this is a negation-match
$neg = 1 if $content =~ s/^!//s;
my $to_resolve; # whether to process formatting codes
$to_resolve = 1 if $content =~ s/^://s;
my $dont_ignore; # whether this target matches us
foreach my $target_name (
split(',', $content, -1),
$neg ? () : '*'
) {
DEBUG > 2 and
print " Considering whether =begin $content matches $target_name\n";
next unless $self->{'accept_targets'}{$target_name};
DEBUG > 2 and
print " It DOES match the acceptable target $target_name!\n";
$to_resolve = 1
if $self->{'accept_targets'}{$target_name} eq 'force_resolve';
$dont_ignore = 1;
$para->[1]{'target_matching'} = $target_name;
last; # stop looking at other target names
}
if($neg) {
if( $dont_ignore ) {
$dont_ignore = '';
delete $para->[1]{'target_matching'};
DEBUG > 2 and print " But the leading ! means that this is a NON-match!\n";
} else {
$dont_ignore = 1;
$para->[1]{'target_matching'} = '!';
DEBUG > 2 and print " But the leading ! means that this IS a match!\n";
}
}
$para->[0] = '=for'; # Just what we happen to call these, internally
$para->[1]{'~really'} ||= '=begin';
$para->[1]{'~ignore'} = (! $dont_ignore) || 0;
$para->[1]{'~resolve'} = $to_resolve || 0;
DEBUG > 1 and print " Making note to ", $dont_ignore ? 'not ' : '',
"ignore contents of this region\n";
DEBUG > 1 and $dont_ignore and print " Making note to treat contents as ",
($to_resolve ? 'verbatim/plain' : 'data'), " paragraphs\n";
DEBUG > 1 and print " (Stack now: ", $self->_dump_curr_open(), ")\n";
push @$curr_open, $para;
if(!$dont_ignore or scalar grep $_->[1]{'~ignore'}, @$curr_open) {
DEBUG > 1 and print "Ignoring ignorable =begin\n";
} else {
$self->{'content_seen'} ||= 1;
$self->_handle_element_start((my $scratch='for'), $para->[1]);
}
return 1;
}
sub _ponder_end {
my ($self,$para,$curr_open,$paras) = @_;
my $content = join ' ', splice @$para, 2;
$content =~ s/^\s+//s;
$content =~ s/\s+$//s;
DEBUG and print "Ogling '=end $content' directive\n";
unless(length($content)) {
$self->whine(
$para->[1]{'start_line'},
"'=end' without a target?" . (
( @$curr_open and $curr_open->[-1][0] eq '=for' )
? ( " (Should be \"=end " . $curr_open->[-1][1]{'target'} . '")' )
: ''
)
);
DEBUG and print "Ignoring targetless =end\n";
return 1;
}
unless($content =~ m/^\S+$/) { # i.e., unless it's one word
$self->whine(
$para->[1]{'start_line'},
"'=end $content' is invalid. (Stack: "
. $self->_dump_curr_open() . ')'
);
DEBUG and print "Ignoring mistargetted =end $content\n";
return 1;
}
unless(@$curr_open and $curr_open->[-1][0] eq '=for') {
$self->whine(
$para->[1]{'start_line'},
"=end $content without matching =begin. (Stack: "
. $self->_dump_curr_open() . ')'
);
DEBUG and print "Ignoring mistargetted =end $content\n";
return 1;
}
unless($content eq $curr_open->[-1][1]{'target'}) {
$self->whine(
$para->[1]{'start_line'},
"=end $content doesn't match =begin "
. $curr_open->[-1][1]{'target'}
. ". (Stack: "
. $self->_dump_curr_open() . ')'
);
DEBUG and print "Ignoring mistargetted =end $content at line $para->[1]{'start_line'}\n";
return 1;
}
# Else it's okay to close...
if(grep $_->[1]{'~ignore'}, @$curr_open) {
DEBUG > 1 and print "Not firing any event for this =end $content because in an ignored region\n";
# And that may be because of this to-be-closed =for region, or some
# other one, but it doesn't matter.
} else {
$curr_open->[-1][1]{'start_line'} = $para->[1]{'start_line'};
# what's that for?
$self->{'content_seen'} ||= 1;
$self->_handle_element_end( my $scratch = 'for', $para->[1]);
}
DEBUG > 1 and print "Popping $curr_open->[-1][0] $curr_open->[-1][1]{'target'} because of =end $content\n";
pop @$curr_open;
return 1;
}
sub _ponder_doc_end {
my ($self,$para,$curr_open,$paras) = @_;
if(@$curr_open) { # Deal with things left open
DEBUG and print "Stack is nonempty at end-document: (",
$self->_dump_curr_open(), ")\n";
DEBUG > 9 and print "Stack: ", pretty($curr_open), "\n";
unshift @$paras, $self->_closers_for_all_curr_open;
# Make sure there is exactly one ~end in the parastack, at the end:
@$paras = grep $_->[0] ne '~end', @$paras;
push @$paras, $para, $para;
# We need two -- once for the next cycle where we
# generate errata, and then another to be at the end
# when that loop back around to process the errata.
return 1;
} else {
DEBUG and print "Okay, stack is empty now.\n";
}
# Try generating errata section, if applicable
unless($self->{'~tried_gen_errata'}) {
$self->{'~tried_gen_errata'} = 1;
my @extras = $self->_gen_errata();
if(@extras) {
unshift @$paras, @extras;
DEBUG and print "Generated errata... relooping...\n";
return 1; # I.e., loop around again to process these fake-o paragraphs
}
}
splice @$paras; # Well, that's that for this paragraph buffer.
DEBUG and print "Throwing end-document event.\n";
$self->_handle_element_end( my $scratch = 'Document' );
return 1; # Hasta la byebye
}
sub _ponder_pod {
my ($self,$para,$curr_open,$paras) = @_;
$self->whine(
$para->[1]{'start_line'},
"=pod directives shouldn't be over one line long! Ignoring all "
. (@$para - 2) . " lines of content"
) if @$para > 3;
# Content ignored unless 'pod_handler' is set
if (my $pod_handler = $self->{'pod_handler'}) {
my ($line_num, $line) = map $_, $para->[1]{'start_line'}, $para->[2];
$line = $line eq '' ? "=pod" : "=pod $line"; # imitate cut_handler output
$pod_handler->($line, $line_num, $self);
}
# The surrounding methods set content_seen, so let us remain consistent.
# I do not know why it was not here before -- should it not be here?
# $self->{'content_seen'} ||= 1;
return;
}
sub _ponder_over {
my ($self,$para,$curr_open,$paras) = @_;
return 1 unless @$paras;
my $list_type;
if($paras->[0][0] eq '=item') { # most common case
$list_type = $self->_get_initial_item_type($paras->[0]);
} elsif($paras->[0][0] eq '=back') {
# Ignore empty lists by default
if ($self->{'parse_empty_lists'}) {
$list_type = 'empty';
} else {
shift @$paras;
return 1;
}
} elsif($paras->[0][0] eq '~end') {
$self->whine(
$para->[1]{'start_line'},
"=over is the last thing in the document?!"
);
return 1; # But feh, ignore it.
} else {
$list_type = 'block';
}
$para->[1]{'~type'} = $list_type;
push @$curr_open, $para;
# yes, we reuse the paragraph as a stack item
my $content = join ' ', splice @$para, 2;
my $overness;
if($content =~ m/^\s*$/s) {
$para->[1]{'indent'} = 4;
} elsif($content =~ m/^\s*((?:\d*\.)?\d+)\s*$/s) {
no integer;
$para->[1]{'indent'} = $1;
if($1 == 0) {
$self->whine(
$para->[1]{'start_line'},
"Can't have a 0 in =over $content"
);
$para->[1]{'indent'} = 4;
}
} else {
$self->whine(
$para->[1]{'start_line'},
"=over should be: '=over' or '=over positive_number'"
);
$para->[1]{'indent'} = 4;
}
DEBUG > 1 and print "=over found of type $list_type\n";
$self->{'content_seen'} ||= 1;
$self->_handle_element_start((my $scratch = 'over-' . $list_type), $para->[1]);
return;
}
sub _ponder_back {
my ($self,$para,$curr_open,$paras) = @_;
# TODO: fire off </item-number> or </item-bullet> or </item-text> ??
my $content = join ' ', splice @$para, 2;
if($content =~ m/\S/) {
$self->whine(
$para->[1]{'start_line'},
"=back doesn't take any parameters, but you said =back $content"
);
}
if(@$curr_open and $curr_open->[-1][0] eq '=over') {
DEBUG > 1 and print "=back happily closes matching =over\n";
# Expected case: we're closing the most recently opened thing
#my $over = pop @$curr_open;
$self->{'content_seen'} ||= 1;
$self->_handle_element_end( my $scratch =
'over-' . ( (pop @$curr_open)->[1]{'~type'} ), $para->[1]
);
} else {
DEBUG > 1 and print "=back found without a matching =over. Stack: (",
join(', ', map $_->[0], @$curr_open), ").\n";
$self->whine(
$para->[1]{'start_line'},
'=back without =over'
);
return 1; # and ignore it
}
}
sub _ponder_item {
my ($self,$para,$curr_open,$paras) = @_;
my $over;
unless(@$curr_open and
$over = (grep { $_->[0] eq '=over' } @$curr_open)[-1]) {
$self->whine(
$para->[1]{'start_line'},
"'=item' outside of any '=over'"
);
unshift @$paras,
['=over', {'start_line' => $para->[1]{'start_line'}}, ''],
$para
;
return 1;
}
my $over_type = $over->[1]{'~type'};
if(!$over_type) {
# Shouldn't happen1
die "Typeless over in stack, starting at line "
. $over->[1]{'start_line'};
} elsif($over_type eq 'block') {
unless($curr_open->[-1][1]{'~bitched_about'}) {
$curr_open->[-1][1]{'~bitched_about'} = 1;
$self->whine(
$curr_open->[-1][1]{'start_line'},
"You can't have =items (as at line "
. $para->[1]{'start_line'}
. ") unless the first thing after the =over is an =item"
);
}
# Just turn it into a paragraph and reconsider it
$para->[0] = '~Para';
unshift @$paras, $para;
return 1;
} elsif($over_type eq 'text') {
my $item_type = $self->_get_item_type($para);
# That kills the content of the item if it's a number or bullet.
DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
if($item_type eq 'text') {
# Nothing special needs doing for 'text'
} elsif($item_type eq 'number' or $item_type eq 'bullet') {
$self->whine(
$para->[1]{'start_line'},
"Expected text after =item, not a $item_type"
);
# Undo our clobbering:
push @$para, $para->[1]{'~orig_content'};
delete $para->[1]{'number'};
# Only a PROPER item-number element is allowed
# to have a number attribute.
} else {
die "Unhandled item type $item_type"; # should never happen
}
# =item-text thingies don't need any assimilation, it seems.
} elsif($over_type eq 'number') {
my $item_type = $self->_get_item_type($para);
# That kills the content of the item if it's a number or bullet.
DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
my $expected_value = ++ $curr_open->[-1][1]{'~counter'};
if($item_type eq 'bullet') {
# Hm, it's not numeric. Correct for this.
$para->[1]{'number'} = $expected_value;
$self->whine(
$para->[1]{'start_line'},
"Expected '=item $expected_value'"
);
push @$para, $para->[1]{'~orig_content'};
# restore the bullet, blocking the assimilation of next para
} elsif($item_type eq 'text') {
# Hm, it's not numeric. Correct for this.
$para->[1]{'number'} = $expected_value;
$self->whine(
$para->[1]{'start_line'},
"Expected '=item $expected_value'"
);
# Text content will still be there and will block next ~Para
} elsif($item_type ne 'number') {
die "Unknown item type $item_type"; # should never happen
} elsif($expected_value == $para->[1]{'number'}) {
DEBUG > 1 and print " Numeric item has the expected value of $expected_value\n";
} else {
DEBUG > 1 and print " Numeric item has ", $para->[1]{'number'},
" instead of the expected value of $expected_value\n";
$self->whine(
$para->[1]{'start_line'},
"You have '=item " . $para->[1]{'number'} .
"' instead of the expected '=item $expected_value'"
);
$para->[1]{'number'} = $expected_value; # correcting!!
}
if(@$para == 2) {
# For the cases where we /didn't/ push to @$para
if($paras->[0][0] eq '~Para') {
DEBUG and print "Assimilating following ~Para content into $over_type item\n";
push @$para, splice @{shift @$paras},2;
} else {
DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
push @$para, ''; # Just so it's not contentless
}
}
} elsif($over_type eq 'bullet') {
my $item_type = $self->_get_item_type($para);
# That kills the content of the item if it's a number or bullet.
DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
if($item_type eq 'bullet') {
# as expected!
if( $para->[1]{'~_freaky_para_hack'} ) {
DEBUG and print "Accomodating '=item * Foo' tolerance hack.\n";
push @$para, delete $para->[1]{'~_freaky_para_hack'};
}
} elsif($item_type eq 'number') {
$self->whine(
$para->[1]{'start_line'},
"Expected '=item *'"
);
push @$para, $para->[1]{'~orig_content'};
# and block assimilation of the next paragraph
delete $para->[1]{'number'};
# Only a PROPER item-number element is allowed
# to have a number attribute.
} elsif($item_type eq 'text') {
$self->whine(
$para->[1]{'start_line'},
"Expected '=item *'"
);
# But doesn't need processing. But it'll block assimilation
# of the next para.
} else {
die "Unhandled item type $item_type"; # should never happen
}
if(@$para == 2) {
# For the cases where we /didn't/ push to @$para
if($paras->[0][0] eq '~Para') {
DEBUG and print "Assimilating following ~Para content into $over_type item\n";
push @$para, splice @{shift @$paras},2;
} else {
DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
push @$para, ''; # Just so it's not contentless
}
}
} else {
die "Unhandled =over type \"$over_type\"?";
# Shouldn't happen!
}
$para->[0] .= '-' . $over_type;
return;
}
sub _ponder_Plain {
my ($self,$para) = @_;
DEBUG and print " giving plain treatment...\n";
unless( @$para == 2 or ( @$para == 3 and $para->[2] eq '' )
or $para->[1]{'~cooked'}
) {
push @$para,
@{$self->_make_treelet(
join("\n", splice(@$para, 2)),
$para->[1]{'start_line'}
)};
}
# Empty paragraphs don't need a treelet for any reason I can see.
# And precooked paragraphs already have a treelet.
return;
}
sub _ponder_Verbatim {
my ($self,$para) = @_;
DEBUG and print " giving verbatim treatment...\n";
$para->[1]{'xml:space'} = 'preserve';
my $indent = $self->strip_verbatim_indent;
if ($indent && ref $indent eq 'CODE') {
my @shifted = (shift @{$para}, shift @{$para});
$indent = $indent->($para);
unshift @{$para}, @shifted;
}
for(my $i = 2; $i < @$para; $i++) {
foreach my $line ($para->[$i]) { # just for aliasing
# Strip indentation.
$line =~ s/^\Q$indent// if $indent
&& !($self->{accept_codes} && $self->{accept_codes}{VerbatimFormatted});
while( $line =~
# Sort of adapted from Text::Tabs -- yes, it's hardwired in that
# tabs are at every EIGHTH column. For portability, it has to be
# one setting everywhere, and 8th wins.
s/^([^\t]*)(\t+)/$1.(" " x ((length($2)<<3)-(length($1)&7)))/e
) {}
# TODO: whinge about (or otherwise treat) unindented or overlong lines
}
}
# Now the VerbatimFormatted hoodoo...
if( $self->{'accept_codes'} and
$self->{'accept_codes'}{'VerbatimFormatted'}
) {
while(@$para > 3 and $para->[-1] !~ m/\S/) { pop @$para }
# Kill any number of terminal newlines
$self->_verbatim_format($para);
} elsif ($self->{'codes_in_verbatim'}) {
push @$para,
@{$self->_make_treelet(
join("\n", splice(@$para, 2)),
$para->[1]{'start_line'}, $para->[1]{'xml:space'}
)};
$para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines
} else {
push @$para, join "\n", splice(@$para, 2) if @$para > 3;
$para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines
}
return;
}
sub _ponder_Data {
my ($self,$para) = @_;
DEBUG and print " giving data treatment...\n";
$para->[1]{'xml:space'} = 'preserve';
push @$para, join "\n", splice(@$para, 2) if @$para > 3;
return;
}
###########################################################################
sub _traverse_treelet_bit { # for use only by the routine above
my($self, $name) = splice @_,0,2;
my $scratch;
$self->_handle_element_start(($scratch=$name), shift @_);
while (@_) {
my $x = shift;
if (ref($x)) {
&_traverse_treelet_bit($self, @$x);
} else {
$x .= shift while @_ && !ref($_[0]);
$self->_handle_text($x);
}
}
$self->_handle_element_end($scratch=$name);
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub _closers_for_all_curr_open {
my $self = $_[0];
my @closers;
foreach my $still_open (@{ $self->{'curr_open'} || return }) {
my @copy = @$still_open;
$copy[1] = {%{ $copy[1] }};
#$copy[1]{'start_line'} = -1;
if($copy[0] eq '=for') {
$copy[0] = '=end';
} elsif($copy[0] eq '=over') {
$copy[0] = '=back';
} else {
die "I don't know how to auto-close an open $copy[0] region";
}
unless( @copy > 2 ) {
push @copy, $copy[1]{'target'};
$copy[-1] = '' unless defined $copy[-1];
# since =over's don't have targets
}
$copy[1]{'fake-closer'} = 1;
DEBUG and print "Queuing up fake-o event: ", pretty(\@copy), "\n";
unshift @closers, \@copy;
}
return @closers;
}
#--------------------------------------------------------------------------
sub _verbatim_format {
my($it, $p) = @_;
my $formatting;
for(my $i = 2; $i < @$p; $i++) { # work backwards over the lines
DEBUG and print "_verbatim_format appends a newline to $i: $p->[$i]\n";
$p->[$i] .= "\n";
# Unlike with simple Verbatim blocks, we don't end up just doing
# a join("\n", ...) on the contents, so we have to append a
# newline to ever line, and then nix the last one later.
}
if( DEBUG > 4 ) {
print "<<\n";
for(my $i = $#$p; $i >= 2; $i--) { # work backwards over the lines
print "_verbatim_format $i: $p->[$i]";
}
print ">>\n";
}
for(my $i = $#$p; $i > 2; $i--) {
# work backwards over the lines, except the first (#2)
#next unless $p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s
# and $p->[$i-1] !~ m{^#:[ \^\/\%]*\n?$}s;
# look at a formatty line preceding a nonformatty one
DEBUG > 5 and print "Scrutinizing line $i: $$p[$i]\n";
if($p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s) {
DEBUG > 5 and print " It's a formatty line. ",
"Peeking at previous line ", $i-1, ": $$p[$i-1]: \n";
if( $p->[$i-1] =~ m{^#:[ \^\/\%]*\n?$}s ) {
DEBUG > 5 and print " Previous line is formatty! Skipping this one.\n";
next;
} else {
DEBUG > 5 and print " Previous line is non-formatty! Yay!\n";
}
} else {
DEBUG > 5 and print " It's not a formatty line. Ignoring\n";
next;
}
# A formatty line has to have #: in the first two columns, and uses
# "^" to mean bold, "/" to mean underline, and "%" to mean bold italic.
# Example:
# What do you want? i like pie. [or whatever]
# #:^^^^^^^^^^^^^^^^^ /////////////
DEBUG > 4 and print "_verbatim_format considers:\n<$p->[$i-1]>\n<$p->[$i]>\n";
$formatting = ' ' . $1;
$formatting =~ s/\s+$//s; # nix trailing whitespace
unless(length $formatting and $p->[$i-1] =~ m/\S/) { # no-op
splice @$p,$i,1; # remove this line
$i--; # don't consider next line
next;
}
if( length($formatting) >= length($p->[$i-1]) ) {
$formatting = substr($formatting, 0, length($p->[$i-1]) - 1) . ' ';
} else {
$formatting .= ' ' x (length($p->[$i-1]) - length($formatting));
}
# Make $formatting and the previous line be exactly the same length,
# with $formatting having a " " as the last character.
DEBUG > 4 and print "Formatting <$formatting> on <", $p->[$i-1], ">\n";
my @new_line;
while( $formatting =~ m{\G(( +)|(\^+)|(\/+)|(\%+))}g ) {
#print "Format matches $1\n";
if($2) {
#print "SKIPPING <$2>\n";
push @new_line,
substr($p->[$i-1], pos($formatting)-length($1), length($1));
} else {
#print "SNARING $+\n";
push @new_line, [
(
$3 ? 'VerbatimB' :
$4 ? 'VerbatimI' :
$5 ? 'VerbatimBI' : die("Should never get called")
), {},
substr($p->[$i-1], pos($formatting)-length($1), length($1))
];
#print "Formatting <$new_line[-1][-1]> as $new_line[-1][0]\n";
}
}
my @nixed =
splice @$p, $i-1, 2, @new_line; # replace myself and the next line
DEBUG > 10 and print "Nixed count: ", scalar(@nixed), "\n";
DEBUG > 6 and print "New version of the above line is these tokens (",
scalar(@new_line), "):",
map( ref($_)?"<@$_> ":"<$_>", @new_line ), "\n";
$i--; # So the next line we scrutinize is the line before the one
# that we just went and formatted
}
$p->[0] = 'VerbatimFormatted';
# Collapse adjacent text nodes, just for kicks.
for( my $i = 2; $i > $#$p; $i++ ) { # work forwards over the tokens except for the last
if( !ref($p->[$i]) and !ref($p->[$i + 1]) ) {
DEBUG > 5 and print "_verbatim_format merges {$p->[$i]} and {$p->[$i+1]}\n";
$p->[$i] .= splice @$p, $i+1, 1; # merge
--$i; # and back up
}
}
# Now look for the last text token, and remove the terminal newline
for( my $i = $#$p; $i >= 2; $i-- ) {
# work backwards over the tokens, even the first
if( !ref($p->[$i]) ) {
if($p->[$i] =~ s/\n$//s) {
DEBUG > 5 and print "_verbatim_format killed the terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]}\n";
} else {
DEBUG > 5 and print
"No terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]} !?\n";
}
last; # we only want the next one
}
}
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub _treelet_from_formatting_codes {
# Given a paragraph, returns a treelet. Full of scary tokenizing code.
# Like [ '~Top', {'start_line' => $start_line},
# "I like ",
# [ 'B', {}, "pie" ],
# "!"
# ]
my($self, $para, $start_line, $preserve_space) = @_;
my $treelet = ['~Top', {'start_line' => $start_line},];
unless ($preserve_space || $self->{'preserve_whitespace'}) {
$para =~ s/\s+/ /g; # collapse and trim all whitespace first.
$para =~ s/ $//;
$para =~ s/^ //;
}
# Only apparent problem the above code is that N<< >> turns into
# N<< >>. But then, word wrapping does that too! So don't do that!
my @stack;
my @lineage = ($treelet);
my $raw = ''; # raw content of L<> fcode before splitting/processing
# XXX 'raw' is not 100% accurate: all surrounding whitespace is condensed
# into just 1 ' '. Is this the regex's doing or 'raw's?
my $inL = 0;
DEBUG > 4 and print "Paragraph:\n$para\n\n";
# Here begins our frightening tokenizer RE. The following regex matches
# text in four main parts:
#
# * Start-codes. The first alternative matches C< or C<<, the latter
# followed by some whitespace. $1 will hold the entire start code
# (including any space following a multiple-angle-bracket delimiter),
# and $2 will hold only the additional brackets past the first in a
# multiple-bracket delimiter. length($2) + 1 will be the number of
# closing brackets we have to find.
#
# * Closing brackets. Match some amount of whitespace followed by
# multiple close brackets. The logic to see if this closes anything
# is down below. Note that in order to parse C<< >> correctly, we
# have to use look-behind (?<=\s\s), since the match of the starting
# code will have consumed the whitespace.
#
# * A single closing bracket, to close a simple code like C<>.
#
# * Something that isn't a start or end code. We have to be careful
# about accepting whitespace, since perlpodspec says that any whitespace
# before a multiple-bracket closing delimiter should be ignored.
#
while($para =~
m/\G
(?:
# Match starting codes, including the whitespace following a
# multiple-delimiter start code. $1 gets the whole start code and
# $2 gets all but one of the <s in the multiple-bracket case.
([A-Z]<(?:(<+)\s+)?)
|
# Match multiple-bracket end codes. $3 gets the whitespace that
# should be discarded before an end bracket but kept in other cases
# and $4 gets the end brackets themselves.
(\s+|(?<=\s\s))(>{2,})
|
(\s?>) # $5: simple end-codes
|
( # $6: stuff containing no start-codes or end-codes
(?:
[^A-Z\s>]
|
(?:
[A-Z](?!<)
)
|
# whitespace is ok, but we don't want to eat the whitespace before
# a multiple-bracket end code.
# NOTE: we may still have problems with e.g. S<< >>
(?:
\s(?!\s*>{2,})
)
)+
)
)
/xgo
) {
DEBUG > 4 and print "\nParagraphic tokenstack = (@stack)\n";
if(defined $1) {
if(defined $2) {
DEBUG > 3 and print "Found complex start-text code \"$1\"\n";
push @stack, length($2) + 1;
# length of the necessary complex end-code string
} else {
DEBUG > 3 and print "Found simple start-text code \"$1\"\n";
push @stack, 0; # signal that we're looking for simple
}
push @lineage, [ substr($1,0,1), {}, ]; # new node object
push @{ $lineage[-2] }, $lineage[-1];
if ('L' eq substr($1,0,1)) {
$raw = $inL ? $raw.$1 : ''; # reset raw content accumulator
$inL = 1;
} else {
$raw .= $1 if $inL;
}
} elsif(defined $4) {
DEBUG > 3 and print "Found apparent complex end-text code \"$3$4\"\n";
# This is where it gets messy...
if(! @stack) {
# We saw " >>>>" but needed nothing. This is ALL just stuff then.
DEBUG > 4 and print " But it's really just stuff.\n";
push @{ $lineage[-1] }, $3, $4;
next;
} elsif(!$stack[-1]) {
# We saw " >>>>" but needed only ">". Back pos up.
DEBUG > 4 and print " And that's more than we needed to close simple.\n";
push @{ $lineage[-1] }, $3; # That was a for-real space, too.
pos($para) = pos($para) - length($4) + 1;
} elsif($stack[-1] == length($4)) {
# We found " >>>>", and it was exactly what we needed. Commonest case.
DEBUG > 4 and print " And that's exactly what we needed to close complex.\n";
} elsif($stack[-1] < length($4)) {
# We saw " >>>>" but needed only " >>". Back pos up.
DEBUG > 4 and print " And that's more than we needed to close complex.\n";
pos($para) = pos($para) - length($4) + $stack[-1];
} else {
# We saw " >>>>" but needed " >>>>>>". So this is all just stuff!
DEBUG > 4 and print " But it's really just stuff, because we needed more.\n";
push @{ $lineage[-1] }, $3, $4;
next;
}
#print "\nHOOBOY ", scalar(@{$lineage[-1]}), "!!!\n";
push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] };
# Keep the element from being childless
pop @stack;
pop @lineage;
unless (@stack) { # not in an L if there are no open fcodes
$inL = 0;
if (ref $lineage[-1][-1] && $lineage[-1][-1][0] eq 'L') {
$lineage[-1][-1][1]{'raw'} = $raw
}
}
$raw .= $3.$4 if $inL;
} elsif(defined $5) {
DEBUG > 3 and print "Found apparent simple end-text code \"$5\"\n";
if(@stack and ! $stack[-1]) {
# We're indeed expecting a simple end-code
DEBUG > 4 and print " It's indeed an end-code.\n";
if(length($5) == 2) { # There was a space there: " >"
push @{ $lineage[-1] }, ' ';
} elsif( 2 == @{ $lineage[-1] } ) { # Closing a childless element
push @{ $lineage[-1] }, ''; # keep it from being really childless
}
pop @stack;
pop @lineage;
} else {
DEBUG > 4 and print " It's just stuff.\n";
push @{ $lineage[-1] }, $5;
}
unless (@stack) { # not in an L if there are no open fcodes
$inL = 0;
if (ref $lineage[-1][-1] && $lineage[-1][-1][0] eq 'L') {
$lineage[-1][-1][1]{'raw'} = $raw
}
}
$raw .= $5 if $inL;
} elsif(defined $6) {
DEBUG > 3 and print "Found stuff \"$6\"\n";
push @{ $lineage[-1] }, $6;
$raw .= $6 if $inL;
# XXX does not capture multiplace whitespaces -- 'raw' ends up with
# at most 1 leading/trailing whitespace, why not all of it?
} else {
# should never ever ever ever happen
DEBUG and print "AYYAYAAAAA at line ", __LINE__, "\n";
die "SPORK 512512!";
}
}
if(@stack) { # Uhoh, some sequences weren't closed.
my $x= "...";
while(@stack) {
push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] };
# Hmmmmm!
my $code = (pop @lineage)->[0];
my $ender_length = pop @stack;
if($ender_length) {
--$ender_length;
$x = $code . ("<" x $ender_length) . " $x " . (">" x $ender_length);
} else {
$x = $code . "<$x>";
}
}
DEBUG > 1 and print "Unterminated $x sequence\n";
$self->whine($start_line,
"Unterminated $x sequence",
);
}
return $treelet;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub text_content_of_treelet { # method: $parser->text_content_of_treelet($lol)
return stringify_lol($_[1]);
}
sub stringify_lol { # function: stringify_lol($lol)
my $string_form = '';
_stringify_lol( $_[0] => \$string_form );
return $string_form;
}
sub _stringify_lol { # the real recursor
my($lol, $to) = @_;
for(my $i = 2; $i < @$lol; ++$i) {
if( ref($lol->[$i] || '') and UNIVERSAL::isa($lol->[$i], 'ARRAY') ) {
_stringify_lol( $lol->[$i], $to); # recurse!
} else {
$$to .= $lol->[$i];
}
}
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub _dump_curr_open { # return a string representation of the stack
my $curr_open = $_[0]{'curr_open'};
return '[empty]' unless @$curr_open;
return join '; ',
map {;
($_->[0] eq '=for')
? ( ($_->[1]{'~really'} || '=over')
. ' ' . $_->[1]{'target'})
: $_->[0]
}
@$curr_open
;
}
###########################################################################
my %pretty_form = (
"\a" => '\a', # ding!
"\b" => '\b', # BS
"\e" => '\e', # ESC
"\f" => '\f', # FF
"\t" => '\t', # tab
"\cm" => '\cm',
"\cj" => '\cj',
"\n" => '\n', # probably overrides one of either \cm or \cj
'"' => '\"',
'\\' => '\\\\',
'$' => '\\$',
'@' => '\\@',
'%' => '\\%',
'#' => '\\#',
);
sub pretty { # adopted from Class::Classless
# Not the most brilliant routine, but passable.
# Don't give it a cyclic data structure!
my @stuff = @_; # copy
my $x;
my $out =
# join ",\n" .
join ", ",
map {;
if(!defined($_)) {
"undef";
} elsif(ref($_) eq 'ARRAY' or ref($_) eq 'Pod::Simple::LinkSection') {
$x = "[ " . pretty(@$_) . " ]" ;
$x;
} elsif(ref($_) eq 'SCALAR') {
$x = "\\" . pretty($$_) ;
$x;
} elsif(ref($_) eq 'HASH') {
my $hr = $_;
$x = "{" . join(", ",
map(pretty($_) . '=>' . pretty($hr->{$_}),
sort keys %$hr ) ) . "}" ;
$x;
} elsif(!length($_)) { q{''} # empty string
} elsif(
$_ eq '0' # very common case
or(
m/^-?(?:[123456789]\d*|0)(?:\.\d+)?$/s
and $_ ne '-0' # the strange case that that RE lets thru
)
) { $_;
} else {
if( chr(65) eq 'A' ) {
s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])>
#<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg;
<$pretty_form{$1} || '\\x{'.sprintf("%x", ord($1)).'}'>eg;
} else {
# We're in some crazy non-ASCII world!
s<([^abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])>
#<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg;
<$pretty_form{$1} || '\\x{'.sprintf("%x", ord($1)).'}'>eg;
}
qq{"$_"};
}
} @stuff;
# $out =~ s/\n */ /g if length($out) < 75;
return $out;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# A rather unsubtle method of blowing away all the state information
# from a parser object so it can be reused. Provided as a utility for
# backward compatibility in Pod::Man, etc. but not recommended for
# general use.
sub reinit {
my $self = shift;
foreach (qw(source_dead source_filename doc_has_started
start_of_pod_block content_seen last_was_blank paras curr_open
line_count pod_para_count in_pod ~tried_gen_errata errata errors_seen
Title)) {
delete $self->{$_};
}
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
1;
POD_SIMPLE_BLACKBOX
$fatpacked{"Pod/Simple/Checker.pm"} = <<'POD_SIMPLE_CHECKER';
# A quite dimwitted pod2plaintext that need only know how to format whatever
# text comes out of Pod::BlackBox's _gen_errata
require 5;
package Pod::Simple::Checker;
use strict;
use Carp ();
use Pod::Simple::Methody ();
use Pod::Simple ();
use vars qw( @ISA $VERSION );
$VERSION = '3.26';
@ISA = ('Pod::Simple::Methody');
BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG)
? \&Pod::Simple::DEBUG
: sub() {0}
}
use Text::Wrap 98.112902 (); # was 2001.0131, but I don't think we need that
$Text::Wrap::wrap = 'overflow';
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub any_errata_seen { # read-only accessor
return $_[1]->{'Errata_seen'};
}
sub new {
my $self = shift;
my $new = $self->SUPER::new(@_);
$new->{'output_fh'} ||= *STDOUT{IO};
$new->nix_X_codes(1);
$new->nbsp_for_S(1);
$new->{'Thispara'} = '';
$new->{'Indent'} = 0;
$new->{'Indentstring'} = ' ';
$new->{'Errata_seen'} = 0;
return $new;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub handle_text { $_[0]{'Errata_seen'} and $_[0]{'Thispara'} .= $_[1] }
sub start_Para { $_[0]{'Thispara'} = '' }
sub start_head1 {
if($_[0]{'Errata_seen'}) {
$_[0]{'Thispara'} = '';
} else {
if($_[1]{'errata'}) { # start of errata!
$_[0]{'Errata_seen'} = 1;
$_[0]{'Thispara'} = $_[0]{'source_filename'} ?
"$_[0]{'source_filename'} -- " : ''
}
}
}
sub start_head2 { $_[0]{'Thispara'} = '' }
sub start_head3 { $_[0]{'Thispara'} = '' }
sub start_head4 { $_[0]{'Thispara'} = '' }
sub start_Verbatim { $_[0]{'Thispara'} = '' }
sub start_item_bullet { $_[0]{'Thispara'} = '* ' }
sub start_item_number { $_[0]{'Thispara'} = "$_[1]{'number'}. " }
sub start_item_text { $_[0]{'Thispara'} = '' }
sub start_over_bullet { ++$_[0]{'Indent'} }
sub start_over_number { ++$_[0]{'Indent'} }
sub start_over_text { ++$_[0]{'Indent'} }
sub start_over_block { ++$_[0]{'Indent'} }
sub end_over_bullet { --$_[0]{'Indent'} }
sub end_over_number { --$_[0]{'Indent'} }
sub end_over_text { --$_[0]{'Indent'} }
sub end_over_block { --$_[0]{'Indent'} }
# . . . . . Now the actual formatters:
sub end_head1 { $_[0]->emit_par(-4) }
sub end_head2 { $_[0]->emit_par(-3) }
sub end_head3 { $_[0]->emit_par(-2) }
sub end_head4 { $_[0]->emit_par(-1) }
sub end_Para { $_[0]->emit_par( 0) }
sub end_item_bullet { $_[0]->emit_par( 0) }
sub end_item_number { $_[0]->emit_par( 0) }
sub end_item_text { $_[0]->emit_par(-2) }
sub emit_par {
return unless $_[0]{'Errata_seen'};
my($self, $tweak_indent) = splice(@_,0,2);
my $indent = ' ' x ( 2 * $self->{'Indent'} + ($tweak_indent||0) );
# Yes, 'STRING' x NEGATIVE gives '', same as 'STRING' x 0
$self->{'Thispara'} =~ tr{\xAD}{}d if Pod::Simple::ASCII;
my $out = Text::Wrap::wrap($indent, $indent, $self->{'Thispara'} .= "\n");
$out =~ tr{\xA0}{ } if Pod::Simple::ASCII;
print {$self->{'output_fh'}} $out,
#"\n"
;
$self->{'Thispara'} = '';
return;
}
# . . . . . . . . . . And then off by its lonesome:
sub end_Verbatim {
return unless $_[0]{'Errata_seen'};
my $self = shift;
if(Pod::Simple::ASCII) {
$self->{'Thispara'} =~ tr{\xA0}{ };
$self->{'Thispara'} =~ tr{\xAD}{}d;
}
my $i = ' ' x ( 2 * $self->{'Indent'} + 4);
$self->{'Thispara'} =~ s/^/$i/mg;
print { $self->{'output_fh'} } '',
$self->{'Thispara'},
"\n\n"
;
$self->{'Thispara'} = '';
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
1;
__END__
=head1 NAME
Pod::Simple::Checker -- check the Pod syntax of a document
=head1 SYNOPSIS
perl -MPod::Simple::Checker -e \
"exit Pod::Simple::Checker->filter(shift)->any_errata_seen" \
thingy.pod
=head1 DESCRIPTION
This class is for checking the syntactic validity of Pod.
It works by basically acting like a simple-minded version of
L<Pod::Simple::Text> that formats only the "Pod Errors" section
(if Pod::Simple even generates one for the given document).
This is a subclass of L<Pod::Simple> and inherits all its methods.
=head1 SEE ALSO
L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Checker>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_CHECKER
$fatpacked{"Pod/Simple/Debug.pm"} = <<'POD_SIMPLE_DEBUG';
require 5;
package Pod::Simple::Debug;
use strict;
use vars qw($VERSION );
$VERSION = '3.26';
sub import {
my($value,$variable);
if(@_ == 2) {
$value = $_[1];
} elsif(@_ == 3) {
($variable, $value) = @_[1,2];
($variable, $value) = ($value, $variable)
if defined $value and ref($value) eq 'SCALAR'
and not(defined $variable and ref($variable) eq 'SCALAR')
; # tolerate getting it backwards
unless( defined $variable and ref($variable) eq 'SCALAR') {
require Carp;
Carp::croak("Usage:\n use Pod::Simple::Debug (NUMVAL)\nor"
. "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting");
}
} else {
require Carp;
Carp::croak("Usage:\n use Pod::Simple::Debug (NUMVAL)\nor"
. "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting");
}
if( defined &Pod::Simple::DEBUG ) {
require Carp;
Carp::croak("It's too late to call Pod::Simple::Debug -- "
. "Pod::Simple has already loaded\nAborting");
}
$value = 0 unless defined $value;
unless($value =~ m/^-?\d+$/) {
require Carp;
Carp::croak( "$value isn't a numeric value."
. "\nUsage:\n use Pod::Simple::Debug (NUMVAL)\nor"
. "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting");
}
if( defined $variable ) {
# make a not-really-constant
*Pod::Simple::DEBUG = sub () { $$variable } ;
$$variable = $value;
print "# Starting Pod::Simple::DEBUG = non-constant $variable with val $value\n";
} else {
*Pod::Simple::DEBUG = eval " sub () { $value } ";
print "# Starting Pod::Simple::DEBUG = $value\n";
}
require Pod::Simple;
return;
}
1;
__END__
=head1 NAME
Pod::Simple::Debug -- put Pod::Simple into trace/debug mode
=head1 SYNOPSIS
use Pod::Simple::Debug (5); # or some integer
Or:
my $debuglevel;
use Pod::Simple::Debug (\$debuglevel, 0);
...some stuff that uses Pod::Simple to do stuff, but which
you don't want debug output from...
$debug_level = 4;
...some stuff that uses Pod::Simple to do stuff, but which
you DO want debug output from...
$debug_level = 0;
=head1 DESCRIPTION
This is an internal module for controlling the debug level (a.k.a. trace
level) of Pod::Simple. This is of interest only to Pod::Simple
developers.
=head1 CAVEATS
Note that you should load this module I<before> loading Pod::Simple (or
any Pod::Simple-based class). If you try loading Pod::Simple::Debug
after &Pod::Simple::DEBUG is already defined, Pod::Simple::Debug will
throw a fatal error to the effect that
"it's s too late to call Pod::Simple::Debug".
Note that the C<use Pod::Simple::Debug (\$x, I<somenum>)> mode will make
Pod::Simple (et al) run rather slower, since &Pod::Simple::DEBUG won't
be a constant sub anymore, and so Pod::Simple (et al) won't compile with
constant-folding.
=head1 GUTS
Doing this:
use Pod::Simple::Debug (5); # or some integer
is basically equivalent to:
BEGIN { sub Pod::Simple::DEBUG () {5} } # or some integer
use Pod::Simple ();
And this:
use Pod::Simple::Debug (\$debug_level,0); # or some integer
is basically equivalent to this:
my $debug_level;
BEGIN { $debug_level = 0 }
BEGIN { sub Pod::Simple::DEBUG () { $debug_level }
use Pod::Simple ();
=head1 SEE ALSO
L<Pod::Simple>
The article "Constants in Perl", in I<The Perl Journal> issue
21. See L<http://interglacial.com/tpj/21/>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_DEBUG
$fatpacked{"Pod/Simple/DumpAsText.pm"} = <<'POD_SIMPLE_DUMPASTEXT';
require 5;
package Pod::Simple::DumpAsText;
$VERSION = '3.26';
use Pod::Simple ();
BEGIN {@ISA = ('Pod::Simple')}
use strict;
use Carp ();
BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
sub new {
my $self = shift;
my $new = $self->SUPER::new(@_);
$new->{'output_fh'} ||= *STDOUT{IO};
$new->accept_codes('VerbatimFormatted');
return $new;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub _handle_element_start {
# ($self, $element_name, $attr_hash_r)
my $fh = $_[0]{'output_fh'};
my($key, $value);
DEBUG and print "++ $_[1]\n";
print $fh ' ' x ($_[0]{'indent'} || 0), "++", $_[1], "\n";
$_[0]{'indent'}++;
while(($key,$value) = each %{$_[2]}) {
unless($key =~ m/^~/s) {
next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
_perly_escape($key);
_perly_escape($value);
printf $fh qq{%s \\ "%s" => "%s"\n},
' ' x ($_[0]{'indent'} || 0), $key, $value;
}
}
return;
}
sub _handle_text {
DEBUG and print "== \"$_[1]\"\n";
if(length $_[1]) {
my $indent = ' ' x $_[0]{'indent'};
my $text = $_[1];
_perly_escape($text);
$text =~ # A not-totally-brilliant wrapping algorithm:
s/(
[^\n]{55} # Snare some characters from a line
[^\n\ ]{0,50} # and finish any current word
)
\x20{1,10}(?!\n) # capture some spaces not at line-end
/$1"\n$indent . "/gx # => line-break here
;
print {$_[0]{'output_fh'}} $indent, '* "', $text, "\"\n";
}
return;
}
sub _handle_element_end {
DEBUG and print "-- $_[1]\n";
print {$_[0]{'output_fh'}}
' ' x --$_[0]{'indent'}, "--", $_[1], "\n";
return;
}
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
sub _perly_escape {
foreach my $x (@_) {
$x =~ s/([^\x00-\xFF])/sprintf'\x{%X}',ord($1)/eg;
# Escape things very cautiously:
$x =~ s/([^-\n\t \&\<\>\'!\#\%\(\)\*\+,\.\/\:\;=\?\~\[\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf'\x%02X',ord($1)/eg;
}
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
1;
__END__
=head1 NAME
Pod::Simple::DumpAsText -- dump Pod-parsing events as text
=head1 SYNOPSIS
perl -MPod::Simple::DumpAsText -e \
"exit Pod::Simple::DumpAsText->filter(shift)->any_errata_seen" \
thingy.pod
=head1 DESCRIPTION
This class is for dumping, as text, the events gotten from parsing a Pod
document. This class is of interest to people writing Pod formatters
based on Pod::Simple. It is useful for seeing exactly what events you
get out of some Pod that you feed in.
This is a subclass of L<Pod::Simple> and inherits all its methods.
=head1 SEE ALSO
L<Pod::Simple::DumpAsXML>
L<Pod::Simple>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_DUMPASTEXT
$fatpacked{"Pod/Simple/DumpAsXML.pm"} = <<'POD_SIMPLE_DUMPASXML';
require 5;
package Pod::Simple::DumpAsXML;
$VERSION = '3.26';
use Pod::Simple ();
BEGIN {@ISA = ('Pod::Simple')}
use strict;
use Carp ();
use Text::Wrap qw(wrap);
BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
sub new {
my $self = shift;
my $new = $self->SUPER::new(@_);
$new->{'output_fh'} ||= *STDOUT{IO};
$new->accept_codes('VerbatimFormatted');
return $new;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub _handle_element_start {
# ($self, $element_name, $attr_hash_r)
my $fh = $_[0]{'output_fh'};
my($key, $value);
DEBUG and print "++ $_[1]\n";
print $fh ' ' x ($_[0]{'indent'} || 0), "<", $_[1];
foreach my $key (sort keys %{$_[2]}) {
unless($key =~ m/^~/s) {
next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
_xml_escape($value = $_[2]{$key});
print $fh ' ', $key, '="', $value, '"';
}
}
print $fh ">\n";
$_[0]{'indent'}++;
return;
}
sub _handle_text {
DEBUG and print "== \"$_[1]\"\n";
if(length $_[1]) {
my $indent = ' ' x $_[0]{'indent'};
my $text = $_[1];
_xml_escape($text);
local $Text::Wrap::huge = 'overflow';
$text = wrap('', $indent, $text);
print {$_[0]{'output_fh'}} $indent, $text, "\n";
}
return;
}
sub _handle_element_end {
DEBUG and print "-- $_[1]\n";
print {$_[0]{'output_fh'}}
' ' x --$_[0]{'indent'}, "</", $_[1], ">\n";
return;
}
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
sub _xml_escape {
foreach my $x (@_) {
# Escape things very cautiously:
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
# Yes, stipulate the list without a range, so that this can work right on
# all charsets that this module happens to run under.
# Altho, hmm, what about that ord? Presumably that won't work right
# under non-ASCII charsets. Something should be done about that.
}
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
1;
__END__
=head1 NAME
Pod::Simple::DumpAsXML -- turn Pod into XML
=head1 SYNOPSIS
perl -MPod::Simple::DumpAsXML -e \
"exit Pod::Simple::DumpAsXML->filter(shift)->any_errata_seen" \
thingy.pod
=head1 DESCRIPTION
Pod::Simple::DumpAsXML is a subclass of L<Pod::Simple> that parses Pod
and turns it into indented and wrapped XML. This class is of
interest to people writing Pod formatters based on Pod::Simple.
Pod::Simple::DumpAsXML inherits methods from
L<Pod::Simple>.
=head1 SEE ALSO
L<Pod::Simple::XMLOutStream> is rather like this class.
Pod::Simple::XMLOutStream's output is space-padded in a way
that's better for sending to an XML processor (that is, it has
no ignorable whitespace). But
Pod::Simple::DumpAsXML's output is much more human-readable, being
(more-or-less) one token per line, with line-wrapping.
L<Pod::Simple::DumpAsText> is rather like this class,
except that it doesn't dump with XML syntax. Try them and see
which one you like best!
L<Pod::Simple>, L<Pod::Simple::DumpAsXML>
The older libraries L<Pod::PXML>, L<Pod::XML>, L<Pod::SAX>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_DUMPASXML
$fatpacked{"Pod/Simple/HTML.pm"} = <<'POD_SIMPLE_HTML';
require 5;
package Pod::Simple::HTML;
use strict;
use Pod::Simple::PullParser ();
use vars qw(
@ISA %Tagmap $Computerese $LamePad $Linearization_Limit $VERSION
$Perldoc_URL_Prefix $Perldoc_URL_Postfix $Man_URL_Prefix $Man_URL_Postfix
$Title_Prefix $Title_Postfix $HTML_EXTENSION %ToIndex
$Doctype_decl $Content_decl
);
@ISA = ('Pod::Simple::PullParser');
$VERSION = '3.26';
BEGIN {
if(defined &DEBUG) { } # no-op
elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG }
else { *DEBUG = sub () {0}; }
}
$Doctype_decl ||= ''; # No. Just No. Don't even ask me for it.
# qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
# "http://www.w3.org/TR/html4/loose.dtd">\n};
$Content_decl ||=
q{<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" >};
$HTML_EXTENSION = '.html' unless defined $HTML_EXTENSION;
$Computerese = "" unless defined $Computerese;
$LamePad = '' unless defined $LamePad;
$Linearization_Limit = 120 unless defined $Linearization_Limit;
# headings/items longer than that won't get an <a name="...">
$Perldoc_URL_Prefix = 'http://search.cpan.org/perldoc?'
unless defined $Perldoc_URL_Prefix;
$Perldoc_URL_Postfix = ''
unless defined $Perldoc_URL_Postfix;
$Man_URL_Prefix = 'http://man.he.net/man';
$Man_URL_Postfix = '';
$Title_Prefix = '' unless defined $Title_Prefix;
$Title_Postfix = '' unless defined $Title_Postfix;
%ToIndex = map {; $_ => 1 } qw(head1 head2 head3 head4 ); # item-text
# 'item-text' stuff in the index doesn't quite work, and may
# not be a good idea anyhow.
__PACKAGE__->_accessorize(
'perldoc_url_prefix',
# In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what
# to put before the "Foo%3a%3aBar".
# (for singleton mode only?)
'perldoc_url_postfix',
# what to put after "Foo%3a%3aBar" in the URL. Normally "".
'man_url_prefix',
# In turning L<crontab(5)> into http://whatever/man/1/crontab, what
# to put before the "1/crontab".
'man_url_postfix',
# what to put after the "1/crontab" in the URL. Normally "".
'batch_mode', # whether we're in batch mode
'batch_mode_current_level',
# When in batch mode, how deep the current module is: 1 for "LWP",
# 2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc
'title_prefix', 'title_postfix',
# What to put before and after the title in the head.
# Should already be &-escaped
'html_h_level',
'html_header_before_title',
'html_header_after_title',
'html_footer',
'index', # whether to add an index at the top of each page
# (actually it's a table-of-contents, but we'll call it an index,
# out of apparently longstanding habit)
'html_css', # URL of CSS file to point to
'html_javascript', # URL of Javascript file to point to
'force_title', # should already be &-escaped
'default_title', # should already be &-escaped
);
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
my @_to_accept;
%Tagmap = (
'Verbatim' => "\n<pre$Computerese>",
'/Verbatim' => "</pre>\n",
'VerbatimFormatted' => "\n<pre$Computerese>",
'/VerbatimFormatted' => "</pre>\n",
'VerbatimB' => "<b>",
'/VerbatimB' => "</b>",
'VerbatimI' => "<i>",
'/VerbatimI' => "</i>",
'VerbatimBI' => "<b><i>",
'/VerbatimBI' => "</i></b>",
'Data' => "\n",
'/Data' => "\n",
'head1' => "\n<h1>", # And also stick in an <a name="...">
'head2' => "\n<h2>", # ''
'head3' => "\n<h3>", # ''
'head4' => "\n<h4>", # ''
'/head1' => "</a></h1>\n",
'/head2' => "</a></h2>\n",
'/head3' => "</a></h3>\n",
'/head4' => "</a></h4>\n",
'X' => "<!--\n\tINDEX: ",
'/X' => "\n-->",
changes(qw(
Para=p
B=b I=i
over-bullet=ul
over-number=ol
over-text=dl
over-block=blockquote
item-bullet=li
item-number=li
item-text=dt
)),
changes2(
map {; m/^([-a-z]+)/s && push @_to_accept, $1; $_ }
qw[
sample=samp
definition=dfn
keyboard=kbd
variable=var
citation=cite
abbreviation=abbr
acronym=acronym
subscript=sub
superscript=sup
big=big
small=small
underline=u
strikethrough=s
preformat=pre
teletype=tt
] # no point in providing a way to get <q>...</q>, I think
),
'/item-bullet' => "</li>$LamePad\n",
'/item-number' => "</li>$LamePad\n",
'/item-text' => "</a></dt>$LamePad\n",
'item-body' => "\n<dd>",
'/item-body' => "</dd>\n",
'B' => "<b>", '/B' => "</b>",
'I' => "<i>", '/I' => "</i>",
'F' => "<em$Computerese>", '/F' => "</em>",
'C' => "<code$Computerese>", '/C' => "</code>",
'L' => "<a href='YOU_SHOULD_NEVER_SEE_THIS'>", # ideally never used!
'/L' => "</a>",
);
sub changes {
return map {; m/^([-_:0-9a-zA-Z]+)=([-_:0-9a-zA-Z]+)$/s
? ( $1, => "\n<$2>", "/$1", => "</$2>\n" ) : die "Funky $_"
} @_;
}
sub changes2 {
return map {; m/^([-_:0-9a-zA-Z]+)=([-_:0-9a-zA-Z]+)$/s
? ( $1, => "<$2>", "/$1", => "</$2>" ) : die "Funky $_"
} @_;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub go { Pod::Simple::HTML->parse_from_file(@ARGV); exit 0 }
# Just so we can run from the command line. No options.
# For that, use perldoc!
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub new {
my $new = shift->SUPER::new(@_);
#$new->nix_X_codes(1);
$new->nbsp_for_S(1);
$new->accept_targets( 'html', 'HTML' );
$new->accept_codes('VerbatimFormatted');
$new->accept_codes(@_to_accept);
DEBUG > 2 and print "To accept: ", join(' ',@_to_accept), "\n";
$new->perldoc_url_prefix( $Perldoc_URL_Prefix );
$new->perldoc_url_postfix( $Perldoc_URL_Postfix );
$new->man_url_prefix( $Man_URL_Prefix );
$new->man_url_postfix( $Man_URL_Postfix );
$new->title_prefix( $Title_Prefix );
$new->title_postfix( $Title_Postfix );
$new->html_header_before_title(
qq[$Doctype_decl<html><head><title>]
);
$new->html_header_after_title( join "\n" =>
"</title>",
$Content_decl,
"</head>\n<body class='pod'>",
$new->version_tag_comment,
"<!-- start doc -->\n",
);
$new->html_footer( qq[\n<!-- end doc -->\n\n</body></html>\n] );
$new->{'Tagmap'} = {%Tagmap};
return $new;
}
sub __adjust_html_h_levels {
my ($self) = @_;
my $Tagmap = $self->{'Tagmap'};
my $add = $self->html_h_level;
return unless defined $add;
return if ($self->{'Adjusted_html_h_levels'}||0) == $add;
$add -= 1;
for (1 .. 4) {
$Tagmap->{"head$_"} =~ s/$_/$_ + $add/e;
$Tagmap->{"/head$_"} =~ s/$_/$_ + $add/e;
}
}
sub batch_mode_page_object_init {
my($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_;
DEBUG and print "Initting $self\n for $module\n",
" in $infile\n out $outfile\n depth $depth\n";
$self->batch_mode(1);
$self->batch_mode_current_level($depth);
return $self;
}
sub run {
my $self = $_[0];
return $self->do_middle if $self->bare_output;
return
$self->do_beginning && $self->do_middle && $self->do_end;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub do_beginning {
my $self = $_[0];
my $title;
if(defined $self->force_title) {
$title = $self->force_title;
DEBUG and print "Forcing title to be $title\n";
} else {
# Actually try looking for the title in the document:
$title = $self->get_short_title();
unless($self->content_seen) {
DEBUG and print "No content seen in search for title.\n";
return;
}
$self->{'Title'} = $title;
if(defined $title and $title =~ m/\S/) {
$title = $self->title_prefix . esc($title) . $self->title_postfix;
} else {
$title = $self->default_title;
$title = '' unless defined $title;
DEBUG and print "Title defaults to $title\n";
}
}
my $after = $self->html_header_after_title || '';
if($self->html_css) {
my $link =
$self->html_css =~ m/</
? $self->html_css # It's a big blob of markup, let's drop it in
: sprintf( # It's just a URL, so let's wrap it up
qq[<link rel="stylesheet" type="text/css" title="pod_stylesheet" href="%s">\n],
$self->html_css,
);
$after =~ s{(</head>)}{$link\n$1}i; # otherwise nevermind
}
$self->_add_top_anchor(\$after);
if($self->html_javascript) {
my $link =
$self->html_javascript =~ m/</
? $self->html_javascript # It's a big blob of markup, let's drop it in
: sprintf( # It's just a URL, so let's wrap it up
qq[<script type="text/javascript" src="%s"></script>\n],
$self->html_javascript,
);
$after =~ s{(</head>)}{$link\n$1}i; # otherwise nevermind
}
print {$self->{'output_fh'}}
$self->html_header_before_title || '',
$title, # already escaped
$after,
;
DEBUG and print "Returning from do_beginning...\n";
return 1;
}
sub _add_top_anchor {
my($self, $text_r) = @_;
unless($$text_r and $$text_r =~ m/name=['"]___top['"]/) { # a hack
$$text_r .= "<a name='___top' class='dummyTopAnchor' ></a>\n";
}
return;
}
sub version_tag_comment {
my $self = shift;
return sprintf
"<!--\n generated by %s v%s,\n using %s v%s,\n under Perl v%s at %s GMT.\n\n %s\n\n-->\n",
esc(
ref($self), $self->VERSION(), $ISA[0], $ISA[0]->VERSION(),
$], scalar(gmtime),
), $self->_modnote(),
;
}
sub _modnote {
my $class = ref($_[0]) || $_[0];
return join "\n " => grep m/\S/, split "\n",
qq{
If you want to change this HTML document, you probably shouldn't do that
by changing it directly. Instead, see about changing the calling options
to $class, and/or subclassing $class,
then reconverting this document from the Pod source.
When in doubt, email the author of $class for advice.
See 'perldoc $class' for more info.
};
}
sub do_end {
my $self = $_[0];
print {$self->{'output_fh'}} $self->html_footer || '';
return 1;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Normally this would just be a call to _do_middle_main_loop -- but we
# have to do some elaborate things to emit all the content and then
# summarize it and output it /before/ the content that it's a summary of.
sub do_middle {
my $self = $_[0];
return $self->_do_middle_main_loop unless $self->index;
if( $self->output_string ) {
# An efficiency hack
my $out = $self->output_string; #it's a reference to it
my $sneakytag = "\f\f\e\e\b\bIndex Here\e\e\b\b\f\f\n";
$$out .= $sneakytag;
$self->_do_middle_main_loop;
$sneakytag = quotemeta($sneakytag);
my $index = $self->index_as_html();
if( $$out =~ s/$sneakytag/$index/s ) {
# Expected case
DEBUG and print "Inserted ", length($index), " bytes of index HTML into $out.\n";
} else {
DEBUG and print "Odd, couldn't find where to insert the index in the output!\n";
# I don't think this should ever happen.
}
return 1;
}
unless( $self->output_fh ) {
require Carp;
Carp::confess("Parser object \$p doesn't seem to have any output object! I don't know how to deal with that.");
}
# If we get here, we're outputting to a FH. So we need to do some magic.
# Namely, divert all content to a string, which we output after the index.
my $fh = $self->output_fh;
my $content = '';
{
# Our horrible bait and switch:
$self->output_string( \$content );
$self->_do_middle_main_loop;
$self->abandon_output_string();
$self->output_fh($fh);
}
print $fh $self->index_as_html();
print $fh $content;
return 1;
}
###########################################################################
sub index_as_html {
my $self = $_[0];
# This is meant to be called AFTER the input document has been parsed!
my $points = $self->{'PSHTML_index_points'} || [];
@$points > 1 or return qq[<div class='indexgroupEmpty'></div>\n];
# There's no point in having a 0-item or 1-item index, I dare say.
my(@out) = qq{\n<div class='indexgroup'>};
my $level = 0;
my( $target_level, $previous_tagname, $tagname, $text, $anchorname, $indent);
foreach my $p (@$points, ['head0', '(end)']) {
($tagname, $text) = @$p;
$anchorname = $self->section_escape($text);
if( $tagname =~ m{^head(\d+)$} ) {
$target_level = 0 + $1;
} else { # must be some kinda list item
if($previous_tagname =~ m{^head\d+$} ) {
$target_level = $level + 1;
} else {
$target_level = $level; # no change needed
}
}
# Get to target_level by opening or closing ULs
while($level > $target_level)
{ --$level; push @out, (" " x $level) . "</ul>"; }
while($level < $target_level)
{ ++$level; push @out, (" " x ($level-1))
. "<ul class='indexList indexList$level'>"; }
$previous_tagname = $tagname;
next unless $level;
$indent = ' ' x $level;
push @out, sprintf
"%s<li class='indexItem indexItem%s'><a href='#%s'>%s</a>",
$indent, $level, esc($anchorname), esc($text)
;
}
push @out, "</div>\n";
return join "\n", @out;
}
###########################################################################
sub _do_middle_main_loop {
my $self = $_[0];
my $fh = $self->{'output_fh'};
my $tagmap = $self->{'Tagmap'};
$self->__adjust_html_h_levels;
my($token, $type, $tagname, $linkto, $linktype);
my @stack;
my $dont_wrap = 0;
while($token = $self->get_token) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if( ($type = $token->type) eq 'start' ) {
if(($tagname = $token->tagname) eq 'L') {
$linktype = $token->attr('type') || 'insane';
$linkto = $self->do_link($token);
if(defined $linkto and length $linkto) {
esc($linkto);
# (Yes, SGML-escaping applies on top of %-escaping!
# But it's rarely noticeable in practice.)
print $fh qq{<a href="$linkto" class="podlink$linktype"\n>};
} else {
print $fh "<a>"; # Yes, an 'a' element with no attributes!
}
} elsif ($tagname eq 'item-text' or $tagname =~ m/^head\d$/s) {
print $fh $tagmap->{$tagname} || next;
my @to_unget;
while(1) {
push @to_unget, $self->get_token;
last if $to_unget[-1]->is_end
and $to_unget[-1]->tagname eq $tagname;
# TODO: support for X<...>'s found in here? (maybe hack into linearize_tokens)
}
my $name = $self->linearize_tokens(@to_unget);
$name = $self->do_section($name, $token) if defined $name;
print $fh "<a ";
if ($tagname =~ m/^head\d$/s) {
print $fh "class='u'", $self->index
? " href='#___top' title='click to go to top of document'\n"
: "\n";
}
if(defined $name) {
my $esc = esc( $self->section_name_tidy( $name ) );
print $fh qq[name="$esc"];
DEBUG and print "Linearized ", scalar(@to_unget),
" tokens as \"$name\".\n";
push @{ $self->{'PSHTML_index_points'} }, [$tagname, $name]
if $ToIndex{ $tagname };
# Obviously, this discards all formatting codes (saving
# just their content), but ahwell.
} else { # ludicrously long, so nevermind
DEBUG and print "Linearized ", scalar(@to_unget),
" tokens, but it was too long, so nevermind.\n";
}
print $fh "\n>";
$self->unget_token(@to_unget);
} elsif ($tagname eq 'Data') {
my $next = $self->get_token;
next unless defined $next;
unless( $next->type eq 'text' ) {
$self->unget_token($next);
next;
}
DEBUG and print " raw text ", $next->text, "\n";
print $fh "\n" . $next->text . "\n";
next;
} else {
if( $tagname =~ m/^over-/s ) {
push @stack, '';
} elsif( $tagname =~ m/^item-/s and @stack and $stack[-1] ) {
print $fh $stack[-1];
$stack[-1] = '';
}
print $fh $tagmap->{$tagname} || next;
++$dont_wrap if $tagname eq 'Verbatim' or $tagname eq "VerbatimFormatted"
or $tagname eq 'X';
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
} elsif( $type eq 'end' ) {
if( ($tagname = $token->tagname) =~ m/^over-/s ) {
if( my $end = pop @stack ) {
print $fh $end;
}
} elsif( $tagname =~ m/^item-/s and @stack) {
$stack[-1] = $tagmap->{"/$tagname"};
if( $tagname eq 'item-text' and defined(my $next = $self->get_token) ) {
$self->unget_token($next);
if( $next->type eq 'start' ) {
print $fh $tagmap->{"/item-text"},$tagmap->{"item-body"};
$stack[-1] = $tagmap->{"/item-body"};
}
}
next;
}
print $fh $tagmap->{"/$tagname"} || next;
--$dont_wrap if $tagname eq 'Verbatim' or $tagname eq 'X';
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
} elsif( $type eq 'text' ) {
esc($type = $token->text); # reuse $type, why not
$type =~ s/([\?\!\"\'\.\,]) /$1\n/g unless $dont_wrap;
print $fh $type;
}
}
return 1;
}
###########################################################################
#
sub do_section {
my($self, $name, $token) = @_;
return $name;
}
sub do_link {
my($self, $token) = @_;
my $type = $token->attr('type');
if(!defined $type) {
$self->whine("Typeless L!?", $token->attr('start_line'));
} elsif( $type eq 'pod') { return $self->do_pod_link($token);
} elsif( $type eq 'url') { return $self->do_url_link($token);
} elsif( $type eq 'man') { return $self->do_man_link($token);
} else {
$self->whine("L of unknown type $type!?", $token->attr('start_line'));
}
return 'FNORG'; # should never get called
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub do_url_link { return $_[1]->attr('to') }
sub do_man_link {
my ($self, $link) = @_;
my $to = $link->attr('to');
my $frag = $link->attr('section');
return undef unless defined $to and length $to; # should never happen
$frag = $self->section_escape($frag)
if defined $frag and length($frag .= ''); # (stringify)
DEBUG and print "Resolving \"$to/$frag\"\n\n";
return $self->resolve_man_page_link($to, $frag);
}
sub do_pod_link {
# And now things get really messy...
my($self, $link) = @_;
my $to = $link->attr('to');
my $section = $link->attr('section');
return undef unless( # should never happen
(defined $to and length $to) or
(defined $section and length $section)
);
$section = $self->section_escape($section)
if defined $section and length($section .= ''); # (stringify)
DEBUG and printf "Resolving \"%s\" \"%s\"...\n",
$to || "(nil)", $section || "(nil)";
{
# An early hack:
my $complete_url = $self->resolve_pod_link_by_table($to, $section);
if( $complete_url ) {
DEBUG > 1 and print "resolve_pod_link_by_table(T,S) gives ",
$complete_url, "\n (Returning that.)\n";
return $complete_url;
} else {
DEBUG > 4 and print " resolve_pod_link_by_table(T,S)",
" didn't return anything interesting.\n";
}
}
if(defined $to and length $to) {
# Give this routine first hack again
my $there = $self->resolve_pod_link_by_table($to);
if(defined $there and length $there) {
DEBUG > 1
and print "resolve_pod_link_by_table(T) gives $there\n";
} else {
$there =
$self->resolve_pod_page_link($to, $section);
# (I pass it the section value, but I don't see a
# particular reason it'd use it.)
DEBUG > 1 and print "resolve_pod_page_link gives ", $to || "(nil)", "\n";
unless( defined $there and length $there ) {
DEBUG and print "Can't resolve $to\n";
return undef;
}
# resolve_pod_page_link returning undef is how it
# can signal that it gives up on making a link
}
$to = $there;
}
#DEBUG and print "So far [", $to||'nil', "] [", $section||'nil', "]\n";
my $out = (defined $to and length $to) ? $to : '';
$out .= "#" . $section if defined $section and length $section;
unless(length $out) { # sanity check
DEBUG and printf "Oddly, couldn't resolve \"%s\" \"%s\"...\n",
$to || "(nil)", $section || "(nil)";
return undef;
}
DEBUG and print "Resolved to $out\n";
return $out;
}
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
sub section_escape {
my($self, $section) = @_;
return $self->section_url_escape(
$self->section_name_tidy($section)
);
}
sub section_name_tidy {
my($self, $section) = @_;
$section =~ s/^\s+//;
$section =~ s/\s+$//;
$section =~ tr/ /_/;
$section =~ tr/\x00-\x1F\x80-\x9F//d if 'A' eq chr(65); # drop crazy characters
$section = $self->unicode_escape_url($section);
$section = '_' unless length $section;
return $section;
}
sub section_url_escape { shift->general_url_escape(@_) }
sub pagepath_url_escape { shift->general_url_escape(@_) }
sub manpage_url_escape { shift->general_url_escape(@_) }
sub general_url_escape {
my($self, $string) = @_;
$string =~ s/([^\x00-\xFF])/join '', map sprintf('%%%02X',$_), unpack 'C*', $1/eg;
# express Unicode things as urlencode(utf(orig)).
# A pretty conservative escaping, behoovey even for query components
# of a URL (see RFC 2396)
$string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',ord($1))/eg;
# Yes, stipulate the list without a range, so that this can work right on
# all charsets that this module happens to run under.
# Altho, hmm, what about that ord? Presumably that won't work right
# under non-ASCII charsets. Something should be done
# about that, I guess?
return $string;
}
#--------------------------------------------------------------------------
#
# Oh look, a yawning portal to Hell! Let's play touch football right by it!
#
sub resolve_pod_page_link {
# resolve_pod_page_link must return a properly escaped URL
my $self = shift;
return $self->batch_mode()
? $self->resolve_pod_page_link_batch_mode(@_)
: $self->resolve_pod_page_link_singleton_mode(@_)
;
}
sub resolve_pod_page_link_singleton_mode {
my($self, $it) = @_;
return undef unless defined $it and length $it;
my $url = $self->pagepath_url_escape($it);
$url =~ s{::$}{}s; # probably never comes up anyway
$url =~ s{::}{/}g unless $self->perldoc_url_prefix =~ m/\?/s; # sane DWIM?
return undef unless length $url;
return $self->perldoc_url_prefix . $url . $self->perldoc_url_postfix;
}
sub resolve_pod_page_link_batch_mode {
my($self, $to) = @_;
DEBUG > 1 and print " During batch mode, resolving $to ...\n";
my @path = grep length($_), split m/::/s, $to, -1;
unless( @path ) { # sanity
DEBUG and print "Very odd! Splitting $to gives (nil)!\n";
return undef;
}
$self->batch_mode_rectify_path(\@path);
my $out = join('/', map $self->pagepath_url_escape($_), @path)
. $HTML_EXTENSION;
DEBUG > 1 and print " => $out\n";
return $out;
}
sub batch_mode_rectify_path {
my($self, $pathbits) = @_;
my $level = $self->batch_mode_current_level;
$level--; # how many levels up to go to get to the root
if($level < 1) {
unshift @$pathbits, '.'; # just to be pretty
} else {
unshift @$pathbits, ('..') x $level;
}
return;
}
sub resolve_man_page_link {
my ($self, $to, $frag) = @_;
my ($page, $section) = $to =~ /^([^(]+)(?:[(](\d+)[)])?$/;
return undef unless defined $page and length $page;
$section ||= 1;
return $self->man_url_prefix . "$section/"
. $self->manpage_url_escape($page)
. $self->man_url_postfix;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub resolve_pod_link_by_table {
# A crazy hack to allow specifying custom L<foo> => URL mappings
return unless $_[0]->{'podhtml_LOT'}; # An optimizy shortcut
my($self, $to, $section) = @_;
# TODO: add a method that actually populates podhtml_LOT from a file?
if(defined $section) {
$to = '' unless defined $to and length $to;
return $self->{'podhtml_LOT'}{"$to#$section"}; # quite possibly undef!
} else {
return $self->{'podhtml_LOT'}{$to}; # quite possibly undef!
}
return;
}
###########################################################################
sub linearize_tokens { # self, tokens
my $self = shift;
my $out = '';
my $t;
while($t = shift @_) {
if(!ref $t or !UNIVERSAL::can($t, 'is_text')) {
$out .= $t; # a string, or some insane thing
} elsif($t->is_text) {
$out .= $t->text;
} elsif($t->is_start and $t->tag eq 'X') {
# Ignore until the end of this X<...> sequence:
my $x_open = 1;
while($x_open) {
next if( ($t = shift @_)->is_text );
if( $t->is_start and $t->tag eq 'X') { ++$x_open }
elsif($t->is_end and $t->tag eq 'X') { --$x_open }
}
}
}
return undef if length $out > $Linearization_Limit;
return $out;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub unicode_escape_url {
my($self, $string) = @_;
$string =~ s/([^\x00-\xFF])/'('.ord($1).')'/eg;
# Turn char 1234 into "(1234)"
return $string;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub esc { # a function.
if(defined wantarray) {
if(wantarray) {
@_ = splice @_; # break aliasing
} else {
my $x = shift;
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
return $x;
}
}
foreach my $x (@_) {
# Escape things very cautiously:
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg
if defined $x;
# Leave out "- so that "--" won't make it thru in X-generated comments
# with text in them.
# Yes, stipulate the list without a range, so that this can work right on
# all charsets that this module happens to run under.
# Altho, hmm, what about that ord? Presumably that won't work right
# under non-ASCII charsets. Something should be done about that.
}
return @_;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1;
__END__
=head1 NAME
Pod::Simple::HTML - convert Pod to HTML
=head1 SYNOPSIS
perl -MPod::Simple::HTML -e Pod::Simple::HTML::go thingy.pod
=head1 DESCRIPTION
This class is for making an HTML rendering of a Pod document.
This is a subclass of L<Pod::Simple::PullParser> and inherits all its
methods (and options).
Note that if you want to do a batch conversion of a lot of Pod
documents to HTML, you should see the module L<Pod::Simple::HTMLBatch>.
=head1 CALLING FROM THE COMMAND LINE
TODO
perl -MPod::Simple::HTML -e Pod::Simple::HTML::go Thing.pod Thing.html
=head1 CALLING FROM PERL
=head2 Minimal code
use Pod::Simple::HTML;
my $p = Pod::Simple::HTML->new;
$p->output_string(\my $html);
$p->parse_file('path/to/Module/Name.pm');
open my $out, '>', 'out.html' or die "Cannot open 'out.html': $!\n";
print $out $html;
=head2 More detailed example
use Pod::Simple::HTML;
Set the content type:
$Pod::Simple::HTML::Content_decl = q{<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" >};
my $p = Pod::Simple::HTML->new;
Include a single javascript source:
$p->html_javascript('http://abc.com/a.js');
Or insert multiple javascript source in the header
(or for that matter include anything, thought this is not recommended)
$p->html_javascript('
<script type="text/javascript" src="http://abc.com/b.js"></script>
<script type="text/javascript" src="http://abc.com/c.js"></script>');
Include a single css source in the header:
$p->html_css('/style.css');
or insert multiple css sources:
$p->html_css('
<link rel="stylesheet" type="text/css" title="pod_stylesheet" href="http://remote.server.com/jquery.css">
<link rel="stylesheet" type="text/css" title="pod_stylesheet" href="/style.css">');
Tell the parser where should the output go. In this case it will be placed in the $html variable:
my $html;
$p->output_string(\$html);
Parse and process a file with pod in it:
$p->parse_file('path/to/Module/Name.pm');
=head1 METHODS
TODO
all (most?) accessorized methods
The following variables need to be set B<before> the call to the ->new constructor.
Set the string that is included before the opening <html> tag:
$Pod::Simple::HTML::Doctype_decl = qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
"http://www.w3.org/TR/html4/loose.dtd">\n};
Set the content-type in the HTML head: (defaults to ISO-8859-1)
$Pod::Simple::HTML::Content_decl = q{<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" >};
Set the value that will be ebedded in the opening tags of F, C tags and verbatim text.
F maps to <em>, C maps to <code>, Verbatim text maps to <pre> (Computerese defaults to "")
$Pod::Simple::HTML::Computerese = ' class="some_class_name';
=head2 html_css
=head2 html_javascript
=head2 title_prefix
=head2 title_postfix
=head2 html_header_before_title
This includes everything before the <title> opening tag including the Document type
and including the opening <title> tag. The following call will set it to be a simple HTML
file:
$p->html_header_before_title('<html><head><title>');
=head2 html_h_level
Normally =head1 will become <h1>, =head2 will become <h2> etc.
Using the html_h_level method will change these levels setting the h level
of =head1 tags:
$p->html_h_level(3);
Will make sure that =head1 will become <h3> and =head2 will become <h4> etc...
=head2 index
Set it to some true value if you want to have an index (in reality a table of contents)
to be added at the top of the generated HTML.
$p->index(1);
=head2 html_header_after_title
Includes the closing tag of </title> and through the rest of the head
till the opening of the body
$p->html_header_after_title('</title>...</head><body id="my_id">');
=head2 html_footer
The very end of the document:
$p->html_footer( qq[\n<!-- end doc -->\n\n</body></html>\n] );
=head1 SUBCLASSING
Can use any of the methods described above but for further customization
one needs to override some of the methods:
package My::Pod;
use strict;
use warnings;
use base 'Pod::Simple::HTML';
# needs to return a URL string such
# http://some.other.com/page.html
# #anchor_in_the_same_file
# /internal/ref.html
sub do_pod_link {
# My::Pod object and Pod::Simple::PullParserStartToken object
my ($self, $link) = @_;
say $link->tagname; # will be L for links
say $link->attr('to'); #
say $link->attr('type'); # will be 'pod' always
say $link->attr('section');
# Links local to our web site
if ($link->tagname eq 'L' and $link->attr('type') eq 'pod') {
my $to = $link->attr('to');
if ($to =~ /^Padre::/) {
$to =~ s{::}{/}g;
return "/docs/Padre/$to.html";
}
}
# all other links are generated by the parent class
my $ret = $self->SUPER::do_pod_link($link);
return $ret;
}
1;
Meanwhile in script.pl:
use My::Pod;
my $p = My::Pod->new;
my $html;
$p->output_string(\$html);
$p->parse_file('path/to/Module/Name.pm');
open my $out, '>', 'out.html' or die;
print $out $html;
TODO
maybe override do_beginning do_end
=head1 SEE ALSO
L<Pod::Simple>, L<Pod::Simple::HTMLBatch>
TODO: a corpus of sample Pod input and HTML output? Or common
idioms?
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002-2004 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 ACKNOWLEDGEMENTS
Thanks to L<Hurricane Electric|http://he.net/> for permission to use its
L<Linux man pages online|http://man.he.net/> site for man page links.
Thanks to L<search.cpan.org|http://search.cpan.org/> for permission to use the
site for Perl module links.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_HTML
$fatpacked{"Pod/Simple/HTMLBatch.pm"} = <<'POD_SIMPLE_HTMLBATCH';
require 5;
package Pod::Simple::HTMLBatch;
use strict;
use vars qw( $VERSION $HTML_RENDER_CLASS $HTML_EXTENSION
$CSS $JAVASCRIPT $SLEEPY $SEARCH_CLASS @ISA
);
$VERSION = '3.26';
@ISA = (); # Yup, we're NOT a subclass of Pod::Simple::HTML!
# TODO: nocontents stylesheets. Strike some of the color variations?
use Pod::Simple::HTML ();
BEGIN {*esc = \&Pod::Simple::HTML::esc }
use File::Spec ();
use Pod::Simple::Search;
$SEARCH_CLASS ||= 'Pod::Simple::Search';
BEGIN {
if(defined &DEBUG) { } # no-op
elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG }
else { *DEBUG = sub () {0}; }
}
$SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i;
# flag to occasionally sleep for $SLEEPY - 1 seconds.
$HTML_RENDER_CLASS ||= "Pod::Simple::HTML";
#
# Methods beginning with "_" are particularly internal and possibly ugly.
#
Pod::Simple::_accessorize( __PACKAGE__,
'verbose', # how verbose to be during batch conversion
'html_render_class', # what class to use to render
'search_class', # what to use to search for POD documents
'contents_file', # If set, should be the name of a file (in current directory)
# to write the list of all modules to
'index', # will set $htmlpage->index(...) to this (true or false)
'progress', # progress object
'contents_page_start', 'contents_page_end',
'css_flurry', '_css_wad', 'javascript_flurry', '_javascript_wad',
'no_contents_links', # set to true to suppress automatic adding of << links.
'_contents',
);
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Just so we can run from the command line more easily
sub go {
@ARGV == 2 or die sprintf(
"Usage: perl -M%s -e %s:go indirs outdir\n (or use \"\@INC\" for indirs)\n",
__PACKAGE__, __PACKAGE__,
);
if(defined($ARGV[1]) and length($ARGV[1])) {
my $d = $ARGV[1];
-e $d or die "I see no output directory named \"$d\"\nAborting";
-d $d or die "But \"$d\" isn't a directory!\nAborting";
-w $d or die "Directory \"$d\" isn't writeable!\nAborting";
}
__PACKAGE__->batch_convert(@ARGV);
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub new {
my $new = bless {}, ref($_[0]) || $_[0];
$new->html_render_class($HTML_RENDER_CLASS);
$new->search_class($SEARCH_CLASS);
$new->verbose(1 + DEBUG);
$new->_contents([]);
$new->index(1);
$new-> _css_wad([]); $new->css_flurry(1);
$new->_javascript_wad([]); $new->javascript_flurry(1);
$new->contents_file(
'index' . ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION)
);
$new->contents_page_start( join "\n", grep $_,
$Pod::Simple::HTML::Doctype_decl,
"<html><head>",
"<title>Perl Documentation</title>",
$Pod::Simple::HTML::Content_decl,
"</head>",
"\n<body class='contentspage'>\n<h1>Perl Documentation</h1>\n"
); # override if you need a different title
$new->contents_page_end( sprintf(
"\n\n<p class='contentsfooty'>Generated by %s v%s under Perl v%s\n<br >At %s GMT, which is %s local time.</p>\n\n</body></html>\n",
esc(
ref($new),
eval {$new->VERSION} || $VERSION,
$], scalar(gmtime), scalar(localtime),
)));
return $new;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub muse {
my $self = shift;
if($self->verbose) {
print 'T+', int(time() - $self->{'_batch_start_time'}), "s: ", @_, "\n";
}
return 1;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub batch_convert {
my($self, $dirs, $outdir) = @_;
$self ||= __PACKAGE__; # tolerate being called as an optionless function
$self = $self->new unless ref $self; # tolerate being used as a class method
if(!defined($dirs) or $dirs eq '' or $dirs eq '@INC' ) {
$dirs = '';
} elsif(ref $dirs) {
# OK, it's an explicit set of dirs to scan, specified as an arrayref.
} else {
# OK, it's an explicit set of dirs to scan, specified as a
# string like "/thing:/also:/whatever/perl" (":"-delim, as usual)
# or, under MSWin, like "c:/thing;d:/also;c:/whatever/perl" (";"-delim!)
require Config;
my $ps = quotemeta( $Config::Config{'path_sep'} || ":" );
$dirs = [ grep length($_), split qr/$ps/, $dirs ];
}
$outdir = $self->filespecsys->curdir
unless defined $outdir and length $outdir;
$self->_batch_convert_main($dirs, $outdir);
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _batch_convert_main {
my($self, $dirs, $outdir) = @_;
# $dirs is either false, or an arrayref.
# $outdir is a pathspec.
$self->{'_batch_start_time'} ||= time();
$self->muse( "= ", scalar(localtime) );
$self->muse( "Starting batch conversion to \"$outdir\"" );
my $progress = $self->progress;
if(!$progress and $self->verbose > 0 and $self->verbose() <= 5) {
require Pod::Simple::Progress;
$progress = Pod::Simple::Progress->new(
($self->verbose < 2) ? () # Default omission-delay
: ($self->verbose == 2) ? 1 # Reduce the omission-delay
: 0 # Eliminate the omission-delay
);
$self->progress($progress);
}
if($dirs) {
$self->muse(scalar(@$dirs), " dirs to scan: @$dirs");
} else {
$self->muse("Scanning \@INC. This could take a minute or two.");
}
my $mod2path = $self->find_all_pods($dirs ? $dirs : ());
$self->muse("Done scanning.");
my $total = keys %$mod2path;
unless($total) {
$self->muse("No pod found. Aborting batch conversion.\n");
return $self;
}
$progress and $progress->goal($total);
$self->muse("Now converting pod files to HTML.",
($total > 25) ? " This will take a while more." : ()
);
$self->_spray_css( $outdir );
$self->_spray_javascript( $outdir );
$self->_do_all_batch_conversions($mod2path, $outdir);
$progress and $progress->done(sprintf (
"Done converting %d files.", $self->{"__batch_conv_page_count"}
));
return $self->_batch_convert_finish($outdir);
return $self;
}
sub _do_all_batch_conversions {
my($self, $mod2path, $outdir) = @_;
$self->{"__batch_conv_page_count"} = 0;
foreach my $module (sort {lc($a) cmp lc($b)} keys %$mod2path) {
$self->_do_one_batch_conversion($module, $mod2path, $outdir);
sleep($SLEEPY - 1) if $SLEEPY;
}
return;
}
sub _batch_convert_finish {
my($self, $outdir) = @_;
$self->write_contents_file($outdir);
$self->muse("Done with batch conversion. $$self{'__batch_conv_page_count'} files done.");
$self->muse( "= ", scalar(localtime) );
$self->progress and $self->progress->done("All done!");
return;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _do_one_batch_conversion {
my($self, $module, $mod2path, $outdir, $outfile) = @_;
my $retval;
my $total = scalar keys %$mod2path;
my $infile = $mod2path->{$module};
my @namelets = grep m/\S/, split "::", $module;
# this can stick around in the contents LoL
my $depth = scalar @namelets;
die "Contentless thingie?! $module $infile" unless @namelets; #sanity
$outfile ||= do {
my @n = @namelets;
$n[-1] .= $HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION;
$self->filespecsys->catfile( $outdir, @n );
};
my $progress = $self->progress;
my $page = $self->html_render_class->new;
if(DEBUG > 5) {
$self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: ",
ref($page), " render ($depth) $module => $outfile");
} elsif(DEBUG > 2) {
$self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: $module => $outfile")
}
# Give each class a chance to init the converter:
$page->batch_mode_page_object_init($self, $module, $infile, $outfile, $depth)
if $page->can('batch_mode_page_object_init');
# Init for the index (TOC), too.
$self->batch_mode_page_object_init($page, $module, $infile, $outfile, $depth)
if $self->can('batch_mode_page_object_init');
# Now get busy...
$self->makepath($outdir => \@namelets);
$progress and $progress->reach($self->{"__batch_conv_page_count"}, "Rendering $module");
if( $retval = $page->parse_from_file($infile, $outfile) ) {
++ $self->{"__batch_conv_page_count"} ;
$self->note_for_contents_file( \@namelets, $infile, $outfile );
} else {
$self->muse("Odd, parse_from_file(\"$infile\", \"$outfile\") returned false.");
}
$page->batch_mode_page_object_kill($self, $module, $infile, $outfile, $depth)
if $page->can('batch_mode_page_object_kill');
# The following isn't a typo. Note that it switches $self and $page.
$self->batch_mode_page_object_kill($page, $module, $infile, $outfile, $depth)
if $self->can('batch_mode_page_object_kill');
DEBUG > 4 and printf "%s %sb < $infile %s %sb\n",
$outfile, -s $outfile, $infile, -s $infile
;
undef($page);
return $retval;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub filespecsys { $_[0]{'_filespecsys'} || 'File::Spec' }
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub note_for_contents_file {
my($self, $namelets, $infile, $outfile) = @_;
# I think the infile and outfile parts are never used. -- SMB
# But it's handy to have them around for debugging.
if( $self->contents_file ) {
my $c = $self->_contents();
push @$c,
[ join("::", @$namelets), $infile, $outfile, $namelets ]
# 0 1 2 3
;
DEBUG > 3 and print "Noting @$c[-1]\n";
}
return;
}
#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
sub write_contents_file {
my($self, $outdir) = @_;
my $outfile = $self->_contents_filespec($outdir) || return;
$self->muse("Preparing list of modules for ToC");
my($toplevel, # maps toplevelbit => [all submodules]
$toplevel_form_freq, # ends up being 'foo' => 'Foo'
) = $self->_prep_contents_breakdown;
my $Contents = eval { $self->_wopen($outfile) };
if( $Contents ) {
$self->muse( "Writing contents file $outfile" );
} else {
warn "Couldn't write-open contents file $outfile: $!\nAbort writing to $outfile at all";
return;
}
$self->_write_contents_start( $Contents, $outfile, );
$self->_write_contents_middle( $Contents, $outfile, $toplevel, $toplevel_form_freq );
$self->_write_contents_end( $Contents, $outfile, );
return $outfile;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _write_contents_start {
my($self, $Contents, $outfile) = @_;
my $starter = $self->contents_page_start || '';
{
my $css_wad = $self->_css_wad_to_markup(1);
if( $css_wad ) {
$starter =~ s{(</head>)}{\n$css_wad\n$1}i; # otherwise nevermind
}
my $javascript_wad = $self->_javascript_wad_to_markup(1);
if( $javascript_wad ) {
$starter =~ s{(</head>)}{\n$javascript_wad\n$1}i; # otherwise nevermind
}
}
unless(print $Contents $starter, "<dl class='superindex'>\n" ) {
warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all";
close($Contents);
return 0;
}
return 1;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _write_contents_middle {
my($self, $Contents, $outfile, $toplevel2submodules, $toplevel_form_freq) = @_;
foreach my $t (sort keys %$toplevel2submodules) {
my @downlines = sort {$a->[-1] cmp $b->[-1]}
@{ $toplevel2submodules->{$t} };
printf $Contents qq[<dt><a name="%s">%s</a></dt>\n<dd>\n],
esc( $t, $toplevel_form_freq->{$t} )
;
my($path, $name);
foreach my $e (@downlines) {
$name = $e->[0];
$path = join( "/", '.', esc( @{$e->[3]} ) )
. ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION);
print $Contents qq{ <a href="$path">}, esc($name), "</a> \n";
}
print $Contents "</dd>\n\n";
}
return 1;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _write_contents_end {
my($self, $Contents, $outfile) = @_;
unless(
print $Contents "</dl>\n",
$self->contents_page_end || '',
) {
warn "Couldn't write to $outfile: $!";
}
close($Contents) or warn "Couldn't close $outfile: $!";
return 1;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _prep_contents_breakdown {
my($self) = @_;
my $contents = $self->_contents;
my %toplevel; # maps lctoplevelbit => [all submodules]
my %toplevel_form_freq; # ends up being 'foo' => 'Foo'
# (mapping anycase forms to most freq form)
foreach my $entry (@$contents) {
my $toplevel =
$entry->[0] =~ m/^perl\w*$/ ? 'perl_core_docs'
# group all the perlwhatever docs together
: $entry->[3][0] # normal case
;
++$toplevel_form_freq{ lc $toplevel }{ $toplevel };
push @{ $toplevel{ lc $toplevel } }, $entry;
push @$entry, lc($entry->[0]); # add a sort-order key to the end
}
foreach my $toplevel (sort keys %toplevel) {
my $fgroup = $toplevel_form_freq{$toplevel};
$toplevel_form_freq{$toplevel} =
(
sort { $fgroup->{$b} <=> $fgroup->{$a} or $a cmp $b }
keys %$fgroup
# This hash is extremely unlikely to have more than 4 members, so this
# sort isn't so very wasteful
)[0];
}
return(\%toplevel, \%toplevel_form_freq) if wantarray;
return \%toplevel;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _contents_filespec {
my($self, $outdir) = @_;
my $outfile = $self->contents_file;
return unless $outfile;
return $self->filespecsys->catfile( $outdir, $outfile );
}
#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
sub makepath {
my($self, $outdir, $namelets) = @_;
return unless @$namelets > 1;
for my $i (0 .. ($#$namelets - 1)) {
my $dir = $self->filespecsys->catdir( $outdir, @$namelets[0 .. $i] );
if(-e $dir) {
die "$dir exists but not as a directory!?" unless -d $dir;
next;
}
DEBUG > 3 and print " Making $dir\n";
mkdir $dir, 0777
or die "Can't mkdir $dir: $!\nAborting"
;
}
return;
}
#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
sub batch_mode_page_object_init {
my $self = shift;
my($page, $module, $infile, $outfile, $depth) = @_;
# TODO: any further options to percolate onto this new object here?
$page->default_title($module);
$page->index( $self->index );
$page->html_css( $self-> _css_wad_to_markup($depth) );
$page->html_javascript( $self->_javascript_wad_to_markup($depth) );
$self->add_header_backlink($page, $module, $infile, $outfile, $depth);
$self->add_footer_backlink($page, $module, $infile, $outfile, $depth);
return $self;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub add_header_backlink {
my $self = shift;
return if $self->no_contents_links;
my($page, $module, $infile, $outfile, $depth) = @_;
$page->html_header_after_title( join '',
$page->html_header_after_title || '',
qq[<p class="backlinktop"><b><a name="___top" href="],
$self->url_up_to_contents($depth),
qq[" accesskey="1" title="All Documents"><<</a></b></p>\n],
)
if $self->contents_file
;
return;
}
sub add_footer_backlink {
my $self = shift;
return if $self->no_contents_links;
my($page, $module, $infile, $outfile, $depth) = @_;
$page->html_footer( join '',
qq[<p class="backlinkbottom"><b><a name="___bottom" href="],
$self->url_up_to_contents($depth),
qq[" title="All Documents"><<</a></b></p>\n],
$page->html_footer || '',
)
if $self->contents_file
;
return;
}
sub url_up_to_contents {
my($self, $depth) = @_;
--$depth;
return join '/', ('..') x $depth, esc($self->contents_file);
}
#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
sub find_all_pods {
my($self, $dirs) = @_;
# You can override find_all_pods in a subclass if you want to
# do extra filtering or whatnot. But for the moment, we just
# pass to modnames2paths:
return $self->modnames2paths($dirs);
}
#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
sub modnames2paths { # return a hashref mapping modulenames => paths
my($self, $dirs) = @_;
my $m2p;
{
my $search = $self->search_class->new;
DEBUG and print "Searching via $search\n";
$search->verbose(1) if DEBUG > 10;
$search->progress( $self->progress->copy->goal(0) ) if $self->progress;
$search->shadows(0); # don't bother noting shadowed files
$search->inc( $dirs ? 0 : 1 );
$search->survey( $dirs ? @$dirs : () );
$m2p = $search->name2path;
die "What, no name2path?!" unless $m2p;
}
$self->muse("That's odd... no modules found!") unless keys %$m2p;
if( DEBUG > 4 ) {
print "Modules found (name => path):\n";
foreach my $m (sort {lc($a) cmp lc($b)} keys %$m2p) {
print " $m $$m2p{$m}\n";
}
print "(total ", scalar(keys %$m2p), ")\n\n";
} elsif( DEBUG ) {
print "Found ", scalar(keys %$m2p), " modules.\n";
}
$self->muse( "Found ", scalar(keys %$m2p), " modules." );
# return the Foo::Bar => /whatever/Foo/Bar.pod|pm hashref
return $m2p;
}
#===========================================================================
sub _wopen {
# this is abstracted out so that the daemon class can override it
my($self, $outpath) = @_;
require Symbol;
my $out_fh = Symbol::gensym();
DEBUG > 5 and print "Write-opening to $outpath\n";
return $out_fh if open($out_fh, "> $outpath");
require Carp;
Carp::croak("Can't write-open $outpath: $!");
}
#==========================================================================
sub add_css {
my($self, $url, $is_default, $name, $content_type, $media, $_code) = @_;
return unless $url;
unless($name) {
# cook up a reasonable name based on the URL
$name = $url;
if( $name !~ m/\?/ and $name =~ m{([^/]+)$}s ) {
$name = $1;
$name =~ s/\.css//i;
}
}
$media ||= 'all';
$content_type ||= 'text/css';
my $bunch = [$url, $name, $content_type, $media, $_code];
if($is_default) { unshift @{ $self->_css_wad }, $bunch }
else { push @{ $self->_css_wad }, $bunch }
return;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _spray_css {
my($self, $outdir) = @_;
return unless $self->css_flurry();
$self->_gen_css_wad();
my $lol = $self->_css_wad;
foreach my $chunk (@$lol) {
my $url = $chunk->[0];
my $outfile;
if( ref($chunk->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.css$)} ) {
$outfile = $self->filespecsys->catfile( $outdir, "$1" );
DEBUG > 5 and print "Noting $$chunk[0] as a file I'll create.\n";
} else {
DEBUG > 5 and print "OK, noting $$chunk[0] as an external CSS.\n";
# Requires no further attention.
next;
}
#$self->muse( "Writing autogenerated CSS file $outfile" );
my $Cssout = $self->_wopen($outfile);
print $Cssout ${$chunk->[-1]}
or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all";
close($Cssout);
DEBUG > 5 and print "Wrote $outfile\n";
}
return;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _css_wad_to_markup {
my($self, $depth) = @_;
my @css = @{ $self->_css_wad || return '' };
return '' unless @css;
my $rel = 'stylesheet';
my $out = '';
--$depth;
my $uplink = $depth ? ('../' x $depth) : '';
foreach my $chunk (@css) {
next unless $chunk and @$chunk;
my( $url1, $url2, $title, $type, $media) = (
$self->_maybe_uplink( $chunk->[0], $uplink ),
esc(grep !ref($_), @$chunk)
);
$out .= qq{<link rel="$rel" title="$title" type="$type" href="$url1$url2" media="$media" >\n};
$rel = 'alternate stylesheet'; # alternates = all non-first iterations
}
return $out;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _maybe_uplink {
# if the given URL looks relative, return the given uplink string --
# otherwise return emptystring
my($self, $url, $uplink) = @_;
($url =~ m{^\./} or $url !~ m{[/\:]} )
? $uplink
: ''
# qualify it, if/as needed
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _gen_css_wad {
my $self = $_[0];
my $css_template = $self->_css_template;
foreach my $variation (
# Commented out for sake of concision:
#
# 011n=black_with_red_on_white
# 001n=black_with_yellow_on_white
# 101n=black_with_green_on_white
# 110=white_with_yellow_on_black
# 010=white_with_green_on_black
# 011=white_with_blue_on_black
# 100=white_with_red_on_black
'110n=blkbluw', # black_with_blue_on_white
'010n=blkmagw', # black_with_magenta_on_white
'100n=blkcynw', # black_with_cyan_on_white
'101=whtprpk', # white_with_purple_on_black
'001=whtnavk', # white_with_navy_blue_on_black
'010a=grygrnk', # grey_with_green_on_black
'010b=whtgrng', # white_with_green_on_grey
'101an=blkgrng', # black_with_green_on_grey
'101bn=grygrnw', # grey_with_green_on_white
) {
my $outname = $variation;
my($flipmode, @swap) = ( ($4 || ''), $1,$2,$3)
if $outname =~ s/^([012])([012])([[012])([a-z]*)=?//s;
@swap = () if '010' eq join '', @swap; # 010 is a swop-no-op!
my $this_css =
"/* This file is autogenerated. Do not edit. $variation */\n\n"
. $css_template;
# Only look at three-digitty colors, for now at least.
if( $flipmode =~ m/n/ ) {
$this_css =~ s/(#[0-9a-fA-F]{3})\b/_color_negate($1)/eg;
$this_css =~ s/\bthin\b/medium/g;
}
$this_css =~ s<#([0-9a-fA-F])([0-9a-fA-F])([0-9a-fA-F])\b>
< join '', '#', ($1,$2,$3)[@swap] >eg if @swap;
if( $flipmode =~ m/a/)
{ $this_css =~ s/#fff\b/#999/gi } # black -> dark grey
elsif($flipmode =~ m/b/)
{ $this_css =~ s/#000\b/#666/gi } # white -> light grey
my $name = $outname;
$name =~ tr/-_/ /;
$self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css);
}
# Now a few indexless variations:
foreach my $variation (
'blkbluw', # black_with_blue_on_white
'whtpurk', # white_with_purple_on_black
'whtgrng', # white_with_green_on_grey
'grygrnw', # grey_with_green_on_white
) {
my $outname = $variation;
my $this_css = join "\n",
"/* This file is autogenerated. Do not edit. $outname */\n",
"\@import url(\"./_$variation.css\");",
".indexgroup { display: none; }",
"\n",
;
my $name = $outname;
$name =~ tr/-_/ /;
$self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css);
}
return;
}
sub _color_negate {
my $x = lc $_[0];
$x =~ tr[0123456789abcdef]
[fedcba9876543210];
return $x;
}
#===========================================================================
sub add_javascript {
my($self, $url, $content_type, $_code) = @_;
return unless $url;
push @{ $self->_javascript_wad }, [
$url, $content_type || 'text/javascript', $_code
];
return;
}
sub _spray_javascript {
my($self, $outdir) = @_;
return unless $self->javascript_flurry();
$self->_gen_javascript_wad();
my $lol = $self->_javascript_wad;
foreach my $script (@$lol) {
my $url = $script->[0];
my $outfile;
if( ref($script->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.js$)} ) {
$outfile = $self->filespecsys->catfile( $outdir, "$1" );
DEBUG > 5 and print "Noting $$script[0] as a file I'll create.\n";
} else {
DEBUG > 5 and print "OK, noting $$script[0] as an external JavaScript.\n";
next;
}
#$self->muse( "Writing JavaScript file $outfile" );
my $Jsout = $self->_wopen($outfile);
print $Jsout ${$script->[-1]}
or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all";
close($Jsout);
DEBUG > 5 and print "Wrote $outfile\n";
}
return;
}
sub _gen_javascript_wad {
my $self = $_[0];
my $js_code = $self->_javascript || return;
$self->add_javascript( "_podly.js", 0, \$js_code);
return;
}
sub _javascript_wad_to_markup {
my($self, $depth) = @_;
my @scripts = @{ $self->_javascript_wad || return '' };
return '' unless @scripts;
my $out = '';
--$depth;
my $uplink = $depth ? ('../' x $depth) : '';
foreach my $s (@scripts) {
next unless $s and @$s;
my( $url1, $url2, $type, $media) = (
$self->_maybe_uplink( $s->[0], $uplink ),
esc(grep !ref($_), @$s)
);
$out .= qq{<script type="$type" src="$url1$url2"></script>\n};
}
return $out;
}
#===========================================================================
sub _css_template { return $CSS }
sub _javascript { return $JAVASCRIPT }
$CSS = <<'EOCSS';
/* For accessibility reasons, never specify text sizes in px/pt/pc/in/cm/mm */
@media all { .hide { display: none; } }
@media print {
.noprint, div.indexgroup, .backlinktop, .backlinkbottom { display: none }
* {
border-color: black !important;
color: black !important;
background-color: transparent !important;
background-image: none !important;
}
dl.superindex > dd {
word-spacing: .6em;
}
}
@media aural, braille, embossed {
div.indexgroup { display: none; } /* Too noisy, don't you think? */
dl.superindex > dt:before { content: "Group "; }
dl.superindex > dt:after { content: " contains:"; }
.backlinktop a:before { content: "Back to contents"; }
.backlinkbottom a:before { content: "Back to contents"; }
}
@media aural {
dl.superindex > dt { pause-before: 600ms; }
}
@media screen, tty, tv, projection {
.noscreen { display: none; }
a:link { color: #7070ff; text-decoration: underline; }
a:visited { color: #e030ff; text-decoration: underline; }
a:active { color: #800000; text-decoration: underline; }
body.contentspage a { text-decoration: none; }
a.u { color: #fff !important; text-decoration: none; }
body.pod {
margin: 0 5px;
color: #fff;
background-color: #000;
}
body.pod h1, body.pod h2, body.pod h3, body.pod h4 {
font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif;
font-weight: normal;
margin-top: 1.2em;
margin-bottom: .1em;
border-top: thin solid transparent;
/* margin-left: -5px; border-left: 2px #7070ff solid; padding-left: 3px; */
}
body.pod h1 { border-top-color: #0a0; }
body.pod h2 { border-top-color: #080; }
body.pod h3 { border-top-color: #040; }
body.pod h4 { border-top-color: #010; }
p.backlinktop + h1 { border-top: none; margin-top: 0em; }
p.backlinktop + h2 { border-top: none; margin-top: 0em; }
p.backlinktop + h3 { border-top: none; margin-top: 0em; }
p.backlinktop + h4 { border-top: none; margin-top: 0em; }
body.pod dt {
font-size: 105%; /* just a wee bit more than normal */
}
.indexgroup { font-size: 80%; }
.backlinktop, .backlinkbottom {
margin-left: -5px;
margin-right: -5px;
background-color: #040;
border-top: thin solid #050;
border-bottom: thin solid #050;
}
.backlinktop a, .backlinkbottom a {
text-decoration: none;
color: #080;
background-color: #000;
border: thin solid #0d0;
}
.backlinkbottom { margin-bottom: 0; padding-bottom: 0; }
.backlinktop { margin-top: 0; padding-top: 0; }
body.contentspage {
color: #fff;
background-color: #000;
}
body.contentspage h1 {
color: #0d0;
margin-left: 1em;
margin-right: 1em;
text-indent: -.9em;
font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif;
font-weight: normal;
border-top: thin solid #fff;
border-bottom: thin solid #fff;
text-align: center;
}
dl.superindex > dt {
font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif;
font-weight: normal;
font-size: 90%;
margin-top: .45em;
/* margin-bottom: -.15em; */
}
dl.superindex > dd {
word-spacing: .6em; /* most important rule here! */
}
dl.superindex > a:link {
text-decoration: none;
color: #fff;
}
.contentsfooty {
border-top: thin solid #999;
font-size: 90%;
}
}
/* The End */
EOCSS
#==========================================================================
$JAVASCRIPT = <<'EOJAVASCRIPT';
// From http://www.alistapart.com/articles/alternate/
function setActiveStyleSheet(title) {
var i, a, main;
for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) {
if(a.getAttribute("rel").indexOf("style") != -1 && a.getAttribute("title")) {
a.disabled = true;
if(a.getAttribute("title") == title) a.disabled = false;
}
}
}
function getActiveStyleSheet() {
var i, a;
for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) {
if( a.getAttribute("rel").indexOf("style") != -1
&& a.getAttribute("title")
&& !a.disabled
) return a.getAttribute("title");
}
return null;
}
function getPreferredStyleSheet() {
var i, a;
for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) {
if( a.getAttribute("rel").indexOf("style") != -1
&& a.getAttribute("rel").indexOf("alt") == -1
&& a.getAttribute("title")
) return a.getAttribute("title");
}
return null;
}
function createCookie(name,value,days) {
if (days) {
var date = new Date();
date.setTime(date.getTime()+(days*24*60*60*1000));
var expires = "; expires="+date.toGMTString();
}
else expires = "";
document.cookie = name+"="+value+expires+"; path=/";
}
function readCookie(name) {
var nameEQ = name + "=";
var ca = document.cookie.split(';');
for(var i=0 ; i < ca.length ; i++) {
var c = ca[i];
while (c.charAt(0)==' ') c = c.substring(1,c.length);
if (c.indexOf(nameEQ) == 0) return c.substring(nameEQ.length,c.length);
}
return null;
}
window.onload = function(e) {
var cookie = readCookie("style");
var title = cookie ? cookie : getPreferredStyleSheet();
setActiveStyleSheet(title);
}
window.onunload = function(e) {
var title = getActiveStyleSheet();
createCookie("style", title, 365);
}
var cookie = readCookie("style");
var title = cookie ? cookie : getPreferredStyleSheet();
setActiveStyleSheet(title);
// The End
EOJAVASCRIPT
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1;
__END__
=head1 NAME
Pod::Simple::HTMLBatch - convert several Pod files to several HTML files
=head1 SYNOPSIS
perl -MPod::Simple::HTMLBatch -e 'Pod::Simple::HTMLBatch::go' in out
=head1 DESCRIPTION
This module is used for running batch-conversions of a lot of HTML
documents
This class is NOT a subclass of Pod::Simple::HTML
(nor of bad old Pod::Html) -- although it uses
Pod::Simple::HTML for doing the conversion of each document.
The normal use of this class is like so:
use Pod::Simple::HTMLBatch;
my $batchconv = Pod::Simple::HTMLBatch->new;
$batchconv->some_option( some_value );
$batchconv->some_other_option( some_other_value );
$batchconv->batch_convert( \@search_dirs, $output_dir );
=head2 FROM THE COMMAND LINE
Note that this class also provides
(but does not export) the function Pod::Simple::HTMLBatch::go.
This is basically just a shortcut for C<<
Pod::Simple::HTMLBatch->batch_convert(@ARGV) >>.
It's meant to be handy for calling from the command line.
However, the shortcut requires that you specify exactly two command-line
arguments, C<indirs> and C<outdir>.
Example:
% mkdir out_html
% perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go @INC out_html
(to convert the pod from Perl's @INC
files under the directory ./out_html)
(Note that the command line there contains a literal atsign-I-N-C. This
is handled as a special case by batch_convert, in order to save you having
to enter the odd-looking "" as the first command-line parameter when you
mean "just use whatever's in @INC".)
Example:
% mkdir ../seekrut
% chmod og-rx ../seekrut
% perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go . ../seekrut
(to convert the pod under the current dir into HTML
files under the directory ./seekrut)
Example:
% perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go happydocs .
(to convert all pod from happydocs into the current directory)
=head1 MAIN METHODS
=over
=item $batchconv = Pod::Simple::HTMLBatch->new;
This TODO
=item $batchconv->batch_convert( I<indirs>, I<outdir> );
this TODO
=item $batchconv->batch_convert( undef , ...);
=item $batchconv->batch_convert( q{@INC}, ...);
These two values for I<indirs> specify that the normal Perl @INC
=item $batchconv->batch_convert( \@dirs , ...);
This specifies that the input directories are the items in
the arrayref C<\@dirs>.
=item $batchconv->batch_convert( "somedir" , ...);
This specifies that the director "somedir" is the input.
(This can be an absolute or relative path, it doesn't matter.)
A common value you might want would be just "." for the current
directory:
$batchconv->batch_convert( "." , ...);
=item $batchconv->batch_convert( 'somedir:someother:also' , ...);
This specifies that you want the dirs "somedir", "someother", and "also"
scanned, just as if you'd passed the arrayref
C<[qw( somedir someother also)]>. Note that a ":"-separator is normal
under Unix, but Under MSWin, you'll need C<'somedir;someother;also'>
instead, since the pathsep on MSWin is ";" instead of ":". (And
I<that> is because ":" often comes up in paths, like
C<"c:/perl/lib">.)
(Exactly what separator character should be used, is gotten from
C<$Config::Config{'path_sep'}>, via the L<Config> module.)
=item $batchconv->batch_convert( ... , undef );
This specifies that you want the HTML output to go into the current
directory.
(Note that a missing or undefined value means a different thing in
the first slot than in the second. That's so that C<batch_convert()>
with no arguments (or undef arguments) means "go from @INC, into
the current directory.)
=item $batchconv->batch_convert( ... , 'somedir' );
This specifies that you want the HTML output to go into the
directory 'somedir'.
(This can be an absolute or relative path, it doesn't matter.)
=back
Note that you can also call C<batch_convert> as a class method,
like so:
Pod::Simple::HTMLBatch->batch_convert( ... );
That is just short for this:
Pod::Simple::HTMLBatch-> new-> batch_convert(...);
That is, it runs a conversion with default options, for
whatever inputdirs and output dir you specify.
=head2 ACCESSOR METHODS
The following are all accessor methods -- that is, they don't do anything
on their own, but just alter the contents of the conversion object,
which comprises the options for this particular batch conversion.
We show the "put" form of the accessors below (i.e., the syntax you use
for setting the accessor to a specific value). But you can also
call each method with no parameters to get its current value. For
example, C<< $self->contents_file() >> returns the current value of
the contents_file attribute.
=over
=item $batchconv->verbose( I<nonnegative_integer> );
This controls how verbose to be during batch conversion, as far as
notes to STDOUT (or whatever is C<select>'d) about how the conversion
is going. If 0, no progress information is printed.
If 1 (the default value), some progress information is printed.
Higher values print more information.
=item $batchconv->index( I<true-or-false> );
This controls whether or not each HTML page is liable to have a little
table of contents at the top (which we call an "index" for historical
reasons). This is true by default.
=item $batchconv->contents_file( I<filename> );
If set, should be the name of a file (in the output directory)
to write the HTML index to. The default value is "index.html".
If you set this to a false value, no contents file will be written.
=item $batchconv->contents_page_start( I<HTML_string> );
This specifies what string should be put at the beginning of
the contents page.
The default is a string more or less like this:
<html>
<head><title>Perl Documentation</title></head>
<body class='contentspage'>
<h1>Perl Documentation</h1>
=item $batchconv->contents_page_end( I<HTML_string> );
This specifies what string should be put at the end of the contents page.
The default is a string more or less like this:
<p class='contentsfooty'>Generated by
Pod::Simple::HTMLBatch v3.01 under Perl v5.008
<br >At Fri May 14 22:26:42 2004 GMT,
which is Fri May 14 14:26:42 2004 local time.</p>
=item $batchconv->add_css( $url );
TODO
=item $batchconv->add_javascript( $url );
TODO
=item $batchconv->css_flurry( I<true-or-false> );
If true (the default value), we autogenerate some CSS files in the
output directory, and set our HTML files to use those.
TODO: continue
=item $batchconv->javascript_flurry( I<true-or-false> );
If true (the default value), we autogenerate a JavaScript in the
output directory, and set our HTML files to use it. Currently,
the JavaScript is used only to get the browser to remember what
stylesheet it prefers.
TODO: continue
=item $batchconv->no_contents_links( I<true-or-false> );
TODO
=item $batchconv->html_render_class( I<classname> );
This sets what class is used for rendering the files.
The default is "Pod::Simple::HTML". If you set it to something else,
it should probably be a subclass of Pod::Simple::HTML, and you should
C<require> or C<use> that class so that's it's loaded before
Pod::Simple::HTMLBatch tries loading it.
=item $batchconv->search_class( I<classname> );
This sets what class is used for searching for the files.
The default is "Pod::Simple::Search". If you set it to something else,
it should probably be a subclass of Pod::Simple::Search, and you should
C<require> or C<use> that class so that's it's loaded before
Pod::Simple::HTMLBatch tries loading it.
=back
=head1 NOTES ON CUSTOMIZATION
TODO
call add_css($someurl) to add stylesheet as alternate
call add_css($someurl,1) to add as primary stylesheet
call add_javascript
subclass Pod::Simple::HTML and set $batchconv->html_render_class to
that classname
and maybe override
$page->batch_mode_page_object_init($self, $module, $infile, $outfile, $depth)
or maybe override
$batchconv->batch_mode_page_object_init($page, $module, $infile, $outfile, $depth)
subclass Pod::Simple::Search and set $batchconv->search_class to
that classname
=head1 ASK ME!
If you want to do some kind of big pod-to-HTML version with some
particular kind of option that you don't see how to achieve using this
module, email me (C<sburke@cpan.org>) and I'll probably have a good idea
how to do it. For reasons of concision and energetic laziness, some
methods and options in this module (and the dozen modules it depends on)
are undocumented; but one of those undocumented bits might be just what
you're looking for.
=head1 SEE ALSO
L<Pod::Simple>, L<Pod::Simple::HTMLBatch>, L<perlpod>, L<perlpodspec>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_HTMLBATCH
$fatpacked{"Pod/Simple/HTMLLegacy.pm"} = <<'POD_SIMPLE_HTMLLEGACY';
require 5;
package Pod::Simple::HTMLLegacy;
use strict;
use vars qw($VERSION);
use Getopt::Long;
$VERSION = "5.01";
#--------------------------------------------------------------------------
#
# This class is meant to thinly emulate bad old Pod::Html
#
# TODO: some basic docs
sub pod2html {
my @args = (@_);
my( $verbose, $infile, $outfile, $title );
my $index = 1;
{
my($help);
my($netscape); # dummy
local @ARGV = @args;
GetOptions(
"help" => \$help,
"verbose!" => \$verbose,
"infile=s" => \$infile,
"outfile=s" => \$outfile,
"title=s" => \$title,
"index!" => \$index,
"netscape!" => \$netscape,
) or return bad_opts(@args);
bad_opts(@args) if @ARGV; # it should be all switches!
return help_message() if $help;
}
for($infile, $outfile) { $_ = undef unless defined and length }
if($verbose) {
warn sprintf "%s version %s\n", __PACKAGE__, $VERSION;
warn "OK, processed args [@args] ...\n";
warn sprintf
" Verbose: %s\n Index: %s\n Infile: %s\n Outfile: %s\n Title: %s\n",
map defined($_) ? $_ : "(nil)",
$verbose, $index, $infile, $outfile, $title,
;
*Pod::Simple::HTML::DEBUG = sub(){1};
}
require Pod::Simple::HTML;
Pod::Simple::HTML->VERSION(3);
die "No such input file as $infile\n"
if defined $infile and ! -e $infile;
my $pod = Pod::Simple::HTML->new;
$pod->force_title($title) if defined $title;
$pod->index($index);
return $pod->parse_from_file($infile, $outfile);
}
#--------------------------------------------------------------------------
sub bad_opts { die _help_message(); }
sub help_message { print STDOUT _help_message() }
#--------------------------------------------------------------------------
sub _help_message {
join '',
"[", __PACKAGE__, " version ", $VERSION, qq~]
Usage: pod2html --help --infile=<name> --outfile=<name>
--verbose --index --noindex
Options:
--help - prints this message.
--[no]index - generate an index at the top of the resulting html
(default behavior).
--infile - filename for the pod to convert (input taken from stdin
by default).
--outfile - filename for the resulting html file (output sent to
stdout by default).
--title - title that will appear in resulting html file.
--[no]verbose - self-explanatory (off by default).
Note that pod2html is DEPRECATED, and this version implements only
some of the options known to older versions.
For more information, see 'perldoc pod2html'.
~;
}
1;
__END__
OVER the underpass! UNDER the overpass! Around the FUTURE and BEYOND REPAIR!!
POD_SIMPLE_HTMLLEGACY
$fatpacked{"Pod/Simple/LinkSection.pm"} = <<'POD_SIMPLE_LINKSECTION';
require 5;
package Pod::Simple::LinkSection;
# Based somewhat dimly on Array::Autojoin
use vars qw($VERSION );
$VERSION = '3.26';
use strict;
use Pod::Simple::BlackBox;
use vars qw($VERSION );
$VERSION = '3.26';
use overload( # So it'll stringify nice
'""' => \&Pod::Simple::BlackBox::stringify_lol,
'bool' => \&Pod::Simple::BlackBox::stringify_lol,
# '.=' => \&tack_on, # grudgingly support
'fallback' => 1, # turn on cleverness
);
sub tack_on {
$_[0] = ['', {}, "$_[0]" ];
return $_[0][2] .= $_[1];
}
sub as_string {
goto &Pod::Simple::BlackBox::stringify_lol;
}
sub stringify {
goto &Pod::Simple::BlackBox::stringify_lol;
}
sub new {
my $class = shift;
$class = ref($class) || $class;
my $new;
if(@_ == 1) {
if (!ref($_[0] || '')) { # most common case: one bare string
return bless ['', {}, $_[0] ], $class;
} elsif( ref($_[0] || '') eq 'ARRAY') {
$new = [ @{ $_[0] } ];
} else {
Carp::croak( "$class new() doesn't know to clone $new" );
}
} else { # misc stuff
$new = [ '', {}, @_ ];
}
# By now it's a treelet: [ 'foo', {}, ... ]
foreach my $x (@$new) {
if(ref($x || '') eq 'ARRAY') {
$x = $class->new($x); # recurse
} elsif(ref($x || '') eq 'HASH') {
$x = { %$x };
}
# otherwise leave it.
}
return bless $new, $class;
}
# Not much in this class is likely to be link-section specific --
# but it just so happens that link-sections are about the only treelets
# that are exposed to the user.
1;
__END__
# TODO: let it be an option whether a given subclass even wants little treelets?
__END__
=head1 NAME
Pod::Simple::LinkSection -- represent "section" attributes of L codes
=head1 SYNOPSIS
# a long story
=head1 DESCRIPTION
This class is not of interest to general users.
Pod::Simple uses this class for representing the value of the
"section" attribute of "L" start-element events. Most applications
can just use the normal stringification of objects of this class;
they stringify to just the text content of the section,
such as "foo" for
C<< LZ<><Stuff/foo> >>, and "bar" for
C<< LZ<><Stuff/bIZ<><ar>> >>.
However, anyone particularly interested in getting the full value of
the treelet, can just traverse the content of the treeleet
@$treelet_object. To wit:
% perl -MData::Dumper -e
"use base qw(Pod::Simple::Methody);
sub start_L { print Dumper($_[1]{'section'} ) }
__PACKAGE__->new->parse_string_document('=head1 L<Foo/bI<ar>baz>>')
"
Output:
$VAR1 = bless( [
'',
{},
'b',
bless( [
'I',
{},
'ar'
], 'Pod::Simple::LinkSection' ),
'baz'
], 'Pod::Simple::LinkSection' );
But stringify it and you get just the text content:
% perl -MData::Dumper -e
"use base qw(Pod::Simple::Methody);
sub start_L { print Dumper( '' . $_[1]{'section'} ) }
__PACKAGE__->new->parse_string_document('=head1 L<Foo/bI<ar>baz>>')
"
Output:
$VAR1 = 'barbaz';
=head1 SEE ALSO
L<Pod::Simple>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2004 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_LINKSECTION
$fatpacked{"Pod/Simple/Methody.pm"} = <<'POD_SIMPLE_METHODY';
require 5;
package Pod::Simple::Methody;
use strict;
use Pod::Simple ();
use vars qw(@ISA $VERSION);
$VERSION = '3.26';
@ISA = ('Pod::Simple');
# Yes, we could use named variables, but I want this to be impose
# as little an additional performance hit as possible.
sub _handle_element_start {
$_[1] =~ tr/-:./__/;
( $_[0]->can( 'start_' . $_[1] )
|| return
)->(
$_[0], $_[2]
);
}
sub _handle_text {
( $_[0]->can( 'handle_text' )
|| return
)->(
@_
);
}
sub _handle_element_end {
$_[1] =~ tr/-:./__/;
( $_[0]->can( 'end_' . $_[1] )
|| return
)->(
$_[0], $_[2]
);
}
1;
__END__
=head1 NAME
Pod::Simple::Methody -- turn Pod::Simple events into method calls
=head1 SYNOPSIS
require 5;
use strict;
package SomePodFormatter;
use base qw(Pod::Simple::Methody);
sub handle_text {
my($self, $text) = @_;
...
}
sub start_head1 {
my($self, $attrs) = @_;
...
}
sub end_head1 {
my($self) = @_;
...
}
...and start_/end_ methods for whatever other events you want to catch.
=head1 DESCRIPTION
This class is of
interest to people writing Pod formatters based on Pod::Simple.
This class (which is very small -- read the source) overrides
Pod::Simple's _handle_element_start, _handle_text, and
_handle_element_end methods so that parser events are turned into method
calls. (Otherwise, this is a subclass of L<Pod::Simple> and inherits all
its methods.)
You can use this class as the base class for a Pod formatter/processor.
=head1 METHOD CALLING
When Pod::Simple sees a "=head1 Hi there", for example, it basically does
this:
$parser->_handle_element_start( "head1", \%attributes );
$parser->_handle_text( "Hi there" );
$parser->_handle_element_end( "head1" );
But if you subclass Pod::Simple::Methody, it will instead do this
when it sees a "=head1 Hi there":
$parser->start_head1( \%attributes ) if $parser->can('start_head1');
$parser->handle_text( "Hi there" ) if $parser->can('handle_text');
$parser->end_head1() if $parser->can('end_head1');
If Pod::Simple sends an event where the element name has a dash,
period, or colon, the corresponding method name will have a underscore
in its place. For example, "foo.bar:baz" becomes start_foo_bar_baz
and end_foo_bar_baz.
See the source for Pod::Simple::Text for an example of using this class.
=head1 SEE ALSO
L<Pod::Simple>, L<Pod::Simple::Subclassing>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_METHODY
$fatpacked{"Pod/Simple/Progress.pm"} = <<'POD_SIMPLE_PROGRESS';
require 5;
package Pod::Simple::Progress;
$VERSION = '3.26';
use strict;
# Objects of this class are used for noting progress of an
# operation every so often. Messages delivered more often than that
# are suppressed.
#
# There's actually nothing in here that's specific to Pod processing;
# but it's ad-hoc enough that I'm not willing to give it a name that
# implies that it's generally useful, like "IO::Progress" or something.
#
# -- sburke
#
#--------------------------------------------------------------------------
sub new {
my($class,$delay) = @_;
my $self = bless {'quiet_until' => 1}, ref($class) || $class;
$self->to(*STDOUT{IO});
$self->delay(defined($delay) ? $delay : 5);
return $self;
}
sub copy {
my $orig = shift;
bless {%$orig, 'quiet_until' => 1}, ref($orig);
}
#--------------------------------------------------------------------------
sub reach {
my($self, $point, $note) = @_;
if( (my $now = time) >= $self->{'quiet_until'}) {
my $goal;
my $to = $self->{'to'};
print $to join('',
($self->{'quiet_until'} == 1) ? () : '... ',
(defined $point) ? (
'#',
($goal = $self->{'goal'}) ? (
' ' x (length($goal) - length($point)),
$point, '/', $goal,
) : $point,
$note ? ': ' : (),
) : (),
$note || '',
"\n"
);
$self->{'quiet_until'} = $now + $self->{'delay'};
}
return $self;
}
#--------------------------------------------------------------------------
sub done {
my($self, $note) = @_;
$self->{'quiet_until'} = 1;
return $self->reach( undef, $note );
}
#--------------------------------------------------------------------------
# Simple accessors:
sub delay {
return $_[0]{'delay'} if @_ == 1; $_[0]{'delay'} = $_[1]; return $_[0] }
sub goal {
return $_[0]{'goal' } if @_ == 1; $_[0]{'goal' } = $_[1]; return $_[0] }
sub to {
return $_[0]{'to' } if @_ == 1; $_[0]{'to' } = $_[1]; return $_[0] }
#--------------------------------------------------------------------------
unless(caller) { # Simple self-test:
my $p = __PACKAGE__->new->goal(5);
$p->reach(1, "Primus!");
sleep 1;
$p->reach(2, "Secundus!");
sleep 3;
$p->reach(3, "Tertius!");
sleep 5;
$p->reach(4);
$p->reach(5, "Quintus!");
sleep 1;
$p->done("All done");
}
#--------------------------------------------------------------------------
1;
__END__
POD_SIMPLE_PROGRESS
$fatpacked{"Pod/Simple/PullParser.pm"} = <<'POD_SIMPLE_PULLPARSER';
require 5;
package Pod::Simple::PullParser;
$VERSION = '3.26';
use Pod::Simple ();
BEGIN {@ISA = ('Pod::Simple')}
use strict;
use Carp ();
use Pod::Simple::PullParserStartToken;
use Pod::Simple::PullParserEndToken;
use Pod::Simple::PullParserTextToken;
BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
__PACKAGE__->_accessorize(
'source_fh', # the filehandle we're reading from
'source_scalar_ref', # the scalarref we're reading from
'source_arrayref', # the arrayref we're reading from
);
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#
# And here is how we implement a pull-parser on top of a push-parser...
sub filter {
my($self, $source) = @_;
$self = $self->new unless ref $self;
$source = *STDIN{IO} unless defined $source;
$self->set_source($source);
$self->output_fh(*STDOUT{IO});
$self->run; # define run() in a subclass if you want to use filter()!
return $self;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub parse_string_document {
my $this = shift;
$this->set_source(\ $_[0]);
$this->run;
}
sub parse_file {
my($this, $filename) = @_;
$this->set_source($filename);
$this->run;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# In case anyone tries to use them:
sub run {
use Carp ();
if( __PACKAGE__ eq ref($_[0]) || $_[0]) { # I'm not being subclassed!
Carp::croak "You can call run() only on subclasses of "
. __PACKAGE__;
} else {
Carp::croak join '',
"You can't call run() because ",
ref($_[0]) || $_[0], " didn't define a run() method";
}
}
sub parse_lines {
use Carp ();
Carp::croak "Use set_source with ", __PACKAGE__,
" and subclasses, not parse_lines";
}
sub parse_line {
use Carp ();
Carp::croak "Use set_source with ", __PACKAGE__,
" and subclasses, not parse_line";
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub new {
my $class = shift;
my $self = $class->SUPER::new(@_);
die "Couldn't construct for $class" unless $self;
$self->{'token_buffer'} ||= [];
$self->{'start_token_class'} ||= 'Pod::Simple::PullParserStartToken';
$self->{'text_token_class'} ||= 'Pod::Simple::PullParserTextToken';
$self->{'end_token_class'} ||= 'Pod::Simple::PullParserEndToken';
DEBUG > 1 and print "New pullparser object: $self\n";
return $self;
}
# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
sub get_token {
my $self = shift;
DEBUG > 1 and print "\nget_token starting up on $self.\n";
DEBUG > 2 and print " Items in token-buffer (",
scalar( @{ $self->{'token_buffer'} } ) ,
") :\n", map(
" " . $_->dump . "\n", @{ $self->{'token_buffer'} }
),
@{ $self->{'token_buffer'} } ? '' : ' (no tokens)',
"\n"
;
until( @{ $self->{'token_buffer'} } ) {
DEBUG > 3 and print "I need to get something into my empty token buffer...\n";
if($self->{'source_dead'}) {
DEBUG and print "$self 's source is dead.\n";
push @{ $self->{'token_buffer'} }, undef;
} elsif(exists $self->{'source_fh'}) {
my @lines;
my $fh = $self->{'source_fh'}
|| Carp::croak('You have to call set_source before you can call get_token');
DEBUG and print "$self 's source is filehandle $fh.\n";
# Read those many lines at a time
for(my $i = Pod::Simple::MANY_LINES; $i--;) {
DEBUG > 3 and print " Fetching a line from source filehandle $fh...\n";
local $/ = $Pod::Simple::NL;
push @lines, scalar(<$fh>); # readline
DEBUG > 3 and print " Line is: ",
defined($lines[-1]) ? $lines[-1] : "<undef>\n";
unless( defined $lines[-1] ) {
DEBUG and print "That's it for that source fh! Killing.\n";
delete $self->{'source_fh'}; # so it can be GC'd
last;
}
# but pass thru the undef, which will set source_dead to true
# TODO: look to see if $lines[-1] is =encoding, and if so,
# do horribly magic things
}
if(DEBUG > 8) {
print "* I've gotten ", scalar(@lines), " lines:\n";
foreach my $l (@lines) {
if(defined $l) {
print " line {$l}\n";
} else {
print " line undef\n";
}
}
print "* end of ", scalar(@lines), " lines\n";
}
$self->SUPER::parse_lines(@lines);
} elsif(exists $self->{'source_arrayref'}) {
DEBUG and print "$self 's source is arrayref $self->{'source_arrayref'}, with ",
scalar(@{$self->{'source_arrayref'}}), " items left in it.\n";
DEBUG > 3 and print " Fetching ", Pod::Simple::MANY_LINES, " lines.\n";
$self->SUPER::parse_lines(
splice @{ $self->{'source_arrayref'} },
0,
Pod::Simple::MANY_LINES
);
unless( @{ $self->{'source_arrayref'} } ) {
DEBUG and print "That's it for that source arrayref! Killing.\n";
$self->SUPER::parse_lines(undef);
delete $self->{'source_arrayref'}; # so it can be GC'd
}
# to make sure that an undef is always sent to signal end-of-stream
} elsif(exists $self->{'source_scalar_ref'}) {
DEBUG and print "$self 's source is scalarref $self->{'source_scalar_ref'}, with ",
length(${ $self->{'source_scalar_ref'} }) -
(pos(${ $self->{'source_scalar_ref'} }) || 0),
" characters left to parse.\n";
DEBUG > 3 and print " Fetching a line from source-string...\n";
if( ${ $self->{'source_scalar_ref'} } =~
m/([^\n\r]*)((?:\r?\n)?)/g
) {
#print(">> $1\n"),
$self->SUPER::parse_lines($1)
if length($1) or length($2)
or pos( ${ $self->{'source_scalar_ref'} })
!= length( ${ $self->{'source_scalar_ref'} });
# I.e., unless it's a zero-length "empty line" at the very
# end of "foo\nbar\n" (i.e., between the \n and the EOS).
} else { # that's the end. Byebye
$self->SUPER::parse_lines(undef);
delete $self->{'source_scalar_ref'};
DEBUG and print "That's it for that source scalarref! Killing.\n";
}
} else {
die "What source??";
}
}
DEBUG and print "get_token about to return ",
Pod::Simple::pretty( @{$self->{'token_buffer'}}
? $self->{'token_buffer'}[-1] : undef
), "\n";
return shift @{$self->{'token_buffer'}}; # that's an undef if empty
}
sub unget_token {
my $self = shift;
DEBUG and print "Ungetting ", scalar(@_), " tokens: ",
@_ ? "@_\n" : "().\n";
foreach my $t (@_) {
Carp::croak "Can't unget that, because it's not a token -- it's undef!"
unless defined $t;
Carp::croak "Can't unget $t, because it's not a token -- it's a string!"
unless ref $t;
Carp::croak "Can't unget $t, because it's not a token object!"
unless UNIVERSAL::can($t, 'type');
}
unshift @{$self->{'token_buffer'}}, @_;
DEBUG > 1 and print "Token buffer now has ",
scalar(@{$self->{'token_buffer'}}), " items in it.\n";
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# $self->{'source_filename'} = $source;
sub set_source {
my $self = shift @_;
return $self->{'source_fh'} unless @_;
Carp::croak("Cannot assign new source to pull parser; create a new instance, instead")
if $self->{'source_fh'} || $self->{'source_scalar_ref'} || $self->{'source_arrayref'};
my $handle;
if(!defined $_[0]) {
Carp::croak("Can't use empty-string as a source for set_source");
} elsif(ref(\( $_[0] )) eq 'GLOB') {
$self->{'source_filename'} = '' . ($handle = $_[0]);
DEBUG and print "$self 's source is glob $_[0]\n";
# and fall thru
} elsif(ref( $_[0] ) eq 'SCALAR') {
$self->{'source_scalar_ref'} = $_[0];
DEBUG and print "$self 's source is scalar ref $_[0]\n";
return;
} elsif(ref( $_[0] ) eq 'ARRAY') {
$self->{'source_arrayref'} = $_[0];
DEBUG and print "$self 's source is array ref $_[0]\n";
return;
} elsif(ref $_[0]) {
$self->{'source_filename'} = '' . ($handle = $_[0]);
DEBUG and print "$self 's source is fh-obj $_[0]\n";
} elsif(!length $_[0]) {
Carp::croak("Can't use empty-string as a source for set_source");
} else { # It's a filename!
DEBUG and print "$self 's source is filename $_[0]\n";
{
local *PODSOURCE;
open(PODSOURCE, "<$_[0]") || Carp::croak "Can't open $_[0]: $!";
$handle = *PODSOURCE{IO};
}
$self->{'source_filename'} = $_[0];
DEBUG and print " Its name is $_[0].\n";
# TODO: file-discipline things here!
}
$self->{'source_fh'} = $handle;
DEBUG and print " Its handle is $handle\n";
return 1;
}
# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
sub get_title_short { shift->get_short_title(@_) } # alias
sub get_short_title {
my $title = shift->get_title(@_);
$title = $1 if $title =~ m/^(\S{1,60})\s+--?\s+./s;
# turn "Foo::Bar -- bars for your foo" into "Foo::Bar"
return $title;
}
sub get_title { shift->_get_titled_section(
'NAME', max_token => 50, desperate => 1, @_)
}
sub get_version { shift->_get_titled_section(
'VERSION',
max_token => 400,
accept_verbatim => 1,
max_content_length => 3_000,
@_,
);
}
sub get_description { shift->_get_titled_section(
'DESCRIPTION',
max_token => 400,
max_content_length => 3_000,
@_,
) }
sub get_authors { shift->get_author(@_) } # a harmless alias
sub get_author {
my $this = shift;
# Max_token is so high because these are
# typically at the end of the document:
$this->_get_titled_section('AUTHOR' , max_token => 10_000, @_) ||
$this->_get_titled_section('AUTHORS', max_token => 10_000, @_);
}
#--------------------------------------------------------------------------
sub _get_titled_section {
# Based on a get_title originally contributed by Graham Barr
my($self, $titlename, %options) = (@_);
my $max_token = delete $options{'max_token'};
my $desperate_for_title = delete $options{'desperate'};
my $accept_verbatim = delete $options{'accept_verbatim'};
my $max_content_length = delete $options{'max_content_length'};
my $nocase = delete $options{'nocase'};
$max_content_length = 120 unless defined $max_content_length;
Carp::croak( "Unknown " . ((1 == keys %options) ? "option: " : "options: ")
. join " ", map "[$_]", sort keys %options
)
if keys %options;
my %content_containers;
$content_containers{'Para'} = 1;
if($accept_verbatim) {
$content_containers{'Verbatim'} = 1;
$content_containers{'VerbatimFormatted'} = 1;
}
my $token_count = 0;
my $title;
my @to_unget;
my $state = 0;
my $depth = 0;
Carp::croak "What kind of titlename is \"$titlename\"?!" unless
defined $titlename and $titlename =~ m/^[A-Z ]{1,60}$/s; #sanity
my $titlename_re = quotemeta($titlename);
my $head1_text_content;
my $para_text_content;
my $skipX;
while(
++$token_count <= ($max_token || 1_000_000)
and defined(my $token = $self->get_token)
) {
push @to_unget, $token;
if ($state == 0) { # seeking =head1
if( $token->is_start and $token->tagname eq 'head1' ) {
DEBUG and print " Found head1. Seeking content...\n";
++$state;
$head1_text_content = '';
}
}
elsif($state == 1) { # accumulating text until end of head1
if( $token->is_text ) {
unless ($skipX) {
DEBUG and print " Adding \"", $token->text, "\" to head1-content.\n";
$head1_text_content .= $token->text;
}
} elsif( $token->is_tagname('X') ) {
# We're going to want to ignore X<> stuff.
$skipX = $token->is_start;
DEBUG and print +($skipX ? 'Start' : 'End'), 'ing ignoring of X<> tag';
} elsif( $token->is_end and $token->tagname eq 'head1' ) {
DEBUG and print " Found end of head1. Considering content...\n";
$head1_text_content = uc $head1_text_content if $nocase;
if($head1_text_content eq $titlename
or $head1_text_content =~ m/\($titlename_re\)/s
# We accept "=head1 Nomen Modularis (NAME)" for sake of i18n
) {
DEBUG and print " Yup, it was $titlename. Seeking next para-content...\n";
++$state;
} elsif(
$desperate_for_title
# if we're so desperate we'll take the first
# =head1's content as a title
and $head1_text_content =~ m/\S/
and $head1_text_content !~ m/^[ A-Z]+$/s
and $head1_text_content !~
m/\((?:
NAME | TITLE | VERSION | AUTHORS? | DESCRIPTION | SYNOPSIS
| COPYRIGHT | LICENSE | NOTES? | FUNCTIONS? | METHODS?
| CAVEATS? | BUGS? | SEE\ ALSO | SWITCHES | ENVIRONMENT
)\)/sx
# avoid accepting things like =head1 Thingy Thongy (DESCRIPTION)
and ($max_content_length
? (length($head1_text_content) <= $max_content_length) # sanity
: 1)
) {
# Looks good; trim it
($title = $head1_text_content) =~ s/\s+$//;
DEBUG and print " It looks titular: \"$title\".\n\n Using that.\n";
last;
} else {
--$state;
DEBUG and print " Didn't look titular ($head1_text_content).\n",
"\n Dropping back to seeking-head1-content mode...\n";
}
}
}
elsif($state == 2) {
# seeking start of para (which must immediately follow)
if($token->is_start and $content_containers{ $token->tagname }) {
DEBUG and print " Found start of Para. Accumulating content...\n";
$para_text_content = '';
++$state;
} else {
DEBUG and print
" Didn't see an immediately subsequent start-Para. Reseeking H1\n";
$state = 0;
}
}
elsif($state == 3) {
# accumulating text until end of Para
if( $token->is_text ) {
DEBUG and print " Adding \"", $token->text, "\" to para-content.\n";
$para_text_content .= $token->text;
# and keep looking
} elsif( $token->is_end and $content_containers{ $token->tagname } ) {
DEBUG and print " Found end of Para. Considering content: ",
$para_text_content, "\n";
if( $para_text_content =~ m/\S/
and ($max_content_length
? (length($para_text_content) <= $max_content_length)
: 1)
) {
# Some minimal sanity constraints, I think.
DEBUG and print " It looks contentworthy, I guess. Using it.\n";
$title = $para_text_content;
last;
} else {
DEBUG and print " Doesn't look at all contentworthy!\n Giving up.\n";
undef $title;
last;
}
}
}
else {
die "IMPOSSIBLE STATE $state!\n"; # should never happen
}
}
# Put it all back!
$self->unget_token(@to_unget);
if(DEBUG) {
if(defined $title) { print " Returning title <$title>\n" }
else { print "Returning title <>\n" }
}
return '' unless defined $title;
$title =~ s/^\s+//;
return $title;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#
# Methods that actually do work at parse-time:
sub _handle_element_start {
my $self = shift; # leaving ($element_name, $attr_hash_r)
DEBUG > 2 and print "++ $_[0] (", map("<$_> ", %{$_[1]}), ")\n";
push @{ $self->{'token_buffer'} },
$self->{'start_token_class'}->new(@_);
return;
}
sub _handle_text {
my $self = shift; # leaving ($text)
DEBUG > 2 and print "== $_[0]\n";
push @{ $self->{'token_buffer'} },
$self->{'text_token_class'}->new(@_);
return;
}
sub _handle_element_end {
my $self = shift; # leaving ($element_name);
DEBUG > 2 and print "-- $_[0]\n";
push @{ $self->{'token_buffer'} },
$self->{'end_token_class'}->new(@_);
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
1;
__END__
=head1 NAME
Pod::Simple::PullParser -- a pull-parser interface to parsing Pod
=head1 SYNOPSIS
my $parser = SomePodProcessor->new;
$parser->set_source( "whatever.pod" );
$parser->run;
Or:
my $parser = SomePodProcessor->new;
$parser->set_source( $some_filehandle_object );
$parser->run;
Or:
my $parser = SomePodProcessor->new;
$parser->set_source( \$document_source );
$parser->run;
Or:
my $parser = SomePodProcessor->new;
$parser->set_source( \@document_lines );
$parser->run;
And elsewhere:
require 5;
package SomePodProcessor;
use strict;
use base qw(Pod::Simple::PullParser);
sub run {
my $self = shift;
Token:
while(my $token = $self->get_token) {
...process each token...
}
}
=head1 DESCRIPTION
This class is for using Pod::Simple to build a Pod processor -- but
one that uses an interface based on a stream of token objects,
instead of based on events.
This is a subclass of L<Pod::Simple> and inherits all its methods.
A subclass of Pod::Simple::PullParser should define a C<run> method
that calls C<< $token = $parser->get_token >> to pull tokens.
See the source for Pod::Simple::RTF for an example of a formatter
that uses Pod::Simple::PullParser.
=head1 METHODS
=over
=item my $token = $parser->get_token
This returns the next token object (which will be of a subclass of
L<Pod::Simple::PullParserToken>), or undef if the parser-stream has hit
the end of the document.
=item $parser->unget_token( $token )
=item $parser->unget_token( $token1, $token2, ... )
This restores the token object(s) to the front of the parser stream.
=back
The source has to be set before you can parse anything. The lowest-level
way is to call C<set_source>:
=over
=item $parser->set_source( $filename )
=item $parser->set_source( $filehandle_object )
=item $parser->set_source( \$document_source )
=item $parser->set_source( \@document_lines )
=back
Or you can call these methods, which Pod::Simple::PullParser has defined
to work just like Pod::Simple's same-named methods:
=over
=item $parser->parse_file(...)
=item $parser->parse_string_document(...)
=item $parser->filter(...)
=item $parser->parse_from_file(...)
=back
For those to work, the Pod-processing subclass of
Pod::Simple::PullParser has to have defined a $parser->run method --
so it is advised that all Pod::Simple::PullParser subclasses do so.
See the Synopsis above, or the source for Pod::Simple::RTF.
Authors of formatter subclasses might find these methods useful to
call on a parser object that you haven't started pulling tokens
from yet:
=over
=item my $title_string = $parser->get_title
This tries to get the title string out of $parser, by getting some tokens,
and scanning them for the title, and then ungetting them so that you can
process the token-stream from the beginning.
For example, suppose you have a document that starts out:
=head1 NAME
Hoo::Boy::Wowza -- Stuff B<wow> yeah!
$parser->get_title on that document will return "Hoo::Boy::Wowza --
Stuff wow yeah!". If the document starts with:
=head1 Name
Hoo::Boy::W00t -- Stuff B<w00t> yeah!
Then you'll need to pass the C<nocase> option in order to recognize "Name":
$parser->get_title(nocase => 1);
In cases where get_title can't find the title, it will return empty-string
("").
=item my $title_string = $parser->get_short_title
This is just like get_title, except that it returns just the modulename, if
the title seems to be of the form "SomeModuleName -- description".
For example, suppose you have a document that starts out:
=head1 NAME
Hoo::Boy::Wowza -- Stuff B<wow> yeah!
then $parser->get_short_title on that document will return
"Hoo::Boy::Wowza".
But if the document starts out:
=head1 NAME
Hooboy, stuff B<wow> yeah!
then $parser->get_short_title on that document will return "Hooboy,
stuff wow yeah!". If the document starts with:
=head1 Name
Hoo::Boy::W00t -- Stuff B<w00t> yeah!
Then you'll need to pass the C<nocase> option in order to recognize "Name":
$parser->get_short_title(nocase => 1);
If the title can't be found, then get_short_title returns empty-string
("").
=item $author_name = $parser->get_author
This works like get_title except that it returns the contents of the
"=head1 AUTHOR\n\nParagraph...\n" section, assuming that that section
isn't terribly long. To recognize a "=head1 Author\n\nParagraph\n"
section, pass the C<nocase> otpion:
$parser->get_author(nocase => 1);
(This method tolerates "AUTHORS" instead of "AUTHOR" too.)
=item $description_name = $parser->get_description
This works like get_title except that it returns the contents of the
"=head1 DESCRIPTION\n\nParagraph...\n" section, assuming that that section
isn't terribly long. To recognize a "=head1 Description\n\nParagraph\n"
section, pass the C<nocase> otpion:
$parser->get_description(nocase => 1);
=item $version_block = $parser->get_version
This works like get_title except that it returns the contents of
the "=head1 VERSION\n\n[BIG BLOCK]\n" block. Note that this does NOT
return the module's C<$VERSION>!! To recognize a
"=head1 Version\n\n[BIG BLOCK]\n" section, pass the C<nocase> otpion:
$parser->get_version(nocase => 1);
=back
=head1 NOTE
You don't actually I<have> to define a C<run> method. If you're
writing a Pod-formatter class, you should define a C<run> just so
that users can call C<parse_file> etc, but you don't I<have> to.
And if you're not writing a formatter class, but are instead just
writing a program that does something simple with a Pod::PullParser
object (and not an object of a subclass), then there's no reason to
bother subclassing to add a C<run> method.
=head1 SEE ALSO
L<Pod::Simple>
L<Pod::Simple::PullParserToken> -- and its subclasses
L<Pod::Simple::PullParserStartToken>,
L<Pod::Simple::PullParserTextToken>, and
L<Pod::Simple::PullParserEndToken>.
L<HTML::TokeParser>, which inspired this.
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
JUNK:
sub _old_get_title { # some witchery in here
my $self = $_[0];
my $title;
my @to_unget;
while(1) {
push @to_unget, $self->get_token;
unless(defined $to_unget[-1]) { # whoops, short doc!
pop @to_unget;
last;
}
DEBUG and print "-Got token ", $to_unget[-1]->dump, "\n";
(DEBUG and print "Too much in the buffer.\n"),
last if @to_unget > 25; # sanity
my $pattern = '';
if( #$to_unget[-1]->type eq 'end'
#and $to_unget[-1]->tagname eq 'Para'
#and
($pattern = join('',
map {;
($_->type eq 'start') ? ("<" . $_->tagname .">")
: ($_->type eq 'end' ) ? ("</". $_->tagname .">")
: ($_->type eq 'text' ) ? ($_->text =~ m<^([A-Z]+)$>s ? $1 : 'X')
: "BLORP"
} @to_unget
)) =~ m{<head1>NAME</head1><Para>(X|</?[BCIFLS]>)+</Para>$}s
) {
# Whee, it fits the pattern
DEBUG and print "Seems to match =head1 NAME pattern.\n";
$title = '';
foreach my $t (reverse @to_unget) {
last if $t->type eq 'start' and $t->tagname eq 'Para';
$title = $t->text . $title if $t->type eq 'text';
}
undef $title if $title =~ m<^\s*$>; # make sure it's contentful!
last;
} elsif ($pattern =~ m{<head(\d)>(.+)</head\d>$}
and !( $1 eq '1' and $2 eq 'NAME' )
) {
# Well, it fits a fallback pattern
DEBUG and print "Seems to match NAMEless pattern.\n";
$title = '';
foreach my $t (reverse @to_unget) {
last if $t->type eq 'start' and $t->tagname =~ m/^head\d$/s;
$title = $t->text . $title if $t->type eq 'text';
}
undef $title if $title =~ m<^\s*$>; # make sure it's contentful!
last;
} else {
DEBUG and $pattern and print "Leading pattern: $pattern\n";
}
}
# Put it all back:
$self->unget_token(@to_unget);
if(DEBUG) {
if(defined $title) { print " Returning title <$title>\n" }
else { print "Returning title <>\n" }
}
return '' unless defined $title;
return $title;
}
POD_SIMPLE_PULLPARSER
$fatpacked{"Pod/Simple/PullParserEndToken.pm"} = <<'POD_SIMPLE_PULLPARSERENDTOKEN';
require 5;
package Pod::Simple::PullParserEndToken;
use Pod::Simple::PullParserToken ();
use strict;
use vars qw(@ISA $VERSION);
@ISA = ('Pod::Simple::PullParserToken');
$VERSION = '3.26';
sub new { # Class->new(tagname);
my $class = shift;
return bless ['end', @_], ref($class) || $class;
}
# Purely accessors:
sub tagname { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] }
sub tag { shift->tagname(@_) }
# shortcut:
sub is_tagname { $_[0][1] eq $_[1] }
sub is_tag { shift->is_tagname(@_) }
1;
__END__
=head1 NAME
Pod::Simple::PullParserEndToken -- end-tokens from Pod::Simple::PullParser
=head1 SYNOPSIS
(See L<Pod::Simple::PullParser>)
=head1 DESCRIPTION
When you do $parser->get_token on a L<Pod::Simple::PullParser>, you might
get an object of this class.
This is a subclass of L<Pod::Simple::PullParserToken> and inherits all its methods,
and adds these methods:
=over
=item $token->tagname
This returns the tagname for this end-token object.
For example, parsing a "=head1 ..." line will give you
a start-token with the tagname of "head1", token(s) for its
content, and then an end-token with the tagname of "head1".
=item $token->tagname(I<somestring>)
This changes the tagname for this end-token object.
You probably won't need to do this.
=item $token->tag(...)
A shortcut for $token->tagname(...)
=item $token->is_tag(I<somestring>) or $token->is_tagname(I<somestring>)
These are shortcuts for C<< $token->tag() eq I<somestring> >>
=back
You're unlikely to ever need to construct an object of this class for
yourself, but if you want to, call
C<<
Pod::Simple::PullParserEndToken->new( I<tagname> )
>>
=head1 SEE ALSO
L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_PULLPARSERENDTOKEN
$fatpacked{"Pod/Simple/PullParserStartToken.pm"} = <<'POD_SIMPLE_PULLPARSERSTARTTOKEN';
require 5;
package Pod::Simple::PullParserStartToken;
use Pod::Simple::PullParserToken ();
use strict;
use vars qw(@ISA $VERSION);
@ISA = ('Pod::Simple::PullParserToken');
$VERSION = '3.26';
sub new { # Class->new(tagname, optional_attrhash);
my $class = shift;
return bless ['start', @_], ref($class) || $class;
}
# Purely accessors:
sub tagname { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] }
sub tag { shift->tagname(@_) }
sub is_tagname { $_[0][1] eq $_[1] }
sub is_tag { shift->is_tagname(@_) }
sub attr_hash { $_[0][2] ||= {} }
sub attr {
if(@_ == 2) { # Reading: $token->attr('attrname')
${$_[0][2] || return undef}{ $_[1] };
} elsif(@_ > 2) { # Writing: $token->attr('attrname', 'newval')
${$_[0][2] ||= {}}{ $_[1] } = $_[2];
} else {
require Carp;
Carp::croak(
'usage: $object->attr("val") or $object->attr("key", "newval")');
return undef;
}
}
1;
__END__
=head1 NAME
Pod::Simple::PullParserStartToken -- start-tokens from Pod::Simple::PullParser
=head1 SYNOPSIS
(See L<Pod::Simple::PullParser>)
=head1 DESCRIPTION
When you do $parser->get_token on a L<Pod::Simple::PullParser> object, you might
get an object of this class.
This is a subclass of L<Pod::Simple::PullParserToken> and inherits all its methods,
and adds these methods:
=over
=item $token->tagname
This returns the tagname for this start-token object.
For example, parsing a "=head1 ..." line will give you
a start-token with the tagname of "head1", token(s) for its
content, and then an end-token with the tagname of "head1".
=item $token->tagname(I<somestring>)
This changes the tagname for this start-token object.
You probably won't need
to do this.
=item $token->tag(...)
A shortcut for $token->tagname(...)
=item $token->is_tag(I<somestring>) or $token->is_tagname(I<somestring>)
These are shortcuts for C<< $token->tag() eq I<somestring> >>
=item $token->attr(I<attrname>)
This returns the value of the I<attrname> attribute for this start-token
object, or undef.
For example, parsing a LZ<><Foo/"Bar"> link will produce a start-token
with a "to" attribute with the value "Foo", a "type" attribute with the
value "pod", and a "section" attribute with the value "Bar".
=item $token->attr(I<attrname>, I<newvalue>)
This sets the I<attrname> attribute for this start-token object to
I<newvalue>. You probably won't need to do this.
=item $token->attr_hash
This returns the hashref that is the attribute set for this start-token.
This is useful if (for example) you want to ask what all the attributes
are -- you can just do C<< keys %{$token->attr_hash} >>
=back
You're unlikely to ever need to construct an object of this class for
yourself, but if you want to, call
C<<
Pod::Simple::PullParserStartToken->new( I<tagname>, I<attrhash> )
>>
=head1 SEE ALSO
L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
=head1 SEE ALSO
L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_PULLPARSERSTARTTOKEN
$fatpacked{"Pod/Simple/PullParserTextToken.pm"} = <<'POD_SIMPLE_PULLPARSERTEXTTOKEN';
require 5;
package Pod::Simple::PullParserTextToken;
use Pod::Simple::PullParserToken ();
use strict;
use vars qw(@ISA $VERSION);
@ISA = ('Pod::Simple::PullParserToken');
$VERSION = '3.26';
sub new { # Class->new(text);
my $class = shift;
return bless ['text', @_], ref($class) || $class;
}
# Purely accessors:
sub text { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] }
sub text_r { \ $_[0][1] }
1;
__END__
=head1 NAME
Pod::Simple::PullParserTextToken -- text-tokens from Pod::Simple::PullParser
=head1 SYNOPSIS
(See L<Pod::Simple::PullParser>)
=head1 DESCRIPTION
When you do $parser->get_token on a L<Pod::Simple::PullParser>, you might
get an object of this class.
This is a subclass of L<Pod::Simple::PullParserToken> and inherits all its methods,
and adds these methods:
=over
=item $token->text
This returns the text that this token holds. For example, parsing
CZ<><foo> will return a C start-token, a text-token, and a C end-token. And
if you want to get the "foo" out of the text-token, call C<< $token->text >>
=item $token->text(I<somestring>)
This changes the string that this token holds. You probably won't need
to do this.
=item $token->text_r()
This returns a scalar reference to the string that this token holds.
This can be useful if you don't want to memory-copy the potentially
large text value (well, as large as a paragraph or a verbatim block)
as calling $token->text would do.
Or, if you want to alter the value, you can even do things like this:
for ( ${ $token->text_r } ) { # Aliases it with $_ !!
s/ The / the /g; # just for example
if( 'A' eq chr(65) ) { # (if in an ASCII world)
tr/\xA0/ /;
tr/\xAD//d;
}
...or however you want to alter the value...
}
=back
You're unlikely to ever need to construct an object of this class for
yourself, but if you want to, call
C<<
Pod::Simple::PullParserTextToken->new( I<text> )
>>
=head1 SEE ALSO
L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_PULLPARSERTEXTTOKEN
$fatpacked{"Pod/Simple/PullParserToken.pm"} = <<'POD_SIMPLE_PULLPARSERTOKEN';
require 5;
package Pod::Simple::PullParserToken;
# Base class for tokens gotten from Pod::Simple::PullParser's $parser->get_token
@ISA = ();
$VERSION = '3.26';
use strict;
sub new { # Class->new('type', stuff...); ## Overridden in derived classes anyway
my $class = shift;
return bless [@_], ref($class) || $class;
}
sub type { $_[0][0] } # Can't change the type of an object
sub dump { Pod::Simple::pretty( [ @{ $_[0] } ] ) }
sub is_start { $_[0][0] eq 'start' }
sub is_end { $_[0][0] eq 'end' }
sub is_text { $_[0][0] eq 'text' }
1;
__END__
sub dump { '[' . _esc( @{ $_[0] } ) . ']' }
# JUNK:
sub _esc {
return '' unless @_;
my @out;
foreach my $in (@_) {
push @out, '"' . $in . '"';
$out[-1] =~ s/([^- \:\:\.\,\'\>\<\"\/\=\?\+\|\[\]\{\}\_a-zA-Z0-9_\`\~\!\#\%\^\&\*\(\)])/
sprintf( (ord($1) < 256) ? "\\x%02X" : "\\x{%X}", ord($1))
/eg;
}
return join ', ', @out;
}
__END__
=head1 NAME
Pod::Simple::PullParserToken -- tokens from Pod::Simple::PullParser
=head1 SYNOPSIS
Given a $parser that's an object of class Pod::Simple::PullParser
(or a subclass)...
while(my $token = $parser->get_token) {
$DEBUG and print "Token: ", $token->dump, "\n";
if($token->is_start) {
...access $token->tagname, $token->attr, etc...
} elsif($token->is_text) {
...access $token->text, $token->text_r, etc...
} elsif($token->is_end) {
...access $token->tagname...
}
}
(Also see L<Pod::Simple::PullParser>)
=head1 DESCRIPTION
When you do $parser->get_token on a L<Pod::Simple::PullParser>, you should
get an object of a subclass of Pod::Simple::PullParserToken.
Subclasses will add methods, and will also inherit these methods:
=over
=item $token->type
This returns the type of the token. This will be either the string
"start", the string "text", or the string "end".
Once you know what the type of an object is, you then know what
subclass it belongs to, and therefore what methods it supports.
Yes, you could probably do the same thing with code like
$token->isa('Pod::Simple::PullParserEndToken'), but that's not so
pretty as using just $token->type, or even the following shortcuts:
=item $token->is_start
This is a shortcut for C<< $token->type() eq "start" >>
=item $token->is_text
This is a shortcut for C<< $token->type() eq "text" >>
=item $token->is_end
This is a shortcut for C<< $token->type() eq "end" >>
=item $token->dump
This returns a handy stringified value of this object. This
is useful for debugging, as in:
while(my $token = $parser->get_token) {
$DEBUG and print "Token: ", $token->dump, "\n";
...
}
=back
=head1 SEE ALSO
My subclasses:
L<Pod::Simple::PullParserStartToken>,
L<Pod::Simple::PullParserTextToken>, and
L<Pod::Simple::PullParserEndToken>.
L<Pod::Simple::PullParser> and L<Pod::Simple>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_PULLPARSERTOKEN
$fatpacked{"Pod/Simple/RTF.pm"} = <<'POD_SIMPLE_RTF';
require 5;
package Pod::Simple::RTF;
#sub DEBUG () {4};
#sub Pod::Simple::DEBUG () {4};
#sub Pod::Simple::PullParser::DEBUG () {4};
use strict;
use vars qw($VERSION @ISA %Escape $WRAP %Tagmap);
$VERSION = '3.26';
use Pod::Simple::PullParser ();
BEGIN {@ISA = ('Pod::Simple::PullParser')}
use Carp ();
BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
$WRAP = 1 unless defined $WRAP;
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub _openclose {
return map {;
m/^([-A-Za-z]+)=(\w[^\=]*)$/s or die "what's <$_>?";
( $1, "{\\$2\n", "/$1", "}" );
} @_;
}
my @_to_accept;
%Tagmap = (
# 'foo=bar' means ('foo' => '{\bar'."\n", '/foo' => '}')
_openclose(
'B=cs18\b',
'I=cs16\i',
'C=cs19\f1\lang1024\noproof',
'F=cs17\i\lang1024\noproof',
'VerbatimI=cs26\i',
'VerbatimB=cs27\b',
'VerbatimBI=cs28\b\i',
map {; m/^([-a-z]+)/s && push @_to_accept, $1; $_ }
qw[
underline=ul smallcaps=scaps shadow=shad
superscript=super subscript=sub strikethrough=strike
outline=outl emboss=embo engrave=impr
dotted-underline=uld dash-underline=uldash
dot-dash-underline=uldashd dot-dot-dash-underline=uldashdd
double-underline=uldb thick-underline=ulth
word-underline=ulw wave-underline=ulwave
]
# But no double-strikethrough, because MSWord can't agree with the
# RTF spec on whether it's supposed to be \strikedl or \striked1 (!!!)
),
# Bit of a hack here:
'L=pod' => '{\cs22\i'."\n",
'L=url' => '{\cs23\i'."\n",
'L=man' => '{\cs24\i'."\n",
'/L' => '}',
'Data' => "\n",
'/Data' => "\n",
'Verbatim' => "\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n",
'/Verbatim' => "\n\\par}\n",
'VerbatimFormatted' => "\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n",
'/VerbatimFormatted' => "\n\\par}\n",
'Para' => "\n{\\pard\\li#rtfindent#\\sa180\n",
'/Para' => "\n\\par}\n",
'head1' => "\n{\\pard\\li#rtfindent#\\s31\\keepn\\sb90\\sa180\\f2\\fs#head1_halfpoint_size#\\ul{\n",
'/head1' => "\n}\\par}\n",
'head2' => "\n{\\pard\\li#rtfindent#\\s32\\keepn\\sb90\\sa180\\f2\\fs#head2_halfpoint_size#\\ul{\n",
'/head2' => "\n}\\par}\n",
'head3' => "\n{\\pard\\li#rtfindent#\\s33\\keepn\\sb90\\sa180\\f2\\fs#head3_halfpoint_size#\\ul{\n",
'/head3' => "\n}\\par}\n",
'head4' => "\n{\\pard\\li#rtfindent#\\s34\\keepn\\sb90\\sa180\\f2\\fs#head4_halfpoint_size#\\ul{\n",
'/head4' => "\n}\\par}\n",
# wordpad borks on \tc\tcl1, or I'd put that in =head1 and =head2
'item-bullet' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
'/item-bullet' => "\n\\par}\n",
'item-number' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
'/item-number' => "\n\\par}\n",
'item-text' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
'/item-text' => "\n\\par}\n",
# we don't need any styles for over-* and /over-*
);
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub new {
my $new = shift->SUPER::new(@_);
$new->nix_X_codes(1);
$new->nbsp_for_S(1);
$new->accept_targets( 'rtf', 'RTF' );
$new->{'Tagmap'} = {%Tagmap};
$new->accept_codes(@_to_accept);
$new->accept_codes('VerbatimFormatted');
DEBUG > 2 and print "To accept: ", join(' ',@_to_accept), "\n";
$new->doc_lang(
( $ENV{'RTFDEFLANG'} || '') =~ m/^(\d{1,10})$/s ? $1
: ($ENV{'RTFDEFLANG'} || '') =~ m/^0?x([a-fA-F0-9]{1,10})$/s ? hex($1)
# yes, tolerate hex!
: ($ENV{'RTFDEFLANG'} || '') =~ m/^([a-fA-F0-9]{4})$/s ? hex($1)
# yes, tolerate even more hex!
: '1033'
);
$new->head1_halfpoint_size(32);
$new->head2_halfpoint_size(28);
$new->head3_halfpoint_size(25);
$new->head4_halfpoint_size(22);
$new->codeblock_halfpoint_size(18);
$new->header_halfpoint_size(17);
$new->normal_halfpoint_size(25);
return $new;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
__PACKAGE__->_accessorize(
'doc_lang',
'head1_halfpoint_size',
'head2_halfpoint_size',
'head3_halfpoint_size',
'head4_halfpoint_size',
'codeblock_halfpoint_size',
'header_halfpoint_size',
'normal_halfpoint_size',
'no_proofing_exemptions',
);
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub run {
my $self = $_[0];
return $self->do_middle if $self->bare_output;
return
$self->do_beginning && $self->do_middle && $self->do_end;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub do_middle { # the main work
my $self = $_[0];
my $fh = $self->{'output_fh'};
my($token, $type, $tagname, $scratch);
my @stack;
my @indent_stack;
$self->{'rtfindent'} = 0 unless defined $self->{'rtfindent'};
while($token = $self->get_token) {
if( ($type = $token->type) eq 'text' ) {
if( $self->{'rtfverbatim'} ) {
DEBUG > 1 and print " $type " , $token->text, " in verbatim!\n";
rtf_esc_codely($scratch = $token->text);
print $fh $scratch;
next;
}
DEBUG > 1 and print " $type " , $token->text, "\n";
$scratch = $token->text;
$scratch =~ tr/\t\cb\cc/ /d;
$self->{'no_proofing_exemptions'} or $scratch =~
s/(?:
^
|
(?<=[\cm\cj\t "\[\<\(])
) # start on whitespace, sequence-start, or quote
( # something looking like a Perl token:
(?:
[\$\@\:\<\*\\_]\S+ # either starting with a sigil, etc.
)
|
# or starting alpha, but containing anything strange:
(?:
[a-zA-Z'\x80-\xFF]+[\$\@\:_<>\(\\\*]\S+
)
)
/\cb$1\cc/xsg
;
rtf_esc($scratch);
$scratch =~
s/(
[^\cm\cj\n]{65} # Snare 65 characters from a line
[^\cm\cj\n\x20]{0,50} # and finish any current word
)
(\x20{1,10})(?![\cm\cj\n]) # capture some spaces not at line-end
/$1$2\n/gx # and put a NL before those spaces
if $WRAP;
# This may wrap at well past the 65th column, but not past the 120th.
print $fh $scratch;
} elsif( $type eq 'start' ) {
DEBUG > 1 and print " +$type ",$token->tagname,
" (", map("<$_> ", %{$token->attr_hash}), ")\n";
if( ($tagname = $token->tagname) eq 'Verbatim'
or $tagname eq 'VerbatimFormatted'
) {
++$self->{'rtfverbatim'};
my $next = $self->get_token;
next unless defined $next;
my $line_count = 1;
if($next->type eq 'text') {
my $t = $next->text_r;
while( $$t =~ m/$/mg ) {
last if ++$line_count > 15; # no point in counting further
}
DEBUG > 3 and print " verbatim line count: $line_count\n";
}
$self->unget_token($next);
$self->{'rtfkeep'} = ($line_count > 15) ? '' : '\keepn' ;
} elsif( $tagname =~ m/^item-/s ) {
my @to_unget;
my $text_count_here = 0;
$self->{'rtfitemkeepn'} = '';
# Some heuristics to stop item-*'s functioning as subheadings
# from getting split from the things they're subheadings for.
#
# It's not terribly pretty, but it really does make things pretty.
#
while(1) {
push @to_unget, $self->get_token;
pop(@to_unget), last unless defined $to_unget[-1];
# Erroneously used to be "unshift" instead of pop! Adds instead
# of removes, and operates on the beginning instead of the end!
if($to_unget[-1]->type eq 'text') {
if( ($text_count_here += length ${$to_unget[-1]->text_r}) > 150 ){
DEBUG > 1 and print " item-* is too long to be keepn'd.\n";
last;
}
} elsif (@to_unget > 1 and
$to_unget[-2]->type eq 'end' and
$to_unget[-2]->tagname =~ m/^item-/s
) {
# Bail out here, after setting rtfitemkeepn yea or nay.
$self->{'rtfitemkeepn'} = '\keepn' if
$to_unget[-1]->type eq 'start' and
$to_unget[-1]->tagname eq 'Para';
DEBUG > 1 and printf " item-* before %s(%s) %s keepn'd.\n",
$to_unget[-1]->type,
$to_unget[-1]->can('tagname') ? $to_unget[-1]->tagname : '',
$self->{'rtfitemkeepn'} ? "gets" : "doesn't get";
last;
} elsif (@to_unget > 40) {
DEBUG > 1 and print " item-* now has too many tokens (",
scalar(@to_unget),
(DEBUG > 4) ? (q<: >, map($_->dump, @to_unget)) : (),
") to be keepn'd.\n";
last; # give up
}
# else keep while'ing along
}
# Now put it aaaaall back...
$self->unget_token(@to_unget);
} elsif( $tagname =~ m/^over-/s ) {
push @stack, $1;
push @indent_stack,
int($token->attr('indent') * 4 * $self->normal_halfpoint_size);
DEBUG and print "Indenting over $indent_stack[-1] twips.\n";
$self->{'rtfindent'} += $indent_stack[-1];
} elsif ($tagname eq 'L') {
$tagname .= '=' . ($token->attr('type') || 'pod');
} elsif ($tagname eq 'Data') {
my $next = $self->get_token;
next unless defined $next;
unless( $next->type eq 'text' ) {
$self->unget_token($next);
next;
}
DEBUG and print " raw text ", $next->text, "\n";
printf $fh "\n" . $next->text . "\n";
next;
}
defined($scratch = $self->{'Tagmap'}{$tagname}) or next;
$scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate
print $fh $scratch;
if ($tagname eq 'item-number') {
print $fh $token->attr('number'), ". \n";
} elsif ($tagname eq 'item-bullet') {
print $fh "\\'95 \n";
#for funky testing: print $fh '', rtf_esc("\x{4E4B}\x{9053}");
}
} elsif( $type eq 'end' ) {
DEBUG > 1 and print " -$type ",$token->tagname,"\n";
if( ($tagname = $token->tagname) =~ m/^over-/s ) {
DEBUG and print "Indenting back $indent_stack[-1] twips.\n";
$self->{'rtfindent'} -= pop @indent_stack;
pop @stack;
} elsif( $tagname eq 'Verbatim' or $tagname eq 'VerbatimFormatted') {
--$self->{'rtfverbatim'};
}
defined($scratch = $self->{'Tagmap'}{"/$tagname"}) or next;
$scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate
print $fh $scratch;
}
}
return 1;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub do_beginning {
my $self = $_[0];
my $fh = $self->{'output_fh'};
return print $fh join '',
$self->doc_init,
$self->font_table,
$self->stylesheet,
$self->color_table,
$self->doc_info,
$self->doc_start,
"\n"
;
}
sub do_end {
my $self = $_[0];
my $fh = $self->{'output_fh'};
return print $fh '}'; # that should do it
}
###########################################################################
sub stylesheet {
return sprintf <<'END',
{\stylesheet
{\snext0 Normal;}
{\*\cs10 \additive Default Paragraph Font;}
{\*\cs16 \additive \i \sbasedon10 pod-I;}
{\*\cs17 \additive \i\lang1024\noproof \sbasedon10 pod-F;}
{\*\cs18 \additive \b \sbasedon10 pod-B;}
{\*\cs19 \additive \f1\lang1024\noproof\sbasedon10 pod-C;}
{\s20\ql \li0\ri0\sa180\widctlpar\f1\fs%s\lang1024\noproof\sbasedon0 \snext0 pod-codeblock;}
{\*\cs21 \additive \lang1024\noproof \sbasedon10 pod-computerese;}
{\*\cs22 \additive \i\lang1024\noproof\sbasedon10 pod-L-pod;}
{\*\cs23 \additive \i\lang1024\noproof\sbasedon10 pod-L-url;}
{\*\cs24 \additive \i\lang1024\noproof\sbasedon10 pod-L-man;}
{\*\cs25 \additive \f1\lang1024\noproof\sbasedon0 pod-codelbock-plain;}
{\*\cs26 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-ital;}
{\*\cs27 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold;}
{\*\cs28 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold-ital;}
{\s31\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head1;}
{\s32\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head2;}
{\s33\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head3;}
{\s34\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head4;}
}
END
$_[0]->codeblock_halfpoint_size(),
$_[0]->head1_halfpoint_size(),
$_[0]->head2_halfpoint_size(),
$_[0]->head3_halfpoint_size(),
$_[0]->head4_halfpoint_size(),
;
}
###########################################################################
# Override these as necessary for further customization
sub font_table {
return <<'END'; # text font, code font, heading font
{\fonttbl
{\f0\froman Times New Roman;}
{\f1\fmodern Courier New;}
{\f2\fswiss Arial;}
}
END
}
sub doc_init {
return <<'END';
{\rtf1\ansi\deff0
END
}
sub color_table {
return <<'END';
{\colortbl;\red255\green0\blue0;\red0\green0\blue255;}
END
}
sub doc_info {
my $self = $_[0];
my $class = ref($self) || $self;
my $tag = __PACKAGE__ . ' ' . $VERSION;
unless($class eq __PACKAGE__) {
$tag = " ($tag)";
$tag = " v" . $self->VERSION . $tag if defined $self->VERSION;
$tag = $class . $tag;
}
return sprintf <<'END',
{\info{\doccomm
%s
using %s v%s
under Perl v%s at %s GMT}
{\author [see doc]}{\company [see doc]}{\operator [see doc]}
}
END
# None of the following things should need escaping, I dare say!
$tag,
$ISA[0], $ISA[0]->VERSION(),
$], scalar(gmtime),
;
}
sub doc_start {
my $self = $_[0];
my $title = $self->get_short_title();
DEBUG and print "Short Title: <$title>\n";
$title .= ' ' if length $title;
$title =~ s/ *$/ /s;
$title =~ s/^ //s;
$title =~ s/ $/, /s;
# make sure it ends in a comma and a space, unless it's 0-length
my $is_obviously_module_name;
$is_obviously_module_name = 1
if $title =~ m/^\S+$/s and $title =~ m/::/s;
# catches the most common case, at least
DEBUG and print "Title0: <$title>\n";
$title = rtf_esc($title);
DEBUG and print "Title1: <$title>\n";
$title = '\lang1024\noproof ' . $title
if $is_obviously_module_name;
return sprintf <<'END',
\deflang%s\plain\lang%s\widowctrl
{\header\pard\qr\plain\f2\fs%s
%s
p.\chpgn\par}
\fs%s
END
($self->doc_lang) x 2,
$self->header_halfpoint_size,
$title,
$self->normal_halfpoint_size,
;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#-------------------------------------------------------------------------
use integer;
sub rtf_esc {
my $x; # scratch
if(!defined wantarray) { # void context: alter in-place!
for(@_) {
s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
}
return;
} elsif(wantarray) { # return an array
return map {; ($x = $_) =~
s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
$x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
$x;
} @_;
} else { # return a single scalar
($x = ((@_ == 1) ? $_[0] : join '', @_)
) =~ s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
# Escape \, {, }, -, control chars, and 7f-ff.
$x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
return $x;
}
}
sub rtf_esc_codely {
# Doesn't change "-" to hard-hyphen, nor apply computerese style-smarts.
# We don't want to change the "-" to hard-hyphen, because we want to
# be able to paste this into a file and run it without there being
# dire screaming about the mysterious hard-hyphen character (which
# looks just like a normal dash character).
my $x; # scratch
if(!defined wantarray) { # void context: alter in-place!
for(@_) {
s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
}
return;
} elsif(wantarray) { # return an array
return map {; ($x = $_) =~
s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
$x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
$x;
} @_;
} else { # return a single scalar
($x = ((@_ == 1) ? $_[0] : join '', @_)
) =~ s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
# Escape \, {, }, -, control chars, and 7f-ff.
$x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
return $x;
}
}
%Escape = (
map( (chr($_),chr($_)), # things not apparently needing escaping
0x20 .. 0x7E ),
map( (chr($_),sprintf("\\'%02x", $_)), # apparently escapeworthy things
0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46),
# We get to escape out 'F' so that we can send RTF files thru the mail
# without the slightest worry that paragraphs beginning with "From"
# will get munged.
# And some refinements:
"\cm" => "\n",
"\cj" => "\n",
"\n" => "\n\\line ",
"\t" => "\\tab ", # Tabs (altho theoretically raw \t's are okay)
"\f" => "\n\\page\n", # Formfeed
"-" => "\\_", # Turn plaintext '-' into a non-breaking hyphen
"\xA0" => "\\~", # Latin-1 non-breaking space
"\xAD" => "\\-", # Latin-1 soft (optional) hyphen
# CRAZY HACKS:
"\n" => "\\line\n",
"\r" => "\n",
"\cb" => "{\n\\cs21\\lang1024\\noproof ", # \\cf1
"\cc" => "}",
);
1;
__END__
=head1 NAME
Pod::Simple::RTF -- format Pod as RTF
=head1 SYNOPSIS
perl -MPod::Simple::RTF -e \
"exit Pod::Simple::RTF->filter(shift)->any_errata_seen" \
thingy.pod > thingy.rtf
=head1 DESCRIPTION
This class is a formatter that takes Pod and renders it as RTF, good for
viewing/printing in MSWord, WordPad/write.exe, TextEdit, etc.
This is a subclass of L<Pod::Simple> and inherits all its methods.
=head1 FORMAT CONTROL ATTRIBUTES
You can set these attributes on the parser object before you
call C<parse_file> (or a similar method) on it:
=over
=item $parser->head1_halfpoint_size( I<halfpoint_integer> );
=item $parser->head2_halfpoint_size( I<halfpoint_integer> );
=item $parser->head3_halfpoint_size( I<halfpoint_integer> );
=item $parser->head4_halfpoint_size( I<halfpoint_integer> );
These methods set the size (in half-points, like 52 for 26-point)
that these heading levels will appear as.
=item $parser->codeblock_halfpoint_size( I<halfpoint_integer> );
This method sets the size (in half-points, like 21 for 10.5-point)
that codeblocks ("verbatim sections") will appear as.
=item $parser->header_halfpoint_size( I<halfpoint_integer> );
This method sets the size (in half-points, like 15 for 7.5-point)
that the header on each page will appear in. The header
is usually just "I<modulename> p. I<pagenumber>".
=item $parser->normal_halfpoint_size( I<halfpoint_integer> );
This method sets the size (in half-points, like 26 for 13-point)
that normal paragraphic text will appear in.
=item $parser->no_proofing_exemptions( I<true_or_false> );
Set this value to true if you don't want the formatter to try
putting a hidden code on all Perl symbols (as best as it can
notice them) that labels them as being not in English, and
so not worth spellchecking.
=item $parser->doc_lang( I<microsoft_decimal_language_code> )
This sets the language code to tag this document as being in. By
default, it is currently the value of the environment variable
C<RTFDEFLANG>, or if that's not set, then the value
1033 (for US English).
Setting this appropriately is useful if you want to use the RTF
to spellcheck, and/or if you want it to hyphenate right.
Here are some notable values:
1033 US English
2057 UK English
3081 Australia English
4105 Canada English
1034 Spain Spanish
2058 Mexico Spanish
1031 Germany German
1036 France French
3084 Canada French
1035 Finnish
1044 Norwegian (Bokmal)
2068 Norwegian (Nynorsk)
=back
If you are particularly interested in customizing this module's output
even more, see the source and/or write to me.
=head1 SEE ALSO
L<Pod::Simple>, L<RTF::Writer>, L<RTF::Cookbook>, L<RTF::Document>,
L<RTF::Generator>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_RTF
$fatpacked{"Pod/Simple/Search.pm"} = <<'POD_SIMPLE_SEARCH';
require 5.005;
package Pod::Simple::Search;
use strict;
use vars qw($VERSION $MAX_VERSION_WITHIN $SLEEPY);
$VERSION = '3.26'; ## Current version of this package
BEGIN { *DEBUG = sub () {0} unless defined &DEBUG; } # set DEBUG level
use Carp ();
$SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i;
# flag to occasionally sleep for $SLEEPY - 1 seconds.
$MAX_VERSION_WITHIN ||= 60;
#############################################################################
#use diagnostics;
use File::Spec ();
use File::Basename qw( basename );
use Config ();
use Cwd qw( cwd );
#==========================================================================
__PACKAGE__->_accessorize( # Make my dumb accessor methods
'callback', 'progress', 'dir_prefix', 'inc', 'laborious', 'limit_glob',
'limit_re', 'shadows', 'verbose', 'name2path', 'path2name', 'recurse',
);
#==========================================================================
sub new {
my $class = shift;
my $self = bless {}, ref($class) || $class;
$self->init;
return $self;
}
sub init {
my $self = shift;
$self->inc(1);
$self->recurse(1);
$self->verbose(DEBUG);
return $self;
}
#--------------------------------------------------------------------------
sub survey {
my($self, @search_dirs) = @_;
$self = $self->new unless ref $self; # tolerate being a class method
$self->_expand_inc( \@search_dirs );
$self->{'_scan_count'} = 0;
$self->{'_dirs_visited'} = {};
$self->path2name( {} );
$self->name2path( {} );
$self->limit_re( $self->_limit_glob_to_limit_re ) if $self->{'limit_glob'};
my $cwd = cwd();
my $verbose = $self->verbose;
local $_; # don't clobber the caller's $_ !
foreach my $try (@search_dirs) {
unless( File::Spec->file_name_is_absolute($try) ) {
# make path absolute
$try = File::Spec->catfile( $cwd ,$try);
}
# simplify path
$try = File::Spec->canonpath($try);
my $start_in;
my $modname_prefix;
if($self->{'dir_prefix'}) {
$start_in = File::Spec->catdir(
$try,
grep length($_), split '[\\/:]+', $self->{'dir_prefix'}
);
$modname_prefix = [grep length($_), split m{[:/\\]}, $self->{'dir_prefix'}];
$verbose and print "Appending \"$self->{'dir_prefix'}\" to $try, ",
"giving $start_in (= @$modname_prefix)\n";
} else {
$start_in = $try;
}
if( $self->{'_dirs_visited'}{$start_in} ) {
$verbose and print "Directory '$start_in' already seen, skipping.\n";
next;
} else {
$self->{'_dirs_visited'}{$start_in} = 1;
}
unless(-e $start_in) {
$verbose and print "Skipping non-existent $start_in\n";
next;
}
my $closure = $self->_make_search_callback;
if(-d $start_in) {
# Normal case:
$verbose and print "Beginning excursion under $start_in\n";
$self->_recurse_dir( $start_in, $closure, $modname_prefix );
$verbose and print "Back from excursion under $start_in\n\n";
} elsif(-f _) {
# A excursion consisting of just one file!
$_ = basename($start_in);
$verbose and print "Pondering $start_in ($_)\n";
$closure->($start_in, $_, 0, []);
} else {
$verbose and print "Skipping mysterious $start_in\n";
}
}
$self->progress and $self->progress->done(
"Noted $$self{'_scan_count'} Pod files total");
return unless defined wantarray; # void
return $self->name2path unless wantarray; # scalar
return $self->name2path, $self->path2name; # list
}
#==========================================================================
sub _make_search_callback {
my $self = $_[0];
# Put the options in variables, for easy access
my( $laborious, $verbose, $shadows, $limit_re, $callback, $progress,
$path2name, $name2path, $recurse) =
map scalar($self->$_()),
qw(laborious verbose shadows limit_re callback progress
path2name name2path recurse);
my($file, $shortname, $isdir, $modname_bits);
return sub {
($file, $shortname, $isdir, $modname_bits) = @_;
if($isdir) { # this never gets called on the startdir itself, just subdirs
unless( $recurse ) {
$verbose and print "Not recursing into '$file' as per requested.\n";
return 'PRUNE';
}
if( $self->{'_dirs_visited'}{$file} ) {
$verbose and print "Directory '$file' already seen, skipping.\n";
return 'PRUNE';
}
print "Looking in dir $file\n" if $verbose;
unless ($laborious) { # $laborious overrides pruning
if( m/^(\d+\.[\d_]{3,})\z/s
and do { my $x = $1; $x =~ tr/_//d; $x != $] }
) {
$verbose and print "Perl $] version mismatch on $_, skipping.\n";
return 'PRUNE';
}
if( m/^([A-Za-z][a-zA-Z0-9_]*)\z/s ) {
$verbose and print "$_ is a well-named module subdir. Looking....\n";
} else {
$verbose and print "$_ is a fishy directory name. Skipping.\n";
return 'PRUNE';
}
} # end unless $laborious
$self->{'_dirs_visited'}{$file} = 1;
return; # (not pruning);
}
# Make sure it's a file even worth even considering
if($laborious) {
unless(
m/\.(pod|pm|plx?)\z/i || -x _ and -T _
# Note that the cheapest operation (the RE) is run first.
) {
$verbose > 1 and print " Brushing off uninteresting $file\n";
return;
}
} else {
unless( m/^[-_a-zA-Z0-9]+\.(?:pod|pm|plx?)\z/is ) {
$verbose > 1 and print " Brushing off oddly-named $file\n";
return;
}
}
$verbose and print "Considering item $file\n";
my $name = $self->_path2modname( $file, $shortname, $modname_bits );
$verbose > 0.01 and print " Nominating $file as $name\n";
if($limit_re and $name !~ m/$limit_re/i) {
$verbose and print "Shunning $name as not matching $limit_re\n";
return;
}
if( !$shadows and $name2path->{$name} ) {
$verbose and print "Not worth considering $file ",
"-- already saw $name as ",
join(' ', grep($path2name->{$_} eq $name, keys %$path2name)), "\n";
return;
}
# Put off until as late as possible the expense of
# actually reading the file:
if( m/\.pod\z/is ) {
# just assume it has pod, okay?
} else {
$progress and $progress->reach($self->{'_scan_count'}, "Scanning $file");
return unless $self->contains_pod( $file );
}
++ $self->{'_scan_count'};
# Or finally take note of it:
if( $name2path->{$name} ) {
$verbose and print
"Duplicate POD found (shadowing?): $name ($file)\n",
" Already seen in ",
join(' ', grep($path2name->{$_} eq $name, keys %$path2name)), "\n";
} else {
$name2path->{$name} = $file; # Noting just the first occurrence
}
$verbose and print " Noting $name = $file\n";
if( $callback ) {
local $_ = $_; # insulate from changes, just in case
$callback->($file, $name);
}
$path2name->{$file} = $name;
return;
}
}
#==========================================================================
sub _path2modname {
my($self, $file, $shortname, $modname_bits) = @_;
# this code simplifies the POD name for Perl modules:
# * remove "site_perl"
# * remove e.g. "i586-linux" (from 'archname')
# * remove e.g. 5.00503
# * remove pod/ if followed by perl*.pod (e.g. in pod/perlfunc.pod)
# * dig into the file for case-preserved name if not already mixed case
my @m = @$modname_bits;
my $x;
my $verbose = $self->verbose;
# Shaving off leading naughty-bits
while(@m
and defined($x = lc( $m[0] ))
and( $x eq 'site_perl'
or($x eq 'pod' and @m == 1 and $shortname =~ m{^perl.*\.pod$}s )
or $x =~ m{\\d+\\.z\\d+([_.]?\\d+)?} # if looks like a vernum
or $x eq lc( $Config::Config{'archname'} )
)) { shift @m }
my $name = join '::', @m, $shortname;
$self->_simplify_base($name);
# On VMS, case-preserved document names can't be constructed from
# filenames, so try to extract them from the "=head1 NAME" tag in the
# file instead.
if ($^O eq 'VMS' && ($name eq lc($name) || $name eq uc($name))) {
open PODFILE, "<$file" or die "_path2modname: Can't open $file: $!";
my $in_pod = 0;
my $in_name = 0;
my $line;
while ($line = <PODFILE>) {
chomp $line;
$in_pod = 1 if ($line =~ m/^=\w/);
$in_pod = 0 if ($line =~ m/^=cut/);
next unless $in_pod; # skip non-pod text
next if ($line =~ m/^\s*\z/); # and blank lines
next if ($in_pod && ($line =~ m/^X</)); # and commands
if ($in_name) {
if ($line =~ m/(\w+::)?(\w+)/) {
# substitute case-preserved version of name
my $podname = $2;
my $prefix = $1 || '';
$verbose and print "Attempting case restore of '$name' from '$prefix$podname'\n";
unless ($name =~ s/$prefix$podname/$prefix$podname/i) {
$verbose and print "Attempting case restore of '$name' from '$podname'\n";
$name =~ s/$podname/$podname/i;
}
last;
}
}
$in_name = 1 if ($line =~ m/^=head1 NAME/);
}
close PODFILE;
}
return $name;
}
#==========================================================================
sub _recurse_dir {
my($self, $startdir, $callback, $modname_bits) = @_;
my $maxdepth = $self->{'fs_recursion_maxdepth'} || 10;
my $verbose = $self->verbose;
my $here_string = File::Spec->curdir;
my $up_string = File::Spec->updir;
$modname_bits ||= [];
my $recursor;
$recursor = sub {
my($dir_long, $dir_bare) = @_;
if( @$modname_bits >= 10 ) {
$verbose and print "Too deep! [@$modname_bits]\n";
return;
}
unless(-d $dir_long) {
$verbose > 2 and print "But it's not a dir! $dir_long\n";
return;
}
unless( opendir(INDIR, $dir_long) ) {
$verbose > 2 and print "Can't opendir $dir_long : $!\n";
closedir(INDIR);
return
}
my @items = sort readdir(INDIR);
closedir(INDIR);
push @$modname_bits, $dir_bare unless $dir_bare eq '';
my $i_full;
foreach my $i (@items) {
next if $i eq $here_string or $i eq $up_string or $i eq '';
$i_full = File::Spec->catfile( $dir_long, $i );
if(!-r $i_full) {
$verbose and print "Skipping unreadable $i_full\n";
} elsif(-f $i_full) {
$_ = $i;
$callback->( $i_full, $i, 0, $modname_bits );
} elsif(-d _) {
$i =~ s/\.DIR\z//i if $^O eq 'VMS';
$_ = $i;
my $rv = $callback->( $i_full, $i, 1, $modname_bits ) || '';
if($rv eq 'PRUNE') {
$verbose > 1 and print "OK, pruning";
} else {
# Otherwise, recurse into it
$recursor->( File::Spec->catdir($dir_long, $i) , $i);
}
} else {
$verbose > 1 and print "Skipping oddity $i_full\n";
}
}
pop @$modname_bits;
return;
};;
local $_;
$recursor->($startdir, '');
undef $recursor; # allow it to be GC'd
return;
}
#==========================================================================
sub run {
# A function, useful in one-liners
my $self = __PACKAGE__->new;
$self->limit_glob($ARGV[0]) if @ARGV;
$self->callback( sub {
my($file, $name) = @_;
my $version = '';
# Yes, I know we won't catch the version in like a File/Thing.pm
# if we see File/Thing.pod first. That's just the way the
# cookie crumbles. -- SMB
if($file =~ m/\.pod$/i) {
# Don't bother looking for $VERSION in .pod files
DEBUG and print "Not looking for \$VERSION in .pod $file\n";
} elsif( !open(INPOD, $file) ) {
DEBUG and print "Couldn't open $file: $!\n";
close(INPOD);
} else {
# Sane case: file is readable
my $lines = 0;
while(<INPOD>) {
last if $lines++ > $MAX_VERSION_WITHIN; # some degree of sanity
if( s/^\s*\$VERSION\s*=\s*//s and m/\d/ ) {
DEBUG and print "Found version line (#$lines): $_";
s/\s*\#.*//s;
s/\;\s*$//s;
s/\s+$//s;
s/\t+/ /s; # nix tabs
# Optimize the most common cases:
$_ = "v$1"
if m{^v?["']?([0-9_]+(\.[0-9_]+)*)["']?$}s
# like in $VERSION = "3.14159";
or m{\$Revision:\s*([0-9_]+(?:\.[0-9_]+)*)\s*\$}s
# like in sprintf("%d.%02d", q$Revision: 4.13 $ =~ /(\d+)\.(\d+)/);
;
# Like in sprintf("%d.%s", map {s/_//g; $_} q$Name: release-0_55-public $ =~ /-(\d+)_([\d_]+)/)
$_ = sprintf("v%d.%s",
map {s/_//g; $_}
$1 =~ m/-(\d+)_([\d_]+)/) # snare just the numeric part
if m{\$Name:\s*([^\$]+)\$}s
;
$version = $_;
DEBUG and print "Noting $version as version\n";
last;
}
}
close(INPOD);
}
print "$name\t$version\t$file\n";
return;
# End of callback!
});
$self->survey;
}
#==========================================================================
sub simplify_name {
my($self, $str) = @_;
# Remove all path components
# XXX Why not just use basename()? -- SMB
if ($^O eq 'MacOS') { $str =~ s{^.*:+}{}s }
else { $str =~ s{^.*/+}{}s }
$self->_simplify_base($str);
return $str;
}
#==========================================================================
sub _simplify_base { # Internal method only
# strip Perl's own extensions
$_[1] =~ s/\.(pod|pm|plx?)\z//i;
# strip meaningless extensions on Win32 and OS/2
$_[1] =~ s/\.(bat|exe|cmd)\z//i if $^O =~ /mswin|os2/i;
# strip meaningless extensions on VMS
$_[1] =~ s/\.(com)\z//i if $^O eq 'VMS';
return;
}
#==========================================================================
sub _expand_inc {
my($self, $search_dirs) = @_;
return unless $self->{'inc'};
if ($^O eq 'MacOS') {
push @$search_dirs,
grep $_ ne File::Spec->curdir, $self->_mac_whammy(@INC);
# Any other OSs need custom handling here?
} else {
push @$search_dirs, grep $_ ne File::Spec->curdir, @INC;
}
$self->{'laborious'} = 0; # Since inc said to use INC
return;
}
#==========================================================================
sub _mac_whammy { # Tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
my @them;
(undef,@them) = @_;
for $_ (@them) {
if ( $_ eq '.' ) {
$_ = ':';
} elsif ( $_ =~ s|^((?:\.\./)+)|':' x (length($1)/3)|e ) {
$_ = ':'. $_;
} else {
$_ =~ s|^\./|:|;
}
}
return @them;
}
#==========================================================================
sub _limit_glob_to_limit_re {
my $self = $_[0];
my $limit_glob = $self->{'limit_glob'} || return;
my $limit_re = '^' . quotemeta($limit_glob) . '$';
$limit_re =~ s/\\\?/./g; # glob "?" => "."
$limit_re =~ s/\\\*/.*?/g; # glob "*" => ".*?"
$limit_re =~ s/\.\*\?\$$//s; # final glob "*" => ".*?$" => ""
$self->{'verbose'} and print "Turning limit_glob $limit_glob into re $limit_re\n";
# A common optimization:
if(!exists($self->{'dir_prefix'})
and $limit_glob =~ m/^(?:\w+\:\:)+/s # like "File::*" or "File::Thing*"
# Optimize for sane and common cases (but not things like "*::File")
) {
$self->{'dir_prefix'} = join "::", $limit_glob =~ m/^(?:\w+::)+/sg;
$self->{'verbose'} and print " and setting dir_prefix to $self->{'dir_prefix'}\n";
}
return $limit_re;
}
#==========================================================================
# contribution mostly from Tim Jenness <t.jenness@jach.hawaii.edu>
sub find {
my($self, $pod, @search_dirs) = @_;
$self = $self->new unless ref $self; # tolerate being a class method
# Check usage
Carp::carp 'Usage: \$self->find($podname, ...)'
unless defined $pod and length $pod;
my $verbose = $self->verbose;
# Split on :: and then join the name together using File::Spec
my @parts = split /::/, $pod;
$verbose and print "Chomping {$pod} => {@parts}\n";
#@search_dirs = File::Spec->curdir unless @search_dirs;
if( $self->inc ) {
if( $^O eq 'MacOS' ) {
push @search_dirs, $self->_mac_whammy(@INC);
} else {
push @search_dirs, @INC;
}
# Add location of pod documentation for perl man pages (eg perlfunc)
# This is a pod directory in the private install tree
#my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'},
# 'pod');
#push (@search_dirs, $perlpoddir)
# if -d $perlpoddir;
# Add location of binaries such as pod2text:
push @search_dirs, $Config::Config{'scriptdir'};
# and if that's undef or q{} or nonexistent, we just ignore it later
}
my %seen_dir;
Dir:
foreach my $dir ( @search_dirs ) {
next unless defined $dir and length $dir;
next if $seen_dir{$dir};
$seen_dir{$dir} = 1;
unless(-d $dir) {
print "Directory $dir does not exist\n" if $verbose;
next Dir;
}
print "Looking in directory $dir\n" if $verbose;
my $fullname = File::Spec->catfile( $dir, @parts );
print "Filename is now $fullname\n" if $verbose;
foreach my $ext ('', '.pod', '.pm', '.pl') { # possible extensions
my $fullext = $fullname . $ext;
if( -f $fullext and $self->contains_pod( $fullext ) ){
print "FOUND: $fullext\n" if $verbose;
return $fullext;
}
}
my $subdir = File::Spec->catdir($dir,'pod');
if(-d $subdir) { # slip in the ./pod dir too
$verbose and print "Noticing $subdir and stopping there...\n";
$dir = $subdir;
redo Dir;
}
}
return undef;
}
#==========================================================================
sub contains_pod {
my($self, $file) = @_;
my $verbose = $self->{'verbose'};
# check for one line of POD
$verbose > 1 and print " Scanning $file for pod...\n";
unless( open(MAYBEPOD,"<$file") ) {
print "Error: $file is unreadable: $!\n";
return undef;
}
sleep($SLEEPY - 1) if $SLEEPY;
# avoid totally hogging the processor on OSs with poor process control
local $_;
while( <MAYBEPOD> ) {
if(m/^=(head\d|pod|over|item)\b/s) {
close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting";
chomp;
$verbose > 1 and print " Found some pod ($_) in $file\n";
return 1;
}
}
close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting";
$verbose > 1 and print " No POD in $file, skipping.\n";
return 0;
}
#==========================================================================
sub _accessorize { # A simple-minded method-maker
shift;
no strict 'refs';
foreach my $attrname (@_) {
*{caller() . '::' . $attrname} = sub {
use strict;
$Carp::CarpLevel = 1, Carp::croak(
"Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)"
) unless (@_ == 1 or @_ == 2) and ref $_[0];
# Read access:
return $_[0]->{$attrname} if @_ == 1;
# Write access:
$_[0]->{$attrname} = $_[1];
return $_[0]; # RETURNS MYSELF!
};
}
# Ya know, they say accessories make the ensemble!
return;
}
#==========================================================================
sub _state_as_string {
my $self = $_[0];
return '' unless ref $self;
my @out = "{\n # State of $self ...\n";
foreach my $k (sort keys %$self) {
push @out, " ", _esc($k), " => ", _esc($self->{$k}), ",\n";
}
push @out, "}\n";
my $x = join '', @out;
$x =~ s/^/#/mg;
return $x;
}
sub _esc {
my $in = $_[0];
return 'undef' unless defined $in;
$in =~
s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])>
<'\\x'.(unpack("H2",$1))>eg;
return qq{"$in"};
}
#==========================================================================
run() unless caller; # run if "perl whatever/Search.pm"
1;
#==========================================================================
__END__
=head1 NAME
Pod::Simple::Search - find POD documents in directory trees
=head1 SYNOPSIS
use Pod::Simple::Search;
my $name2path = Pod::Simple::Search->new->limit_glob('LWP::*')->survey;
print "Looky see what I found: ",
join(' ', sort keys %$name2path), "\n";
print "LWPUA docs = ",
Pod::Simple::Search->new->find('LWP::UserAgent') || "?",
"\n";
=head1 DESCRIPTION
B<Pod::Simple::Search> is a class that you use for running searches
for Pod files. An object of this class has several attributes
(mostly options for controlling search options), and some methods
for searching based on those attributes.
The way to use this class is to make a new object of this class,
set any options, and then call one of the search options
(probably C<survey> or C<find>). The sections below discuss the
syntaxes for doing all that.
=head1 CONSTRUCTOR
This class provides the one constructor, called C<new>.
It takes no parameters:
use Pod::Simple::Search;
my $search = Pod::Simple::Search->new;
=head1 ACCESSORS
This class defines several methods for setting (and, occasionally,
reading) the contents of an object. With two exceptions (discussed at
the end of this section), these attributes are just for controlling the
way searches are carried out.
Note that each of these return C<$self> when you call them as
C<< $self->I<whatever(value)> >>. That's so that you can chain
together set-attribute calls like this:
my $name2path =
Pod::Simple::Search->new
-> inc(0) -> verbose(1) -> callback(\&blab)
->survey(@there);
...which works exactly as if you'd done this:
my $search = Pod::Simple::Search->new;
$search->inc(0);
$search->verbose(1);
$search->callback(\&blab);
my $name2path = $search->survey(@there);
=over
=item $search->inc( I<true-or-false> );
This attribute, if set to a true value, means that searches should
implicitly add perl's I<@INC> paths. This
automatically considers paths specified in the C<PERL5LIB> environment
as this is prepended to I<@INC> by the Perl interpreter itself.
This attribute's default value is B<TRUE>. If you want to search
only specific directories, set $self->inc(0) before calling
$inc->survey or $inc->find.
=item $search->verbose( I<nonnegative-number> );
This attribute, if set to a nonzero positive value, will make searches output
(via C<warn>) notes about what they're doing as they do it.
This option may be useful for debugging a pod-related module.
This attribute's default value is zero, meaning that no C<warn> messages
are produced. (Setting verbose to 1 turns on some messages, and setting
it to 2 turns on even more messages, i.e., makes the following search(es)
even more verbose than 1 would make them.)
=item $search->limit_glob( I<some-glob-string> );
This option means that you want to limit the results just to items whose
podnames match the given glob/wildcard expression. For example, you
might limit your search to just "LWP::*", to search only for modules
starting with "LWP::*" (but not including the module "LWP" itself); or
you might limit your search to "LW*" to see only modules whose (full)
names begin with "LW"; or you might search for "*Find*" to search for
all modules with "Find" somewhere in their full name. (You can also use
"?" in a glob expression; so "DB?" will match "DBI" and "DBD".)
=item $search->callback( I<\&some_routine> );
This attribute means that every time this search sees a matching
Pod file, it should call this callback routine. The routine is called
with two parameters: the current file's filespec, and its pod name.
(For example: C<("/etc/perljunk/File/Crunk.pm", "File::Crunk")> would
be in C<@_>.)
The callback routine's return value is not used for anything.
This attribute's default value is false, meaning that no callback
is called.
=item $search->laborious( I<true-or-false> );
Unless you set this attribute to a true value, Pod::Search will
apply Perl-specific heuristics to find the correct module PODs quickly.
This attribute's default value is false. You won't normally need
to set this to true.
Specifically: Turning on this option will disable the heuristics for
seeing only files with Perl-like extensions, omitting subdirectories
that are numeric but do I<not> match the current Perl interpreter's
version ID, suppressing F<site_perl> as a module hierarchy name, etc.
=item $search->shadows( I<true-or-false> );
Unless you set this attribute to a true value, Pod::Simple::Search will
consider only the first file of a given modulename as it looks thru the
specified directories; that is, with this option off, if
Pod::Simple::Search has seen a C<somepathdir/Foo/Bar.pm> already in this
search, then it won't bother looking at a C<somelaterpathdir/Foo/Bar.pm>
later on in that search, because that file is merely a "shadow". But if
you turn on C<< $self->shadows(1) >>, then these "shadow" files are
inspected too, and are noted in the pathname2podname return hash.
This attribute's default value is false; and normally you won't
need to turn it on.
=item $search->limit_re( I<some-regxp> );
Setting this attribute (to a value that's a regexp) means that you want
to limit the results just to items whose podnames match the given
regexp. Normally this option is not needed, and the more efficient
C<limit_glob> attribute is used instead.
=item $search->dir_prefix( I<some-string-value> );
Setting this attribute to a string value means that the searches should
begin in the specified subdirectory name (like "Pod" or "File::Find",
also expressable as "File/Find"). For example, the search option
C<< $search->limit_glob("File::Find::R*") >>
is the same as the combination of the search options
C<< $search->limit_re("^File::Find::R") -> dir_prefix("File::Find") >>.
Normally you don't need to know about the C<dir_prefix> option, but I
include it in case it might prove useful for someone somewhere.
(Implementationally, searching with limit_glob ends up setting limit_re
and usually dir_prefix.)
=item $search->progress( I<some-progress-object> );
If you set a value for this attribute, the value is expected
to be an object (probably of a class that you define) that has a
C<reach> method and a C<done> method. This is meant for reporting
progress during the search, if you don't want to use a simple
callback.
Normally you don't need to know about the C<progress> option, but I
include it in case it might prove useful for someone somewhere.
While a search is in progress, the progress object's C<reach> and
C<done> methods are called like this:
# Every time a file is being scanned for pod:
$progress->reach($count, "Scanning $file"); ++$count;
# And then at the end of the search:
$progress->done("Noted $count Pod files total");
Internally, we often set this to an object of class
Pod::Simple::Progress. That class is probably undocumented,
but you may wish to look at its source.
=item $name2path = $self->name2path;
This attribute is not a search parameter, but is used to report the
result of C<survey> method, as discussed in the next section.
=item $path2name = $self->path2name;
This attribute is not a search parameter, but is used to report the
result of C<survey> method, as discussed in the next section.
=back
=head1 MAIN SEARCH METHODS
Once you've actually set any options you want (if any), you can go
ahead and use the following methods to search for Pod files
in particular ways.
=head2 C<< $search->survey( @directories ) >>
The method C<survey> searches for POD documents in a given set of
files and/or directories. This runs the search according to the various
options set by the accessors above. (For example, if the C<inc> attribute
is on, as it is by default, then the perl @INC directories are implicitly
added to the list of directories (if any) that you specify.)
The return value of C<survey> is two hashes:
=over
=item C<name2path>
A hash that maps from each pod-name to the filespec (like
"Stuff::Thing" => "/whatever/plib/Stuff/Thing.pm")
=item C<path2name>
A hash that maps from each Pod filespec to its pod-name (like
"/whatever/plib/Stuff/Thing.pm" => "Stuff::Thing")
=back
Besides saving these hashes as the hashref attributes
C<name2path> and C<path2name>, calling this function also returns
these hashrefs. In list context, the return value of
C<< $search->survey >> is the list C<(\%name2path, \%path2name)>.
In scalar context, the return value is C<\%name2path>.
Or you can just call this in void context.
Regardless of calling context, calling C<survey> saves
its results in its C<name2path> and C<path2name> attributes.
E.g., when searching in F<$HOME/perl5lib>, the file
F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>,
whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be
I<Myclass::Subclass>. The name information can be used for POD
translators.
Only text files containing at least one valid POD command are found.
In verbose mode, a warning is printed if shadows are found (i.e., more
than one POD file with the same POD name is found, e.g. F<CPAN.pm> in
different directories). This usually indicates duplicate occurrences of
modules in the I<@INC> search path, which is occasionally inadvertent
(but is often simply a case of a user's path dir having a more recent
version than the system's general path dirs in general.)
The options to this argument is a list of either directories that are
searched recursively, or files. (Usually you wouldn't specify files,
but just dirs.) Or you can just specify an empty-list, as in
$name2path; with the
C<inc> option on, as it is by default, teh
The POD names of files are the plain basenames with any Perl-like
extension (.pm, .pl, .pod) stripped, and path separators replaced by
C<::>'s.
Calling Pod::Simple::Search->search(...) is short for
Pod::Simple::Search->new->search(...). That is, a throwaway object
with default attribute values is used.
=head2 C<< $search->simplify_name( $str ) >>
The method B<simplify_name> is equivalent to B<basename>, but also
strips Perl-like extensions (.pm, .pl, .pod) and extensions like
F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively.
=head2 C<< $search->find( $pod ) >>
=head2 C<< $search->find( $pod, @search_dirs ) >>
Returns the location of a Pod file, given a Pod/module/script name
(like "Foo::Bar" or "perlvar" or "perldoc"), and an idea of
what files/directories to look in.
It searches according to the various options set by the accessors above.
(For example, if the C<inc> attribute is on, as it is by default, then
the perl @INC directories are implicitly added to the list of
directories (if any) that you specify.)
This returns the full path of the first occurrence to the file.
Package names (eg 'A::B') are automatically converted to directory
names in the selected directory. Additionally, '.pm', '.pl' and '.pod'
are automatically appended to the search as required.
(So, for example, under Unix, "A::B" is converted to "somedir/A/B.pm",
"somedir/A/B.pod", or "somedir/A/B.pl", as appropriate.)
If no such Pod file is found, this method returns undef.
If any of the given search directories contains a F<pod/> subdirectory,
then it is searched. (That's how we manage to find F<perlfunc>,
for example, which is usually in F<pod/perlfunc> in most Perl dists.)
The C<verbose> and C<inc> attributes influence the behavior of this
search; notably, C<inc>, if true, adds @INC I<and also
$Config::Config{'scriptdir'}> to the list of directories to search.
It is common to simply say C<< $filename = Pod::Simple::Search-> new
->find("perlvar") >> so that just the @INC (well, and scriptdir)
directories are searched. (This happens because the C<inc>
attribute is true by default.)
Calling Pod::Simple::Search->find(...) is short for
Pod::Simple::Search->new->find(...). That is, a throwaway object
with default attribute values is used.
=head2 C<< $self->contains_pod( $file ) >>
Returns true if the supplied filename (not POD module) contains some Pod
documentation.
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org> with code borrowed
from Marek Rouchal's L<Pod::Find>, which in turn heavily borrowed code from
Nick Ing-Simmons' C<PodToHtml>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_SEARCH
$fatpacked{"Pod/Simple/SimpleTree.pm"} = <<'POD_SIMPLE_SIMPLETREE';
require 5;
package Pod::Simple::SimpleTree;
use strict;
use Carp ();
use Pod::Simple ();
use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS);
$VERSION = '3.26';
BEGIN {
@ISA = ('Pod::Simple');
*DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG;
}
__PACKAGE__->_accessorize(
'root', # root of the tree
);
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub _handle_element_start { # self, tagname, attrhash
DEBUG > 2 and print "Handling $_[1] start-event\n";
my $x = [$_[1], $_[2]];
if($_[0]{'_currpos'}) {
push @{ $_[0]{'_currpos'}[0] }, $x; # insert in parent's child-list
unshift @{ $_[0]{'_currpos'} }, $x; # prefix to stack
} else {
DEBUG and print " And oo, it gets to be root!\n";
$_[0]{'_currpos'} = [ $_[0]{'root'} = $x ];
# first event! set to stack, and set as root.
}
DEBUG > 3 and print "Stack is now: ",
join(">", map $_->[0], @{$_[0]{'_currpos'}}), "\n";
return;
}
sub _handle_element_end { # self, tagname
DEBUG > 2 and print "Handling $_[1] end-event\n";
shift @{$_[0]{'_currpos'}};
DEBUG > 3 and print "Stack is now: ",
join(">", map $_->[0], @{$_[0]{'_currpos'}}), "\n";
return;
}
sub _handle_text { # self, text
DEBUG > 2 and print "Handling $_[1] text-event\n";
push @{ $_[0]{'_currpos'}[0] }, $_[1];
return;
}
# A bit of evil from the black box... please avert your eyes, kind souls.
sub _traverse_treelet_bit {
DEBUG > 2 and print "Handling $_[1] paragraph event\n";
my $self = shift;
push @{ $self->{'_currpos'}[0] }, [@_];
return;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1;
__END__
=head1 NAME
Pod::Simple::SimpleTree -- parse Pod into a simple parse tree
=head1 SYNOPSIS
% cat ptest.pod
=head1 PIE
I like B<pie>!
% perl -MPod::Simple::SimpleTree -MData::Dumper -e \
"print Dumper(Pod::Simple::SimpleTree->new->parse_file(shift)->root)" \
ptest.pod
$VAR1 = [
'Document',
{ 'start_line' => 1 },
[
'head1',
{ 'start_line' => 1 },
'PIE'
],
[
'Para',
{ 'start_line' => 3 },
'I like ',
[
'B',
{},
'pie'
],
'!'
]
];
=head1 DESCRIPTION
This class is of interest to people writing a Pod processor/formatter.
This class takes Pod and parses it, returning a parse tree made just
of arrayrefs, and hashrefs, and strings.
This is a subclass of L<Pod::Simple> and inherits all its methods.
This class is inspired by XML::Parser's "Tree" parsing-style, although
it doesn't use exactly the same LoL format.
=head1 METHODS
At the end of the parse, call C<< $parser->root >> to get the
tree's top node.
=head1 Tree Contents
Every element node in the parse tree is represented by an arrayref of
the form: C<[ I<elementname>, \%attributes, I<...subnodes...> ]>.
See the example tree dump in the Synopsis, above.
Every text node in the tree is represented by a simple (non-ref)
string scalar. So you can test C<ref($node)> to see whather you have
an element node or just a text node.
The top node in the tree is C<[ 'Document', \%attributes,
I<...subnodes...> ]>
=head1 SEE ALSO
L<Pod::Simple>
L<perllol>
L<The "Tree" subsubsection in XML::Parser|XML::Parser/"Tree">
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_SIMPLETREE
$fatpacked{"Pod/Simple/Text.pm"} = <<'POD_SIMPLE_TEXT';
require 5;
package Pod::Simple::Text;
use strict;
use Carp ();
use Pod::Simple::Methody ();
use Pod::Simple ();
use vars qw( @ISA $VERSION $FREAKYMODE);
$VERSION = '3.26';
@ISA = ('Pod::Simple::Methody');
BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG)
? \&Pod::Simple::DEBUG
: sub() {0}
}
use Text::Wrap 98.112902 ();
$Text::Wrap::wrap = 'overflow';
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub new {
my $self = shift;
my $new = $self->SUPER::new(@_);
$new->{'output_fh'} ||= *STDOUT{IO};
$new->accept_target_as_text(qw( text plaintext plain ));
$new->nix_X_codes(1);
$new->nbsp_for_S(1);
$new->{'Thispara'} = '';
$new->{'Indent'} = 0;
$new->{'Indentstring'} = ' ';
return $new;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub handle_text { $_[0]{'Thispara'} .= $_[1] }
sub start_Para { $_[0]{'Thispara'} = '' }
sub start_head1 { $_[0]{'Thispara'} = '' }
sub start_head2 { $_[0]{'Thispara'} = '' }
sub start_head3 { $_[0]{'Thispara'} = '' }
sub start_head4 { $_[0]{'Thispara'} = '' }
sub start_Verbatim { $_[0]{'Thispara'} = '' }
sub start_item_bullet { $_[0]{'Thispara'} = $FREAKYMODE ? '' : '* ' }
sub start_item_number { $_[0]{'Thispara'} = $FREAKYMODE ? '' : "$_[1]{'number'}. " }
sub start_item_text { $_[0]{'Thispara'} = '' }
sub start_over_bullet { ++$_[0]{'Indent'} }
sub start_over_number { ++$_[0]{'Indent'} }
sub start_over_text { ++$_[0]{'Indent'} }
sub start_over_block { ++$_[0]{'Indent'} }
sub end_over_bullet { --$_[0]{'Indent'} }
sub end_over_number { --$_[0]{'Indent'} }
sub end_over_text { --$_[0]{'Indent'} }
sub end_over_block { --$_[0]{'Indent'} }
# . . . . . Now the actual formatters:
sub end_head1 { $_[0]->emit_par(-4) }
sub end_head2 { $_[0]->emit_par(-3) }
sub end_head3 { $_[0]->emit_par(-2) }
sub end_head4 { $_[0]->emit_par(-1) }
sub end_Para { $_[0]->emit_par( 0) }
sub end_item_bullet { $_[0]->emit_par( 0) }
sub end_item_number { $_[0]->emit_par( 0) }
sub end_item_text { $_[0]->emit_par(-2) }
sub start_L { $_[0]{'Link'} = $_[1] if $_[1]->{type} eq 'url' }
sub end_L {
if (my $link = delete $_[0]{'Link'}) {
# Append the URL to the output unless it's already present.
$_[0]{'Thispara'} .= " <$link->{to}>"
unless $_[0]{'Thispara'} =~ /\b\Q$link->{to}/;
}
}
sub emit_par {
my($self, $tweak_indent) = splice(@_,0,2);
my $indent = ' ' x ( 2 * $self->{'Indent'} + 4 + ($tweak_indent||0) );
# Yes, 'STRING' x NEGATIVE gives '', same as 'STRING' x 0
$self->{'Thispara'} =~ tr{\xAD}{}d if Pod::Simple::ASCII;
my $out = Text::Wrap::wrap($indent, $indent, $self->{'Thispara'} .= "\n");
$out =~ tr{\xA0}{ } if Pod::Simple::ASCII;
print {$self->{'output_fh'}} $out, "\n";
$self->{'Thispara'} = '';
return;
}
# . . . . . . . . . . And then off by its lonesome:
sub end_Verbatim {
my $self = shift;
if(Pod::Simple::ASCII) {
$self->{'Thispara'} =~ tr{\xA0}{ };
$self->{'Thispara'} =~ tr{\xAD}{}d;
}
my $i = ' ' x ( 2 * $self->{'Indent'} + 4);
#my $i = ' ' x (4 + $self->{'Indent'});
$self->{'Thispara'} =~ s/^/$i/mg;
print { $self->{'output_fh'} } '',
$self->{'Thispara'},
"\n\n"
;
$self->{'Thispara'} = '';
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
1;
__END__
=head1 NAME
Pod::Simple::Text -- format Pod as plaintext
=head1 SYNOPSIS
perl -MPod::Simple::Text -e \
"exit Pod::Simple::Text->filter(shift)->any_errata_seen" \
thingy.pod
=head1 DESCRIPTION
This class is a formatter that takes Pod and renders it as
wrapped plaintext.
Its wrapping is done by L<Text::Wrap>, so you can change
C<$Text::Wrap::columns> as you like.
This is a subclass of L<Pod::Simple> and inherits all its methods.
=head1 SEE ALSO
L<Pod::Simple>, L<Pod::Simple::TextContent>, L<Pod::Text>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_TEXT
$fatpacked{"Pod/Simple/TextContent.pm"} = <<'POD_SIMPLE_TEXTCONTENT';
require 5;
package Pod::Simple::TextContent;
use strict;
use Carp ();
use Pod::Simple ();
use vars qw( @ISA $VERSION );
$VERSION = '3.26';
@ISA = ('Pod::Simple');
sub new {
my $self = shift;
my $new = $self->SUPER::new(@_);
$new->{'output_fh'} ||= *STDOUT{IO};
$new->nix_X_codes(1);
return $new;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub _handle_element_start {
print {$_[0]{'output_fh'}} "\n" unless $_[1] =~ m/^[A-Z]$/s;
return;
}
sub _handle_text {
if( chr(65) eq 'A' ) { # in ASCIIworld
$_[1] =~ tr/\xAD//d;
$_[1] =~ tr/\xA0/ /;
}
print {$_[0]{'output_fh'}} $_[1];
return;
}
sub _handle_element_end {
print {$_[0]{'output_fh'}} "\n" unless $_[1] =~ m/^[A-Z]$/s;
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
1;
__END__
=head1 NAME
Pod::Simple::TextContent -- get the text content of Pod
=head1 SYNOPSIS
TODO
perl -MPod::Simple::TextContent -e \
"exit Pod::Simple::TextContent->filter(shift)->any_errata_seen" \
thingy.pod
=head1 DESCRIPTION
This class is that parses Pod and dumps just the text content. It is
mainly meant for use by the Pod::Simple test suite, but you may find
some other use for it.
This is a subclass of L<Pod::Simple> and inherits all its methods.
=head1 SEE ALSO
L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Spell>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_TEXTCONTENT
$fatpacked{"Pod/Simple/TiedOutFH.pm"} = <<'POD_SIMPLE_TIEDOUTFH';
use strict;
package Pod::Simple::TiedOutFH;
use Symbol ('gensym');
use Carp ();
use vars qw($VERSION );
$VERSION = '3.26';
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub handle_on { # some horrible frightening things are encapsulated in here
my $class = shift;
$class = ref($class) || $class;
Carp::croak "Usage: ${class}->handle_on(\$somescalar)" unless @_;
my $x = (defined($_[0]) and ref($_[0]))
? $_[0]
: ( \( $_[0] ) )[0]
;
$$x = '' unless defined $$x;
#Pod::Simple::DEBUG and print "New $class handle on $x = \"$$x\"\n";
my $new = gensym();
tie *$new, $class, $x;
return $new;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub TIEHANDLE { # Ties to just a scalar ref
my($class, $scalar_ref) = @_;
$$scalar_ref = '' unless defined $$scalar_ref;
return bless \$scalar_ref, ref($class) || $class;
}
sub PRINT {
my $it = shift;
foreach my $x (@_) { $$$it .= $x }
#Pod::Simple::DEBUG > 10 and print " appended to $$it = \"$$$it\"\n";
return 1;
}
sub FETCH {
return ${$_[0]};
}
sub PRINTF {
my $it = shift;
my $format = shift;
$$$it .= sprintf $format, @_;
return 1;
}
sub FILENO { ${ $_[0] } + 100 } # just to produce SOME number
sub CLOSE { 1 }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1;
__END__
Chole
* 1 large red onion
* 2 tomatillos
* 4 or 5 roma tomatoes (optionally with the pulp discarded)
* 1 tablespoons chopped ginger root (or more, to taste)
* 2 tablespoons canola oil (or vegetable oil)
* 1 tablespoon garam masala
* 1/2 teaspoon red chili powder, or to taste
* Salt, to taste (probably quite a bit)
* 2 (15-ounce) cans chick peas or garbanzo beans, drained and rinsed
* juice of one smallish lime
* a dash of balsamic vinegar (to taste)
* cooked rice, preferably long-grain white rice (whether plain,
basmati rice, jasmine rice, or even a mild pilaf)
In a blender or food processor, puree the onions, tomatoes, tomatillos,
and ginger root. You can even do it with a Braun hand "mixer", if you
chop things finer to start with, and work at it.
In a saucepan set over moderate heat, warm the oil until hot.
Add the puree and the balsamic vinegar, and cook, stirring occasionally,
for 20 to 40 minutes. (Cooking it longer will make it sweeter.)
Add the Garam Masala, chili powder, and cook, stirring occasionally, for
5 minutes.
Add the salt and chick peas and cook, stirring, until heated through.
Stir in the lime juice, and optionally one or two teaspoons of tahini.
You can let it simmer longer, depending on how much softer you want the
garbanzos to get.
Serve over rice, like a curry.
Yields 5 to 7 servings.
POD_SIMPLE_TIEDOUTFH
$fatpacked{"Pod/Simple/Transcode.pm"} = <<'POD_SIMPLE_TRANSCODE';
require 5;
package Pod::Simple::Transcode;
use vars qw($VERSION );
$VERSION = '3.26';
BEGIN {
if(defined &DEBUG) {;} # Okay
elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG; }
else { *DEBUG = sub () {0}; }
}
foreach my $class (
'Pod::Simple::TranscodeSmart',
'Pod::Simple::TranscodeDumb',
'',
) {
$class or die "Couldn't load any encoding classes";
DEBUG and print "About to try loading $class...\n";
eval "require $class;";
if($@) {
DEBUG and print "Couldn't load $class: $@\n";
} else {
DEBUG and print "OK, loaded $class.\n";
@ISA = ($class);
last;
}
}
sub _blorp { return; } # just to avoid any "empty class" warning
1;
__END__
POD_SIMPLE_TRANSCODE
$fatpacked{"Pod/Simple/TranscodeDumb.pm"} = <<'POD_SIMPLE_TRANSCODEDUMB';
require 5;
## This module is to be use()'d only by Pod::Simple::Transcode
package Pod::Simple::TranscodeDumb;
use strict;
use vars qw($VERSION %Supported);
$VERSION = '3.26';
# This module basically pretends it knows how to transcode, except
# only for null-transcodings! We use this when Encode isn't
# available.
%Supported = (
'ascii' => 1,
'ascii-ctrl' => 1,
'iso-8859-1' => 1,
'null' => 1,
'latin1' => 1,
'latin-1' => 1,
%Supported,
);
sub is_dumb {1}
sub is_smart {0}
sub all_encodings {
return sort keys %Supported;
}
sub encoding_is_available {
return exists $Supported{lc $_[1]};
}
sub encmodver {
return __PACKAGE__ . " v" .($VERSION || '?');
}
sub make_transcoder {
my($e) = $_[1];
die "WHAT ENCODING!?!?" unless $e;
my $x;
return sub {;
#foreach $x (@_) {
# if(Pod::Simple::ASCII and !Pod::Simple::UNICODE and $] > 5.005) {
# # We're in horrible gimp territory, so we need to knock out
# # all the highbit things
# $x =
# pack 'C*',
# map {; ($_ < 128) ? $_ : 0x7e }
# unpack "C*",
# $x
# ;
# }
#}
#
#return;
};
}
1;
POD_SIMPLE_TRANSCODEDUMB
$fatpacked{"Pod/Simple/TranscodeSmart.pm"} = <<'POD_SIMPLE_TRANSCODESMART';
require 5;
use 5.008;
## Anything before 5.8.0 is GIMPY!
## This module is to be use()'d only by Pod::Simple::Transcode
package Pod::Simple::TranscodeSmart;
use strict;
use Pod::Simple;
require Encode;
use vars qw($VERSION );
$VERSION = '3.26';
sub is_dumb {0}
sub is_smart {1}
sub all_encodings {
return Encode::->encodings(':all');
}
sub encoding_is_available {
return Encode::resolve_alias($_[1]);
}
sub encmodver {
return "Encode.pm v" .($Encode::VERSION || '?');
}
sub make_transcoder {
my $e = Encode::find_encoding($_[1]);
die "WHAT ENCODING!?!?" unless $e;
my $x;
return sub {
foreach $x (@_) {
$x = $e->decode($x) unless Encode::is_utf8($x);
}
return;
};
}
1;
POD_SIMPLE_TRANSCODESMART
$fatpacked{"Pod/Simple/XHTML.pm"} = <<'POD_SIMPLE_XHTML';
=pod
=head1 NAME
Pod::Simple::XHTML -- format Pod as validating XHTML
=head1 SYNOPSIS
use Pod::Simple::XHTML;
my $parser = Pod::Simple::XHTML->new();
...
$parser->parse_file('path/to/file.pod');
=head1 DESCRIPTION
This class is a formatter that takes Pod and renders it as XHTML
validating HTML.
This is a subclass of L<Pod::Simple::Methody> and inherits all its
methods. The implementation is entirely different than
L<Pod::Simple::HTML>, but it largely preserves the same interface.
=head2 Minimal code
use Pod::Simple::XHTML;
my $psx = Pod::Simple::XHTML->new;
$psx->output_string(\my $html);
$psx->parse_file('path/to/Module/Name.pm');
open my $out, '>', 'out.html' or die "Cannot open 'out.html': $!\n";
print $out $html;
You can also control the character encoding and entities. For example, if
you're sure that the POD is properly encoded (using the C<=encoding> command),
you can prevent high-bit characters from being encoded as HTML entities and
declare the output character set as UTF-8 before parsing, like so:
$psx->html_charset('UTF-8');
$psx->html_encode_chars('&<>">');
=cut
package Pod::Simple::XHTML;
use strict;
use vars qw( $VERSION @ISA $HAS_HTML_ENTITIES );
$VERSION = '3.26';
use Pod::Simple::Methody ();
@ISA = ('Pod::Simple::Methody');
BEGIN {
$HAS_HTML_ENTITIES = eval "require HTML::Entities; 1";
}
my %entities = (
q{>} => 'gt',
q{<} => 'lt',
q{'} => '#39',
q{"} => 'quot',
q{&} => 'amp',
);
sub encode_entities {
my $self = shift;
my $ents = $self->html_encode_chars;
return HTML::Entities::encode_entities( $_[0], $ents ) if $HAS_HTML_ENTITIES;
if (defined $ents) {
$ents =~ s,(?<!\\)([]/]),\\$1,g;
$ents =~ s,(?<!\\)\\\z,\\\\,;
} else {
$ents = join '', keys %entities;
}
my $str = $_[0];
$str =~ s/([$ents])/'&' . ($entities{$1} || sprintf '#x%X', ord $1) . ';'/ge;
return $str;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=head1 METHODS
Pod::Simple::XHTML offers a number of methods that modify the format of
the HTML output. Call these after creating the parser object, but before
the call to C<parse_file>:
my $parser = Pod::PseudoPod::HTML->new();
$parser->set_optional_param("value");
$parser->parse_file($file);
=head2 perldoc_url_prefix
In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what
to put before the "Foo%3a%3aBar". The default value is
"http://search.cpan.org/perldoc?".
=head2 perldoc_url_postfix
What to put after "Foo%3a%3aBar" in the URL. This option is not set by
default.
=head2 man_url_prefix
In turning C<< L<crontab(5)> >> into http://whatever/man/1/crontab, what
to put before the "1/crontab". The default value is
"http://man.he.net/man".
=head2 man_url_postfix
What to put after "1/crontab" in the URL. This option is not set by default.
=head2 title_prefix, title_postfix
What to put before and after the title in the head. The values should
already be &-escaped.
=head2 html_css
$parser->html_css('path/to/style.css');
The URL or relative path of a CSS file to include. This option is not
set by default.
=head2 html_javascript
The URL or relative path of a JavaScript file to pull in. This option is
not set by default.
=head2 html_doctype
A document type tag for the file. This option is not set by default.
=head2 html_charset
The charater set to declare in the Content-Type meta tag created by default
for C<html_header_tags>. Note that this option will be ignored if the value of
C<html_header_tags> is changed. Defaults to "ISO-8859-1".
=head2 html_header_tags
Additional arbitrary HTML tags for the header of the document. The
default value is just a content type header tag:
<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
Add additional meta tags here, or blocks of inline CSS or JavaScript
(wrapped in the appropriate tags).
=head3 html_encode_chars
A string containing all characters that should be encoded as HTML entities,
specified using the regular expression character class syntax (what you find
within brackets in regular expressions). This value will be passed as the
second argument to the C<encode_entities> function of L<HTML::Entities>. If
L<HTML::Entities> is not installed, then any characters other than C<&<>"'>
will be encoded numerically.
=head2 html_h_level
This is the level of HTML "Hn" element to which a Pod "head1" corresponds. For
example, if C<html_h_level> is set to 2, a head1 will produce an H2, a head2
will produce an H3, and so on.
=head2 default_title
Set a default title for the page if no title can be determined from the
content. The value of this string should already be &-escaped.
=head2 force_title
Force a title for the page (don't try to determine it from the content).
The value of this string should already be &-escaped.
=head2 html_header, html_footer
Set the HTML output at the beginning and end of each file. The default
header includes a title, a doctype tag (if C<html_doctype> is set), a
content tag (customized by C<html_header_tags>), a tag for a CSS file
(if C<html_css> is set), and a tag for a Javascript file (if
C<html_javascript> is set). The default footer simply closes the C<html>
and C<body> tags.
The options listed above customize parts of the default header, but
setting C<html_header> or C<html_footer> completely overrides the
built-in header or footer. These may be useful if you want to use
template tags instead of literal HTML headers and footers or are
integrating converted POD pages in a larger website.
If you want no headers or footers output in the HTML, set these options
to the empty string.
=head2 index
Whether to add a table-of-contents at the top of each page (called an
index for the sake of tradition).
=head2 anchor_items
Whether to anchor every definition C<=item> directive. This needs to be
enabled if you want to be able to link to specific C<=item> directives, which
are output as C<< <dt> >> elements. Disabled by default.
=head2 backlink
Whether to turn every =head1 directive into a link pointing to the top
of the page (specifically, the opening body tag).
=cut
__PACKAGE__->_accessorize(
'perldoc_url_prefix',
'perldoc_url_postfix',
'man_url_prefix',
'man_url_postfix',
'title_prefix', 'title_postfix',
'html_css',
'html_javascript',
'html_doctype',
'html_charset',
'html_encode_chars',
'html_h_level',
'title', # Used internally for the title extracted from the content
'default_title',
'force_title',
'html_header',
'html_footer',
'index',
'anchor_items',
'backlink',
'batch_mode', # whether we're in batch mode
'batch_mode_current_level',
# When in batch mode, how deep the current module is: 1 for "LWP",
# 2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc
);
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=head1 SUBCLASSING
If the standard options aren't enough, you may want to subclass
Pod::Simple::XHMTL. These are the most likely candidates for methods
you'll want to override when subclassing.
=cut
sub new {
my $self = shift;
my $new = $self->SUPER::new(@_);
$new->{'output_fh'} ||= *STDOUT{IO};
$new->perldoc_url_prefix('http://search.cpan.org/perldoc?');
$new->man_url_prefix('http://man.he.net/man');
$new->html_charset('ISO-8859-1');
$new->nix_X_codes(1);
$new->{'scratch'} = '';
$new->{'to_index'} = [];
$new->{'output'} = [];
$new->{'saved'} = [];
$new->{'ids'} = { '_podtop_' => 1 }; # used in <body>
$new->{'in_li'} = [];
$new->{'__region_targets'} = [];
$new->{'__literal_targets'} = {};
$new->accept_targets_as_html( 'html', 'HTML' );
return $new;
}
sub html_header_tags {
my $self = shift;
return $self->{html_header_tags} = shift if @_;
return $self->{html_header_tags}
||= '<meta http-equiv="Content-Type" content="text/html; charset='
. $self->html_charset . '" />';
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=head2 handle_text
This method handles the body of text within any element: it's the body
of a paragraph, or everything between a "=begin" tag and the
corresponding "=end" tag, or the text within an L entity, etc. You would
want to override this if you are adding a custom element type that does
more than just display formatted text. Perhaps adding a way to generate
HTML tables from an extended version of POD.
So, let's say you want to add a custom element called 'foo'. In your
subclass's C<new> method, after calling C<SUPER::new> you'd call:
$new->accept_targets_as_text( 'foo' );
Then override the C<start_for> method in the subclass to check for when
"$flags->{'target'}" is equal to 'foo' and set a flag that marks that
you're in a foo block (maybe "$self->{'in_foo'} = 1"). Then override the
C<handle_text> method to check for the flag, and pass $text to your
custom subroutine to construct the HTML output for 'foo' elements,
something like:
sub handle_text {
my ($self, $text) = @_;
if ($self->{'in_foo'}) {
$self->{'scratch'} .= build_foo_html($text);
return;
}
$self->SUPER::handle_text($text);
}
=head2 handle_code
This method handles the body of text that is marked up to be code.
You might for instance override this to plug in a syntax highlighter.
The base implementation just escapes the text.
The callback methods C<start_code> and C<end_code> emits the C<code> tags
before and after C<handle_code> is invoked, so you might want to override these
together with C<handle_code> if this wrapping isn't suiteable.
Note that the code might be broken into mulitple segments if there are
nested formatting codes inside a C<< CE<lt>...> >> sequence. In between the
calls to C<handle_code> other markup tags might have been emitted in that
case. The same is true for verbatim sections if the C<codes_in_verbatim>
option is turned on.
=head2 accept_targets_as_html
This method behaves like C<accept_targets_as_text>, but also marks the region
as one whose content should be emitted literally, without HTML entity escaping
or wrapping in a C<div> element.
=cut
sub __in_literal_xhtml_region {
return unless @{ $_[0]{__region_targets} };
my $target = $_[0]{__region_targets}[-1];
return $_[0]{__literal_targets}{ $target };
}
sub accept_targets_as_html {
my ($self, @targets) = @_;
$self->accept_targets(@targets);
$self->{__literal_targets}{$_} = 1 for @targets;
}
sub handle_text {
# escape special characters in HTML (<, >, &, etc)
my $text = $_[0]->__in_literal_xhtml_region
? $_[1]
: $_[0]->encode_entities( $_[1] );
if ($_[0]{'in_code'} && @{$_[0]{'in_code'}}) {
# Intentionally use the raw text in $_[1], even if we're not in a
# literal xhtml region, since handle_code calls encode_entities.
$_[0]->handle_code( $_[1], $_[0]{'in_code'}[-1] );
} else {
$_[0]{'scratch'} .= $text;
}
$_[0]{htext} .= $text if $_[0]{'in_head'};
}
sub start_code {
$_[0]{'scratch'} .= '<code>';
}
sub end_code {
$_[0]{'scratch'} .= '</code>';
}
sub handle_code {
$_[0]{'scratch'} .= $_[0]->encode_entities( $_[1] );
}
sub start_Para {
$_[0]{'scratch'} = '<p>';
}
sub start_Verbatim {
$_[0]{'scratch'} = '<pre>';
push(@{$_[0]{'in_code'}}, 'Verbatim');
$_[0]->start_code($_[0]{'in_code'}[-1]);
}
sub start_head1 { $_[0]{'in_head'} = 1; $_[0]{htext} = ''; }
sub start_head2 { $_[0]{'in_head'} = 2; $_[0]{htext} = ''; }
sub start_head3 { $_[0]{'in_head'} = 3; $_[0]{htext} = ''; }
sub start_head4 { $_[0]{'in_head'} = 4; $_[0]{htext} = ''; }
sub start_item_number {
$_[0]{'scratch'} = "</li>\n" if ($_[0]{'in_li'}->[-1] && pop @{$_[0]{'in_li'}});
$_[0]{'scratch'} .= '<li><p>';
push @{$_[0]{'in_li'}}, 1;
}
sub start_item_bullet {
$_[0]{'scratch'} = "</li>\n" if ($_[0]{'in_li'}->[-1] && pop @{$_[0]{'in_li'}});
$_[0]{'scratch'} .= '<li><p>';
push @{$_[0]{'in_li'}}, 1;
}
sub start_item_text {
# see end_item_text
}
sub start_over_bullet { $_[0]{'scratch'} = '<ul>'; push @{$_[0]{'in_li'}}, 0; $_[0]->emit }
sub start_over_block { $_[0]{'scratch'} = '<ul>'; $_[0]->emit }
sub start_over_number { $_[0]{'scratch'} = '<ol>'; push @{$_[0]{'in_li'}}, 0; $_[0]->emit }
sub start_over_text {
$_[0]{'scratch'} = '<dl>';
$_[0]{'dl_level'}++;
$_[0]{'in_dd'} ||= [];
$_[0]->emit
}
sub end_over_block { $_[0]{'scratch'} .= '</ul>'; $_[0]->emit }
sub end_over_number {
$_[0]{'scratch'} = "</li>\n" if ( pop @{$_[0]{'in_li'}} );
$_[0]{'scratch'} .= '</ol>';
pop @{$_[0]{'in_li'}};
$_[0]->emit;
}
sub end_over_bullet {
$_[0]{'scratch'} = "</li>\n" if ( pop @{$_[0]{'in_li'}} );
$_[0]{'scratch'} .= '</ul>';
pop @{$_[0]{'in_li'}};
$_[0]->emit;
}
sub end_over_text {
if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
$_[0]{'scratch'} = "</dd>\n";
$_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
}
$_[0]{'scratch'} .= '</dl>';
$_[0]{'dl_level'}--;
$_[0]->emit;
}
# . . . . . Now the actual formatters:
sub end_Para { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
sub end_Verbatim {
$_[0]->end_code(pop(@{$_[0]->{'in_code'}}));
$_[0]{'scratch'} .= '</pre>';
$_[0]->emit;
}
sub _end_head {
my $h = delete $_[0]{in_head};
my $add = $_[0]->html_h_level;
$add = 1 unless defined $add;
$h += $add - 1;
my $id = $_[0]->idify($_[0]{htext});
my $text = $_[0]{scratch};
$_[0]{'scratch'} = $_[0]->backlink && ($h - $add == 0)
# backlinks enabled && =head1
? qq{<a href="#_podtop_"><h$h id="$id">$text</h$h></a>}
: qq{<h$h id="$id">$text</h$h>};
$_[0]->emit;
push @{ $_[0]{'to_index'} }, [$h, $id, delete $_[0]{'htext'}];
}
sub end_head1 { shift->_end_head(@_); }
sub end_head2 { shift->_end_head(@_); }
sub end_head3 { shift->_end_head(@_); }
sub end_head4 { shift->_end_head(@_); }
sub end_item_bullet { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
sub end_item_number { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
sub end_item_text {
# idify and anchor =item content if wanted
my $dt_id = $_[0]{'anchor_items'}
? ' id="'. $_[0]->idify($_[0]{'scratch'}) .'"'
: '';
# reset scratch
my $text = $_[0]{scratch};
$_[0]{'scratch'} = '';
if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
$_[0]{'scratch'} = "</dd>\n";
$_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
}
$_[0]{'scratch'} .= qq{<dt$dt_id>$text</dt>\n<dd>};
$_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 1;
$_[0]->emit;
}
# This handles =begin and =for blocks of all kinds.
sub start_for {
my ($self, $flags) = @_;
push @{ $self->{__region_targets} }, $flags->{target_matching};
unless ($self->__in_literal_xhtml_region) {
$self->{scratch} .= '<div';
$self->{scratch} .= qq( class="$flags->{target}") if $flags->{target};
$self->{scratch} .= '>';
}
$self->emit;
}
sub end_for {
my ($self) = @_;
$self->{'scratch'} .= '</div>' unless $self->__in_literal_xhtml_region;
pop @{ $self->{__region_targets} };
$self->emit;
}
sub start_Document {
my ($self) = @_;
if (defined $self->html_header) {
$self->{'scratch'} .= $self->html_header;
$self->emit unless $self->html_header eq "";
} else {
my ($doctype, $title, $metatags, $bodyid);
$doctype = $self->html_doctype || '';
$title = $self->force_title || $self->title || $self->default_title || '';
$metatags = $self->html_header_tags || '';
if (my $css = $self->html_css) {
$metatags .= $css;
if ($css !~ /<link/) {
# this is required to be compatible with Pod::Simple::BatchHTML
$metatags .= '<link rel="stylesheet" href="'
. $self->encode_entities($css) . '" type="text/css" />';
}
}
if ($self->html_javascript) {
$metatags .= qq{\n<script type="text/javascript" src="} .
$self->html_javascript . "'></script>";
}
$bodyid = $self->backlink ? ' id="_podtop_"' : '';
$self->{'scratch'} .= <<"HTML";
$doctype
<html>
<head>
<title>$title</title>
$metatags
</head>
<body$bodyid>
HTML
$self->emit;
}
}
sub end_Document {
my ($self) = @_;
my $to_index = $self->{'to_index'};
if ($self->index && @{ $to_index } ) {
my @out;
my $level = 0;
my $indent = -1;
my $space = '';
my $id = ' id="index"';
for my $h (@{ $to_index }, [0]) {
my $target_level = $h->[0];
# Get to target_level by opening or closing ULs
if ($level == $target_level) {
$out[-1] .= '</li>';
} elsif ($level > $target_level) {
$out[-1] .= '</li>' if $out[-1] =~ /^\s+<li>/;
while ($level > $target_level) {
--$level;
push @out, (' ' x --$indent) . '</li>' if @out && $out[-1] =~ m{^\s+<\/ul};
push @out, (' ' x --$indent) . '</ul>';
}
push @out, (' ' x --$indent) . '</li>' if $level;
} else {
while ($level < $target_level) {
++$level;
push @out, (' ' x ++$indent) . '<li>' if @out && $out[-1]=~ /^\s*<ul/;
push @out, (' ' x ++$indent) . "<ul$id>";
$id = '';
}
++$indent;
}
next unless $level;
$space = ' ' x $indent;
push @out, sprintf '%s<li><a href="#%s">%s</a>',
$space, $h->[1], $h->[2];
}
# Splice the index in between the HTML headers and the first element.
my $offset = defined $self->html_header ? $self->html_header eq '' ? 0 : 1 : 1;
splice @{ $self->{'output'} }, $offset, 0, join "\n", @out;
}
if (defined $self->html_footer) {
$self->{'scratch'} .= $self->html_footer;
$self->emit unless $self->html_footer eq "";
} else {
$self->{'scratch'} .= "</body>\n</html>";
$self->emit;
}
if ($self->index) {
print {$self->{'output_fh'}} join ("\n\n", @{ $self->{'output'} }), "\n\n";
@{$self->{'output'}} = ();
}
}
# Handling code tags
sub start_B { $_[0]{'scratch'} .= '<b>' }
sub end_B { $_[0]{'scratch'} .= '</b>' }
sub start_C { push(@{$_[0]{'in_code'}}, 'C'); $_[0]->start_code($_[0]{'in_code'}[-1]); }
sub end_C { $_[0]->end_code(pop(@{$_[0]{'in_code'}})); }
sub start_F { $_[0]{'scratch'} .= '<i>' }
sub end_F { $_[0]{'scratch'} .= '</i>' }
sub start_I { $_[0]{'scratch'} .= '<i>' }
sub end_I { $_[0]{'scratch'} .= '</i>' }
sub start_L {
my ($self, $flags) = @_;
my ($type, $to, $section) = @{$flags}{'type', 'to', 'section'};
my $url = $self->encode_entities(
$type eq 'url' ? $to
: $type eq 'pod' ? $self->resolve_pod_page_link($to, $section)
: $type eq 'man' ? $self->resolve_man_page_link($to, $section)
: undef
);
# If it's an unknown type, use an attribute-less <a> like HTML.pm.
$self->{'scratch'} .= '<a' . ($url ? ' href="'. $url . '">' : '>');
}
sub end_L { $_[0]{'scratch'} .= '</a>' }
sub start_S { $_[0]{'scratch'} .= '<span style="white-space: nowrap;">' }
sub end_S { $_[0]{'scratch'} .= '</span>' }
sub emit {
my($self) = @_;
if ($self->index) {
push @{ $self->{'output'} }, $self->{'scratch'};
} else {
print {$self->{'output_fh'}} $self->{'scratch'}, "\n\n";
}
$self->{'scratch'} = '';
return;
}
=head2 resolve_pod_page_link
my $url = $pod->resolve_pod_page_link('Net::Ping', 'INSTALL');
my $url = $pod->resolve_pod_page_link('perlpodspec');
my $url = $pod->resolve_pod_page_link(undef, 'SYNOPSIS');
Resolves a POD link target (typically a module or POD file name) and section
name to a URL. The resulting link will be returned for the above examples as:
http://search.cpan.org/perldoc?Net::Ping#INSTALL
http://search.cpan.org/perldoc?perlpodspec
#SYNOPSIS
Note that when there is only a section argument the URL will simply be a link
to a section in the current document.
=cut
sub resolve_pod_page_link {
my ($self, $to, $section) = @_;
return undef unless defined $to || defined $section;
if (defined $section) {
$section = '#' . $self->idify($self->encode_entities($section), 1);
return $section unless defined $to;
} else {
$section = ''
}
return ($self->perldoc_url_prefix || '')
. $self->encode_entities($to) . $section
. ($self->perldoc_url_postfix || '');
}
=head2 resolve_man_page_link
my $url = $pod->resolve_man_page_link('crontab(5)', 'EXAMPLE CRON FILE');
my $url = $pod->resolve_man_page_link('crontab');
Resolves a man page link target and numeric section to a URL. The resulting
link will be returned for the above examples as:
http://man.he.net/man5/crontab
http://man.he.net/man1/crontab
Note that the first argument is required. The section number will be parsed
from it, and if it's missing will default to 1. The second argument is
currently ignored, as L<man.he.net|http://man.he.net> does not currently
include linkable IDs or anchor names in its pages. Subclass to link to a
different man page HTTP server.
=cut
sub resolve_man_page_link {
my ($self, $to, $section) = @_;
return undef unless defined $to;
my ($page, $part) = $to =~ /^([^(]+)(?:[(](\d+)[)])?$/;
return undef unless $page;
return ($self->man_url_prefix || '')
. ($part || 1) . "/" . $self->encode_entities($page)
. ($self->man_url_postfix || '');
}
=head2 idify
my $id = $pod->idify($text);
my $hash = $pod->idify($text, 1);
This method turns an arbitrary string into a valid XHTML ID attribute value.
The rules enforced, following
L<http://webdesign.about.com/od/htmltags/a/aa031707.htm>, are:
=over
=item *
The id must start with a letter (a-z or A-Z)
=item *
All subsequent characters can be letters, numbers (0-9), hyphens (-),
underscores (_), colons (:), and periods (.).
=item *
The final character can't be a hyphen, colon, or period. URLs ending with these
characters, while allowed by XHTML, can be awkward to extract from plain text.
=item *
Each id must be unique within the document.
=back
In addition, the returned value will be unique within the context of the
Pod::Simple::XHTML object unless a second argument is passed a true value. ID
attributes should always be unique within a single XHTML document, but pass
the true value if you are creating not an ID but a URL hash to point to
an ID (i.e., if you need to put the "#foo" in C<< <a href="#foo">foo</a> >>.
=cut
sub idify {
my ($self, $t, $not_unique) = @_;
for ($t) {
s/<[^>]+>//g; # Strip HTML.
s/&[^;]+;//g; # Strip entities.
s/^\s+//; s/\s+$//; # Strip white space.
s/^([^a-zA-Z]+)$/pod$1/; # Prepend "pod" if no valid chars.
s/^[^a-zA-Z]+//; # First char must be a letter.
s/[^-a-zA-Z0-9_:.]+/-/g; # All other chars must be valid.
s/[-:.]+$//; # Strip trailing punctuation.
}
return $t if $not_unique;
my $i = '';
$i++ while $self->{ids}{"$t$i"}++;
return "$t$i";
}
=head2 batch_mode_page_object_init
$pod->batch_mode_page_object_init($batchconvobj, $module, $infile, $outfile, $depth);
Called by L<Pod::Simple::HTMLBatch> so that the class has a chance to
initialize the converter. Internally it sets the C<batch_mode> property to
true and sets C<batch_mode_current_level()>, but Pod::Simple::XHTML does not
currently use those features. Subclasses might, though.
=cut
sub batch_mode_page_object_init {
my ($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_;
$self->batch_mode(1);
$self->batch_mode_current_level($depth);
return $self;
}
sub html_header_after_title {
}
1;
__END__
=head1 SEE ALSO
L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Spell>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2003-2005 Allison Randal.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 ACKNOWLEDGEMENTS
Thanks to L<Hurricane Electric|http://he.net/> for permission to use its
L<Linux man pages online|http://man.he.net/> site for man page links.
Thanks to L<search.cpan.org|http://search.cpan.org/> for permission to use the
site for Perl module links.
=head1 AUTHOR
Pod::Simpele::XHTML was created by Allison Randal <allison@perl.org>.
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_XHTML
$fatpacked{"Pod/Simple/XMLOutStream.pm"} = <<'POD_SIMPLE_XMLOUTSTREAM';
require 5;
package Pod::Simple::XMLOutStream;
use strict;
use Carp ();
use Pod::Simple ();
use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS);
$VERSION = '3.26';
BEGIN {
@ISA = ('Pod::Simple');
*DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG;
}
$ATTR_PAD = "\n" unless defined $ATTR_PAD;
# Don't mess with this unless you know what you're doing.
$SORT_ATTRS = 0 unless defined $SORT_ATTRS;
sub new {
my $self = shift;
my $new = $self->SUPER::new(@_);
$new->{'output_fh'} ||= *STDOUT{IO};
#$new->accept_codes('VerbatimFormatted');
return $new;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub _handle_element_start {
# ($self, $element_name, $attr_hash_r)
my $fh = $_[0]{'output_fh'};
my($key, $value);
DEBUG and print "++ $_[1]\n";
print $fh "<", $_[1];
if($SORT_ATTRS) {
foreach my $key (sort keys %{$_[2]}) {
unless($key =~ m/^~/s) {
next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
_xml_escape($value = $_[2]{$key});
print $fh $ATTR_PAD, $key, '="', $value, '"';
}
}
} else { # faster
while(($key,$value) = each %{$_[2]}) {
unless($key =~ m/^~/s) {
next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
_xml_escape($value);
print $fh $ATTR_PAD, $key, '="', $value, '"';
}
}
}
print $fh ">";
return;
}
sub _handle_text {
DEBUG and print "== \"$_[1]\"\n";
if(length $_[1]) {
my $text = $_[1];
_xml_escape($text);
print {$_[0]{'output_fh'}} $text;
}
return;
}
sub _handle_element_end {
DEBUG and print "-- $_[1]\n";
print {$_[0]{'output_fh'}} "</", $_[1], ">";
return;
}
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
sub _xml_escape {
foreach my $x (@_) {
# Escape things very cautiously:
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
# Yes, stipulate the list without a range, so that this can work right on
# all charsets that this module happens to run under.
# Altho, hmm, what about that ord? Presumably that won't work right
# under non-ASCII charsets. Something should be done about that.
}
return;
}
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
1;
__END__
=head1 NAME
Pod::Simple::XMLOutStream -- turn Pod into XML
=head1 SYNOPSIS
perl -MPod::Simple::XMLOutStream -e \
"exit Pod::Simple::XMLOutStream->filter(shift)->any_errata_seen" \
thingy.pod
=head1 DESCRIPTION
Pod::Simple::XMLOutStream is a subclass of L<Pod::Simple> that parses
Pod and turns it into XML.
Pod::Simple::XMLOutStream inherits methods from
L<Pod::Simple>.
=head1 SEE ALSO
L<Pod::Simple::DumpAsXML> is rather like this class; see its
documentation for a discussion of the differences.
L<Pod::Simple>, L<Pod::Simple::DumpAsXML>, L<Pod::SAX>
L<Pod::Simple::Subclassing>
The older (and possibly obsolete) libraries L<Pod::PXML>, L<Pod::XML>
=head1 ABOUT EXTENDING POD
TODO: An example or two of =extend, then point to Pod::Simple::Subclassing
=head1 ASK ME!
If you actually want to use Pod as a format that you want to render to
XML (particularly if to an XML instance with more elements than normal
Pod has), please email me (C<sburke@cpan.org>) and I'll probably have
some recommendations.
For reasons of concision and energetic laziness, some methods and
options in this module (and the dozen modules it depends on) are
undocumented; but one of those undocumented bits might be just what
you're looking for.
=head1 SEE ALSO
L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Spell>
=head1 SUPPORT
Questions or discussion about POD and Pod::Simple should be sent to the
pod-people@perl.org mail list. Send an empty email to
pod-people-subscribe@perl.org to subscribe.
This module is managed in an open GitHub repository,
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
to clone L<git://github.com/theory/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002-2004 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
But don't bother him, he's retired.
Pod::Simple is maintained by:
=over
=item * Allison Randal C<allison@perl.org>
=item * Hans Dieter Pearcey C<hdp@cpan.org>
=item * David E. Wheeler C<dwheeler@cpan.org>
=back
=cut
POD_SIMPLE_XMLOUTSTREAM
$fatpacked{"Pod/Text.pm"} = <<'POD_TEXT';
# Pod::Text -- Convert POD data to formatted ASCII text.
#
# This module converts POD to formatted text. It replaces the old Pod::Text
# module that came with versions of Perl prior to 5.6.0 and attempts to match
# its output except for some specific circumstances where other decisions
# seemed to produce better output. It uses Pod::Parser and is designed to be
# very easy to subclass.
#
# Perl core hackers, please note that this module is also separately
# maintained outside of the Perl core as part of the podlators. Please send
# me any patches at the address above in addition to sending them to the
# standard Perl mailing lists.
#
# Copyright 1999, 2000, 2001, 2002, 2004, 2006, 2008, 2009, 2012, 2013
# Russ Allbery <rra@stanford.edu>
#
# This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
##############################################################################
# Modules and declarations
##############################################################################
package Pod::Text;
require 5.004;
use strict;
use vars qw(@ISA @EXPORT %ESCAPES $VERSION);
use Carp qw(carp croak);
use Encode qw(encode);
use Exporter ();
use Pod::Simple ();
@ISA = qw(Pod::Simple Exporter);
# We have to export pod2text for backward compatibility.
@EXPORT = qw(pod2text);
$VERSION = '3.17';
##############################################################################
# Initialization
##############################################################################
# This function handles code blocks. It's registered as a callback to
# Pod::Simple and therefore doesn't work as a regular method call, but all it
# does is call output_code with the line.
sub handle_code {
my ($line, $number, $parser) = @_;
$parser->output_code ($line . "\n");
}
# Initialize the object and set various Pod::Simple options that we need.
# Here, we also process any additional options passed to the constructor or
# set up defaults if none were given. Note that all internal object keys are
# in all-caps, reserving all lower-case object keys for Pod::Simple and user
# arguments.
sub new {
my $class = shift;
my $self = $class->SUPER::new;
# Tell Pod::Simple to handle S<> by automatically inserting .
$self->nbsp_for_S (1);
# Tell Pod::Simple to keep whitespace whenever possible.
if ($self->can ('preserve_whitespace')) {
$self->preserve_whitespace (1);
} else {
$self->fullstop_space_harden (1);
}
# The =for and =begin targets that we accept.
$self->accept_targets (qw/text TEXT/);
# Ensure that contiguous blocks of code are merged together. Otherwise,
# some of the guesswork heuristics don't work right.
$self->merge_text (1);
# Pod::Simple doesn't do anything useful with our arguments, but we want
# to put them in our object as hash keys and values. This could cause
# problems if we ever clash with Pod::Simple's own internal class
# variables.
my %opts = @_;
my @opts = map { ("opt_$_", $opts{$_}) } keys %opts;
%$self = (%$self, @opts);
# Send errors to stderr if requested.
if ($$self{opt_stderr} and not $$self{opt_errors}) {
$$self{opt_errors} = 'stderr';
}
delete $$self{opt_stderr};
# Validate the errors parameter and act on it.
if (not defined $$self{opt_errors}) {
$$self{opt_errors} = 'pod';
}
if ($$self{opt_errors} eq 'stderr' || $$self{opt_errors} eq 'die') {
$self->no_errata_section (1);
$self->complain_stderr (1);
if ($$self{opt_errors} eq 'die') {
$$self{complain_die} = 1;
}
} elsif ($$self{opt_errors} eq 'pod') {
$self->no_errata_section (0);
$self->complain_stderr (0);
} elsif ($$self{opt_errors} eq 'none') {
$self->no_whining (1);
} else {
croak (qq(Invalid errors setting: "$$self{errors}"));
}
delete $$self{errors};
# Initialize various things from our parameters.
$$self{opt_alt} = 0 unless defined $$self{opt_alt};
$$self{opt_indent} = 4 unless defined $$self{opt_indent};
$$self{opt_margin} = 0 unless defined $$self{opt_margin};
$$self{opt_loose} = 0 unless defined $$self{opt_loose};
$$self{opt_sentence} = 0 unless defined $$self{opt_sentence};
$$self{opt_width} = 76 unless defined $$self{opt_width};
# Figure out what quotes we'll be using for C<> text.
$$self{opt_quotes} ||= '"';
if ($$self{opt_quotes} eq 'none') {
$$self{LQUOTE} = $$self{RQUOTE} = '';
} elsif (length ($$self{opt_quotes}) == 1) {
$$self{LQUOTE} = $$self{RQUOTE} = $$self{opt_quotes};
} elsif ($$self{opt_quotes} =~ /^(.)(.)$/
|| $$self{opt_quotes} =~ /^(..)(..)$/) {
$$self{LQUOTE} = $1;
$$self{RQUOTE} = $2;
} else {
croak qq(Invalid quote specification "$$self{opt_quotes}");
}
# If requested, do something with the non-POD text.
$self->code_handler (\&handle_code) if $$self{opt_code};
# Return the created object.
return $self;
}
##############################################################################
# Core parsing
##############################################################################
# This is the glue that connects the code below with Pod::Simple itself. The
# goal is to convert the event stream coming from the POD parser into method
# calls to handlers once the complete content of a tag has been seen. Each
# paragraph or POD command will have textual content associated with it, and
# as soon as all of a paragraph or POD command has been seen, that content
# will be passed in to the corresponding method for handling that type of
# object. The exceptions are handlers for lists, which have opening tag
# handlers and closing tag handlers that will be called right away.
#
# The internal hash key PENDING is used to store the contents of a tag until
# all of it has been seen. It holds a stack of open tags, each one
# represented by a tuple of the attributes hash for the tag and the contents
# of the tag.
# Add a block of text to the contents of the current node, formatting it
# according to the current formatting instructions as we do.
sub _handle_text {
my ($self, $text) = @_;
my $tag = $$self{PENDING}[-1];
$$tag[1] .= $text;
}
# Given an element name, get the corresponding method name.
sub method_for_element {
my ($self, $element) = @_;
$element =~ tr/-/_/;
$element =~ tr/A-Z/a-z/;
$element =~ tr/_a-z0-9//cd;
return $element;
}
# Handle the start of a new element. If cmd_element is defined, assume that
# we need to collect the entire tree for this element before passing it to the
# element method, and create a new tree into which we'll collect blocks of
# text and nested elements. Otherwise, if start_element is defined, call it.
sub _handle_element_start {
my ($self, $element, $attrs) = @_;
my $method = $self->method_for_element ($element);
# If we have a command handler, we need to accumulate the contents of the
# tag before calling it.
if ($self->can ("cmd_$method")) {
push (@{ $$self{PENDING} }, [ $attrs, '' ]);
} elsif ($self->can ("start_$method")) {
my $method = 'start_' . $method;
$self->$method ($attrs, '');
}
}
# Handle the end of an element. If we had a cmd_ method for this element,
# this is where we pass along the text that we've accumulated. Otherwise, if
# we have an end_ method for the element, call that.
sub _handle_element_end {
my ($self, $element) = @_;
my $method = $self->method_for_element ($element);
# If we have a command handler, pull off the pending text and pass it to
# the handler along with the saved attribute hash.
if ($self->can ("cmd_$method")) {
my $tag = pop @{ $$self{PENDING} };
my $method = 'cmd_' . $method;
my $text = $self->$method (@$tag);
if (defined $text) {
if (@{ $$self{PENDING} } > 1) {
$$self{PENDING}[-1][1] .= $text;
} else {
$self->output ($text);
}
}
} elsif ($self->can ("end_$method")) {
my $method = 'end_' . $method;
$self->$method ();
}
}
##############################################################################
# Output formatting
##############################################################################
# Wrap a line, indenting by the current left margin. We can't use Text::Wrap
# because it plays games with tabs. We can't use formline, even though we'd
# really like to, because it screws up non-printing characters. So we have to
# do the wrapping ourselves.
sub wrap {
my $self = shift;
local $_ = shift;
my $output = '';
my $spaces = ' ' x $$self{MARGIN};
my $width = $$self{opt_width} - $$self{MARGIN};
while (length > $width) {
if (s/^([^\n]{0,$width})\s+// || s/^([^\n]{$width})//) {
$output .= $spaces . $1 . "\n";
} else {
last;
}
}
$output .= $spaces . $_;
$output =~ s/\s+$/\n\n/;
return $output;
}
# Reformat a paragraph of text for the current margin. Takes the text to
# reformat and returns the formatted text.
sub reformat {
my $self = shift;
local $_ = shift;
# If we're trying to preserve two spaces after sentences, do some munging
# to support that. Otherwise, smash all repeated whitespace.
if ($$self{opt_sentence}) {
s/ +$//mg;
s/\.\n/. \n/g;
s/\n/ /g;
s/ +/ /g;
} else {
s/\s+/ /g;
}
return $self->wrap ($_);
}
# Output text to the output device. Replace non-breaking spaces with spaces
# and soft hyphens with nothing, and then try to fix the output encoding if
# necessary to match the input encoding unless UTF-8 output is forced. This
# preserves the traditional pass-through behavior of Pod::Text.
sub output {
my ($self, @text) = @_;
my $text = join ('', @text);
$text =~ tr/\240\255/ /d;
unless ($$self{opt_utf8} || $$self{CHECKED_ENCODING}) {
my $encoding = $$self{encoding} || '';
if ($encoding) {
eval { binmode ($$self{output_fh}, ":encoding($encoding)") };
}
$$self{CHECKED_ENCODING} = 1;
}
if ($$self{ENCODE}) {
print { $$self{output_fh} } encode ('UTF-8', $text);
} else {
print { $$self{output_fh} } $text;
}
}
# Output a block of code (something that isn't part of the POD text). Called
# by preprocess_paragraph only if we were given the code option. Exists here
# only so that it can be overridden by subclasses.
sub output_code { $_[0]->output ($_[1]) }
##############################################################################
# Document initialization
##############################################################################
# Set up various things that have to be initialized on a per-document basis.
sub start_document {
my ($self, $attrs) = @_;
if ($$attrs{contentless} && !$$self{ALWAYS_EMIT_SOMETHING}) {
$$self{CONTENTLESS} = 1;
return;
} else {
delete $$self{CONTENTLESS};
}
my $margin = $$self{opt_indent} + $$self{opt_margin};
# Initialize a few per-document variables.
$$self{INDENTS} = []; # Stack of indentations.
$$self{MARGIN} = $margin; # Default left margin.
$$self{PENDING} = [[]]; # Pending output.
# We have to redo encoding handling for each document.
delete $$self{CHECKED_ENCODING};
# When UTF-8 output is set, check whether our output file handle already
# has a PerlIO encoding layer set. If it does not, we'll need to encode
# our output before printing it (handled in the output() sub). Wrap the
# check in an eval to handle versions of Perl without PerlIO.
$$self{ENCODE} = 0;
if ($$self{opt_utf8}) {
$$self{ENCODE} = 1;
eval {
my @options = (output => 1, details => 1);
my $flag = (PerlIO::get_layers ($$self{output_fh}, @options))[-1];
if ($flag & PerlIO::F_UTF8 ()) {
$$self{ENCODE} = 0;
}
};
}
return '';
}
# Handle the end of the document. The only thing we do is handle dying on POD
# errors, since Pod::Parser currently doesn't.
sub end_document {
my ($self) = @_;
if ($$self{complain_die} && $self->errors_seen) {
croak ("POD document had syntax errors");
}
}
##############################################################################
# Text blocks
##############################################################################
# Intended for subclasses to override, this method returns text with any
# non-printing formatting codes stripped out so that length() correctly
# returns the length of the text. For basic Pod::Text, it does nothing.
sub strip_format {
my ($self, $string) = @_;
return $string;
}
# This method is called whenever an =item command is complete (in other words,
# we've seen its associated paragraph or know for certain that it doesn't have
# one). It gets the paragraph associated with the item as an argument. If
# that argument is empty, just output the item tag; if it contains a newline,
# output the item tag followed by the newline. Otherwise, see if there's
# enough room for us to output the item tag in the margin of the text or if we
# have to put it on a separate line.
sub item {
my ($self, $text) = @_;
my $tag = $$self{ITEM};
unless (defined $tag) {
carp "Item called without tag";
return;
}
undef $$self{ITEM};
# Calculate the indentation and margin. $fits is set to true if the tag
# will fit into the margin of the paragraph given our indentation level.
my $indent = $$self{INDENTS}[-1];
$indent = $$self{opt_indent} unless defined $indent;
my $margin = ' ' x $$self{opt_margin};
my $tag_length = length ($self->strip_format ($tag));
my $fits = ($$self{MARGIN} - $indent >= $tag_length + 1);
# If the tag doesn't fit, or if we have no associated text, print out the
# tag separately. Otherwise, put the tag in the margin of the paragraph.
if (!$text || $text =~ /^\s+$/ || !$fits) {
my $realindent = $$self{MARGIN};
$$self{MARGIN} = $indent;
my $output = $self->reformat ($tag);
$output =~ s/^$margin /$margin:/ if ($$self{opt_alt} && $indent > 0);
$output =~ s/\n*$/\n/;
# If the text is just whitespace, we have an empty item paragraph;
# this can result from =over/=item/=back without any intermixed
# paragraphs. Insert some whitespace to keep the =item from merging
# into the next paragraph.
$output .= "\n" if $text && $text =~ /^\s*$/;
$self->output ($output);
$$self{MARGIN} = $realindent;
$self->output ($self->reformat ($text)) if ($text && $text =~ /\S/);
} else {
my $space = ' ' x $indent;
$space =~ s/^$margin /$margin:/ if $$self{opt_alt};
$text = $self->reformat ($text);
$text =~ s/^$margin /$margin:/ if ($$self{opt_alt} && $indent > 0);
my $tagspace = ' ' x $tag_length;
$text =~ s/^($space)$tagspace/$1$tag/ or warn "Bizarre space in item";
$self->output ($text);
}
}
# Handle a basic block of text. The only tricky thing here is that if there
# is a pending item tag, we need to format this as an item paragraph.
sub cmd_para {
my ($self, $attrs, $text) = @_;
$text =~ s/\s+$/\n/;
if (defined $$self{ITEM}) {
$self->item ($text . "\n");
} else {
$self->output ($self->reformat ($text . "\n"));
}
return '';
}
# Handle a verbatim paragraph. Just print it out, but indent it according to
# our margin.
sub cmd_verbatim {
my ($self, $attrs, $text) = @_;
$self->item if defined $$self{ITEM};
return if $text =~ /^\s*$/;
$text =~ s/^(\n*)([ \t]*\S+)/$1 . (' ' x $$self{MARGIN}) . $2/gme;
$text =~ s/\s*$/\n\n/;
$self->output ($text);
return '';
}
# Handle literal text (produced by =for and similar constructs). Just output
# it with the minimum of changes.
sub cmd_data {
my ($self, $attrs, $text) = @_;
$text =~ s/^\n+//;
$text =~ s/\n{0,2}$/\n/;
$self->output ($text);
return '';
}
##############################################################################
# Headings
##############################################################################
# The common code for handling all headers. Takes the header text, the
# indentation, and the surrounding marker for the alt formatting method.
sub heading {
my ($self, $text, $indent, $marker) = @_;
$self->item ("\n\n") if defined $$self{ITEM};
$text =~ s/\s+$//;
if ($$self{opt_alt}) {
my $closemark = reverse (split (//, $marker));
my $margin = ' ' x $$self{opt_margin};
$self->output ("\n" . "$margin$marker $text $closemark" . "\n\n");
} else {
$text .= "\n" if $$self{opt_loose};
my $margin = ' ' x ($$self{opt_margin} + $indent);
$self->output ($margin . $text . "\n");
}
return '';
}
# First level heading.
sub cmd_head1 {
my ($self, $attrs, $text) = @_;
$self->heading ($text, 0, '====');
}
# Second level heading.
sub cmd_head2 {
my ($self, $attrs, $text) = @_;
$self->heading ($text, $$self{opt_indent} / 2, '== ');
}
# Third level heading.
sub cmd_head3 {
my ($self, $attrs, $text) = @_;
$self->heading ($text, $$self{opt_indent} * 2 / 3 + 0.5, '= ');
}
# Fourth level heading.
sub cmd_head4 {
my ($self, $attrs, $text) = @_;
$self->heading ($text, $$self{opt_indent} * 3 / 4 + 0.5, '- ');
}
##############################################################################
# List handling
##############################################################################
# Handle the beginning of an =over block. Takes the type of the block as the
# first argument, and then the attr hash. This is called by the handlers for
# the four different types of lists (bullet, number, text, and block).
sub over_common_start {
my ($self, $attrs) = @_;
$self->item ("\n\n") if defined $$self{ITEM};
# Find the indentation level.
my $indent = $$attrs{indent};
unless (defined ($indent) && $indent =~ /^\s*[-+]?\d{1,4}\s*$/) {
$indent = $$self{opt_indent};
}
# Add this to our stack of indents and increase our current margin.
push (@{ $$self{INDENTS} }, $$self{MARGIN});
$$self{MARGIN} += ($indent + 0);
return '';
}
# End an =over block. Takes no options other than the class pointer. Output
# any pending items and then pop one level of indentation.
sub over_common_end {
my ($self) = @_;
$self->item ("\n\n") if defined $$self{ITEM};
$$self{MARGIN} = pop @{ $$self{INDENTS} };
return '';
}
# Dispatch the start and end calls as appropriate.
sub start_over_bullet { $_[0]->over_common_start ($_[1]) }
sub start_over_number { $_[0]->over_common_start ($_[1]) }
sub start_over_text { $_[0]->over_common_start ($_[1]) }
sub start_over_block { $_[0]->over_common_start ($_[1]) }
sub end_over_bullet { $_[0]->over_common_end }
sub end_over_number { $_[0]->over_common_end }
sub end_over_text { $_[0]->over_common_end }
sub end_over_block { $_[0]->over_common_end }
# The common handler for all item commands. Takes the type of the item, the
# attributes, and then the text of the item.
sub item_common {
my ($self, $type, $attrs, $text) = @_;
$self->item if defined $$self{ITEM};
# Clean up the text. We want to end up with two variables, one ($text)
# which contains any body text after taking out the item portion, and
# another ($item) which contains the actual item text. Note the use of
# the internal Pod::Simple attribute here; that's a potential land mine.
$text =~ s/\s+$//;
my ($item, $index);
if ($type eq 'bullet') {
$item = '*';
} elsif ($type eq 'number') {
$item = $$attrs{'~orig_content'};
} else {
$item = $text;
$item =~ s/\s*\n\s*/ /g;
$text = '';
}
$$self{ITEM} = $item;
# If body text for this item was included, go ahead and output that now.
if ($text) {
$text =~ s/\s*$/\n/;
$self->item ($text);
}
return '';
}
# Dispatch the item commands to the appropriate place.
sub cmd_item_bullet { my $self = shift; $self->item_common ('bullet', @_) }
sub cmd_item_number { my $self = shift; $self->item_common ('number', @_) }
sub cmd_item_text { my $self = shift; $self->item_common ('text', @_) }
sub cmd_item_block { my $self = shift; $self->item_common ('block', @_) }
##############################################################################
# Formatting codes
##############################################################################
# The simple ones.
sub cmd_b { return $_[0]{alt} ? "``$_[2]''" : $_[2] }
sub cmd_f { return $_[0]{alt} ? "\"$_[2]\"" : $_[2] }
sub cmd_i { return '*' . $_[2] . '*' }
sub cmd_x { return '' }
# Apply a whole bunch of messy heuristics to not quote things that don't
# benefit from being quoted. These originally come from Barrie Slaymaker and
# largely duplicate code in Pod::Man.
sub cmd_c {
my ($self, $attrs, $text) = @_;
# A regex that matches the portion of a variable reference that's the
# array or hash index, separated out just because we want to use it in
# several places in the following regex.
my $index = '(?: \[.*\] | \{.*\} )?';
# Check for things that we don't want to quote, and if we find any of
# them, return the string with just a font change and no quoting.
$text =~ m{
^\s*
(?:
( [\'\`\"] ) .* \1 # already quoted
| \` .* \' # `quoted'
| \$+ [\#^]? \S $index # special ($^Foo, $")
| [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func
| [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call
| [+-]? ( \d[\d.]* | \.\d+ ) (?: [eE][+-]?\d+ )? # a number
| 0x [a-fA-F\d]+ # a hex constant
)
\s*\z
}xo && return $text;
# If we didn't return, go ahead and quote the text.
return $$self{opt_alt}
? "``$text''"
: "$$self{LQUOTE}$text$$self{RQUOTE}";
}
# Links reduce to the text that we're given, wrapped in angle brackets if it's
# a URL.
sub cmd_l {
my ($self, $attrs, $text) = @_;
if ($$attrs{type} eq 'url') {
if (not defined($$attrs{to}) or $$attrs{to} eq $text) {
return "<$text>";
} elsif ($$self{opt_nourls}) {
return $text;
} else {
return "$text <$$attrs{to}>";
}
} else {
return $text;
}
}
##############################################################################
# Backwards compatibility
##############################################################################
# The old Pod::Text module did everything in a pod2text() function. This
# tries to provide the same interface for legacy applications.
sub pod2text {
my @args;
# This is really ugly; I hate doing option parsing in the middle of a
# module. But the old Pod::Text module supported passing flags to its
# entry function, so handle -a and -<number>.
while ($_[0] =~ /^-/) {
my $flag = shift;
if ($flag eq '-a') { push (@args, alt => 1) }
elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) }
else {
unshift (@_, $flag);
last;
}
}
# Now that we know what arguments we're using, create the parser.
my $parser = Pod::Text->new (@args);
# If two arguments were given, the second argument is going to be a file
# handle. That means we want to call parse_from_filehandle(), which means
# we need to turn the first argument into a file handle. Magic open will
# handle the <&STDIN case automagically.
if (defined $_[1]) {
my @fhs = @_;
local *IN;
unless (open (IN, $fhs[0])) {
croak ("Can't open $fhs[0] for reading: $!\n");
return;
}
$fhs[0] = \*IN;
$parser->output_fh ($fhs[1]);
my $retval = $parser->parse_file ($fhs[0]);
my $fh = $parser->output_fh ();
close $fh;
return $retval;
} else {
$parser->output_fh (\*STDOUT);
return $parser->parse_file (@_);
}
}
# Reset the underlying Pod::Simple object between calls to parse_from_file so
# that the same object can be reused to convert multiple pages.
sub parse_from_file {
my $self = shift;
$self->reinit;
# Fake the old cutting option to Pod::Parser. This fiddings with internal
# Pod::Simple state and is quite ugly; we need a better approach.
if (ref ($_[0]) eq 'HASH') {
my $opts = shift @_;
if (defined ($$opts{-cutting}) && !$$opts{-cutting}) {
$$self{in_pod} = 1;
$$self{last_was_blank} = 1;
}
}
# Do the work.
my $retval = $self->Pod::Simple::parse_from_file (@_);
# Flush output, since Pod::Simple doesn't do this. Ideally we should also
# close the file descriptor if we had to open one, but we can't easily
# figure this out.
my $fh = $self->output_fh ();
my $oldfh = select $fh;
my $oldflush = $|;
$| = 1;
print $fh '';
$| = $oldflush;
select $oldfh;
return $retval;
}
# Pod::Simple failed to provide this backward compatibility function, so
# implement it ourselves. File handles are one of the inputs that
# parse_from_file supports.
sub parse_from_filehandle {
my $self = shift;
$self->parse_from_file (@_);
}
# Pod::Simple's parse_file doesn't set output_fh. Wrap the call and do so
# ourself unless it was already set by the caller, since our documentation has
# always said that this should work.
sub parse_file {
my ($self, $in) = @_;
unless (defined $$self{output_fh}) {
$self->output_fh (\*STDOUT);
}
return $self->SUPER::parse_file ($in);
}
##############################################################################
# Module return value and documentation
##############################################################################
1;
__END__
=for stopwords
alt stderr Allbery Sean Burke's Christiansen UTF-8 pre-Unicode utf8 nourls
=head1 NAME
Pod::Text - Convert POD data to formatted ASCII text
=head1 SYNOPSIS
use Pod::Text;
my $parser = Pod::Text->new (sentence => 0, width => 78);
# Read POD from STDIN and write to STDOUT.
$parser->parse_from_filehandle;
# Read POD from file.pod and write to file.txt.
$parser->parse_from_file ('file.pod', 'file.txt');
=head1 DESCRIPTION
Pod::Text is a module that can convert documentation in the POD format (the
preferred language for documenting Perl) into formatted ASCII. It uses no
special formatting controls or codes whatsoever, and its output is therefore
suitable for nearly any device.
As a derived class from Pod::Simple, Pod::Text supports the same methods and
interfaces. See L<Pod::Simple> for all the details; briefly, one creates a
new parser with C<< Pod::Text->new() >> and then normally calls parse_file().
new() can take options, in the form of key/value pairs, that control the
behavior of the parser. The currently recognized options are:
=over 4
=item alt
If set to a true value, selects 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. Defaults to false.
=item code
If set to a true value, the non-POD parts of the input file will be included
in the output. Useful for viewing code documented with POD blocks with the
POD rendered and the code left intact.
=item errors
How to report errors. 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<output>.
=item indent
The number of spaces to indent regular text, and the default indentation for
C<=over> blocks. Defaults to 4.
=item loose
If set to a true value, a blank line is printed after a C<=head1> heading.
If set to false (the default), no blank line is printed after C<=head1>,
although one is still printed after C<=head2>. This is the default because
it's the expected formatting for manual pages; if you're formatting
arbitrary text documents, setting this to true may result in more pleasing
output.
=item margin
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 the I<indent> option. To set the right
margin, see the I<width> option.
=item 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 option, if set to a true value, 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 quotes
Sets the quote marks used to surround CE<lt>> text. If the value is a
single character, it is used as both the left and right quote; if it is two
characters, the first character is used as the left quote and the second as
the right quoted; and if it is four characters, the first two are used as
the left quote and the second two as the right quote.
This may also be set to the special value C<none>, in which case no quote
marks are added around CE<lt>> text.
=item sentence
If set to a true value, Pod::Text will assume that each sentence ends in two
spaces, and will try to preserve that spacing. If set to false, all
consecutive whitespace in non-verbatim paragraphs is compressed into a
single space. Defaults to true.
=item stderr
Send error messages about invalid POD to standard error instead of
appending a POD ERRORS section to the generated output. This is
equivalent to setting C<errors> to C<stderr> if C<errors> is not already
set. It is supported for backward compatibility.
=item utf8
By default, Pod::Text uses the same output encoding as the input encoding
of the POD source (provided that Perl was built with PerlIO; otherwise, it
doesn't encode its output). If this option is given, the output encoding
is forced to UTF-8.
Be aware that, when using this option, the input encoding of your POD
source must be properly declared unless it is US-ASCII or Latin-1. POD
input without an C<=encoding> command will be assumed to be in Latin-1,
and if it's actually in UTF-8, the output will be double-encoded. See
L<perlpod(1)> for more information on the C<=encoding> command.
=item width
The column at which to wrap text on the right-hand side. Defaults to 76.
=back
The standard Pod::Simple method parse_file() takes one argument, the file or
file handle to read from, and writes output to standard output unless that
has been changed with the output_fh() method. See L<Pod::Simple> for the
specific details and for other alternative interfaces.
=head1 DIAGNOSTICS
=over 4
=item Bizarre space in item
=item Item called without tag
(W) Something has gone wrong in internal C<=item> processing. These
messages indicate a bug in Pod::Text; you should never see them.
=item Can't open %s for reading: %s
(F) Pod::Text was invoked via the compatibility mode pod2text() interface
and the input file it was given could not be opened.
=item Invalid errors setting "%s"
(F) The C<errors> parameter to the constructor was set to an unknown value.
=item Invalid quote specification "%s"
(F) The quote specification given (the C<quotes> option to the
constructor) was invalid. A quote specification must be one, two, or four
characters long.
=item POD document had syntax errors
(F) The POD document being formatted had syntax errors and the C<errors>
option was set to C<die>.
=back
=head1 BUGS
Encoding handling assumes that PerlIO is available and does not work
properly if it isn't. The C<utf8> option is therefore not supported
unless Perl is built with PerlIO support.
=head1 CAVEATS
If Pod::Text is given the C<utf8> option, the encoding of its output file
handle will be forced to UTF-8 if possible, overriding any existing
encoding. This will be done even if the file handle is not created by
Pod::Text and was passed in from outside. This maintains consistency
regardless of PERL_UNICODE and other settings.
If the C<utf8> option is not given, the encoding of its output file handle
will be forced to the detected encoding of the input POD, which preserves
whatever the input text is. This ensures backward compatibility with
earlier, pre-Unicode versions of this module, without large numbers of
Perl warnings.
This is not ideal, but it seems to be the best compromise. If it doesn't
work for you, please let me know the details of how it broke.
=head1 NOTES
This is a replacement for an earlier Pod::Text module written by Tom
Christiansen. It has a revamped interface, since it now uses Pod::Simple,
but an interface roughly compatible with the old Pod::Text::pod2text()
function is still available. Please change to the new calling convention,
though.
The original Pod::Text contained code to do formatting via termcap
sequences, although it wasn't turned on by default and it was problematic to
get it to work at all. This rewrite doesn't even try to do that, but a
subclass of it does. Look for L<Pod::Text::Termcap>.
=head1 SEE ALSO
L<Pod::Simple>, L<Pod::Text::Termcap>, L<perlpod(1)>, L<pod2text(1)>
The current version of this module is always available from its web site at
L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
Perl core distribution as of 5.6.0.
=head1 AUTHOR
Russ Allbery <rra@stanford.edu>, based I<very> heavily on the original
Pod::Text by Tom Christiansen <tchrist@mox.perl.com> and its conversion to
Pod::Parser by Brad Appleton <bradapp@enteract.com>. Sean Burke's initial
conversion of Pod::Man to use Pod::Simple provided much-needed guidance on
how to use Pod::Simple.
=head1 COPYRIGHT AND LICENSE
Copyright 1999, 2000, 2001, 2002, 2004, 2006, 2008, 2009, 2012, 2013 Russ
Allbery <rra@stanford.edu>.
This program is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.
=cut
POD_TEXT
$fatpacked{"Pod/Text/Color.pm"} = <<'POD_TEXT_COLOR';
# Pod::Text::Color -- Convert POD data to formatted color ASCII text
#
# This is just a basic proof of concept. It should later be modified to make
# better use of color, take options changing what colors are used for what
# text, and the like.
#
# Copyright 1999, 2001, 2004, 2006, 2008, 2009 Russ Allbery <rra@stanford.edu>
#
# This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
##############################################################################
# Modules and declarations
##############################################################################
package Pod::Text::Color;
require 5.004;
use Pod::Text ();
use Term::ANSIColor qw(colored);
use strict;
use vars qw(@ISA $VERSION);
@ISA = qw(Pod::Text);
$VERSION = '2.07';
##############################################################################
# Overrides
##############################################################################
# Make level one headings bold.
sub cmd_head1 {
my ($self, $attrs, $text) = @_;
$text =~ s/\s+$//;
$self->SUPER::cmd_head1 ($attrs, colored ($text, 'bold'));
}
# Make level two headings bold.
sub cmd_head2 {
my ($self, $attrs, $text) = @_;
$text =~ s/\s+$//;
$self->SUPER::cmd_head2 ($attrs, colored ($text, 'bold'));
}
# Fix the various formatting codes.
sub cmd_b { return colored ($_[2], 'bold') }
sub cmd_f { return colored ($_[2], 'cyan') }
sub cmd_i { return colored ($_[2], 'yellow') }
# Output any included code in green.
sub output_code {
my ($self, $code) = @_;
$code = colored ($code, 'green');
$self->output ($code);
}
# Strip all of the formatting from a provided string, returning the stripped
# version. We will eventually want to use colorstrip() from Term::ANSIColor,
# but it's fairly new so avoid the tight dependency.
sub strip_format {
my ($self, $text) = @_;
$text =~ s/\e\[[\d;]*m//g;
return $text;
}
# We unfortunately have to override the wrapping code here, since the normal
# wrapping code gets really confused by all the escape sequences.
sub wrap {
my $self = shift;
local $_ = shift;
my $output = '';
my $spaces = ' ' x $$self{MARGIN};
my $width = $$self{opt_width} - $$self{MARGIN};
# We have to do $shortchar and $longchar in variables because the
# construct ${char}{0,$width} didn't do the right thing until Perl 5.8.x.
my $char = '(?:(?:\e\[[\d;]+m)*[^\n])';
my $shortchar = $char . "{0,$width}";
my $longchar = $char . "{$width}";
while (length > $width) {
if (s/^($shortchar)\s+// || s/^($longchar)//) {
$output .= $spaces . $1 . "\n";
} else {
last;
}
}
$output .= $spaces . $_;
$output =~ s/\s+$/\n\n/;
$output;
}
##############################################################################
# Module return value and documentation
##############################################################################
1;
__END__
=head1 NAME
Pod::Text::Color - Convert POD data to formatted color ASCII text
=for stopwords
Allbery
=head1 SYNOPSIS
use Pod::Text::Color;
my $parser = Pod::Text::Color->new (sentence => 0, width => 78);
# Read POD from STDIN and write to STDOUT.
$parser->parse_from_filehandle;
# Read POD from file.pod and write to file.txt.
$parser->parse_from_file ('file.pod', 'file.txt');
=head1 DESCRIPTION
Pod::Text::Color is a simple subclass of Pod::Text that highlights output
text using ANSI color escape sequences. Apart from the color, it in all
ways functions like Pod::Text. See L<Pod::Text> for details and available
options.
Term::ANSIColor is used to get colors and therefore must be installed to use
this module.
=head1 BUGS
This is just a basic proof of concept. It should be seriously expanded to
support configurable coloration via options passed to the constructor, and
B<pod2text> should be taught about those.
=head1 SEE ALSO
L<Pod::Text>, L<Pod::Simple>
The current version of this module is always available from its web site at
L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
Perl core distribution as of 5.6.0.
=head1 AUTHOR
Russ Allbery <rra@stanford.edu>.
=head1 COPYRIGHT AND LICENSE
Copyright 1999, 2001, 2004, 2006, 2008, 2009 Russ Allbery <rra@stanford.edu>.
This program is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.
=cut
POD_TEXT_COLOR
$fatpacked{"Pod/Text/Overstrike.pm"} = <<'POD_TEXT_OVERSTRIKE';
# Pod::Text::Overstrike -- Convert POD data to formatted overstrike text
#
# This was written because the output from:
#
# pod2text Text.pm > plain.txt; less plain.txt
#
# is not as rich as the output from
#
# pod2man Text.pm | nroff -man > fancy.txt; less fancy.txt
#
# and because both Pod::Text::Color and Pod::Text::Termcap are not device
# independent.
#
# Created by Joe Smith <Joe.Smith@inwap.com> 30-Nov-2000
# (based on Pod::Text::Color by Russ Allbery <rra@stanford.edu>)
# Copyright 2000 Joe Smith <Joe.Smith@inwap.com>.
# Copyright 2001, 2004, 2008 Russ Allbery <rra@stanford.edu>.
#
# This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
##############################################################################
# Modules and declarations
##############################################################################
package Pod::Text::Overstrike;
require 5.004;
use Pod::Text ();
use strict;
use vars qw(@ISA $VERSION);
@ISA = qw(Pod::Text);
$VERSION = '2.05';
##############################################################################
# Overrides
##############################################################################
# Make level one headings bold, overridding any existing formatting.
sub cmd_head1 {
my ($self, $attrs, $text) = @_;
$text =~ s/\s+$//;
$text = $self->strip_format ($text);
$text =~ s/(.)/$1\b$1/g;
return $self->SUPER::cmd_head1 ($attrs, $text);
}
# Make level two headings bold, overriding any existing formatting.
sub cmd_head2 {
my ($self, $attrs, $text) = @_;
$text =~ s/\s+$//;
$text = $self->strip_format ($text);
$text =~ s/(.)/$1\b$1/g;
return $self->SUPER::cmd_head2 ($attrs, $text);
}
# Make level three headings underscored, overriding any existing formatting.
sub cmd_head3 {
my ($self, $attrs, $text) = @_;
$text =~ s/\s+$//;
$text = $self->strip_format ($text);
$text =~ s/(.)/_\b$1/g;
return $self->SUPER::cmd_head3 ($attrs, $text);
}
# Level four headings look like level three headings.
sub cmd_head4 {
my ($self, $attrs, $text) = @_;
$text =~ s/\s+$//;
$text = $self->strip_format ($text);
$text =~ s/(.)/_\b$1/g;
return $self->SUPER::cmd_head4 ($attrs, $text);
}
# The common code for handling all headers. We have to override to avoid
# interpolating twice and because we don't want to honor alt.
sub heading {
my ($self, $text, $indent, $marker) = @_;
$self->item ("\n\n") if defined $$self{ITEM};
$text .= "\n" if $$self{opt_loose};
my $margin = ' ' x ($$self{opt_margin} + $indent);
$self->output ($margin . $text . "\n");
return '';
}
# Fix the various formatting codes.
sub cmd_b { local $_ = $_[0]->strip_format ($_[2]); s/(.)/$1\b$1/g; $_ }
sub cmd_f { local $_ = $_[0]->strip_format ($_[2]); s/(.)/_\b$1/g; $_ }
sub cmd_i { local $_ = $_[0]->strip_format ($_[2]); s/(.)/_\b$1/g; $_ }
# Output any included code in bold.
sub output_code {
my ($self, $code) = @_;
$code =~ s/(.)/$1\b$1/g;
$self->output ($code);
}
# Strip all of the formatting from a provided string, returning the stripped
# version.
sub strip_format {
my ($self, $text) = @_;
$text =~ s/(.)[\b]\1/$1/g;
$text =~ s/_[\b]//g;
return $text;
}
# We unfortunately have to override the wrapping code here, since the normal
# wrapping code gets really confused by all the backspaces.
sub wrap {
my $self = shift;
local $_ = shift;
my $output = '';
my $spaces = ' ' x $$self{MARGIN};
my $width = $$self{opt_width} - $$self{MARGIN};
while (length > $width) {
# This regex represents a single character, that's possibly underlined
# or in bold (in which case, it's three characters; the character, a
# backspace, and a character). Use [^\n] rather than . to protect
# against odd settings of $*.
my $char = '(?:[^\n][\b])?[^\n]';
if (s/^((?>$char){0,$width})(?:\Z|\s+)//) {
$output .= $spaces . $1 . "\n";
} else {
last;
}
}
$output .= $spaces . $_;
$output =~ s/\s+$/\n\n/;
return $output;
}
##############################################################################
# Module return value and documentation
##############################################################################
1;
__END__
=head1 NAME
=for stopwords
overstrike
Pod::Text::Overstrike - Convert POD data to formatted overstrike text
=for stopwords
overstruck Overstruck Allbery terminal's
=head1 SYNOPSIS
use Pod::Text::Overstrike;
my $parser = Pod::Text::Overstrike->new (sentence => 0, width => 78);
# Read POD from STDIN and write to STDOUT.
$parser->parse_from_filehandle;
# Read POD from file.pod and write to file.txt.
$parser->parse_from_file ('file.pod', 'file.txt');
=head1 DESCRIPTION
Pod::Text::Overstrike is a simple subclass of Pod::Text that highlights
output text using overstrike sequences, in a manner similar to nroff.
Characters in bold text are overstruck (character, backspace, character)
and characters in underlined text are converted to overstruck underscores
(underscore, backspace, character). This format was originally designed
for hard-copy terminals and/or line printers, yet is readable on soft-copy
(CRT) terminals.
Overstruck text is best viewed by page-at-a-time programs that take
advantage of the terminal's B<stand-out> and I<underline> capabilities, such
as the less program on Unix.
Apart from the overstrike, it in all ways functions like Pod::Text. See
L<Pod::Text> for details and available options.
=head1 BUGS
Currently, the outermost formatting instruction wins, so for example
underlined text inside a region of bold text is displayed as simply bold.
There may be some better approach possible.
=head1 SEE ALSO
L<Pod::Text>, L<Pod::Simple>
The current version of this module is always available from its web site at
L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
Perl core distribution as of 5.6.0.
=head1 AUTHOR
Joe Smith <Joe.Smith@inwap.com>, using the framework created by Russ Allbery
<rra@stanford.edu>.
=head1 COPYRIGHT AND LICENSE
Copyright 2000 by Joe Smith <Joe.Smith@inwap.com>.
Copyright 2001, 2004, 2008 by Russ Allbery <rra@stanford.edu>.
This program is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.
=cut
POD_TEXT_OVERSTRIKE
$fatpacked{"Pod/Text/Termcap.pm"} = <<'POD_TEXT_TERMCAP';
# Pod::Text::Termcap -- Convert POD data to ASCII text with format escapes.
#
# This is a simple subclass of Pod::Text that overrides a few key methods to
# output the right termcap escape sequences for formatted text on the current
# terminal type.
#
# Copyright 1999, 2001, 2002, 2004, 2006, 2008, 2009
# Russ Allbery <rra@stanford.edu>
#
# This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
##############################################################################
# Modules and declarations
##############################################################################
package Pod::Text::Termcap;
require 5.004;
use Pod::Text ();
use POSIX ();
use Term::Cap;
use strict;
use vars qw(@ISA $VERSION);
@ISA = qw(Pod::Text);
$VERSION = '2.07';
##############################################################################
# Overrides
##############################################################################
# In the initialization method, grab our terminal characteristics as well as
# do all the stuff we normally do.
sub new {
my ($self, @args) = @_;
my ($ospeed, $term, $termios);
$self = $self->SUPER::new (@args);
# $ENV{HOME} is usually not set on Windows. The default Term::Cap path
# may not work on Solaris.
my $home = exists $ENV{HOME} ? "$ENV{HOME}/.termcap:" : '';
$ENV{TERMPATH} = $home . '/etc/termcap:/usr/share/misc/termcap'
. ':/usr/share/lib/termcap';
# Fall back on a hard-coded terminal speed if POSIX::Termios isn't
# available (such as on VMS).
eval { $termios = POSIX::Termios->new };
if ($@) {
$ospeed = 9600;
} else {
$termios->getattr;
$ospeed = $termios->getospeed || 9600;
}
# Fall back on the ANSI escape sequences if Term::Cap doesn't work.
eval { $term = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed } };
$$self{BOLD} = $$term{_md} || "\e[1m";
$$self{UNDL} = $$term{_us} || "\e[4m";
$$self{NORM} = $$term{_me} || "\e[m";
unless (defined $$self{width}) {
$$self{opt_width} = $ENV{COLUMNS} || $$term{_co} || 80;
$$self{opt_width} -= 2;
}
return $self;
}
# Make level one headings bold.
sub cmd_head1 {
my ($self, $attrs, $text) = @_;
$text =~ s/\s+$//;
$self->SUPER::cmd_head1 ($attrs, "$$self{BOLD}$text$$self{NORM}");
}
# Make level two headings bold.
sub cmd_head2 {
my ($self, $attrs, $text) = @_;
$text =~ s/\s+$//;
$self->SUPER::cmd_head2 ($attrs, "$$self{BOLD}$text$$self{NORM}");
}
# Fix up B<> and I<>. Note that we intentionally don't do F<>.
sub cmd_b { my $self = shift; return "$$self{BOLD}$_[1]$$self{NORM}" }
sub cmd_i { my $self = shift; return "$$self{UNDL}$_[1]$$self{NORM}" }
# Output any included code in bold.
sub output_code {
my ($self, $code) = @_;
$self->output ($$self{BOLD} . $code . $$self{NORM});
}
# Strip all of the formatting from a provided string, returning the stripped
# version.
sub strip_format {
my ($self, $text) = @_;
$text =~ s/\Q$$self{BOLD}//g;
$text =~ s/\Q$$self{UNDL}//g;
$text =~ s/\Q$$self{NORM}//g;
return $text;
}
# Override the wrapping code to igore the special sequences.
sub wrap {
my $self = shift;
local $_ = shift;
my $output = '';
my $spaces = ' ' x $$self{MARGIN};
my $width = $$self{opt_width} - $$self{MARGIN};
# $codes matches a single special sequence. $char matches any number of
# special sequences preceeding a single character other than a newline.
# We have to do $shortchar and $longchar in variables because the
# construct ${char}{0,$width} didn't do the right thing until Perl 5.8.x.
my $codes = "(?:\Q$$self{BOLD}\E|\Q$$self{UNDL}\E|\Q$$self{NORM}\E)";
my $char = "(?:$codes*[^\\n])";
my $shortchar = $char . "{0,$width}";
my $longchar = $char . "{$width}";
while (length > $width) {
if (s/^($shortchar)\s+// || s/^($longchar)//) {
$output .= $spaces . $1 . "\n";
} else {
last;
}
}
$output .= $spaces . $_;
$output =~ s/\s+$/\n\n/;
return $output;
}
##############################################################################
# Module return value and documentation
##############################################################################
1;
__END__
=head1 NAME
Pod::Text::Termcap - Convert POD data to ASCII text with format escapes
=for stopwords
ECMA-48 VT100 Allbery
=head1 SYNOPSIS
use Pod::Text::Termcap;
my $parser = Pod::Text::Termcap->new (sentence => 0, width => 78);
# Read POD from STDIN and write to STDOUT.
$parser->parse_from_filehandle;
# Read POD from file.pod and write to file.txt.
$parser->parse_from_file ('file.pod', 'file.txt');
=head1 DESCRIPTION
Pod::Text::Termcap is a simple subclass of Pod::Text that highlights output
text using the correct termcap escape sequences for the current terminal.
Apart from the format codes, it in all ways functions like Pod::Text. See
L<Pod::Text> for details and available options.
=head1 NOTES
This module uses Term::Cap to retrieve the formatting escape sequences for
the current terminal, and falls back on the ECMA-48 (the same in this
regard as ANSI X3.64 and ISO 6429, the escape codes also used by DEC VT100
terminals) if the bold, underline, and reset codes aren't set in the
termcap information.
=head1 SEE ALSO
L<Pod::Text>, L<Pod::Simple>, L<Term::Cap>
The current version of this module is always available from its web site at
L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
Perl core distribution as of 5.6.0.
=head1 AUTHOR
Russ Allbery <rra@stanford.edu>.
=head1 COPYRIGHT AND LICENSE
Copyright 1999, 2001, 2002, 2004, 2006, 2008, 2009 Russ Allbery
<rra@stanford.edu>.
This program is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.
=cut
POD_TEXT_TERMCAP
$fatpacked{"Pod/Usage.pm"} = <<'POD_USAGE';
#############################################################################
# Pod/Usage.pm -- print usage messages for the running script.
#
# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.
# This file is part of "PodParser". PodParser is free software;
# you can redistribute it and/or modify it under the same terms
# as Perl itself.
#############################################################################
package Pod::Usage;
use strict;
use vars qw($VERSION @ISA @EXPORT);
$VERSION = '1.61'; ## Current version of this package
require 5.005; ## requires this Perl version or later
#use diagnostics;
use Carp;
use Config;
use Exporter;
use File::Spec;
@EXPORT = qw(&pod2usage);
BEGIN {
$Pod::Usage::Formatter ||=
( $] >= 5.005_58 ? 'Pod::Text' : 'Pod::PlainText');
eval "require $Pod::Usage::Formatter";
die $@ if $@;
@ISA = ( $Pod::Usage::Formatter );
}
require Pod::Select;
##---------------------------------------------------------------------------
##---------------------------------
## Function definitions begin here
##---------------------------------
sub pod2usage {
local($_) = shift;
my %opts;
## Collect arguments
if (@_ > 0) {
## Too many arguments - assume that this is a hash and
## the user forgot to pass a reference to it.
%opts = ($_, @_);
}
elsif (!defined $_) {
$_ = '';
}
elsif (ref $_) {
## User passed a ref to a hash
%opts = %{$_} if (ref($_) eq 'HASH');
}
elsif (/^[-+]?\d+$/) {
## User passed in the exit value to use
$opts{'-exitval'} = $_;
}
else {
## User passed in a message to print before issuing usage.
$_ and $opts{'-message'} = $_;
}
## Need this for backward compatibility since we formerly used
## options that were all uppercase words rather than ones that
## looked like Unix command-line options.
## to be uppercase keywords)
%opts = map {
my ($key, $val) = ($_, $opts{$_});
$key =~ s/^(?=\w)/-/;
$key =~ /^-msg/i and $key = '-message';
$key =~ /^-exit/i and $key = '-exitval';
lc($key) => $val;
} (keys %opts);
## Now determine default -exitval and -verbose values to use
if ((! defined $opts{'-exitval'}) && (! defined $opts{'-verbose'})) {
$opts{'-exitval'} = 2;
$opts{'-verbose'} = 0;
}
elsif (! defined $opts{'-exitval'}) {
$opts{'-exitval'} = ($opts{'-verbose'} > 0) ? 1 : 2;
}
elsif (! defined $opts{'-verbose'}) {
$opts{'-verbose'} = (lc($opts{'-exitval'}) eq 'noexit' ||
$opts{'-exitval'} < 2);
}
## Default the output file
$opts{'-output'} = (lc($opts{'-exitval'}) eq 'noexit' ||
$opts{'-exitval'} < 2) ? \*STDOUT : \*STDERR
unless (defined $opts{'-output'});
## Default the input file
$opts{'-input'} = $0 unless (defined $opts{'-input'});
## Look up input file in path if it doesnt exist.
unless ((ref $opts{'-input'}) || (-e $opts{'-input'})) {
my $basename = $opts{'-input'};
my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/i) ? ';'
: (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' : ':');
my $pathspec = $opts{'-pathlist'} || $ENV{PATH} || $ENV{PERL5LIB};
my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec);
for my $dirname (@paths) {
$_ = File::Spec->catfile($dirname, $basename) if length;
last if (-e $_) && ($opts{'-input'} = $_);
}
}
## Now create a pod reader and constrain it to the desired sections.
my $parser = new Pod::Usage(USAGE_OPTIONS => \%opts);
if ($opts{'-verbose'} == 0) {
$parser->select('(?:SYNOPSIS|USAGE)\s*');
}
elsif ($opts{'-verbose'} == 1) {
my $opt_re = '(?i)' .
'(?:OPTIONS|ARGUMENTS)' .
'(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?';
$parser->select( '(?:SYNOPSIS|USAGE)\s*', $opt_re, "DESCRIPTION/$opt_re" );
}
elsif ($opts{'-verbose'} >= 2 && $opts{'-verbose'} != 99) {
$parser->select('.*');
}
elsif ($opts{'-verbose'} == 99) {
my $sections = $opts{'-sections'};
$parser->select( (ref $sections) ? @$sections : $sections );
$opts{'-verbose'} = 1;
}
## Check for perldoc
my $progpath = File::Spec->catfile($Config{scriptdirexp}
|| $Config{scriptdir}, 'perldoc');
my $version = sprintf("%vd",$^V);
if ($Config{versiononly} and $Config{startperl} =~ /\Q$version\E$/ ) {
$progpath .= $version;
}
$opts{'-noperldoc'} = 1 unless -e $progpath;
## Now translate the pod document and then exit with the desired status
if ( !$opts{'-noperldoc'}
and $opts{'-verbose'} >= 2
and !ref($opts{'-input'})
and $opts{'-output'} == \*STDOUT )
{
## spit out the entire PODs. Might as well invoke perldoc
print { $opts{'-output'} } ($opts{'-message'}, "\n") if($opts{'-message'});
if(defined $opts{-input} && $opts{-input} =~ /^\s*(\S.*?)\s*$/) {
# the perldocs back to 5.005 should all have -F
# without -F there are warnings in -T scripts
system($progpath, '-F', $1);
if($?) {
# RT16091: fall back to more if perldoc failed
system(($Config{pager} || $ENV{PAGER} || '/bin/more'), $1);
}
} else {
croak "Unspecified input file or insecure argument.\n";
}
}
else {
$parser->parse_from_file($opts{'-input'}, $opts{'-output'});
}
exit($opts{'-exitval'}) unless (lc($opts{'-exitval'}) eq 'noexit');
}
##---------------------------------------------------------------------------
##-------------------------------
## Method definitions begin here
##-------------------------------
sub new {
my $this = shift;
my $class = ref($this) || $this;
my %params = @_;
my $self = {%params};
bless $self, $class;
if ($self->can('initialize')) {
$self->initialize();
} else {
# pass through options to Pod::Text
my %opts;
for (qw(alt code indent loose margin quotes sentence stderr utf8 width)) {
my $val = $params{USAGE_OPTIONS}{"-$_"};
$opts{$_} = $val if defined $val;
}
$self = $self->SUPER::new(%opts);
%$self = (%$self, %params);
}
return $self;
}
sub select {
my ($self, @sections) = @_;
if ($ISA[0]->can('select')) {
$self->SUPER::select(@sections);
} else {
# we're using Pod::Simple - need to mimic the behavior of Pod::Select
my $add = ($sections[0] eq '+') ? shift(@sections) : '';
## Reset the set of sections to use
unless (@sections) {
delete $self->{USAGE_SELECT} unless ($add);
return;
}
$self->{USAGE_SELECT} = []
unless ($add && $self->{USAGE_SELECT});
my $sref = $self->{USAGE_SELECT};
## Compile each spec
for my $spec (@sections) {
my $cs = Pod::Select::_compile_section_spec($spec);
if ( defined $cs ) {
## Store them in our sections array
push(@$sref, $cs);
} else {
carp qq{Ignoring section spec "$spec"!\n};
}
}
}
}
# Override Pod::Text->seq_i to return just "arg", not "*arg*".
sub seq_i { return $_[1] }
# This overrides the Pod::Text method to do something very akin to what
# Pod::Select did as well as the work done below by preprocess_paragraph.
# Note that the below is very, very specific to Pod::Text.
sub _handle_element_end {
my ($self, $element) = @_;
if ($element eq 'head1') {
$self->{USAGE_HEADINGS} = [ $$self{PENDING}[-1][1] ];
if ($self->{USAGE_OPTIONS}->{-verbose} < 2) {
$$self{PENDING}[-1][1] =~ s/^\s*SYNOPSIS\s*$/USAGE/;
}
} elsif ($element =~ /^head(\d+)$/ && $1) { # avoid 0
my $idx = $1 - 1;
$self->{USAGE_HEADINGS} = [] unless($self->{USAGE_HEADINGS});
$self->{USAGE_HEADINGS}->[$idx] = $$self{PENDING}[-1][1];
}
if ($element =~ /^head\d+$/) {
$$self{USAGE_SKIPPING} = 1;
if (!$$self{USAGE_SELECT} || !@{ $$self{USAGE_SELECT} }) {
$$self{USAGE_SKIPPING} = 0;
} else {
my @headings = @{$$self{USAGE_HEADINGS}};
for my $section_spec ( @{$$self{USAGE_SELECT}} ) {
my $match = 1;
for (my $i = 0; $i < $Pod::Select::MAX_HEADING_LEVEL; ++$i) {
$headings[$i] = '' unless defined $headings[$i];
my $regex = $section_spec->[$i];
my $negated = ($regex =~ s/^\!//);
$match &= ($negated ? ($headings[$i] !~ /${regex}/)
: ($headings[$i] =~ /${regex}/));
last unless ($match);
} # end heading levels
if ($match) {
$$self{USAGE_SKIPPING} = 0;
last;
}
} # end sections
}
# Try to do some lowercasing instead of all-caps in headings, and use
# a colon to end all headings.
if($self->{USAGE_OPTIONS}->{-verbose} < 2) {
local $_ = $$self{PENDING}[-1][1];
s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge;
s/\s*$/:/ unless (/:\s*$/);
$_ .= "\n";
$$self{PENDING}[-1][1] = $_;
}
}
if ($$self{USAGE_SKIPPING} && $element !~ m/^over-/) {
pop @{ $$self{PENDING} };
} else {
$self->SUPER::_handle_element_end($element);
}
}
# required for Pod::Simple API
sub start_document {
my $self = shift;
$self->SUPER::start_document();
my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1;
my $out_fh = $self->output_fh();
print $out_fh "$msg\n";
}
# required for old Pod::Parser API
sub begin_pod {
my $self = shift;
$self->SUPER::begin_pod(); ## Have to call superclass
my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1;
my $out_fh = $self->output_handle();
print $out_fh "$msg\n";
}
sub preprocess_paragraph {
my $self = shift;
local $_ = shift;
my $line = shift;
## See if this is a heading and we arent printing the entire manpage.
if (($self->{USAGE_OPTIONS}->{-verbose} < 2) && /^=head/) {
## Change the title of the SYNOPSIS section to USAGE
s/^=head1\s+SYNOPSIS\s*$/=head1 USAGE/;
## Try to do some lowercasing instead of all-caps in headings
s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge;
## Use a colon to end all headings
s/\s*$/:/ unless (/:\s*$/);
$_ .= "\n";
}
return $self->SUPER::preprocess_paragraph($_);
}
1; # keep require happy
__END__
=head1 NAME
Pod::Usage, pod2usage() - print a usage message from embedded pod documentation
=head1 SYNOPSIS
use Pod::Usage
my $message_text = "This text precedes the usage message.";
my $exit_status = 2; ## The exit status to use
my $verbose_level = 0; ## The verbose level to use
my $filehandle = \*STDERR; ## The filehandle to write to
pod2usage($message_text);
pod2usage($exit_status);
pod2usage( { -message => $message_text ,
-exitval => $exit_status ,
-verbose => $verbose_level,
-output => $filehandle } );
pod2usage( -msg => $message_text ,
-exitval => $exit_status ,
-verbose => $verbose_level,
-output => $filehandle );
pod2usage( -verbose => 2,
-noperldoc => 1 )
=head1 ARGUMENTS
B<pod2usage> should be given either a single argument, or a list of
arguments corresponding to an associative array (a "hash"). When a single
argument is given, it should correspond to exactly one of the following:
=over 4
=item *
A string containing the text of a message to print I<before> printing
the usage message
=item *
A numeric value corresponding to the desired exit status
=item *
A reference to a hash
=back
If more than one argument is given then the entire argument list is
assumed to be a hash. If a hash is supplied (either as a reference or
as a list) it should contain one or more elements with the following
keys:
=over 4
=item C<-message>
=item C<-msg>
The text of a message to print immediately prior to printing the
program's usage message.
=item C<-exitval>
The desired exit status to pass to the B<exit()> function.
This should be an integer, or else the string "NOEXIT" to
indicate that control should simply be returned without
terminating the invoking process.
=item C<-verbose>
The desired level of "verboseness" to use when printing the usage
message. If the corresponding value is 0, then only the "SYNOPSIS"
section of the pod documentation is printed. If the corresponding value
is 1, then the "SYNOPSIS" section, along with any section entitled
"OPTIONS", "ARGUMENTS", or "OPTIONS AND ARGUMENTS" is printed. If the
corresponding value is 2 or more then the entire manpage is printed.
The special verbosity level 99 requires to also specify the -sections
parameter; then these sections are extracted (see L<Pod::Select>)
and printed.
=item C<-sections>
A string representing a selection list for sections to be printed
when -verbose is set to 99, e.g. C<"NAME|SYNOPSIS|DESCRIPTION|VERSION">.
Alternatively, an array reference of section specifications can be used:
pod2usage(-verbose => 99,
-sections => [ qw(fred fred/subsection) ] );
=item C<-output>
A reference to a filehandle, or the pathname of a file to which the
usage message should be written. The default is C<\*STDERR> unless the
exit value is less than 2 (in which case the default is C<\*STDOUT>).
=item C<-input>
A reference to a filehandle, or the pathname of a file from which the
invoking script's pod documentation should be read. It defaults to the
file indicated by C<$0> (C<$PROGRAM_NAME> for users of F<English.pm>).
If you are calling B<pod2usage()> from a module and want to display
that module's POD, you can use this:
use Pod::Find qw(pod_where);
pod2usage( -input => pod_where({-inc => 1}, __PACKAGE__) );
=item C<-pathlist>
A list of directory paths. If the input file does not exist, then it
will be searched for in the given directory list (in the order the
directories appear in the list). It defaults to the list of directories
implied by C<$ENV{PATH}>. The list may be specified either by a reference
to an array, or by a string of directory paths which use the same path
separator as C<$ENV{PATH}> on your system (e.g., C<:> for Unix, C<;> for
MSWin32 and DOS).
=item C<-noperldoc>
By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is
specified. This does not work well e.g. if the script was packed
with L<PAR>. The -noperldoc option suppresses the external call to
L<perldoc> and uses the simple text formatter (L<Pod::Text>) to
output the POD.
=back
=head2 Formatting base class
The default text formatter depends on the Perl version (L<Pod::Text> or
L<Pod::PlainText> for Perl versions E<lt> 5.005_58). The base class for
Pod::Usage can be defined by pre-setting C<$Pod::Usage::Formatter> I<before>
loading Pod::Usage, e.g.:
BEGIN { $Pod::Usage::Formatter = 'Pod::Text::Termcap'; }
use Pod::Usage qw(pod2usage);
=head2 Pass-through options
The following options are passed through to the underlying text formatter.
See the manual pages of these modules for more information.
alt code indent loose margin quotes sentence stderr utf8 width
=head1 DESCRIPTION
B<pod2usage> will print a usage message for the invoking script (using
its embedded pod documentation) and then exit the script with the
desired exit status. The usage message printed may have any one of three
levels of "verboseness": If the verbose level is 0, then only a synopsis
is printed. If the verbose level is 1, then the synopsis is printed
along with a description (if present) of the command line options and
arguments. If the verbose level is 2, then the entire manual page is
printed.
Unless they are explicitly specified, the default values for the exit
status, verbose level, and output stream to use are determined as
follows:
=over 4
=item *
If neither the exit status nor the verbose level is specified, then the
default is to use an exit status of 2 with a verbose level of 0.
=item *
If an exit status I<is> specified but the verbose level is I<not>, then the
verbose level will default to 1 if the exit status is less than 2 and
will default to 0 otherwise.
=item *
If an exit status is I<not> specified but verbose level I<is> given, then
the exit status will default to 2 if the verbose level is 0 and will
default to 1 otherwise.
=item *
If the exit status used is less than 2, then output is printed on
C<STDOUT>. Otherwise output is printed on C<STDERR>.
=back
Although the above may seem a bit confusing at first, it generally does
"the right thing" in most situations. This determination of the default
values to use is based upon the following typical Unix conventions:
=over 4
=item *
An exit status of 0 implies "success". For example, B<diff(1)> exits
with a status of 0 if the two files have the same contents.
=item *
An exit status of 1 implies possibly abnormal, but non-defective, program
termination. For example, B<grep(1)> exits with a status of 1 if
it did I<not> find a matching line for the given regular expression.
=item *
An exit status of 2 or more implies a fatal error. For example, B<ls(1)>
exits with a status of 2 if you specify an illegal (unknown) option on
the command line.
=item *
Usage messages issued as a result of bad command-line syntax should go
to C<STDERR>. However, usage messages issued due to an explicit request
to print usage (like specifying B<-help> on the command line) should go
to C<STDOUT>, just in case the user wants to pipe the output to a pager
(such as B<more(1)>).
=item *
If program usage has been explicitly requested by the user, it is often
desirable to exit with a status of 1 (as opposed to 0) after issuing
the user-requested usage message. It is also desirable to give a
more verbose description of program usage in this case.
=back
B<pod2usage> doesn't force the above conventions upon you, but it will
use them by default if you don't expressly tell it to do otherwise. The
ability of B<pod2usage()> to accept a single number or a string makes it
convenient to use as an innocent looking error message handling function:
use Pod::Usage;
use Getopt::Long;
## Parse options
GetOptions("help", "man", "flag1") || pod2usage(2);
pod2usage(1) if ($opt_help);
pod2usage(-verbose => 2) if ($opt_man);
## Check for too many filenames
pod2usage("$0: Too many files given.\n") if (@ARGV > 1);
Some user's however may feel that the above "economy of expression" is
not particularly readable nor consistent and may instead choose to do
something more like the following:
use Pod::Usage;
use Getopt::Long;
## Parse options
GetOptions("help", "man", "flag1") || pod2usage(-verbose => 0);
pod2usage(-verbose => 1) if ($opt_help);
pod2usage(-verbose => 2) if ($opt_man);
## Check for too many filenames
pod2usage(-verbose => 2, -message => "$0: Too many files given.\n")
if (@ARGV > 1);
As with all things in Perl, I<there's more than one way to do it>, and
B<pod2usage()> adheres to this philosophy. If you are interested in
seeing a number of different ways to invoke B<pod2usage> (although by no
means exhaustive), please refer to L<"EXAMPLES">.
=head1 EXAMPLES
Each of the following invocations of C<pod2usage()> will print just the
"SYNOPSIS" section to C<STDERR> and will exit with a status of 2:
pod2usage();
pod2usage(2);
pod2usage(-verbose => 0);
pod2usage(-exitval => 2);
pod2usage({-exitval => 2, -output => \*STDERR});
pod2usage({-verbose => 0, -output => \*STDERR});
pod2usage(-exitval => 2, -verbose => 0);
pod2usage(-exitval => 2, -verbose => 0, -output => \*STDERR);
Each of the following invocations of C<pod2usage()> will print a message
of "Syntax error." (followed by a newline) to C<STDERR>, immediately
followed by just the "SYNOPSIS" section (also printed to C<STDERR>) and
will exit with a status of 2:
pod2usage("Syntax error.");
pod2usage(-message => "Syntax error.", -verbose => 0);
pod2usage(-msg => "Syntax error.", -exitval => 2);
pod2usage({-msg => "Syntax error.", -exitval => 2, -output => \*STDERR});
pod2usage({-msg => "Syntax error.", -verbose => 0, -output => \*STDERR});
pod2usage(-msg => "Syntax error.", -exitval => 2, -verbose => 0);
pod2usage(-message => "Syntax error.",
-exitval => 2,
-verbose => 0,
-output => \*STDERR);
Each of the following invocations of C<pod2usage()> will print the
"SYNOPSIS" section and any "OPTIONS" and/or "ARGUMENTS" sections to
C<STDOUT> and will exit with a status of 1:
pod2usage(1);
pod2usage(-verbose => 1);
pod2usage(-exitval => 1);
pod2usage({-exitval => 1, -output => \*STDOUT});
pod2usage({-verbose => 1, -output => \*STDOUT});
pod2usage(-exitval => 1, -verbose => 1);
pod2usage(-exitval => 1, -verbose => 1, -output => \*STDOUT});
Each of the following invocations of C<pod2usage()> will print the
entire manual page to C<STDOUT> and will exit with a status of 1:
pod2usage(-verbose => 2);
pod2usage({-verbose => 2, -output => \*STDOUT});
pod2usage(-exitval => 1, -verbose => 2);
pod2usage({-exitval => 1, -verbose => 2, -output => \*STDOUT});
=head2 Recommended Use
Most scripts should print some type of usage message to C<STDERR> when a
command line syntax error is detected. They should also provide an
option (usually C<-H> or C<-help>) to print a (possibly more verbose)
usage message to C<STDOUT>. Some scripts may even wish to go so far as to
provide a means of printing their complete documentation to C<STDOUT>
(perhaps by allowing a C<-man> option). The following complete example
uses B<Pod::Usage> in combination with B<Getopt::Long> to do all of these
things:
use Getopt::Long;
use Pod::Usage;
my $man = 0;
my $help = 0;
## Parse options and print usage if there is a syntax error,
## or if usage was explicitly requested.
GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
pod2usage(1) if $help;
pod2usage(-verbose => 2) if $man;
## If no arguments were given, then allow STDIN to be used only
## if it's not connected to a terminal (otherwise print usage)
pod2usage("$0: No files given.") if ((@ARGV == 0) && (-t STDIN));
__END__
=head1 NAME
sample - Using GetOpt::Long and Pod::Usage
=head1 SYNOPSIS
sample [options] [file ...]
Options:
-help brief help message
-man full documentation
=head1 OPTIONS
=over 8
=item B<-help>
Print a brief help message and exits.
=item B<-man>
Prints the manual page and exits.
=back
=head1 DESCRIPTION
B<This program> will read the given input file(s) and do something
useful with the contents thereof.
=cut
=head1 CAVEATS
By default, B<pod2usage()> will use C<$0> as the path to the pod input
file. Unfortunately, not all systems on which Perl runs will set C<$0>
properly (although if C<$0> isn't found, B<pod2usage()> will search
C<$ENV{PATH}> or else the list specified by the C<-pathlist> option).
If this is the case for your system, you may need to explicitly specify
the path to the pod docs for the invoking script using something
similar to the following:
pod2usage(-exitval => 2, -input => "/path/to/your/pod/docs");
In the pathological case that a script is called via a relative path
I<and> the script itself changes the current working directory
(see L<perlfunc/chdir>) I<before> calling pod2usage, Pod::Usage will
fail even on robust platforms. Don't do that. Or use L<FindBin> to locate
the script:
use FindBin;
pod2usage(-input => $FindBin::Bin . "/" . $FindBin::Script);
=head1 AUTHOR
Please report bugs using L<http://rt.cpan.org>.
Marek Rouchal E<lt>marekr@cpan.orgE<gt>
Brad Appleton E<lt>bradapp@enteract.comE<gt>
Based on code for B<Pod::Text::pod2text()> written by
Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
=head1 ACKNOWLEDGMENTS
Steven McDougall E<lt>swmcd@world.std.comE<gt> for his help and patience
with re-writing this manpage.
=head1 SEE ALSO
B<Pod::Usage> is now a standalone distribution.
L<Pod::Parser>, L<Pod::Perldoc>, L<Getopt::Long>, L<Pod::Find>, L<FindBin>,
L<Pod::Text>, L<Pod::PlainText>, L<Pod::Text::Termcap>
=cut
POD_USAGE
$fatpacked{"constant.pm"} = <<'CONSTANT';
package constant;
use 5.008;
use strict;
use warnings::register;
use vars qw($VERSION %declared);
$VERSION = '1.27';
#=======================================================================
# Some names are evil choices.
my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD };
$keywords{UNITCHECK}++ if $] > 5.009;
my %forced_into_main = map +($_, 1),
qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG };
my %forbidden = (%keywords, %forced_into_main);
my $normal_constant_name = qr/^_?[^\W_0-9]\w*\z/;
my $tolerable = qr/^[A-Za-z_]\w*\z/;
my $boolean = qr/^[01]?\z/;
BEGIN {
# We'd like to do use constant _CAN_PCS => $] > 5.009002
# but that's a bit tricky before we load the constant module :-)
# By doing this, we save 1 run time check for *every* call to import.
no strict 'refs';
my $const = $] > 5.009002;
*_CAN_PCS = sub () {$const};
my $downgrade = $] < 5.015004; # && $] >= 5.008
*_DOWNGRADE = sub () { $downgrade };
}
#=======================================================================
# import() - import symbols into user's namespace
#
# What we actually do is define a function in the caller's namespace
# which returns the value. The function we create will normally
# be inlined as a constant, thereby avoiding further sub calling
# overhead.
#=======================================================================
sub import {
my $class = shift;
return unless @_; # Ignore 'use constant;'
my $constants;
my $multiple = ref $_[0];
my $pkg = caller;
my $flush_mro;
my $symtab;
if (_CAN_PCS) {
no strict 'refs';
$symtab = \%{$pkg . '::'};
};
if ( $multiple ) {
if (ref $_[0] ne 'HASH') {
require Carp;
Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'");
}
$constants = shift;
} else {
unless (defined $_[0]) {
require Carp;
Carp::croak("Can't use undef as constant name");
}
$constants->{+shift} = undef;
}
foreach my $name ( keys %$constants ) {
# Normal constant name
if ($name =~ $normal_constant_name and !$forbidden{$name}) {
# Everything is okay
# Name forced into main, but we're not in main. Fatal.
} elsif ($forced_into_main{$name} and $pkg ne 'main') {
require Carp;
Carp::croak("Constant name '$name' is forced into main::");
# Starts with double underscore. Fatal.
} elsif ($name =~ /^__/) {
require Carp;
Carp::croak("Constant name '$name' begins with '__'");
# Maybe the name is tolerable
} elsif ($name =~ $tolerable) {
# Then we'll warn only if you've asked for warnings
if (warnings::enabled()) {
if ($keywords{$name}) {
warnings::warn("Constant name '$name' is a Perl keyword");
} elsif ($forced_into_main{$name}) {
warnings::warn("Constant name '$name' is " .
"forced into package main::");
}
}
# Looks like a boolean
# use constant FRED == fred;
} elsif ($name =~ $boolean) {
require Carp;
if (@_) {
Carp::croak("Constant name '$name' is invalid");
} else {
Carp::croak("Constant name looks like boolean value");
}
} else {
# Must have bad characters
require Carp;
Carp::croak("Constant name '$name' has invalid characters");
}
{
no strict 'refs';
my $full_name = "${pkg}::$name";
$declared{$full_name}++;
if ($multiple || @_ == 1) {
my $scalar = $multiple ? $constants->{$name} : $_[0];
if (_DOWNGRADE) { # for 5.8 to 5.14
# Work around perl bug #31991: Sub names (actually glob
# names in general) ignore the UTF8 flag. So we have to
# turn it off to get the "right" symbol table entry.
utf8::is_utf8 $name and utf8::encode $name;
}
# The constant serves to optimise this entire block out on
# 5.8 and earlier.
if (_CAN_PCS && $symtab && !exists $symtab->{$name}) {
# No typeglob yet, so we can use a reference as space-
# efficient proxy for a constant subroutine
# The check in Perl_ck_rvconst knows that inlinable
# constants from cv_const_sv are read only. So we have to:
Internals::SvREADONLY($scalar, 1);
$symtab->{$name} = \$scalar;
++$flush_mro;
} else {
*$full_name = sub () { $scalar };
}
} elsif (@_) {
my @list = @_;
*$full_name = sub () { @list };
} else {
*$full_name = sub () { };
}
}
}
# Flush the cache exactly once if we make any direct symbol table changes.
mro::method_changed_in($pkg) if _CAN_PCS && $flush_mro;
}
1;
__END__
=head1 NAME
constant - Perl pragma to declare constants
=head1 SYNOPSIS
use constant PI => 4 * atan2(1, 1);
use constant DEBUG => 0;
print "Pi equals ", PI, "...\n" if DEBUG;
use constant {
SEC => 0,
MIN => 1,
HOUR => 2,
MDAY => 3,
MON => 4,
YEAR => 5,
WDAY => 6,
YDAY => 7,
ISDST => 8,
};
use constant WEEKDAYS => qw(
Sunday Monday Tuesday Wednesday Thursday Friday Saturday
);
print "Today is ", (WEEKDAYS)[ (localtime)[WDAY] ], ".\n";
=head1 DESCRIPTION
This pragma allows you to declare constants at compile-time.
When you declare a constant such as C<PI> using the method shown
above, each machine your script runs upon can have as many digits
of accuracy as it can use. Also, your program will be easier to
read, more likely to be maintained (and maintained correctly), and
far less likely to send a space probe to the wrong planet because
nobody noticed the one equation in which you wrote C<3.14195>.
When a constant is used in an expression, Perl replaces it with its
value at compile time, and may then optimize the expression further.
In particular, any code in an C<if (CONSTANT)> block will be optimized
away if the constant is false.
=head1 NOTES
As with all C<use> directives, defining a constant happens at
compile time. Thus, it's probably not correct to put a constant
declaration inside of a conditional statement (like C<if ($foo)
{ use constant ... }>).
Constants defined using this module cannot be interpolated into
strings like variables. However, concatenation works just fine:
print "Pi equals PI...\n"; # WRONG: does not expand "PI"
print "Pi equals ".PI."...\n"; # right
Even though a reference may be declared as a constant, the reference may
point to data which may be changed, as this code shows.
use constant ARRAY => [ 1,2,3,4 ];
print ARRAY->[1];
ARRAY->[1] = " be changed";
print ARRAY->[1];
Dereferencing constant references incorrectly (such as using an array
subscript on a constant hash reference, or vice versa) will be trapped at
compile time.
Constants belong to the package they are defined in. To refer to a
constant defined in another package, specify the full package name, as
in C<Some::Package::CONSTANT>. Constants may be exported by modules,
and may also be called as either class or instance methods, that is,
as C<< Some::Package->CONSTANT >> or as C<< $obj->CONSTANT >> where
C<$obj> is an instance of C<Some::Package>. Subclasses may define
their own constants to override those in their base class.
The use of all caps for constant names is merely a convention,
although it is recommended in order to make constants stand out
and to help avoid collisions with other barewords, keywords, and
subroutine names. Constant names must begin with a letter or
underscore. Names beginning with a double underscore are reserved. Some
poor choices for names will generate warnings, if warnings are enabled at
compile time.
=head2 List constants
Constants may be lists of more (or less) than one value. A constant
with no values evaluates to C<undef> in scalar context. Note that
constants with more than one value do I<not> return their last value in
scalar context as one might expect. They currently return the number
of values, but B<this may change in the future>. Do not use constants
with multiple values in scalar context.
B<NOTE:> This implies that the expression defining the value of a
constant is evaluated in list context. This may produce surprises:
use constant TIMESTAMP => localtime; # WRONG!
use constant TIMESTAMP => scalar localtime; # right
The first line above defines C<TIMESTAMP> as a 9-element list, as
returned by C<localtime()> in list context. To set it to the string
returned by C<localtime()> in scalar context, an explicit C<scalar>
keyword is required.
List constants are lists, not arrays. To index or slice them, they
must be placed in parentheses.
my @workdays = WEEKDAYS[1 .. 5]; # WRONG!
my @workdays = (WEEKDAYS)[1 .. 5]; # right
=head2 Defining multiple constants at once
Instead of writing multiple C<use constant> statements, you may define
multiple constants in a single statement by giving, instead of the
constant name, a reference to a hash where the keys are the names of
the constants to be defined. Obviously, all constants defined using
this method must have a single value.
use constant {
FOO => "A single value",
BAR => "This", "won't", "work!", # Error!
};
This is a fundamental limitation of the way hashes are constructed in
Perl. The error messages produced when this happens will often be
quite cryptic -- in the worst case there may be none at all, and
you'll only later find that something is broken.
When defining multiple constants, you cannot use the values of other
constants defined in the same declaration. This is because the
calling package doesn't know about any constant within that group
until I<after> the C<use> statement is finished.
use constant {
BITMASK => 0xAFBAEBA8,
NEGMASK => ~BITMASK, # Error!
};
=head2 Magic constants
Magical values and references can be made into constants at compile
time, allowing for way cool stuff like this. (These error numbers
aren't totally portable, alas.)
use constant E2BIG => ($! = 7);
print E2BIG, "\n"; # something like "Arg list too long"
print 0+E2BIG, "\n"; # "7"
You can't produce a tied constant by giving a tied scalar as the
value. References to tied variables, however, can be used as
constants without any problems.
=head1 TECHNICAL NOTES
In the current implementation, scalar constants are actually
inlinable subroutines. As of version 5.004 of Perl, the appropriate
scalar constant is inserted directly in place of some subroutine
calls, thereby saving the overhead of a subroutine call. See
L<perlsub/"Constant Functions"> for details about how and when this
happens.
In the rare case in which you need to discover at run time whether a
particular constant has been declared via this module, you may use
this function to examine the hash C<%constant::declared>. If the given
constant name does not include a package name, the current package is
used.
sub declared ($) {
use constant 1.01; # don't omit this!
my $name = shift;
$name =~ s/^::/main::/;
my $pkg = caller;
my $full_name = $name =~ /::/ ? $name : "${pkg}::$name";
$constant::declared{$full_name};
}
=head1 CAVEATS
In the current version of Perl, list constants are not inlined
and some symbols may be redefined without generating a warning.
It is not possible to have a subroutine or a keyword with the same
name as a constant in the same package. This is probably a Good Thing.
A constant with a name in the list C<STDIN STDOUT STDERR ARGV ARGVOUT
ENV INC SIG> is not allowed anywhere but in package C<main::>, for
technical reasons.
Unlike constants in some languages, these cannot be overridden
on the command line or via environment variables.
You can get into trouble if you use constants in a context which
automatically quotes barewords (as is true for any subroutine call).
For example, you can't say C<$hash{CONSTANT}> because C<CONSTANT> will
be interpreted as a string. Use C<$hash{CONSTANT()}> or
C<$hash{+CONSTANT}> to prevent the bareword quoting mechanism from
kicking in. Similarly, since the C<< => >> operator quotes a bareword
immediately to its left, you have to say C<< CONSTANT() => 'value' >>
(or simply use a comma in place of the big arrow) instead of
C<< CONSTANT => 'value' >>.
=head1 SEE ALSO
L<Readonly> - Facility for creating read-only scalars, arrays, hashes.
L<Attribute::Constant> - Make read-only variables via attribute
L<Scalar::Readonly> - Perl extension to the C<SvREADONLY> scalar flag
L<Hash::Util> - A selection of general-utility hash subroutines (mostly
to lock/unlock keys and values)
=head1 BUGS
Please report any bugs or feature requests via the perlbug(1) utility.
=head1 AUTHORS
Tom Phoenix, E<lt>F<rootbeer@redcat.com>E<gt>, with help from
many other folks.
Multiple constant declarations at once added by Casey West,
E<lt>F<casey@geeknest.com>E<gt>.
Documentation mostly rewritten by Ilmari Karonen,
E<lt>F<perl@itz.pp.sci.fi>E<gt>.
This program is maintained by the Perl 5 Porters.
The CPAN distribution is maintained by SE<eacute>bastien Aperghis-Tramoni
E<lt>F<sebastien@aperghis.net>E<gt>.
=head1 COPYRIGHT & LICENSE
Copyright (C) 1997, 1999 Tom Phoenix
This module is free software; you can redistribute it or modify it
under the same terms as Perl itself.
=cut
CONSTANT
$fatpacked{"darwin-2level/Cwd.pm"} = <<'DARWIN-2LEVEL_CWD';
package Cwd;
=head1 NAME
Cwd - get pathname of current working directory
=head1 SYNOPSIS
use Cwd;
my $dir = getcwd;
use Cwd 'abs_path';
my $abs_path = abs_path($file);
=head1 DESCRIPTION
This module provides functions for determining the pathname of the
current working directory. It is recommended that getcwd (or another
*cwd() function) be used in I<all> code to ensure portability.
By default, it exports the functions cwd(), getcwd(), fastcwd(), and
fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace.
=head2 getcwd and friends
Each of these functions are called without arguments and return the
absolute path of the current working directory.
=over 4
=item getcwd
my $cwd = getcwd();
Returns the current working directory.
Exposes the POSIX function getcwd(3) or re-implements it if it's not
available.
=item cwd
my $cwd = cwd();
The cwd() is the most natural form for the current architecture. For
most systems it is identical to `pwd` (but without the trailing line
terminator).
=item fastcwd
my $cwd = fastcwd();
A more dangerous version of getcwd(), but potentially faster.
It might conceivably chdir() you out of a directory that it can't
chdir() you back into. If fastcwd encounters a problem it will return
undef but will probably leave you in a different directory. For a
measure of extra security, if everything appears to have worked, the
fastcwd() function will check that it leaves you in the same directory
that it started in. If it has changed it will C<die> with the message
"Unstable directory path, current directory changed
unexpectedly". That should never happen.
=item fastgetcwd
my $cwd = fastgetcwd();
The fastgetcwd() function is provided as a synonym for cwd().
=item getdcwd
my $cwd = getdcwd();
my $cwd = getdcwd('C:');
The getdcwd() function is also provided on Win32 to get the current working
directory on the specified drive, since Windows maintains a separate current
working directory for each drive. If no drive is specified then the current
drive is assumed.
This function simply calls the Microsoft C library _getdcwd() function.
=back
=head2 abs_path and friends
These functions are exported only on request. They each take a single
argument and return the absolute pathname for it. If no argument is
given they'll use the current working directory.
=over 4
=item abs_path
my $abs_path = abs_path($file);
Uses the same algorithm as getcwd(). Symbolic links and relative-path
components ("." and "..") are resolved to return the canonical
pathname, just like realpath(3).
=item realpath
my $abs_path = realpath($file);
A synonym for abs_path().
=item fast_abs_path
my $abs_path = fast_abs_path($file);
A more dangerous, but potentially faster version of abs_path.
=back
=head2 $ENV{PWD}
If you ask to override your chdir() built-in function,
use Cwd qw(chdir);
then your PWD environment variable will be kept up to date. Note that
it will only be kept up to date if all packages which use chdir import
it from Cwd.
=head1 NOTES
=over 4
=item *
Since the path separators are different on some operating systems ('/'
on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
modules wherever portability is a concern.
=item *
Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
functions are all aliases for the C<cwd()> function, which, on Mac OS,
calls `pwd`. Likewise, the C<abs_path()> function is an alias for
C<fast_abs_path()>.
=back
=head1 AUTHOR
Originally by the perl5-porters.
Maintained by Ken Williams <KWILLIAMS@cpan.org>
=head1 COPYRIGHT
Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
Portions of the C code in this library are copyright (c) 1994 by the
Regents of the University of California. All rights reserved. The
license on this code is compatible with the licensing of the rest of
the distribution - please see the source code in F<Cwd.xs> for the
details.
=head1 SEE ALSO
L<File::chdir>
=cut
use strict;
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
$VERSION = '3.40';
my $xs_version = $VERSION;
$VERSION =~ tr/_//;
@ISA = qw/ Exporter /;
@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32';
@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
# sys_cwd may keep the builtin command
# All the functionality of this module may provided by builtins,
# there is no sense to process the rest of the file.
# The best choice may be to have this in BEGIN, but how to return from BEGIN?
if ($^O eq 'os2') {
local $^W = 0;
*cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
*getcwd = \&cwd;
*fastgetcwd = \&cwd;
*fastcwd = \&cwd;
*fast_abs_path = \&sys_abspath if defined &sys_abspath;
*abs_path = \&fast_abs_path;
*realpath = \&fast_abs_path;
*fast_realpath = \&fast_abs_path;
return 1;
}
# Need to look up the feature settings on VMS. The preferred way is to use the
# VMS::Feature module, but that may not be available to dual life modules.
my $use_vms_feature;
BEGIN {
if ($^O eq 'VMS') {
if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
$use_vms_feature = 1;
}
}
}
# Need to look up the UNIX report mode. This may become a dynamic mode
# in the future.
sub _vms_unix_rpt {
my $unix_rpt;
if ($use_vms_feature) {
$unix_rpt = VMS::Feature::current("filename_unix_report");
} else {
my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
$unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
}
return $unix_rpt;
}
# Need to look up the EFS character set mode. This may become a dynamic
# mode in the future.
sub _vms_efs {
my $efs;
if ($use_vms_feature) {
$efs = VMS::Feature::current("efs_charset");
} else {
my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
$efs = $env_efs =~ /^[ET1]/i;
}
return $efs;
}
# If loading the XS stuff doesn't work, we can fall back to pure perl
eval {
if ( $] >= 5.006 ) {
require XSLoader;
XSLoader::load( __PACKAGE__, $xs_version);
} else {
require DynaLoader;
push @ISA, 'DynaLoader';
__PACKAGE__->bootstrap( $xs_version );
}
};
# Big nasty table of function aliases
my %METHOD_MAP =
(
VMS =>
{
cwd => '_vms_cwd',
getcwd => '_vms_cwd',
fastcwd => '_vms_cwd',
fastgetcwd => '_vms_cwd',
abs_path => '_vms_abs_path',
fast_abs_path => '_vms_abs_path',
},
MSWin32 =>
{
# We assume that &_NT_cwd is defined as an XSUB or in the core.
cwd => '_NT_cwd',
getcwd => '_NT_cwd',
fastcwd => '_NT_cwd',
fastgetcwd => '_NT_cwd',
abs_path => 'fast_abs_path',
realpath => 'fast_abs_path',
},
dos =>
{
cwd => '_dos_cwd',
getcwd => '_dos_cwd',
fastgetcwd => '_dos_cwd',
fastcwd => '_dos_cwd',
abs_path => 'fast_abs_path',
},
# QNX4. QNX6 has a $os of 'nto'.
qnx =>
{
cwd => '_qnx_cwd',
getcwd => '_qnx_cwd',
fastgetcwd => '_qnx_cwd',
fastcwd => '_qnx_cwd',
abs_path => '_qnx_abs_path',
fast_abs_path => '_qnx_abs_path',
},
cygwin =>
{
getcwd => 'cwd',
fastgetcwd => 'cwd',
fastcwd => 'cwd',
abs_path => 'fast_abs_path',
realpath => 'fast_abs_path',
},
epoc =>
{
cwd => '_epoc_cwd',
getcwd => '_epoc_cwd',
fastgetcwd => '_epoc_cwd',
fastcwd => '_epoc_cwd',
abs_path => 'fast_abs_path',
},
MacOS =>
{
getcwd => 'cwd',
fastgetcwd => 'cwd',
fastcwd => 'cwd',
abs_path => 'fast_abs_path',
},
);
$METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
# Find the pwd command in the expected locations. We assume these
# are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
# so everything works under taint mode.
my $pwd_cmd;
foreach my $try ('/bin/pwd',
'/usr/bin/pwd',
'/QOpenSys/bin/pwd', # OS/400 PASE.
) {
if( -x $try ) {
$pwd_cmd = $try;
last;
}
}
my $found_pwd_cmd = defined($pwd_cmd);
unless ($pwd_cmd) {
# Isn't this wrong? _backtick_pwd() will fail if somenone has
# pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
# See [perl #16774]. --jhi
$pwd_cmd = 'pwd';
}
# Lazy-load Carp
sub _carp { require Carp; Carp::carp(@_) }
sub _croak { require Carp; Carp::croak(@_) }
# The 'natural and safe form' for UNIX (pwd may be setuid root)
sub _backtick_pwd {
# Localize %ENV entries in a way that won't create new hash keys
my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV);
local @ENV{@localize};
my $cwd = `$pwd_cmd`;
# Belt-and-suspenders in case someone said "undef $/".
local $/ = "\n";
# `pwd` may fail e.g. if the disk is full
chomp($cwd) if defined $cwd;
$cwd;
}
# Since some ports may predefine cwd internally (e.g., NT)
# we take care not to override an existing definition for cwd().
unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
# The pwd command is not available in some chroot(2)'ed environments
my $sep = $Config::Config{path_sep} || ':';
my $os = $^O; # Protect $^O from tainting
# Try again to find a pwd, this time searching the whole PATH.
if (defined $ENV{PATH} and $os ne 'MSWin32') { # no pwd on Windows
my @candidates = split($sep, $ENV{PATH});
while (!$found_pwd_cmd and @candidates) {
my $candidate = shift @candidates;
$found_pwd_cmd = 1 if -x "$candidate/pwd";
}
}
# MacOS has some special magic to make `pwd` work.
if( $os eq 'MacOS' || $found_pwd_cmd )
{
*cwd = \&_backtick_pwd;
}
else {
*cwd = \&getcwd;
}
}
if ($^O eq 'cygwin') {
# We need to make sure cwd() is called with no args, because it's
# got an arg-less prototype and will die if args are present.
local $^W = 0;
my $orig_cwd = \&cwd;
*cwd = sub { &$orig_cwd() }
}
# set a reasonable (and very safe) default for fastgetcwd, in case it
# isn't redefined later (20001212 rspier)
*fastgetcwd = \&cwd;
# A non-XS version of getcwd() - also used to bootstrap the perl build
# process, when miniperl is running and no XS loading happens.
sub _perl_getcwd
{
abs_path('.');
}
# By John Bazik
#
# Usage: $cwd = &fastcwd;
#
# This is a faster version of getcwd. It's also more dangerous because
# you might chdir out of a directory that you can't chdir back into.
sub fastcwd_ {
my($odev, $oino, $cdev, $cino, $tdev, $tino);
my(@path, $path);
local(*DIR);
my($orig_cdev, $orig_cino) = stat('.');
($cdev, $cino) = ($orig_cdev, $orig_cino);
for (;;) {
my $direntry;
($odev, $oino) = ($cdev, $cino);
CORE::chdir('..') || return undef;
($cdev, $cino) = stat('.');
last if $odev == $cdev && $oino == $cino;
opendir(DIR, '.') || return undef;
for (;;) {
$direntry = readdir(DIR);
last unless defined $direntry;
next if $direntry eq '.';
next if $direntry eq '..';
($tdev, $tino) = lstat($direntry);
last unless $tdev != $odev || $tino != $oino;
}
closedir(DIR);
return undef unless defined $direntry; # should never happen
unshift(@path, $direntry);
}
$path = '/' . join('/', @path);
if ($^O eq 'apollo') { $path = "/".$path; }
# At this point $path may be tainted (if tainting) and chdir would fail.
# Untaint it then check that we landed where we started.
$path =~ /^(.*)\z/s # untaint
&& CORE::chdir($1) or return undef;
($cdev, $cino) = stat('.');
die "Unstable directory path, current directory changed unexpectedly"
if $cdev != $orig_cdev || $cino != $orig_cino;
$path;
}
if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
# Keeps track of current working directory in PWD environment var
# Usage:
# use Cwd 'chdir';
# chdir $newdir;
my $chdir_init = 0;
sub chdir_init {
if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
my($dd,$di) = stat('.');
my($pd,$pi) = stat($ENV{'PWD'});
if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
$ENV{'PWD'} = cwd();
}
}
else {
my $wd = cwd();
$wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
$ENV{'PWD'} = $wd;
}
# Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
my($pd,$pi) = stat($2);
my($dd,$di) = stat($1);
if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
$ENV{'PWD'}="$2$3";
}
}
$chdir_init = 1;
}
sub chdir {
my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
$newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
chdir_init() unless $chdir_init;
my $newpwd;
if ($^O eq 'MSWin32') {
# get the full path name *before* the chdir()
$newpwd = Win32::GetFullPathName($newdir);
}
return 0 unless CORE::chdir $newdir;
if ($^O eq 'VMS') {
return $ENV{'PWD'} = $ENV{'DEFAULT'}
}
elsif ($^O eq 'MacOS') {
return $ENV{'PWD'} = cwd();
}
elsif ($^O eq 'MSWin32') {
$ENV{'PWD'} = $newpwd;
return 1;
}
if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in
$ENV{'PWD'} = cwd();
} elsif ($newdir =~ m#^/#s) {
$ENV{'PWD'} = $newdir;
} else {
my @curdir = split(m#/#,$ENV{'PWD'});
@curdir = ('') unless @curdir;
my $component;
foreach $component (split(m#/#, $newdir)) {
next if $component eq '.';
pop(@curdir),next if $component eq '..';
push(@curdir,$component);
}
$ENV{'PWD'} = join('/',@curdir) || '/';
}
1;
}
sub _perl_abs_path
{
my $start = @_ ? shift : '.';
my($dotdots, $cwd, @pst, @cst, $dir, @tst);
unless (@cst = stat( $start ))
{
_carp("stat($start): $!");
return '';
}
unless (-d _) {
# Make sure we can be invoked on plain files, not just directories.
# NOTE that this routine assumes that '/' is the only directory separator.
my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
or return cwd() . '/' . $start;
# Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
if (-l $start) {
my $link_target = readlink($start);
die "Can't resolve link $start: $!" unless defined $link_target;
require File::Spec;
$link_target = $dir . '/' . $link_target
unless File::Spec->file_name_is_absolute($link_target);
return abs_path($link_target);
}
return $dir ? abs_path($dir) . "/$file" : "/$file";
}
$cwd = '';
$dotdots = $start;
do
{
$dotdots .= '/..';
@pst = @cst;
local *PARENT;
unless (opendir(PARENT, $dotdots))
{
# probably a permissions issue. Try the native command.
require File::Spec;
return File::Spec->rel2abs( $start, _backtick_pwd() );
}
unless (@cst = stat($dotdots))
{
_carp("stat($dotdots): $!");
closedir(PARENT);
return '';
}
if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
{
$dir = undef;
}
else
{
do
{
unless (defined ($dir = readdir(PARENT)))
{
_carp("readdir($dotdots): $!");
closedir(PARENT);
return '';
}
$tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
}
while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
$tst[1] != $pst[1]);
}
$cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
closedir(PARENT);
} while (defined $dir);
chop($cwd) unless $cwd eq '/'; # drop the trailing /
$cwd;
}
my $Curdir;
sub fast_abs_path {
local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
my $cwd = getcwd();
require File::Spec;
my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
# Detaint else we'll explode in taint mode. This is safe because
# we're not doing anything dangerous with it.
($path) = $path =~ /(.*)/s;
($cwd) = $cwd =~ /(.*)/s;
unless (-e $path) {
_croak("$path: No such file or directory");
}
unless (-d _) {
# Make sure we can be invoked on plain files, not just directories.
my ($vol, $dir, $file) = File::Spec->splitpath($path);
return File::Spec->catfile($cwd, $path) unless length $dir;
if (-l $path) {
my $link_target = readlink($path);
die "Can't resolve link $path: $!" unless defined $link_target;
$link_target = File::Spec->catpath($vol, $dir, $link_target)
unless File::Spec->file_name_is_absolute($link_target);
return fast_abs_path($link_target);
}
return $dir eq File::Spec->rootdir
? File::Spec->catpath($vol, $dir, $file)
: fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
}
if (!CORE::chdir($path)) {
_croak("Cannot chdir to $path: $!");
}
my $realpath = getcwd();
if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
_croak("Cannot chdir back to $cwd: $!");
}
$realpath;
}
# added function alias to follow principle of least surprise
# based on previous aliasing. --tchrist 27-Jan-00
*fast_realpath = \&fast_abs_path;
# --- PORTING SECTION ---
# VMS: $ENV{'DEFAULT'} points to default directory at all times
# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu
# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
# in the process logical name table as the default device and directory
# seen by Perl. This may not be the same as the default device
# and directory seen by DCL after Perl exits, since the effects
# the CRTL chdir() function persist only until Perl exits.
sub _vms_cwd {
return $ENV{'DEFAULT'};
}
sub _vms_abs_path {
return $ENV{'DEFAULT'} unless @_;
my $path = shift;
my $efs = _vms_efs;
my $unix_rpt = _vms_unix_rpt;
if (defined &VMS::Filespec::vmsrealpath) {
my $path_unix = 0;
my $path_vms = 0;
$path_unix = 1 if ($path =~ m#(?<=\^)/#);
$path_unix = 1 if ($path =~ /^\.\.?$/);
$path_vms = 1 if ($path =~ m#[\[<\]]#);
$path_vms = 1 if ($path =~ /^--?$/);
my $unix_mode = $path_unix;
if ($efs) {
# In case of a tie, the Unix report mode decides.
if ($path_vms == $path_unix) {
$unix_mode = $unix_rpt;
} else {
$unix_mode = 0 if $path_vms;
}
}
if ($unix_mode) {
# Unix format
return VMS::Filespec::unixrealpath($path);
}
# VMS format
my $new_path = VMS::Filespec::vmsrealpath($path);
# Perl expects directories to be in directory format
$new_path = VMS::Filespec::pathify($new_path) if -d $path;
return $new_path;
}
# Fallback to older algorithm if correct ones are not
# available.
if (-l $path) {
my $link_target = readlink($path);
die "Can't resolve link $path: $!" unless defined $link_target;
return _vms_abs_path($link_target);
}
# may need to turn foo.dir into [.foo]
my $pathified = VMS::Filespec::pathify($path);
$path = $pathified if defined $pathified;
return VMS::Filespec::rmsexpand($path);
}
sub _os2_cwd {
$ENV{'PWD'} = `cmd /c cd`;
chomp $ENV{'PWD'};
$ENV{'PWD'} =~ s:\\:/:g ;
return $ENV{'PWD'};
}
sub _win32_cwd_simple {
$ENV{'PWD'} = `cd`;
chomp $ENV{'PWD'};
$ENV{'PWD'} =~ s:\\:/:g ;
return $ENV{'PWD'};
}
sub _win32_cwd {
# Need to avoid taking any sort of reference to the typeglob or the code in
# the optree, so that this tests the runtime state of things, as the
# ExtUtils::MakeMaker tests for "miniperl" need to be able to fake things at
# runtime by deleting the subroutine. *foo{THING} syntax on a symbol table
# lookup avoids needing a string eval, which has been reported to cause
# problems (for reasons that we haven't been able to get to the bottom of -
# rt.cpan.org #56225)
if (*{$DynaLoader::{boot_DynaLoader}}{CODE}) {
$ENV{'PWD'} = Win32::GetCwd();
}
else { # miniperl
chomp($ENV{'PWD'} = `cd`);
}
$ENV{'PWD'} =~ s:\\:/:g ;
return $ENV{'PWD'};
}
*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_win32_cwd_simple;
sub _dos_cwd {
if (!defined &Dos::GetCwd) {
$ENV{'PWD'} = `command /c cd`;
chomp $ENV{'PWD'};
$ENV{'PWD'} =~ s:\\:/:g ;
} else {
$ENV{'PWD'} = Dos::GetCwd();
}
return $ENV{'PWD'};
}
sub _qnx_cwd {
local $ENV{PATH} = '';
local $ENV{CDPATH} = '';
local $ENV{ENV} = '';
$ENV{'PWD'} = `/usr/bin/fullpath -t`;
chomp $ENV{'PWD'};
return $ENV{'PWD'};
}
sub _qnx_abs_path {
local $ENV{PATH} = '';
local $ENV{CDPATH} = '';
local $ENV{ENV} = '';
my $path = @_ ? shift : '.';
local *REALPATH;
defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
die "Can't open /usr/bin/fullpath: $!";
my $realpath = <REALPATH>;
close REALPATH;
chomp $realpath;
return $realpath;
}
sub _epoc_cwd {
$ENV{'PWD'} = EPOC::getcwd();
return $ENV{'PWD'};
}
# Now that all the base-level functions are set up, alias the
# user-level functions to the right places
if (exists $METHOD_MAP{$^O}) {
my $map = $METHOD_MAP{$^O};
foreach my $name (keys %$map) {
local $^W = 0; # assignments trigger 'subroutine redefined' warning
no strict 'refs';
*{$name} = \&{$map->{$name}};
}
}
# In case the XS version doesn't load.
*abs_path = \&_perl_abs_path unless defined &abs_path;
*getcwd = \&_perl_getcwd unless defined &getcwd;
# added function alias for those of us more
# used to the libc function. --tchrist 27-Jan-00
*realpath = \&abs_path;
1;
DARWIN-2LEVEL_CWD
$fatpacked{"darwin-2level/Encode.pm"} = <<'DARWIN-2LEVEL_ENCODE';
#
# $Id: Encode.pm,v 2.49 2013/03/05 03:13:47 dankogai Exp dankogai $
#
package Encode;
use strict;
use warnings;
our $VERSION = sprintf "%d.%02d", q$Revision: 2.49 $ =~ /(\d+)/g;
use constant DEBUG => !!$ENV{PERL_ENCODE_DEBUG};
use XSLoader ();
XSLoader::load( __PACKAGE__, $VERSION );
require Exporter;
use base qw/Exporter/;
# Public, encouraged API is exported by default
our @EXPORT = qw(
decode decode_utf8 encode encode_utf8 str2bytes bytes2str
encodings find_encoding clone_encoding
);
our @FB_FLAGS = qw(
DIE_ON_ERR WARN_ON_ERR RETURN_ON_ERR LEAVE_SRC
PERLQQ HTMLCREF XMLCREF STOP_AT_PARTIAL
);
our @FB_CONSTS = qw(
FB_DEFAULT FB_CROAK FB_QUIET FB_WARN
FB_PERLQQ FB_HTMLCREF FB_XMLCREF
);
our @EXPORT_OK = (
qw(
_utf8_off _utf8_on define_encoding from_to is_16bit is_8bit
is_utf8 perlio_ok resolve_alias utf8_downgrade utf8_upgrade
),
@FB_FLAGS, @FB_CONSTS,
);
our %EXPORT_TAGS = (
all => [ @EXPORT, @EXPORT_OK ],
default => [ @EXPORT ],
fallbacks => [ @FB_CONSTS ],
fallback_all => [ @FB_CONSTS, @FB_FLAGS ],
);
# Documentation moved after __END__ for speed - NI-S
our $ON_EBCDIC = ( ord("A") == 193 );
use Encode::Alias;
# Make a %Encoding package variable to allow a certain amount of cheating
our %Encoding;
our %ExtModule;
require Encode::Config;
# See
# https://bugzilla.redhat.com/show_bug.cgi?id=435505#c2
# to find why sig handers inside eval{} are disabled.
eval {
local $SIG{__DIE__};
local $SIG{__WARN__};
require Encode::ConfigLocal;
};
sub encodings {
my %enc;
my $arg = $_[1] || '';
if ( $arg eq ":all" ) {
%enc = ( %Encoding, %ExtModule );
}
else {
%enc = %Encoding;
for my $mod ( map { m/::/ ? $_ : "Encode::$_" } @_ ) {
DEBUG and warn $mod;
for my $enc ( keys %ExtModule ) {
$ExtModule{$enc} eq $mod and $enc{$enc} = $mod;
}
}
}
return sort { lc $a cmp lc $b }
grep { !/^(?:Internal|Unicode|Guess)$/o } keys %enc;
}
sub perlio_ok {
my $obj = ref( $_[0] ) ? $_[0] : find_encoding( $_[0] );
$obj->can("perlio_ok") and return $obj->perlio_ok();
return 0; # safety net
}
sub define_encoding {
my $obj = shift;
my $name = shift;
$Encoding{$name} = $obj;
my $lc = lc($name);
define_alias( $lc => $obj ) unless $lc eq $name;
while (@_) {
my $alias = shift;
define_alias( $alias, $obj );
}
return $obj;
}
sub getEncoding {
my ( $class, $name, $skip_external ) = @_;
$name =~ s/\s+//g; # https://rt.cpan.org/Ticket/Display.html?id=65796
ref($name) && $name->can('renew') and return $name;
exists $Encoding{$name} and return $Encoding{$name};
my $lc = lc $name;
exists $Encoding{$lc} and return $Encoding{$lc};
my $oc = $class->find_alias($name);
defined($oc) and return $oc;
$lc ne $name and $oc = $class->find_alias($lc);
defined($oc) and return $oc;
unless ($skip_external) {
if ( my $mod = $ExtModule{$name} || $ExtModule{$lc} ) {
$mod =~ s,::,/,g;
$mod .= '.pm';
eval { require $mod; };
exists $Encoding{$name} and return $Encoding{$name};
}
}
return;
}
sub find_encoding($;$) {
my ( $name, $skip_external ) = @_;
return __PACKAGE__->getEncoding( $name, $skip_external );
}
sub resolve_alias($) {
my $obj = find_encoding(shift);
defined $obj and return $obj->name;
return;
}
sub clone_encoding($) {
my $obj = find_encoding(shift);
ref $obj or return;
eval { require Storable };
$@ and return;
return Storable::dclone($obj);
}
sub encode($$;$) {
my ( $name, $string, $check ) = @_;
return undef unless defined $string;
$string .= ''; # stringify;
$check ||= 0;
unless ( defined $name ) {
require Carp;
Carp::croak("Encoding name should not be undef");
}
my $enc = find_encoding($name);
unless ( defined $enc ) {
require Carp;
Carp::croak("Unknown encoding '$name'");
}
my $octets = $enc->encode( $string, $check );
$_[1] = $string if $check and !ref $check and !( $check & LEAVE_SRC() );
return $octets;
}
*str2bytes = \&encode;
sub decode($$;$) {
my ( $name, $octets, $check ) = @_;
return undef unless defined $octets;
$octets .= '';
$check ||= 0;
my $enc = find_encoding($name);
unless ( defined $enc ) {
require Carp;
Carp::croak("Unknown encoding '$name'");
}
my $string = $enc->decode( $octets, $check );
$_[1] = $octets if $check and !ref $check and !( $check & LEAVE_SRC() );
return $string;
}
*bytes2str = \&decode;
sub from_to($$$;$) {
my ( $string, $from, $to, $check ) = @_;
return undef unless defined $string;
$check ||= 0;
my $f = find_encoding($from);
unless ( defined $f ) {
require Carp;
Carp::croak("Unknown encoding '$from'");
}
my $t = find_encoding($to);
unless ( defined $t ) {
require Carp;
Carp::croak("Unknown encoding '$to'");
}
my $uni = $f->decode($string);
$_[0] = $string = $t->encode( $uni, $check );
return undef if ( $check && length($uni) );
return defined( $_[0] ) ? length($string) : undef;
}
sub encode_utf8($) {
my ($str) = @_;
utf8::encode($str);
return $str;
}
my $utf8enc;
sub decode_utf8($;$) {
my ( $octets, $check ) = @_;
return $octets if is_utf8($octets);
return undef unless defined $octets;
$octets .= '' if ref $octets;
$check ||= 0;
$utf8enc ||= find_encoding('utf8');
my $string = $utf8enc->decode( $octets, $check );
$_[0] = $octets if $check and !ref $check and !( $check & LEAVE_SRC() );
return $string;
}
# sub decode_utf8($;$) {
# my ( $str, $check ) = @_;
# return $str if is_utf8($str);
# if ($check) {
# return decode( "utf8", $str, $check );
# }
# else {
# return decode( "utf8", $str );
# return $str;
# }
# }
predefine_encodings(1);
#
# This is to restore %Encoding if really needed;
#
sub predefine_encodings {
require Encode::Encoding;
no warnings 'redefine';
my $use_xs = shift;
if ($ON_EBCDIC) {
# was in Encode::UTF_EBCDIC
package Encode::UTF_EBCDIC;
push @Encode::UTF_EBCDIC::ISA, 'Encode::Encoding';
*decode = sub {
my ( undef, $str, $chk ) = @_;
my $res = '';
for ( my $i = 0 ; $i < length($str) ; $i++ ) {
$res .=
chr(
utf8::unicode_to_native( ord( substr( $str, $i, 1 ) ) )
);
}
$_[1] = '' if $chk;
return $res;
};
*encode = sub {
my ( undef, $str, $chk ) = @_;
my $res = '';
for ( my $i = 0 ; $i < length($str) ; $i++ ) {
$res .=
chr(
utf8::native_to_unicode( ord( substr( $str, $i, 1 ) ) )
);
}
$_[1] = '' if $chk;
return $res;
};
$Encode::Encoding{Unicode} =
bless { Name => "UTF_EBCDIC" } => "Encode::UTF_EBCDIC";
}
else {
package Encode::Internal;
push @Encode::Internal::ISA, 'Encode::Encoding';
*decode = sub {
my ( undef, $str, $chk ) = @_;
utf8::upgrade($str);
$_[1] = '' if $chk;
return $str;
};
*encode = \&decode;
$Encode::Encoding{Unicode} =
bless { Name => "Internal" } => "Encode::Internal";
}
{
# was in Encode::utf8
package Encode::utf8;
push @Encode::utf8::ISA, 'Encode::Encoding';
#
if ($use_xs) {
Encode::DEBUG and warn __PACKAGE__, " XS on";
*decode = \&decode_xs;
*encode = \&encode_xs;
}
else {
Encode::DEBUG and warn __PACKAGE__, " XS off";
*decode = sub {
my ( undef, $octets, $chk ) = @_;
my $str = Encode::decode_utf8($octets);
if ( defined $str ) {
$_[1] = '' if $chk;
return $str;
}
return undef;
};
*encode = sub {
my ( undef, $string, $chk ) = @_;
my $octets = Encode::encode_utf8($string);
$_[1] = '' if $chk;
return $octets;
};
}
*cat_decode = sub { # ($obj, $dst, $src, $pos, $trm, $chk)
# currently ignores $chk
my ( undef, undef, undef, $pos, $trm ) = @_;
my ( $rdst, $rsrc, $rpos ) = \@_[ 1, 2, 3 ];
use bytes;
if ( ( my $npos = index( $$rsrc, $trm, $pos ) ) >= 0 ) {
$$rdst .=
substr( $$rsrc, $pos, $npos - $pos + length($trm) );
$$rpos = $npos + length($trm);
return 1;
}
$$rdst .= substr( $$rsrc, $pos );
$$rpos = length($$rsrc);
return '';
};
$Encode::Encoding{utf8} =
bless { Name => "utf8" } => "Encode::utf8";
$Encode::Encoding{"utf-8-strict"} =
bless { Name => "utf-8-strict", strict_utf8 => 1 }
=> "Encode::utf8";
}
}
1;
__END__
=head1 NAME
Encode - character encodings in Perl
=head1 SYNOPSIS
use Encode qw(decode encode);
$characters = decode('UTF-8', $octets, Encode::FB_CROAK);
$octets = encode('UTF-8', $characters, Encode::FB_CROAK);
=head2 Table of Contents
Encode consists of a collection of modules whose details are too extensive
to fit in one document. This one itself explains the top-level APIs
and general topics at a glance. For other topics and more details,
see the documentation for these modules:
=over 2
=item L<Encode::Alias> - Alias definitions to encodings
=item L<Encode::Encoding> - Encode Implementation Base Class
=item L<Encode::Supported> - List of Supported Encodings
=item L<Encode::CN> - Simplified Chinese Encodings
=item L<Encode::JP> - Japanese Encodings
=item L<Encode::KR> - Korean Encodings
=item L<Encode::TW> - Traditional Chinese Encodings
=back
=head1 DESCRIPTION
The C<Encode> module provides the interface between Perl strings
and the rest of the system. Perl strings are sequences of
I<characters>.
The repertoire of characters that Perl can represent is a superset of those
defined by the Unicode Consortium. On most platforms the ordinal
values of a character as returned by C<ord(I<S>)> is the I<Unicode
codepoint> for that character. The exceptions are platforms where
the legacy encoding is some variant of EBCDIC rather than a superset
of ASCII; see L<perlebcdic>.
During recent history, data is moved around a computer in 8-bit chunks,
often called "bytes" but also known as "octets" in standards documents.
Perl is widely used to manipulate data of many types: not only strings of
characters representing human or computer languages, but also "binary"
data, being the machine's representation of numbers, pixels in an image, or
just about anything.
When Perl is processing "binary data", the programmer wants Perl to
process "sequences of bytes". This is not a problem for Perl: because a
byte has 256 possible values, it easily fits in Perl's much larger
"logical character".
This document mostly explains the I<how>. L<perlunitut> and L<perlunifaq>
explain the I<why>.
=head2 TERMINOLOGY
=head3 character
A character in the range 0 .. 2**32-1 (or more);
what Perl's strings are made of.
=head3 byte
A character in the range 0..255;
a special case of a Perl character.
=head3 octet
8 bits of data, with ordinal values 0..255;
term for bytes passed to or from a non-Perl context, such as a disk file,
standard I/O stream, database, command-line argument, environment variable,
socket etc.
=head1 THE PERL ENCODING API
=head2 Basic methods
=head3 encode
$octets = encode(ENCODING, STRING[, CHECK])
Encodes the scalar value I<STRING> from Perl's internal form into
I<ENCODING> and returns a sequence of octets. I<ENCODING> can be either a
canonical name or an alias. For encoding names and aliases, see
L</"Defining Aliases">. For CHECK, see L</"Handling Malformed Data">.
For example, to convert a string from Perl's internal format into
ISO-8859-1, also known as Latin1:
$octets = encode("iso-8859-1", $string);
B<CAVEAT>: When you run C<$octets = encode("utf8", $string)>, then
$octets I<might not be equal to> $string. Though both contain the
same data, the UTF8 flag for $octets is I<always> off. When you
encode anything, the UTF8 flag on the result is always off, even when it
contains a completely valid utf8 string. See L</"The UTF8 flag"> below.
If the $string is C<undef>, then C<undef> is returned.
=head3 decode
$string = decode(ENCODING, OCTETS[, CHECK])
This function returns the string that results from decoding the scalar
value I<OCTETS>, assumed to be a sequence of octets in I<ENCODING>, into
Perl's internal form. The returns the resulting string. As with encode(),
I<ENCODING> can be either a canonical name or an alias. For encoding names
and aliases, see L</"Defining Aliases">; for I<CHECK>, see L</"Handling
Malformed Data">.
For example, to convert ISO-8859-1 data into a string in Perl's
internal format:
$string = decode("iso-8859-1", $octets);
B<CAVEAT>: When you run C<$string = decode("utf8", $octets)>, then $string
I<might not be equal to> $octets. Though both contain the same data, the
UTF8 flag for $string is on unless $octets consists entirely of ASCII data
on ASCII machines or EBCDIC on EBCDIC machines. See L</"The UTF8 flag">
below.
If the $string is C<undef>, then C<undef> is returned.
=head3 find_encoding
[$obj =] find_encoding(ENCODING)
Returns the I<encoding object> corresponding to I<ENCODING>. Returns
C<undef> if no matching I<ENCODING> is find. The returned object is
what does the actual encoding or decoding.
$utf8 = decode($name, $bytes);
is in fact
$utf8 = do {
$obj = find_encoding($name);
croak qq(encoding "$name" not found) unless ref $obj;
$obj->decode($bytes);
};
with more error checking.
You can therefore save time by reusing this object as follows;
my $enc = find_encoding("iso-8859-1");
while(<>) {
my $utf8 = $enc->decode($_);
... # now do something with $utf8;
}
Besides L</decode> and L</encode>, other methods are
available as well. For instance, C<name()> returns the canonical
name of the encoding object.
find_encoding("latin1")->name; # iso-8859-1
See L<Encode::Encoding> for details.
=head3 from_to
[$length =] from_to($octets, FROM_ENC, TO_ENC [, CHECK])
Converts I<in-place> data between two encodings. The data in $octets
must be encoded as octets and I<not> as characters in Perl's internal
format. For example, to convert ISO-8859-1 data into Microsoft's CP1250
encoding:
from_to($octets, "iso-8859-1", "cp1250");
and to convert it back:
from_to($octets, "cp1250", "iso-8859-1");
Because the conversion happens in place, the data to be
converted cannot be a string constant: it must be a scalar variable.
C<from_to()> returns the length of the converted string in octets on success,
and C<undef> on error.
B<CAVEAT>: The following operations may look the same, but are not:
from_to($data, "iso-8859-1", "utf8"); #1
$data = decode("iso-8859-1", $data); #2
Both #1 and #2 make $data consist of a completely valid UTF-8 string,
but only #2 turns the UTF8 flag on. #1 is equivalent to:
$data = encode("utf8", decode("iso-8859-1", $data));
See L</"The UTF8 flag"> below.
Also note that:
from_to($octets, $from, $to, $check);
is equivalent t:o
$octets = encode($to, decode($from, $octets), $check);
Yes, it does I<not> respect the $check during decoding. It is
deliberately done that way. If you need minute control, use C<decode>
followed by C<encode> as follows:
$octets = encode($to, decode($from, $octets, $check_from), $check_to);
=head3 encode_utf8
$octets = encode_utf8($string);
Equivalent to C<$octets = encode("utf8", $string)>. The characters in
$string are encoded in Perl's internal format, and the result is returned
as a sequence of octets. Because all possible characters in Perl have a
(loose, not strict) UTF-8 representation, this function cannot fail.
=head3 decode_utf8
$string = decode_utf8($octets [, CHECK]);
Equivalent to C<$string = decode("utf8", $octets [, CHECK])>.
The sequence of octets represented by $octets is decoded
from UTF-8 into a sequence of logical characters.
Because not all sequences of octets are valid UTF-8,
it is quite possible for this function to fail.
For CHECK, see L</"Handling Malformed Data">.
=head2 Listing available encodings
use Encode;
@list = Encode->encodings();
Returns a list of canonical names of available encodings that have already
been loaded. To get a list of all available encodings including those that
have not yet been loaded, say:
@all_encodings = Encode->encodings(":all");
Or you can give the name of a specific module:
@with_jp = Encode->encodings("Encode::JP");
When "C<::>" is not in the name, "C<Encode::>" is assumed.
@ebcdic = Encode->encodings("EBCDIC");
To find out in detail which encodings are supported by this package,
see L<Encode::Supported>.
=head2 Defining Aliases
To add a new alias to a given encoding, use:
use Encode;
use Encode::Alias;
define_alias(NEWNAME => ENCODING);
After that, I<NEWNAME> can be used as an alias for I<ENCODING>.
I<ENCODING> may be either the name of an encoding or an
I<encoding object>.
Before you do that, first make sure the alias is nonexistent using
C<resolve_alias()>, which returns the canonical name thereof.
For example:
Encode::resolve_alias("latin1") eq "iso-8859-1" # true
Encode::resolve_alias("iso-8859-12") # false; nonexistent
Encode::resolve_alias($name) eq $name # true if $name is canonical
C<resolve_alias()> does not need C<use Encode::Alias>; it can be
imported via C<use Encode qw(resolve_alias)>.
See L<Encode::Alias> for details.
=head2 Finding IANA Character Set Registry names
The canonical name of a given encoding does not necessarily agree with
IANA Character Set Registry, commonly seen as C<< Content-Type:
text/plain; charset=I<WHATEVER> >>. For most cases, the canonical name
works, but sometimes it does not, most notably with "utf-8-strict".
As of C<Encode> version 2.21, a new method C<mime_name()> is therefore added.
use Encode;
my $enc = find_encoding("UTF-8");
warn $enc->name; # utf-8-strict
warn $enc->mime_name; # UTF-8
See also: L<Encode::Encoding>
=head1 Encoding via PerlIO
If your perl supports C<PerlIO> (which is the default), you can use a
C<PerlIO> layer to decode and encode directly via a filehandle. The
following two examples are fully identical in functionality:
### Version 1 via PerlIO
open(INPUT, "< :encoding(shiftjis)", $infile)
|| die "Can't open < $infile for reading: $!";
open(OUTPUT, "> :encoding(euc-jp)", $outfile)
|| die "Can't open > $output for writing: $!";
while (<INPUT>) { # auto decodes $_
print OUTPUT; # auto encodes $_
}
close(INPUT) || die "can't close $infile: $!";
close(OUTPUT) || die "can't close $outfile: $!";
### Version 2 via from_to()
open(INPUT, "< :raw", $infile)
|| die "Can't open < $infile for reading: $!";
open(OUTPUT, "> :raw", $outfile)
|| die "Can't open > $output for writing: $!";
while (<INPUT>) {
from_to($_, "shiftjis", "euc-jp", 1); # switch encoding
print OUTPUT; # emit raw (but properly encoded) data
}
close(INPUT) || die "can't close $infile: $!";
close(OUTPUT) || die "can't close $outfile: $!";
In the first version above, you let the appropriate encoding layer
handle the conversion. In the second, you explicitly translate
from one encoding to the other.
Unfortunately, it may be that encodings are C<PerlIO>-savvy. You can check
to see whether your encoding is supported by C<PerlIO> by invoking the
C<perlio_ok> method on it:
Encode::perlio_ok("hz"); # false
find_encoding("euc-cn")->perlio_ok; # true wherever PerlIO is available
use Encode qw(perlio_ok); # imported upon request
perlio_ok("euc-jp")
Fortunately, all encodings that come with C<Encode> core are C<PerlIO>-savvy
except for C<hz> and C<ISO-2022-kr>. For the gory details, see
L<Encode::Encoding> and L<Encode::PerlIO>.
=head1 Handling Malformed Data
The optional I<CHECK> argument tells C<Encode> what to do when
encountering malformed data. Without I<CHECK>, C<Encode::FB_DEFAULT>
(== 0) is assumed.
As of version 2.12, C<Encode> supports coderef values for C<CHECK>;
see below.
B<NOTE:> Not all encodings support this feature.
Some encodings ignore the I<CHECK> argument. For example,
L<Encode::Unicode> ignores I<CHECK> and it always croaks on error.
=head2 List of I<CHECK> values
=head3 FB_DEFAULT
I<CHECK> = Encode::FB_DEFAULT ( == 0)
If I<CHECK> is 0, encoding and decoding replace any malformed character
with a I<substitution character>. When you encode, I<SUBCHAR> is used.
When you decode, the Unicode REPLACEMENT CHARACTER, code point U+FFFD, is
used. If the data is supposed to be UTF-8, an optional lexical warning of
warning category C<"utf8"> is given.
=head3 FB_CROAK
I<CHECK> = Encode::FB_CROAK ( == 1)
If I<CHECK> is 1, methods immediately die with an error
message. Therefore, when I<CHECK> is 1, you should trap
exceptions with C<eval{}>, unless you really want to let it C<die>.
=head3 FB_QUIET
I<CHECK> = Encode::FB_QUIET
If I<CHECK> is set to C<Encode::FB_QUIET>, encoding and decoding immediately
return the portion of the data that has been processed so far when an
error occurs. The data argument is overwritten with everything
after that point; that is, the unprocessed portion of the data. This is
handy when you have to call C<decode> repeatedly in the case where your
source data may contain partial multi-byte character sequences,
(that is, you are reading with a fixed-width buffer). Here's some sample
code to do exactly that:
my($buffer, $string) = ("", "");
while (read($fh, $buffer, 256, length($buffer))) {
$string .= decode($encoding, $buffer, Encode::FB_QUIET);
# $buffer now contains the unprocessed partial character
}
=head3 FB_WARN
I<CHECK> = Encode::FB_WARN
This is the same as C<FB_QUIET> above, except that instead of being silent
on errors, it issues a warning. This is handy for when you are debugging.
=head3 FB_PERLQQ FB_HTMLCREF FB_XMLCREF
=over 2
=item perlqq mode (I<CHECK> = Encode::FB_PERLQQ)
=item HTML charref mode (I<CHECK> = Encode::FB_HTMLCREF)
=item XML charref mode (I<CHECK> = Encode::FB_XMLCREF)
=back
For encodings that are implemented by the C<Encode::XS> module, C<CHECK> C<==>
C<Encode::FB_PERLQQ> puts C<encode> and C<decode> into C<perlqq> fallback mode.
When you decode, C<\xI<HH>> is inserted for a malformed character, where
I<HH> is the hex representation of the octet that could not be decoded to
utf8. When you encode, C<\x{I<HHHH>}> will be inserted, where I<HHHH> is
the Unicode code point (in any number of hex digits) of the character that
cannot be found in the character repertoire of the encoding.
The HTML/XML character reference modes are about the same. In place of
C<\x{I<HHHH>}>, HTML uses C<&#I<NNN>;> where I<NNN> is a decimal number, and
XML uses C<&#xI<HHHH>;> where I<HHHH> is the hexadecimal number.
In C<Encode> 2.10 or later, C<LEAVE_SRC> is also implied.
=head3 The bitmask
These modes are all actually set via a bitmask. Here is how the C<FB_I<XXX>>
constants are laid out. You can import the C<FB_I<XXX>> constants via
C<use Encode qw(:fallbacks)>, and you can import the generic bitmask
constants via C<use Encode qw(:fallback_all)>.
FB_DEFAULT FB_CROAK FB_QUIET FB_WARN FB_PERLQQ
DIE_ON_ERR 0x0001 X
WARN_ON_ERR 0x0002 X
RETURN_ON_ERR 0x0004 X X
LEAVE_SRC 0x0008 X
PERLQQ 0x0100 X
HTMLCREF 0x0200
XMLCREF 0x0400
=head3 LEAVE_SRC
Encode::LEAVE_SRC
If the C<Encode::LEAVE_SRC> bit is I<not> set but I<CHECK> is set, then the
source string to encode() or decode() will be overwritten in place.
If you're not interested in this, then bitwise-OR it with the bitmask.
=head2 coderef for CHECK
As of C<Encode> 2.12, C<CHECK> can also be a code reference which takes the
ordinal value of the unmapped character as an argument and returns a string
that represents the fallback character. For instance:
$ascii = encode("ascii", $utf8, sub{ sprintf "<U+%04X>", shift });
Acts like C<FB_PERLQQ> but U+I<XXXX> is used instead of C<\x{I<XXXX>}>.
=head1 Defining Encodings
To define a new encoding, use:
use Encode qw(define_encoding);
define_encoding($object, CANONICAL_NAME [, alias...]);
I<CANONICAL_NAME> will be associated with I<$object>. The object
should provide the interface described in L<Encode::Encoding>.
If more than two arguments are provided, additional
arguments are considered aliases for I<$object>.
See L<Encode::Encoding> for details.
=head1 The UTF8 flag
Before the introduction of Unicode support in Perl, The C<eq> operator
just compared the strings represented by two scalars. Beginning with
Perl 5.8, C<eq> compares two strings with simultaneous consideration of
I<the UTF8 flag>. To explain why we made it so, I quote from page 402 of
I<Programming Perl, 3rd ed.>
=over 2
=item Goal #1:
Old byte-oriented programs should not spontaneously break on the old
byte-oriented data they used to work on.
=item Goal #2:
Old byte-oriented programs should magically start working on the new
character-oriented data when appropriate.
=item Goal #3:
Programs should run just as fast in the new character-oriented mode
as in the old byte-oriented mode.
=item Goal #4:
Perl should remain one language, rather than forking into a
byte-oriented Perl and a character-oriented Perl.
=back
When I<Programming Perl, 3rd ed.> was written, not even Perl 5.6.0 had been
born yet, many features documented in the book remained unimplemented for a
long time. Perl 5.8 corrected much of this, and the introduction of the
UTF8 flag is one of them. You can think of there being two fundamentally
different kinds of strings and string-operations in Perl: one a
byte-oriented mode for when the internal UTF8 flag is off, and the other a
character-oriented mode for when the internal UTF8 flag is on.
Here is how C<Encode> handles the UTF8 flag.
=over 2
=item *
When you I<encode>, the resulting UTF8 flag is always B<off>.
=item *
When you I<decode>, the resulting UTF8 flag is B<on>--I<unless> you can
unambiguously represent data. Here is what we mean by "unambiguously".
After C<$utf8 = decode("foo", $octet)>,
When $octet is... The UTF8 flag in $utf8 is
---------------------------------------------
In ASCII only (or EBCDIC only) OFF
In ISO-8859-1 ON
In any other Encoding ON
---------------------------------------------
As you see, there is one exception: in ASCII. That way you can assume
Goal #1. And with C<Encode>, Goal #2 is assumed but you still have to be
careful in the cases mentioned in the B<CAVEAT> paragraphs above.
This UTF8 flag is not visible in Perl scripts, exactly for the same reason
you cannot (or rather, you I<don't have to>) see whether a scalar contains
a string, an integer, or a floating-point number. But you can still peek
and poke these if you will. See the next section.
=back
=head2 Messing with Perl's Internals
The following API uses parts of Perl's internals in the current
implementation. As such, they are efficient but may change in a future
release.
=head3 is_utf8
is_utf8(STRING [, CHECK])
[INTERNAL] Tests whether the UTF8 flag is turned on in the I<STRING>.
If I<CHECK> is true, also checks whether I<STRING> contains well-formed
UTF-8. Returns true if successful, false otherwise.
As of Perl 5.8.1, L<utf8> also has the C<utf8::is_utf8> function.
=head3 _utf8_on
_utf8_on(STRING)
[INTERNAL] Turns the I<STRING>'s internal UTF8 flag B<on>. The I<STRING>
is I<not> checked for containing only well-formed UTF-8. Do not use this
unless you I<know with absolute certainty> that the STRING holds only
well-formed UTF-8. Returns the previous state of the UTF8 flag (so please
don't treat the return value as indicating success or failure), or C<undef>
if I<STRING> is not a string.
B<NOTE>: For security reasons, this function does not work on tainted values.
=head3 _utf8_off
_utf8_off(STRING)
[INTERNAL] Turns the I<STRING>'s internal UTF8 flag B<off>. Do not use
frivolously. Returns the previous state of the UTF8 flag, or C<undef> if
I<STRING> is not a string. Do not treat the return value as indicative of
success or failure, because that isn't what it means: it is only the
previous setting.
B<NOTE>: For security reasons, this function does not work on tainted values.
=head1 UTF-8 vs. utf8 vs. UTF8
....We now view strings not as sequences of bytes, but as sequences
of numbers in the range 0 .. 2**32-1 (or in the case of 64-bit
computers, 0 .. 2**64-1) -- Programming Perl, 3rd ed.
That has historically been Perl's notion of UTF-8, as that is how UTF-8 was
first conceived by Ken Thompson when he invented it. However, thanks to
later revisions to the applicable standards, official UTF-8 is now rather
stricter than that. For example, its range is much narrower (0 .. 0x10_FFFF
to cover only 21 bits instead of 32 or 64 bits) and some sequences
are not allowed, like those used in surrogate pairs, the 31 non-character
code points 0xFDD0 .. 0xFDEF, the last two code points in I<any> plane
(0xI<XX>_FFFE and 0xI<XX>_FFFF), all non-shortest encodings, etc.
The former default in which Perl would always use a loose interpretation of
UTF-8 has now been overruled:
From: Larry Wall <larry@wall.org>
Date: December 04, 2004 11:51:58 JST
To: perl-unicode@perl.org
Subject: Re: Make Encode.pm support the real UTF-8
Message-Id: <20041204025158.GA28754@wall.org>
On Fri, Dec 03, 2004 at 10:12:12PM +0000, Tim Bunce wrote:
: I've no problem with 'utf8' being perl's unrestricted uft8 encoding,
: but "UTF-8" is the name of the standard and should give the
: corresponding behaviour.
For what it's worth, that's how I've always kept them straight in my
head.
Also for what it's worth, Perl 6 will mostly default to strict but
make it easy to switch back to lax.
Larry
Got that? As of Perl 5.8.7, B<"UTF-8"> means UTF-8 in its current
sense, which is conservative and strict and security-conscious, whereas
B<"utf8"> means UTF-8 in its former sense, which was liberal and loose and
lax. C<Encode> version 2.10 or later thus groks this subtle but critically
important distinction between C<"UTF-8"> and C<"utf8">.
encode("utf8", "\x{FFFF_FFFF}", 1); # okay
encode("UTF-8", "\x{FFFF_FFFF}", 1); # croaks
In the C<Encode> module, C<"UTF-8"> is actually a canonical name for
C<"utf-8-strict">. That hyphen between the C<"UTF"> and the C<"8"> is
critical; without it, C<Encode> goes "liberal" and (perhaps overly-)permissive:
find_encoding("UTF-8")->name # is 'utf-8-strict'
find_encoding("utf-8")->name # ditto. names are case insensitive
find_encoding("utf_8")->name # ditto. "_" are treated as "-"
find_encoding("UTF8")->name # is 'utf8'.
Perl's internal UTF8 flag is called "UTF8", without a hyphen. It indicates
whether a string is internally encoded as "utf8", also without a hyphen.
=head1 SEE ALSO
L<Encode::Encoding>,
L<Encode::Supported>,
L<Encode::PerlIO>,
L<encoding>,
L<perlebcdic>,
L<perlfunc/open>,
L<perlunicode>, L<perluniintro>, L<perlunifaq>, L<perlunitut>
L<utf8>,
the Perl Unicode Mailing List L<http://lists.perl.org/list/perl-unicode.html>
=head1 MAINTAINER
This project was originated by the late Nick Ing-Simmons and later
maintained by Dan Kogai I<< <dankogai@cpan.org> >>. See AUTHORS
for a full list of people involved. For any questions, send mail to
I<< <perl-unicode@perl.org> >> so that we can all share.
While Dan Kogai retains the copyright as a maintainer, credit
should go to all those involved. See AUTHORS for a list of those
who submitted code to the project.
=head1 COPYRIGHT
Copyright 2002-2012 Dan Kogai I<< <dankogai@cpan.org> >>.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
DARWIN-2LEVEL_ENCODE
$fatpacked{"darwin-2level/Encode/Alias.pm"} = <<'DARWIN-2LEVEL_ENCODE_ALIAS';
package Encode::Alias;
use strict;
use warnings;
no warnings 'redefine';
our $VERSION = do { my @r = ( q$Revision: 2.16 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
use constant DEBUG => !!$ENV{PERL_ENCODE_DEBUG};
use base qw(Exporter);
# Public, encouraged API is exported by default
our @EXPORT =
qw (
define_alias
find_alias
);
our @Alias; # ordered matching list
our %Alias; # cached known aliases
sub find_alias {
require Encode;
my $class = shift;
my $find = shift;
unless ( exists $Alias{$find} ) {
$Alias{$find} = undef; # Recursion guard
for ( my $i = 0 ; $i < @Alias ; $i += 2 ) {
my $alias = $Alias[$i];
my $val = $Alias[ $i + 1 ];
my $new;
if ( ref($alias) eq 'Regexp' && $find =~ $alias ) {
DEBUG and warn "eval $val";
$new = eval $val;
DEBUG and $@ and warn "$val, $@";
}
elsif ( ref($alias) eq 'CODE' ) {
DEBUG and warn "$alias", "->", "($find)";
$new = $alias->($find);
}
elsif ( lc($find) eq lc($alias) ) {
$new = $val;
}
if ( defined($new) ) {
next if $new eq $find; # avoid (direct) recursion on bugs
DEBUG and warn "$alias, $new";
my $enc =
( ref($new) ) ? $new : Encode::find_encoding($new);
if ($enc) {
$Alias{$find} = $enc;
last;
}
}
}
# case insensitive search when canonical is not in all lowercase
# RT ticket #7835
unless ( $Alias{$find} ) {
my $lcfind = lc($find);
for my $name ( keys %Encode::Encoding, keys %Encode::ExtModule )
{
$lcfind eq lc($name) or next;
$Alias{$find} = Encode::find_encoding($name);
DEBUG and warn "$find => $name";
}
}
}
if (DEBUG) {
my $name;
if ( my $e = $Alias{$find} ) {
$name = $e->name;
}
else {
$name = "";
}
warn "find_alias($class, $find)->name = $name";
}
return $Alias{$find};
}
sub define_alias {
while (@_) {
my ( $alias, $name ) = splice( @_, 0, 2 );
unshift( @Alias, $alias => $name ); # newer one has precedence
if ( ref($alias) ) {
# clear %Alias cache to allow overrides
my @a = keys %Alias;
for my $k (@a) {
if ( ref($alias) eq 'Regexp' && $k =~ $alias ) {
DEBUG and warn "delete \$Alias\{$k\}";
delete $Alias{$k};
}
elsif ( ref($alias) eq 'CODE' && $alias->($k) ) {
DEBUG and warn "delete \$Alias\{$k\}";
delete $Alias{$k};
}
}
}
else {
DEBUG and warn "delete \$Alias\{$alias\}";
delete $Alias{$alias};
}
}
}
# Allow latin-1 style names as well
# 0 1 2 3 4 5 6 7 8 9 10
our @Latin2iso = ( 0, 1, 2, 3, 4, 9, 10, 13, 14, 15, 16 );
# Allow winlatin1 style names as well
our %Winlatin2cp = (
'latin1' => 1252,
'latin2' => 1250,
'cyrillic' => 1251,
'greek' => 1253,
'turkish' => 1254,
'hebrew' => 1255,
'arabic' => 1256,
'baltic' => 1257,
'vietnamese' => 1258,
);
init_aliases();
sub undef_aliases {
@Alias = ();
%Alias = ();
}
sub init_aliases {
require Encode;
undef_aliases();
# Try all-lower-case version should all else fails
define_alias( qr/^(.*)$/ => '"\L$1"' );
# UTF/UCS stuff
define_alias( qr/^(unicode-1-1-)?UTF-?7$/i => '"UTF-7"' );
define_alias( qr/^UCS-?2-?LE$/i => '"UCS-2LE"' );
define_alias(
qr/^UCS-?2-?(BE)?$/i => '"UCS-2BE"',
qr/^UCS-?4-?(BE|LE)?$/i => 'uc("UTF-32$1")',
qr/^iso-10646-1$/i => '"UCS-2BE"'
);
define_alias(
qr/^UTF-?(16|32)-?BE$/i => '"UTF-$1BE"',
qr/^UTF-?(16|32)-?LE$/i => '"UTF-$1LE"',
qr/^UTF-?(16|32)$/i => '"UTF-$1"',
);
# ASCII
define_alias( qr/^(?:US-?)ascii$/i => '"ascii"' );
define_alias( 'C' => 'ascii' );
define_alias( qr/\b(?:ISO[-_]?)?646(?:[-_]?US)?$/i => '"ascii"' );
# Allow variants of iso-8859-1 etc.
define_alias( qr/\biso[-_]?(\d+)[-_](\d+)$/i => '"iso-$1-$2"' );
# At least HP-UX has these.
define_alias( qr/\biso8859(\d+)$/i => '"iso-8859-$1"' );
# More HP stuff.
define_alias(
qr/\b(?:hp-)?(arabic|greek|hebrew|kana|roman|thai|turkish)8$/i =>
'"${1}8"' );
# The Official name of ASCII.
define_alias( qr/\bANSI[-_]?X3\.4[-_]?1968$/i => '"ascii"' );
# This is a font issue, not an encoding issue.
# (The currency symbol of the Latin 1 upper half
# has been redefined as the euro symbol.)
define_alias( qr/^(.+)\@euro$/i => '"$1"' );
define_alias( qr/\b(?:iso[-_]?)?latin[-_]?(\d+)$/i =>
'defined $Encode::Alias::Latin2iso[$1] ? "iso-8859-$Encode::Alias::Latin2iso[$1]" : undef'
);
define_alias(
qr/\bwin(latin[12]|cyrillic|baltic|greek|turkish|
hebrew|arabic|baltic|vietnamese)$/ix =>
'"cp" . $Encode::Alias::Winlatin2cp{lc($1)}'
);
# Common names for non-latin preferred MIME names
define_alias(
'ascii' => 'US-ascii',
'cyrillic' => 'iso-8859-5',
'arabic' => 'iso-8859-6',
'greek' => 'iso-8859-7',
'hebrew' => 'iso-8859-8',
'thai' => 'iso-8859-11',
);
# RT #20781
define_alias(qr/\btis-?620\b/i => '"iso-8859-11"');
# At least AIX has IBM-NNN (surprisingly...) instead of cpNNN.
# And Microsoft has their own naming (again, surprisingly).
# And windows-* is registered in IANA!
define_alias(
qr/\b(?:cp|ibm|ms|windows)[-_ ]?(\d{2,4})$/i => '"cp$1"' );
# Sometimes seen with a leading zero.
# define_alias( qr/\bcp037\b/i => '"cp37"');
# Mac Mappings
# predefined in *.ucm; unneeded
# define_alias( qr/\bmacIcelandic$/i => '"macIceland"');
define_alias( qr/^(?:x[_-])?mac[_-](.*)$/i => '"mac$1"' );
# http://rt.cpan.org/Ticket/Display.html?id=36326
define_alias( qr/^macintosh$/i => '"MacRoman"' );
# https://rt.cpan.org/Ticket/Display.html?id=78125
define_alias( qr/^macce$/i => '"MacCentralEurRoman"' );
# Ououououou. gone. They are differente!
# define_alias( qr/\bmacRomanian$/i => '"macRumanian"');
# Standardize on the dashed versions.
define_alias( qr/\bkoi8[\s\-_]*([ru])$/i => '"koi8-$1"' );
unless ($Encode::ON_EBCDIC) {
# for Encode::CN
define_alias( qr/\beuc.*cn$/i => '"euc-cn"' );
define_alias( qr/\bcn.*euc$/i => '"euc-cn"' );
# define_alias( qr/\bGB[- ]?(\d+)$/i => '"euc-cn"' )
# CP936 doesn't have vendor-addon for GBK, so they're identical.
define_alias( qr/^gbk$/i => '"cp936"' );
# This fixes gb2312 vs. euc-cn confusion, practically
define_alias( qr/\bGB[-_ ]?2312(?!-?raw)/i => '"euc-cn"' );
# for Encode::JP
define_alias( qr/\bjis$/i => '"7bit-jis"' );
define_alias( qr/\beuc.*jp$/i => '"euc-jp"' );
define_alias( qr/\bjp.*euc$/i => '"euc-jp"' );
define_alias( qr/\bujis$/i => '"euc-jp"' );
define_alias( qr/\bshift.*jis$/i => '"shiftjis"' );
define_alias( qr/\bsjis$/i => '"shiftjis"' );
define_alias( qr/\bwindows-31j$/i => '"cp932"' );
# for Encode::KR
define_alias( qr/\beuc.*kr$/i => '"euc-kr"' );
define_alias( qr/\bkr.*euc$/i => '"euc-kr"' );
# This fixes ksc5601 vs. euc-kr confusion, practically
define_alias( qr/(?:x-)?uhc$/i => '"cp949"' );
define_alias( qr/(?:x-)?windows-949$/i => '"cp949"' );
define_alias( qr/\bks_c_5601-1987$/i => '"cp949"' );
# for Encode::TW
define_alias( qr/\bbig-?5$/i => '"big5-eten"' );
define_alias( qr/\bbig5-?et(?:en)?$/i => '"big5-eten"' );
define_alias( qr/\btca[-_]?big5$/i => '"big5-eten"' );
define_alias( qr/\bbig5-?hk(?:scs)?$/i => '"big5-hkscs"' );
define_alias( qr/\bhk(?:scs)?[-_]?big5$/i => '"big5-hkscs"' );
}
# utf8 is blessed :)
define_alias( qr/\bUTF-8$/i => '"utf-8-strict"' );
# At last, Map white space and _ to '-'
define_alias( qr/^(\S+)[\s_]+(.*)$/i => '"$1-$2"' );
}
1;
__END__
# TODO: HP-UX '8' encodings arabic8 greek8 hebrew8 kana8 thai8 turkish8
# TODO: HP-UX '15' encodings japanese15 korean15 roi15
# TODO: Cyrillic encoding ISO-IR-111 (useful?)
# TODO: Armenian encoding ARMSCII-8
# TODO: Hebrew encoding ISO-8859-8-1
# TODO: Thai encoding TCVN
# TODO: Vietnamese encodings VPS
# TODO: Mac Asian+African encodings: Arabic Armenian Bengali Burmese
# ChineseSimp ChineseTrad Devanagari Ethiopic ExtArabic
# Farsi Georgian Gujarati Gurmukhi Hebrew Japanese
# Kannada Khmer Korean Laotian Malayalam Mongolian
# Oriya Sinhalese Symbol Tamil Telugu Tibetan Vietnamese
=head1 NAME
Encode::Alias - alias definitions to encodings
=head1 SYNOPSIS
use Encode;
use Encode::Alias;
define_alias( "newName" => ENCODING);
define_alias( qr/.../ => ENCODING);
define_alias( sub { return ENCODING if ...; } );
=head1 DESCRIPTION
Allows newName to be used as an alias for ENCODING. ENCODING may be
either the name of an encoding or an encoding object (as described
in L<Encode>).
Currently the first argument to define_alias() can be specified in the
following ways:
=over 4
=item As a simple string.
=item As a qr// compiled regular expression, e.g.:
define_alias( qr/^iso8859-(\d+)$/i => '"iso-8859-$1"' );
In this case, if I<ENCODING> is not a reference, it is C<eval>-ed
in order to allow C<$1> etc. to be substituted. The example is one
way to alias names as used in X11 fonts to the MIME names for the
iso-8859-* family. Note the double quotes inside the single quotes.
(or, you don't have to do this yourself because this example is predefined)
If you are using a regex here, you have to use the quotes as shown or
it won't work. Also note that regex handling is tricky even for the
experienced. Use this feature with caution.
=item As a code reference, e.g.:
define_alias( sub {shift =~ /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } );
The same effect as the example above in a different way. The coderef
takes the alias name as an argument and returns a canonical name on
success or undef if not. Note the second argument is ignored if provided.
Use this with even more caution than the regex version.
=back
=head3 Changes in code reference aliasing
As of Encode 1.87, the older form
define_alias( sub { return /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } );
no longer works.
Encode up to 1.86 internally used "local $_" to implement ths older
form. But consider the code below;
use Encode;
$_ = "eeeee" ;
while (/(e)/g) {
my $utf = decode('aliased-encoding-name', $1);
print "position:",pos,"\n";
}
Prior to Encode 1.86 this fails because of "local $_".
=head2 Alias overloading
You can override predefined aliases by simply applying define_alias().
The new alias is always evaluated first, and when necessary,
define_alias() flushes the internal cache to make the new definition
available.
# redirect SHIFT_JIS to MS/IBM Code Page 932, which is a
# superset of SHIFT_JIS
define_alias( qr/shift.*jis$/i => '"cp932"' );
define_alias( qr/sjis$/i => '"cp932"' );
If you want to zap all predefined aliases, you can use
Encode::Alias->undef_aliases;
to do so. And
Encode::Alias->init_aliases;
gets the factory settings back.
Note that define_alias() will not be able to override the canonical name
of encodings. Encodings are first looked up by canonical name before
potential aliases are tried.
=head1 SEE ALSO
L<Encode>, L<Encode::Supported>
=cut
DARWIN-2LEVEL_ENCODE_ALIAS
$fatpacked{"darwin-2level/Encode/Byte.pm"} = <<'DARWIN-2LEVEL_ENCODE_BYTE';
package Encode::Byte;
use strict;
use warnings;
use Encode;
our $VERSION = do { my @r = ( q$Revision: 2.4 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
use XSLoader;
XSLoader::load( __PACKAGE__, $VERSION );
1;
__END__
=head1 NAME
Encode::Byte - Single Byte Encodings
=head1 SYNOPSIS
use Encode qw/encode decode/;
$greek = encode("iso-8859-7", $utf8); # loads Encode::Byte implicitly
$utf8 = decode("iso-8859-7", $greek); # ditto
=head1 ABSTRACT
This module implements various single byte encodings. For most cases it uses
\x80-\xff (upper half) to map non-ASCII characters. Encodings
supported are as follows.
Canonical Alias Description
--------------------------------------------------------------------
# ISO 8859 series
(iso-8859-1 is in built-in)
iso-8859-2 latin2 [ISO]
iso-8859-3 latin3 [ISO]
iso-8859-4 latin4 [ISO]
iso-8859-5 [ISO]
iso-8859-6 [ISO]
iso-8859-7 [ISO]
iso-8859-8 [ISO]
iso-8859-9 latin5 [ISO]
iso-8859-10 latin6 [ISO]
iso-8859-11
(iso-8859-12 is nonexistent)
iso-8859-13 latin7 [ISO]
iso-8859-14 latin8 [ISO]
iso-8859-15 latin9 [ISO]
iso-8859-16 latin10 [ISO]
# Cyrillic
koi8-f
koi8-r cp878 [RFC1489]
koi8-u [RFC2319]
# Vietnamese
viscii
# all cp* are also available as ibm-*, ms-*, and windows-*
# also see L<http://msdn.microsoft.com/en-us/library/aa752010%28VS.85%29.aspx>
cp424
cp437
cp737
cp775
cp850
cp852
cp855
cp856
cp857
cp860
cp861
cp862
cp863
cp864
cp865
cp866
cp869
cp874
cp1006
cp1250 WinLatin2
cp1251 WinCyrillic
cp1252 WinLatin1
cp1253 WinGreek
cp1254 WinTurkish
cp1255 WinHebrew
cp1256 WinArabic
cp1257 WinBaltic
cp1258 WinVietnamese
# Macintosh
# Also see L<http://developer.apple.com/technotes/tn/tn1150.html>
MacArabic
MacCentralEurRoman
MacCroatian
MacCyrillic
MacFarsi
MacGreek
MacHebrew
MacIcelandic
MacRoman
MacRomanian
MacRumanian
MacSami
MacThai
MacTurkish
MacUkrainian
# More vendor encodings
AdobeStandardEncoding
nextstep
hp-roman8
=head1 DESCRIPTION
To find how to use this module in detail, see L<Encode>.
=head1 SEE ALSO
L<Encode>
=cut
DARWIN-2LEVEL_ENCODE_BYTE
$fatpacked{"darwin-2level/Encode/CJKConstants.pm"} = <<'DARWIN-2LEVEL_ENCODE_CJKCONSTANTS';
#
# $Id: CJKConstants.pm,v 2.2 2006/06/03 20:28:48 dankogai Exp $
#
package Encode::CJKConstants;
use strict;
use warnings;
our $RCSID = q$Id: CJKConstants.pm,v 2.2 2006/06/03 20:28:48 dankogai Exp $;
our $VERSION = do { my @r = ( q$Revision: 2.2 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
use Carp;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw();
our @EXPORT_OK = qw(%CHARCODE %ESC %RE);
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK, @EXPORT ] );
my %_0208 = (
1978 => '\e\$\@',
1983 => '\e\$B',
1990 => '\e&\@\e\$B',
);
our %CHARCODE = (
UNDEF_EUC => "\xa2\xae", # ¢® in EUC
UNDEF_SJIS => "\x81\xac", # ¢® in SJIS
UNDEF_JIS => "\xa2\xf7", # ¢÷ -- used in unicode
UNDEF_UNICODE => "\x20\x20", # ¢÷ -- used in unicode
);
our %ESC = (
GB_2312 => "\e\$A",
JIS_0208 => "\e\$B",
JIS_0212 => "\e\$(D",
KSC_5601 => "\e\$(C",
ASC => "\e\(B",
KANA => "\e\(I",
'2022_KR' => "\e\$)C",
);
our %RE = (
ASCII => '[\x00-\x7f]',
BIN => '[\x00-\x06\x7f\xff]',
EUC_0212 => '\x8f[\xa1-\xfe][\xa1-\xfe]',
EUC_C => '[\xa1-\xfe][\xa1-\xfe]',
EUC_KANA => '\x8e[\xa1-\xdf]',
JIS_0208 => "$_0208{1978}|$_0208{1983}|$_0208{1990}",
JIS_0212 => "\e" . '\$\(D',
ISO_ASC => "\e" . '\([BJ]',
JIS_KANA => "\e" . '\(I',
'2022_KR' => "\e" . '\$\)C',
SJIS_C => '[\x81-\x9f\xe0-\xfc][\x40-\x7e\x80-\xfc]',
SJIS_KANA => '[\xa1-\xdf]',
UTF8 => '[\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf][\x80-\xbf]'
);
1;
=head1 NAME
Encode::CJKConstants.pm -- Internally used by Encode::??::ISO_2022_*
=cut
DARWIN-2LEVEL_ENCODE_CJKCONSTANTS
$fatpacked{"darwin-2level/Encode/CN.pm"} = <<'DARWIN-2LEVEL_ENCODE_CN';
package Encode::CN;
BEGIN {
if ( ord("A") == 193 ) {
die "Encode::CN not supported on EBCDIC\n";
}
}
use strict;
use warnings;
use Encode;
our $VERSION = do { my @r = ( q$Revision: 2.3 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
use XSLoader;
XSLoader::load( __PACKAGE__, $VERSION );
# Relocated from Encode.pm
use Encode::CN::HZ;
# use Encode::CN::2022_CN;
1;
__END__
=head1 NAME
Encode::CN - China-based Chinese Encodings
=head1 SYNOPSIS
use Encode qw/encode decode/;
$euc_cn = encode("euc-cn", $utf8); # loads Encode::CN implicitly
$utf8 = decode("euc-cn", $euc_cn); # ditto
=head1 DESCRIPTION
This module implements China-based Chinese charset encodings.
Encodings supported are as follows.
Canonical Alias Description
--------------------------------------------------------------------
euc-cn /\beuc.*cn$/i EUC (Extended Unix Character)
/\bcn.*euc$/i
/\bGB[-_ ]?2312(?:\D.*$|$)/i (see below)
gb2312-raw The raw (low-bit) GB2312 character map
gb12345-raw Traditional chinese counterpart to
GB2312 (raw)
iso-ir-165 GB2312 + GB6345 + GB8565 + additions
MacChineseSimp GB2312 + Apple Additions
cp936 Code Page 936, also known as GBK
(Extended GuoBiao)
hz 7-bit escaped GB2312 encoding
--------------------------------------------------------------------
To find how to use this module in detail, see L<Encode>.
=head1 NOTES
Due to size concerns, C<GB 18030> (an extension to C<GBK>) is distributed
separately on CPAN, under the name L<Encode::HanExtra>. That module
also contains extra Taiwan-based encodings.
=head1 BUGS
When you see C<charset=gb2312> on mails and web pages, they really
mean C<euc-cn> encodings. To fix that, C<gb2312> is aliased to C<euc-cn>.
Use C<gb2312-raw> when you really mean it.
The ASCII region (0x00-0x7f) is preserved for all encodings, even though
this conflicts with mappings by the Unicode Consortium.
=head1 SEE ALSO
L<Encode>
=cut
DARWIN-2LEVEL_ENCODE_CN
$fatpacked{"darwin-2level/Encode/CN/HZ.pm"} = <<'DARWIN-2LEVEL_ENCODE_CN_HZ';
package Encode::CN::HZ;
use strict;
use warnings;
use utf8 ();
use vars qw($VERSION);
$VERSION = do { my @r = ( q$Revision: 2.5 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
use Encode qw(:fallbacks);
use base qw(Encode::Encoding);
__PACKAGE__->Define('hz');
# HZ is a combination of ASCII and escaped GB, so we implement it
# with the GB2312(raw) encoding here. Cf. RFCs 1842 & 1843.
# not ported for EBCDIC. Which should be used, "~" or "\x7E"?
sub needs_lines { 1 }
sub decode ($$;$) {
my ( $obj, $str, $chk ) = @_;
my $GB = Encode::find_encoding('gb2312-raw');
my $ret = '';
my $in_ascii = 1; # default mode is ASCII.
while ( length $str ) {
if ($in_ascii) { # ASCII mode
if ( $str =~ s/^([\x00-\x7D\x7F]+)// ) { # no '~' => ASCII
$ret .= $1;
# EBCDIC should need ascii2native, but not ported.
}
elsif ( $str =~ s/^\x7E\x7E// ) { # escaped tilde
$ret .= '~';
}
elsif ( $str =~ s/^\x7E\cJ// ) { # '\cJ' == LF in ASCII
1; # no-op
}
elsif ( $str =~ s/^\x7E\x7B// ) { # '~{'
$in_ascii = 0; # to GB
}
else { # encounters an invalid escape, \x80 or greater
last;
}
}
else { # GB mode; the byte ranges are as in RFC 1843.
no warnings 'uninitialized';
if ( $str =~ s/^((?:[\x21-\x77][\x21-\x7E])+)// ) {
$ret .= $GB->decode( $1, $chk );
}
elsif ( $str =~ s/^\x7E\x7D// ) { # '~}'
$in_ascii = 1;
}
else { # invalid
last;
}
}
}
$_[1] = '' if $chk; # needs_lines guarantees no partial character
return $ret;
}
sub cat_decode {
my ( $obj, undef, $src, $pos, $trm, $chk ) = @_;
my ( $rdst, $rsrc, $rpos ) = \@_[ 1 .. 3 ];
my $GB = Encode::find_encoding('gb2312-raw');
my $ret = '';
my $in_ascii = 1; # default mode is ASCII.
my $ini_pos = pos($$rsrc);
substr( $src, 0, $pos ) = '';
my $ini_len = bytes::length($src);
# $trm is the first of the pair '~~', then 2nd tilde is to be removed.
# XXX: Is better C<$src =~ s/^\x7E// or die if ...>?
$src =~ s/^\x7E// if $trm eq "\x7E";
while ( length $src ) {
my $now;
if ($in_ascii) { # ASCII mode
if ( $src =~ s/^([\x00-\x7D\x7F])// ) { # no '~' => ASCII
$now = $1;
}
elsif ( $src =~ s/^\x7E\x7E// ) { # escaped tilde
$now = '~';
}
elsif ( $src =~ s/^\x7E\cJ// ) { # '\cJ' == LF in ASCII
next;
}
elsif ( $src =~ s/^\x7E\x7B// ) { # '~{'
$in_ascii = 0; # to GB
next;
}
else { # encounters an invalid escape, \x80 or greater
last;
}
}
else { # GB mode; the byte ranges are as in RFC 1843.
if ( $src =~ s/^((?:[\x21-\x77][\x21-\x7F])+)// ) {
$now = $GB->decode( $1, $chk );
}
elsif ( $src =~ s/^\x7E\x7D// ) { # '~}'
$in_ascii = 1;
next;
}
else { # invalid
last;
}
}
next if !defined $now;
$ret .= $now;
if ( $now eq $trm ) {
$$rdst .= $ret;
$$rpos = $ini_pos + $pos + $ini_len - bytes::length($src);
pos($$rsrc) = $ini_pos;
return 1;
}
}
$$rdst .= $ret;
$$rpos = $ini_pos + $pos + $ini_len - bytes::length($src);
pos($$rsrc) = $ini_pos;
return ''; # terminator not found
}
sub encode($$;$) {
my ( $obj, $str, $chk ) = @_;
my $GB = Encode::find_encoding('gb2312-raw');
my $ret = '';
my $in_ascii = 1; # default mode is ASCII.
no warnings 'utf8'; # $str may be malformed UTF8 at the end of a chunk.
while ( length $str ) {
if ( $str =~ s/^([[:ascii:]]+)// ) {
my $tmp = $1;
$tmp =~ s/~/~~/g; # escapes tildes
if ( !$in_ascii ) {
$ret .= "\x7E\x7D"; # '~}'
$in_ascii = 1;
}
$ret .= pack 'a*', $tmp; # remove UTF8 flag.
}
elsif ( $str =~ s/(.)// ) {
my $s = $1;
my $tmp = $GB->encode( $s, $chk );
last if !defined $tmp;
if ( length $tmp == 2 ) { # maybe a valid GB char (XXX)
if ($in_ascii) {
$ret .= "\x7E\x7B"; # '~{'
$in_ascii = 0;
}
$ret .= $tmp;
}
elsif ( length $tmp ) { # maybe FALLBACK in ASCII (XXX)
if ( !$in_ascii ) {
$ret .= "\x7E\x7D"; # '~}'
$in_ascii = 1;
}
$ret .= $tmp;
}
}
else { # if $str is malformed UTF8 *and* if length $str != 0.
last;
}
}
$_[1] = $str if $chk;
# The state at the end of the chunk is discarded, even if in GB mode.
# That results in the combination of GB-OUT and GB-IN, i.e. "~}~{".
# Parhaps it is harmless, but further investigations may be required...
if ( !$in_ascii ) {
$ret .= "\x7E\x7D"; # '~}'
$in_ascii = 1;
}
utf8::encode($ret); # https://rt.cpan.org/Ticket/Display.html?id=35120
return $ret;
}
1;
__END__
=head1 NAME
Encode::CN::HZ -- internally used by Encode::CN
=cut
DARWIN-2LEVEL_ENCODE_CN_HZ
$fatpacked{"darwin-2level/Encode/Config.pm"} = <<'DARWIN-2LEVEL_ENCODE_CONFIG';
#
# Demand-load module list
#
package Encode::Config;
our $VERSION = do { my @r = ( q$Revision: 2.5 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
use strict;
use warnings;
our %ExtModule = (
# Encode::Byte
#iso-8859-1 is in Encode.pm itself
'iso-8859-2' => 'Encode::Byte',
'iso-8859-3' => 'Encode::Byte',
'iso-8859-4' => 'Encode::Byte',
'iso-8859-5' => 'Encode::Byte',
'iso-8859-6' => 'Encode::Byte',
'iso-8859-7' => 'Encode::Byte',
'iso-8859-8' => 'Encode::Byte',
'iso-8859-9' => 'Encode::Byte',
'iso-8859-10' => 'Encode::Byte',
'iso-8859-11' => 'Encode::Byte',
'iso-8859-13' => 'Encode::Byte',
'iso-8859-14' => 'Encode::Byte',
'iso-8859-15' => 'Encode::Byte',
'iso-8859-16' => 'Encode::Byte',
'koi8-f' => 'Encode::Byte',
'koi8-r' => 'Encode::Byte',
'koi8-u' => 'Encode::Byte',
'viscii' => 'Encode::Byte',
'cp424' => 'Encode::Byte',
'cp437' => 'Encode::Byte',
'cp737' => 'Encode::Byte',
'cp775' => 'Encode::Byte',
'cp850' => 'Encode::Byte',
'cp852' => 'Encode::Byte',
'cp855' => 'Encode::Byte',
'cp856' => 'Encode::Byte',
'cp857' => 'Encode::Byte',
'cp858' => 'Encode::Byte',
'cp860' => 'Encode::Byte',
'cp861' => 'Encode::Byte',
'cp862' => 'Encode::Byte',
'cp863' => 'Encode::Byte',
'cp864' => 'Encode::Byte',
'cp865' => 'Encode::Byte',
'cp866' => 'Encode::Byte',
'cp869' => 'Encode::Byte',
'cp874' => 'Encode::Byte',
'cp1006' => 'Encode::Byte',
'cp1250' => 'Encode::Byte',
'cp1251' => 'Encode::Byte',
'cp1252' => 'Encode::Byte',
'cp1253' => 'Encode::Byte',
'cp1254' => 'Encode::Byte',
'cp1255' => 'Encode::Byte',
'cp1256' => 'Encode::Byte',
'cp1257' => 'Encode::Byte',
'cp1258' => 'Encode::Byte',
'AdobeStandardEncoding' => 'Encode::Byte',
'MacArabic' => 'Encode::Byte',
'MacCentralEurRoman' => 'Encode::Byte',
'MacCroatian' => 'Encode::Byte',
'MacCyrillic' => 'Encode::Byte',
'MacFarsi' => 'Encode::Byte',
'MacGreek' => 'Encode::Byte',
'MacHebrew' => 'Encode::Byte',
'MacIcelandic' => 'Encode::Byte',
'MacRoman' => 'Encode::Byte',
'MacRomanian' => 'Encode::Byte',
'MacRumanian' => 'Encode::Byte',
'MacSami' => 'Encode::Byte',
'MacThai' => 'Encode::Byte',
'MacTurkish' => 'Encode::Byte',
'MacUkrainian' => 'Encode::Byte',
'nextstep' => 'Encode::Byte',
'hp-roman8' => 'Encode::Byte',
#'gsm0338' => 'Encode::Byte',
'gsm0338' => 'Encode::GSM0338',
# Encode::EBCDIC
'cp37' => 'Encode::EBCDIC',
'cp500' => 'Encode::EBCDIC',
'cp875' => 'Encode::EBCDIC',
'cp1026' => 'Encode::EBCDIC',
'cp1047' => 'Encode::EBCDIC',
'posix-bc' => 'Encode::EBCDIC',
# Encode::Symbol
'dingbats' => 'Encode::Symbol',
'symbol' => 'Encode::Symbol',
'AdobeSymbol' => 'Encode::Symbol',
'AdobeZdingbat' => 'Encode::Symbol',
'MacDingbats' => 'Encode::Symbol',
'MacSymbol' => 'Encode::Symbol',
# Encode::Unicode
'UCS-2BE' => 'Encode::Unicode',
'UCS-2LE' => 'Encode::Unicode',
'UTF-16' => 'Encode::Unicode',
'UTF-16BE' => 'Encode::Unicode',
'UTF-16LE' => 'Encode::Unicode',
'UTF-32' => 'Encode::Unicode',
'UTF-32BE' => 'Encode::Unicode',
'UTF-32LE' => 'Encode::Unicode',
'UTF-7' => 'Encode::Unicode::UTF7',
);
unless ( ord("A") == 193 ) {
%ExtModule = (
%ExtModule,
'euc-cn' => 'Encode::CN',
'gb12345-raw' => 'Encode::CN',
'gb2312-raw' => 'Encode::CN',
'hz' => 'Encode::CN',
'iso-ir-165' => 'Encode::CN',
'cp936' => 'Encode::CN',
'MacChineseSimp' => 'Encode::CN',
'7bit-jis' => 'Encode::JP',
'euc-jp' => 'Encode::JP',
'iso-2022-jp' => 'Encode::JP',
'iso-2022-jp-1' => 'Encode::JP',
'jis0201-raw' => 'Encode::JP',
'jis0208-raw' => 'Encode::JP',
'jis0212-raw' => 'Encode::JP',
'cp932' => 'Encode::JP',
'MacJapanese' => 'Encode::JP',
'shiftjis' => 'Encode::JP',
'euc-kr' => 'Encode::KR',
'iso-2022-kr' => 'Encode::KR',
'johab' => 'Encode::KR',
'ksc5601-raw' => 'Encode::KR',
'cp949' => 'Encode::KR',
'MacKorean' => 'Encode::KR',
'big5-eten' => 'Encode::TW',
'big5-hkscs' => 'Encode::TW',
'cp950' => 'Encode::TW',
'MacChineseTrad' => 'Encode::TW',
#'big5plus' => 'Encode::HanExtra',
#'euc-tw' => 'Encode::HanExtra',
#'gb18030' => 'Encode::HanExtra',
'MIME-Header' => 'Encode::MIME::Header',
'MIME-B' => 'Encode::MIME::Header',
'MIME-Q' => 'Encode::MIME::Header',
'MIME-Header-ISO_2022_JP' => 'Encode::MIME::Header::ISO_2022_JP',
);
}
#
# Why not export ? to keep ConfigLocal Happy!
#
while ( my ( $enc, $mod ) = each %ExtModule ) {
$Encode::ExtModule{$enc} = $mod;
}
1;
__END__
=head1 NAME
Encode::Config -- internally used by Encode
=cut
DARWIN-2LEVEL_ENCODE_CONFIG
$fatpacked{"darwin-2level/Encode/EBCDIC.pm"} = <<'DARWIN-2LEVEL_ENCODE_EBCDIC';
package Encode::EBCDIC;
use strict;
use warnings;
use Encode;
our $VERSION = do { my @r = ( q$Revision: 2.2 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
use XSLoader;
XSLoader::load( __PACKAGE__, $VERSION );
1;
__END__
=head1 NAME
Encode::EBCDIC - EBCDIC Encodings
=head1 SYNOPSIS
use Encode qw/encode decode/;
$posix_bc = encode("posix-bc", $utf8); # loads Encode::EBCDIC implicitly
$utf8 = decode("", $posix_bc); # ditto
=head1 ABSTRACT
This module implements various EBCDIC-Based encodings. Encodings
supported are as follows.
Canonical Alias Description
--------------------------------------------------------------------
cp37
cp500
cp875
cp1026
cp1047
posix-bc
=head1 DESCRIPTION
To find how to use this module in detail, see L<Encode>.
=head1 SEE ALSO
L<Encode>, L<perlebcdic>
=cut
DARWIN-2LEVEL_ENCODE_EBCDIC
$fatpacked{"darwin-2level/Encode/Encoder.pm"} = <<'DARWIN-2LEVEL_ENCODE_ENCODER';
#
# $Id: Encoder.pm,v 2.2 2011/08/09 07:49:44 dankogai Exp $
#
package Encode::Encoder;
use strict;
use warnings;
our $VERSION = do { my @r = ( q$Revision: 2.2 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw ( encoder );
our $AUTOLOAD;
use constant DEBUG => !!$ENV{PERL_ENCODE_DEBUG};
use Encode qw(encode decode find_encoding from_to);
use Carp;
sub new {
my ( $class, $data, $encname ) = @_;
unless ($encname) {
$encname = Encode::is_utf8($data) ? 'utf8' : '';
}
else {
my $obj = find_encoding($encname)
or croak __PACKAGE__, ": unknown encoding: $encname";
$encname = $obj->name;
}
my $self = {
data => $data,
encoding => $encname,
};
bless $self => $class;
}
sub encoder { __PACKAGE__->new(@_) }
sub data {
my ( $self, $data ) = @_;
if ( defined $data ) {
$self->{data} = $data;
return $data;
}
else {
return $self->{data};
}
}
sub encoding {
my ( $self, $encname ) = @_;
if ($encname) {
my $obj = find_encoding($encname)
or confess __PACKAGE__, ": unknown encoding: $encname";
$self->{encoding} = $obj->name;
return $self;
}
else {
return $self->{encoding};
}
}
sub bytes {
my ( $self, $encname ) = @_;
$encname ||= $self->{encoding};
my $obj = find_encoding($encname)
or confess __PACKAGE__, ": unknown encoding: $encname";
$self->{data} = $obj->decode( $self->{data}, 1 );
$self->{encoding} = '';
return $self;
}
sub DESTROY { # defined so it won't autoload.
DEBUG and warn shift;
}
sub AUTOLOAD {
my $self = shift;
my $type = ref($self)
or confess "$self is not an object";
my $myname = $AUTOLOAD;
$myname =~ s/.*://; # strip fully-qualified portion
my $obj = find_encoding($myname)
or confess __PACKAGE__, ": unknown encoding: $myname";
DEBUG and warn $self->{encoding}, " => ", $obj->name;
if ( $self->{encoding} ) {
from_to( $self->{data}, $self->{encoding}, $obj->name, 1 );
}
else {
$self->{data} = $obj->encode( $self->{data}, 1 );
}
$self->{encoding} = $obj->name;
return $self;
}
use overload
q("") => sub { $_[0]->{data} },
q(0+) => sub { use bytes(); bytes::length( $_[0]->{data} ) },
fallback => 1,
;
1;
__END__
=head1 NAME
Encode::Encoder -- Object Oriented Encoder
=head1 SYNOPSIS
use Encode::Encoder;
# Encode::encode("ISO-8859-1", $data);
Encode::Encoder->new($data)->iso_8859_1; # OOP way
# shortcut
use Encode::Encoder qw(encoder);
encoder($data)->iso_8859_1;
# you can stack them!
encoder($data)->iso_8859_1->base64; # provided base64() is defined
# you can use it as a decoder as well
encoder($base64)->bytes('base64')->latin1;
# stringified
print encoder($data)->utf8->latin1; # prints the string in latin1
# numified
encoder("\x{abcd}\x{ef}g")->utf8 == 6; # true. bytes::length($data)
=head1 ABSTRACT
B<Encode::Encoder> allows you to use Encode in an object-oriented
style. This is not only more intuitive than a functional approach,
but also handier when you want to stack encodings. Suppose you want
your UTF-8 string converted to Latin1 then Base64: you can simply say
my $base64 = encoder($utf8)->latin1->base64;
instead of
my $latin1 = encode("latin1", $utf8);
my $base64 = encode_base64($utf8);
or the lazier and more convoluted
my $base64 = encode_base64(encode("latin1", $utf8));
=head1 Description
Here is how to use this module.
=over 4
=item *
There are at least two instance variables stored in a hash reference,
{data} and {encoding}.
=item *
When there is no method, it takes the method name as the name of the
encoding and encodes the instance I<data> with I<encoding>. If successful,
the instance I<encoding> is set accordingly.
=item *
You can retrieve the result via -E<gt>data but usually you don't have to
because the stringify operator ("") is overridden to do exactly that.
=back
=head2 Predefined Methods
This module predefines the methods below:
=over 4
=item $e = Encode::Encoder-E<gt>new([$data, $encoding]);
returns an encoder object. Its data is initialized with $data if
present, and its encoding is set to $encoding if present.
When $encoding is omitted, it defaults to utf8 if $data is already in
utf8 or "" (empty string) otherwise.
=item encoder()
is an alias of Encode::Encoder-E<gt>new(). This one is exported on demand.
=item $e-E<gt>data([$data])
When $data is present, sets the instance data to $data and returns the
object itself. Otherwise, the current instance data is returned.
=item $e-E<gt>encoding([$encoding])
When $encoding is present, sets the instance encoding to $encoding and
returns the object itself. Otherwise, the current instance encoding is
returned.
=item $e-E<gt>bytes([$encoding])
decodes instance data from $encoding, or the instance encoding if
omitted. If the conversion is successful, the instance encoding
will be set to "".
The name I<bytes> was deliberately picked to avoid namespace tainting
-- this module may be used as a base class so method names that appear
in Encode::Encoding are avoided.
=back
=head2 Example: base64 transcoder
This module is designed to work with L<Encode::Encoding>.
To make the Base64 transcoder example above really work, you could
write a module like this:
package Encode::Base64;
use base 'Encode::Encoding';
__PACKAGE__->Define('base64');
use MIME::Base64;
sub encode{
my ($obj, $data) = @_;
return encode_base64($data);
}
sub decode{
my ($obj, $data) = @_;
return decode_base64($data);
}
1;
__END__
And your caller module would be something like this:
use Encode::Encoder;
use Encode::Base64;
# now you can really do the following
encoder($data)->iso_8859_1->base64;
encoder($base64)->bytes('base64')->latin1;
=head2 Operator Overloading
This module overloads two operators, stringify ("") and numify (0+).
Stringify dumps the data inside the object.
Numify returns the number of bytes in the instance data.
They come in handy when you want to print or find the size of data.
=head1 SEE ALSO
L<Encode>,
L<Encode::Encoding>
=cut
DARWIN-2LEVEL_ENCODE_ENCODER
$fatpacked{"darwin-2level/Encode/Encoding.pm"} = <<'DARWIN-2LEVEL_ENCODE_ENCODING';
package Encode::Encoding;
# Base class for classes which implement encodings
use strict;
use warnings;
our $VERSION = do { my @r = ( q$Revision: 2.5 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
require Encode;
sub DEBUG { 0 }
sub Define {
my $obj = shift;
my $canonical = shift;
$obj = bless { Name => $canonical }, $obj unless ref $obj;
# warn "$canonical => $obj\n";
Encode::define_encoding( $obj, $canonical, @_ );
}
sub name { return shift->{'Name'} }
sub mime_name{
require Encode::MIME::Name;
return Encode::MIME::Name::get_mime_name(shift->name);
}
# sub renew { return $_[0] }
sub renew {
my $self = shift;
my $clone = bless {%$self} => ref($self);
$clone->{renewed}++; # so the caller can see it
DEBUG and warn $clone->{renewed};
return $clone;
}
sub renewed { return $_[0]->{renewed} || 0 }
*new_sequence = \&renew;
sub needs_lines { 0 }
sub perlio_ok {
eval { require PerlIO::encoding };
return $@ ? 0 : 1;
}
# (Temporary|legacy) methods
sub toUnicode { shift->decode(@_) }
sub fromUnicode { shift->encode(@_) }
#
# Needs to be overloaded or just croak
#
sub encode {
require Carp;
my $obj = shift;
my $class = ref($obj) ? ref($obj) : $obj;
Carp::croak( $class . "->encode() not defined!" );
}
sub decode {
require Carp;
my $obj = shift;
my $class = ref($obj) ? ref($obj) : $obj;
Carp::croak( $class . "->encode() not defined!" );
}
sub DESTROY { }
1;
__END__
=head1 NAME
Encode::Encoding - Encode Implementation Base Class
=head1 SYNOPSIS
package Encode::MyEncoding;
use base qw(Encode::Encoding);
__PACKAGE__->Define(qw(myCanonical myAlias));
=head1 DESCRIPTION
As mentioned in L<Encode>, encodings are (in the current
implementation at least) defined as objects. The mapping of encoding
name to object is via the C<%Encode::Encoding> hash. Though you can
directly manipulate this hash, it is strongly encouraged to use this
base class module and add encode() and decode() methods.
=head2 Methods you should implement
You are strongly encouraged to implement methods below, at least
either encode() or decode().
=over 4
=item -E<gt>encode($string [,$check])
MUST return the octet sequence representing I<$string>.
=over 2
=item *
If I<$check> is true, it SHOULD modify I<$string> in place to remove
the converted part (i.e. the whole string unless there is an error).
If perlio_ok() is true, SHOULD becomes MUST.
=item *
If an error occurs, it SHOULD return the octet sequence for the
fragment of string that has been converted and modify $string in-place
to remove the converted part leaving it starting with the problem
fragment. If perlio_ok() is true, SHOULD becomes MUST.
=item *
If I<$check> is is false then C<encode> MUST make a "best effort" to
convert the string - for example, by using a replacement character.
=back
=item -E<gt>decode($octets [,$check])
MUST return the string that I<$octets> represents.
=over 2
=item *
If I<$check> is true, it SHOULD modify I<$octets> in place to remove
the converted part (i.e. the whole sequence unless there is an
error). If perlio_ok() is true, SHOULD becomes MUST.
=item *
If an error occurs, it SHOULD return the fragment of string that has
been converted and modify $octets in-place to remove the converted
part leaving it starting with the problem fragment. If perlio_ok() is
true, SHOULD becomes MUST.
=item *
If I<$check> is false then C<decode> should make a "best effort" to
convert the string - for example by using Unicode's "\x{FFFD}" as a
replacement character.
=back
=back
If you want your encoding to work with L<encoding> pragma, you should
also implement the method below.
=over 4
=item -E<gt>cat_decode($destination, $octets, $offset, $terminator [,$check])
MUST decode I<$octets> with I<$offset> and concatenate it to I<$destination>.
Decoding will terminate when $terminator (a string) appears in output.
I<$offset> will be modified to the last $octets position at end of decode.
Returns true if $terminator appears output, else returns false.
=back
=head2 Other methods defined in Encode::Encodings
You do not have to override methods shown below unless you have to.
=over 4
=item -E<gt>name
Predefined As:
sub name { return shift->{'Name'} }
MUST return the string representing the canonical name of the encoding.
=item -E<gt>mime_name
Predefined As:
sub mime_name{
require Encode::MIME::Name;
return Encode::MIME::Name::get_mime_name(shift->name);
}
MUST return the string representing the IANA charset name of the encoding.
=item -E<gt>renew
Predefined As:
sub renew {
my $self = shift;
my $clone = bless { %$self } => ref($self);
$clone->{renewed}++;
return $clone;
}
This method reconstructs the encoding object if necessary. If you need
to store the state during encoding, this is where you clone your object.
PerlIO ALWAYS calls this method to make sure it has its own private
encoding object.
=item -E<gt>renewed
Predefined As:
sub renewed { $_[0]->{renewed} || 0 }
Tells whether the object is renewed (and how many times). Some
modules emit C<Use of uninitialized value in null operation> warning
unless the value is numeric so return 0 for false.
=item -E<gt>perlio_ok()
Predefined As:
sub perlio_ok {
eval{ require PerlIO::encoding };
return $@ ? 0 : 1;
}
If your encoding does not support PerlIO for some reasons, just;
sub perlio_ok { 0 }
=item -E<gt>needs_lines()
Predefined As:
sub needs_lines { 0 };
If your encoding can work with PerlIO but needs line buffering, you
MUST define this method so it returns true. 7bit ISO-2022 encodings
are one example that needs this. When this method is missing, false
is assumed.
=back
=head2 Example: Encode::ROT13
package Encode::ROT13;
use strict;
use base qw(Encode::Encoding);
__PACKAGE__->Define('rot13');
sub encode($$;$){
my ($obj, $str, $chk) = @_;
$str =~ tr/A-Za-z/N-ZA-Mn-za-m/;
$_[1] = '' if $chk; # this is what in-place edit means
return $str;
}
# Jr pna or ynml yvxr guvf;
*decode = \&encode;
1;
=head1 Why the heck Encode API is different?
It should be noted that the I<$check> behaviour is different from the
outer public API. The logic is that the "unchecked" case is useful
when the encoding is part of a stream which may be reporting errors
(e.g. STDERR). In such cases, it is desirable to get everything
through somehow without causing additional errors which obscure the
original one. Also, the encoding is best placed to know what the
correct replacement character is, so if that is the desired behaviour
then letting low level code do it is the most efficient.
By contrast, if I<$check> is true, the scheme above allows the
encoding to do as much as it can and tell the layer above how much
that was. What is lacking at present is a mechanism to report what
went wrong. The most likely interface will be an additional method
call to the object, or perhaps (to avoid forcing per-stream objects
on otherwise stateless encodings) an additional parameter.
It is also highly desirable that encoding classes inherit from
C<Encode::Encoding> as a base class. This allows that class to define
additional behaviour for all encoding objects.
package Encode::MyEncoding;
use base qw(Encode::Encoding);
__PACKAGE__->Define(qw(myCanonical myAlias));
to create an object with C<< bless {Name => ...}, $class >>, and call
define_encoding. They inherit their C<name> method from
C<Encode::Encoding>.
=head2 Compiled Encodings
For the sake of speed and efficiency, most of the encodings are now
supported via a I<compiled form>: XS modules generated from UCM
files. Encode provides the enc2xs tool to achieve that. Please see
L<enc2xs> for more details.
=head1 SEE ALSO
L<perlmod>, L<enc2xs>
=begin future
=over 4
=item Scheme 1
The fixup routine gets passed the remaining fragment of string being
processed. It modifies it in place to remove bytes/characters it can
understand and returns a string used to represent them. For example:
sub fixup {
my $ch = substr($_[0],0,1,'');
return sprintf("\x{%02X}",ord($ch);
}
This scheme is close to how the underlying C code for Encode works,
but gives the fixup routine very little context.
=item Scheme 2
The fixup routine gets passed the original string, an index into
it of the problem area, and the output string so far. It appends
what it wants to the output string and returns a new index into the
original string. For example:
sub fixup {
# my ($s,$i,$d) = @_;
my $ch = substr($_[0],$_[1],1);
$_[2] .= sprintf("\x{%02X}",ord($ch);
return $_[1]+1;
}
This scheme gives maximal control to the fixup routine but is more
complicated to code, and may require that the internals of Encode be tweaked to
keep the original string intact.
=item Other Schemes
Hybrids of the above.
Multiple return values rather than in-place modifications.
Index into the string could be C<pos($str)> allowing C<s/\G...//>.
=back
=end future
=cut
DARWIN-2LEVEL_ENCODE_ENCODING
$fatpacked{"darwin-2level/Encode/GSM0338.pm"} = <<'DARWIN-2LEVEL_ENCODE_GSM0338';
#
# $Id: GSM0338.pm,v 2.2 2012/08/15 05:36:16 dankogai Exp $
#
package Encode::GSM0338;
use strict;
use warnings;
use Carp;
use vars qw($VERSION);
$VERSION = do { my @r = ( q$Revision: 2.2 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
use Encode qw(:fallbacks);
use base qw(Encode::Encoding);
__PACKAGE__->Define('gsm0338');
sub needs_lines { 1 }
sub perlio_ok { 0 }
use utf8;
our %UNI2GSM = (
"\x{0040}" => "\x00", # COMMERCIAL AT
"\x{000A}" => "\x0A", # LINE FEED
"\x{000C}" => "\x1B\x0A", # FORM FEED
"\x{000D}" => "\x0D", # CARRIAGE RETURN
"\x{0020}" => "\x20", # SPACE
"\x{0021}" => "\x21", # EXCLAMATION MARK
"\x{0022}" => "\x22", # QUOTATION MARK
"\x{0023}" => "\x23", # NUMBER SIGN
"\x{0024}" => "\x02", # DOLLAR SIGN
"\x{0025}" => "\x25", # PERCENT SIGN
"\x{0026}" => "\x26", # AMPERSAND
"\x{0027}" => "\x27", # APOSTROPHE
"\x{0028}" => "\x28", # LEFT PARENTHESIS
"\x{0029}" => "\x29", # RIGHT PARENTHESIS
"\x{002A}" => "\x2A", # ASTERISK
"\x{002B}" => "\x2B", # PLUS SIGN
"\x{002C}" => "\x2C", # COMMA
"\x{002D}" => "\x2D", # HYPHEN-MINUS
"\x{002E}" => "\x2E", # FULL STOP
"\x{002F}" => "\x2F", # SOLIDUS
"\x{0030}" => "\x30", # DIGIT ZERO
"\x{0031}" => "\x31", # DIGIT ONE
"\x{0032}" => "\x32", # DIGIT TWO
"\x{0033}" => "\x33", # DIGIT THREE
"\x{0034}" => "\x34", # DIGIT FOUR
"\x{0035}" => "\x35", # DIGIT FIVE
"\x{0036}" => "\x36", # DIGIT SIX
"\x{0037}" => "\x37", # DIGIT SEVEN
"\x{0038}" => "\x38", # DIGIT EIGHT
"\x{0039}" => "\x39", # DIGIT NINE
"\x{003A}" => "\x3A", # COLON
"\x{003B}" => "\x3B", # SEMICOLON
"\x{003C}" => "\x3C", # LESS-THAN SIGN
"\x{003D}" => "\x3D", # EQUALS SIGN
"\x{003E}" => "\x3E", # GREATER-THAN SIGN
"\x{003F}" => "\x3F", # QUESTION MARK
"\x{0041}" => "\x41", # LATIN CAPITAL LETTER A
"\x{0042}" => "\x42", # LATIN CAPITAL LETTER B
"\x{0043}" => "\x43", # LATIN CAPITAL LETTER C
"\x{0044}" => "\x44", # LATIN CAPITAL LETTER D
"\x{0045}" => "\x45", # LATIN CAPITAL LETTER E
"\x{0046}" => "\x46", # LATIN CAPITAL LETTER F
"\x{0047}" => "\x47", # LATIN CAPITAL LETTER G
"\x{0048}" => "\x48", # LATIN CAPITAL LETTER H
"\x{0049}" => "\x49", # LATIN CAPITAL LETTER I
"\x{004A}" => "\x4A", # LATIN CAPITAL LETTER J
"\x{004B}" => "\x4B", # LATIN CAPITAL LETTER K
"\x{004C}" => "\x4C", # LATIN CAPITAL LETTER L
"\x{004D}" => "\x4D", # LATIN CAPITAL LETTER M
"\x{004E}" => "\x4E", # LATIN CAPITAL LETTER N
"\x{004F}" => "\x4F", # LATIN CAPITAL LETTER O
"\x{0050}" => "\x50", # LATIN CAPITAL LETTER P
"\x{0051}" => "\x51", # LATIN CAPITAL LETTER Q
"\x{0052}" => "\x52", # LATIN CAPITAL LETTER R
"\x{0053}" => "\x53", # LATIN CAPITAL LETTER S
"\x{0054}" => "\x54", # LATIN CAPITAL LETTER T
"\x{0055}" => "\x55", # LATIN CAPITAL LETTER U
"\x{0056}" => "\x56", # LATIN CAPITAL LETTER V
"\x{0057}" => "\x57", # LATIN CAPITAL LETTER W
"\x{0058}" => "\x58", # LATIN CAPITAL LETTER X
"\x{0059}" => "\x59", # LATIN CAPITAL LETTER Y
"\x{005A}" => "\x5A", # LATIN CAPITAL LETTER Z
"\x{005F}" => "\x11", # LOW LINE
"\x{0061}" => "\x61", # LATIN SMALL LETTER A
"\x{0062}" => "\x62", # LATIN SMALL LETTER B
"\x{0063}" => "\x63", # LATIN SMALL LETTER C
"\x{0064}" => "\x64", # LATIN SMALL LETTER D
"\x{0065}" => "\x65", # LATIN SMALL LETTER E
"\x{0066}" => "\x66", # LATIN SMALL LETTER F
"\x{0067}" => "\x67", # LATIN SMALL LETTER G
"\x{0068}" => "\x68", # LATIN SMALL LETTER H
"\x{0069}" => "\x69", # LATIN SMALL LETTER I
"\x{006A}" => "\x6A", # LATIN SMALL LETTER J
"\x{006B}" => "\x6B", # LATIN SMALL LETTER K
"\x{006C}" => "\x6C", # LATIN SMALL LETTER L
"\x{006D}" => "\x6D", # LATIN SMALL LETTER M
"\x{006E}" => "\x6E", # LATIN SMALL LETTER N
"\x{006F}" => "\x6F", # LATIN SMALL LETTER O
"\x{0070}" => "\x70", # LATIN SMALL LETTER P
"\x{0071}" => "\x71", # LATIN SMALL LETTER Q
"\x{0072}" => "\x72", # LATIN SMALL LETTER R
"\x{0073}" => "\x73", # LATIN SMALL LETTER S
"\x{0074}" => "\x74", # LATIN SMALL LETTER T
"\x{0075}" => "\x75", # LATIN SMALL LETTER U
"\x{0076}" => "\x76", # LATIN SMALL LETTER V
"\x{0077}" => "\x77", # LATIN SMALL LETTER W
"\x{0078}" => "\x78", # LATIN SMALL LETTER X
"\x{0079}" => "\x79", # LATIN SMALL LETTER Y
"\x{007A}" => "\x7A", # LATIN SMALL LETTER Z
"\x{000C}" => "\x1B\x0A", # FORM FEED
"\x{005B}" => "\x1B\x3C", # LEFT SQUARE BRACKET
"\x{005C}" => "\x1B\x2F", # REVERSE SOLIDUS
"\x{005D}" => "\x1B\x3E", # RIGHT SQUARE BRACKET
"\x{005E}" => "\x1B\x14", # CIRCUMFLEX ACCENT
"\x{007B}" => "\x1B\x28", # LEFT CURLY BRACKET
"\x{007C}" => "\x1B\x40", # VERTICAL LINE
"\x{007D}" => "\x1B\x29", # RIGHT CURLY BRACKET
"\x{007E}" => "\x1B\x3D", # TILDE
"\x{00A0}" => "\x1B", # NO-BREAK SPACE
"\x{00A1}" => "\x40", # INVERTED EXCLAMATION MARK
"\x{00A3}" => "\x01", # POUND SIGN
"\x{00A4}" => "\x24", # CURRENCY SIGN
"\x{00A5}" => "\x03", # YEN SIGN
"\x{00A7}" => "\x5F", # SECTION SIGN
"\x{00BF}" => "\x60", # INVERTED QUESTION MARK
"\x{00C4}" => "\x5B", # LATIN CAPITAL LETTER A WITH DIAERESIS
"\x{00C5}" => "\x0E", # LATIN CAPITAL LETTER A WITH RING ABOVE
"\x{00C6}" => "\x1C", # LATIN CAPITAL LETTER AE
"\x{00C9}" => "\x1F", # LATIN CAPITAL LETTER E WITH ACUTE
"\x{00D1}" => "\x5D", # LATIN CAPITAL LETTER N WITH TILDE
"\x{00D6}" => "\x5C", # LATIN CAPITAL LETTER O WITH DIAERESIS
"\x{00D8}" => "\x0B", # LATIN CAPITAL LETTER O WITH STROKE
"\x{00DC}" => "\x5E", # LATIN CAPITAL LETTER U WITH DIAERESIS
"\x{00DF}" => "\x1E", # LATIN SMALL LETTER SHARP S
"\x{00E0}" => "\x7F", # LATIN SMALL LETTER A WITH GRAVE
"\x{00E4}" => "\x7B", # LATIN SMALL LETTER A WITH DIAERESIS
"\x{00E5}" => "\x0F", # LATIN SMALL LETTER A WITH RING ABOVE
"\x{00E6}" => "\x1D", # LATIN SMALL LETTER AE
#"\x{00E7}" => "\x09", # LATIN SMALL LETTER C WITH CEDILLA
"\x{00C7}" => "\x09", # LATIN CAPITAL LETTER C WITH CEDILLA
"\x{00E8}" => "\x04", # LATIN SMALL LETTER E WITH GRAVE
"\x{00E9}" => "\x05", # LATIN SMALL LETTER E WITH ACUTE
"\x{00EC}" => "\x07", # LATIN SMALL LETTER I WITH GRAVE
"\x{00F1}" => "\x7D", # LATIN SMALL LETTER N WITH TILDE
"\x{00F2}" => "\x08", # LATIN SMALL LETTER O WITH GRAVE
"\x{00F6}" => "\x7C", # LATIN SMALL LETTER O WITH DIAERESIS
"\x{00F8}" => "\x0C", # LATIN SMALL LETTER O WITH STROKE
"\x{00F9}" => "\x06", # LATIN SMALL LETTER U WITH GRAVE
"\x{00FC}" => "\x7E", # LATIN SMALL LETTER U WITH DIAERESIS
"\x{0393}" => "\x13", # GREEK CAPITAL LETTER GAMMA
"\x{0394}" => "\x10", # GREEK CAPITAL LETTER DELTA
"\x{0398}" => "\x19", # GREEK CAPITAL LETTER THETA
"\x{039B}" => "\x14", # GREEK CAPITAL LETTER LAMDA
"\x{039E}" => "\x1A", # GREEK CAPITAL LETTER XI
"\x{03A0}" => "\x16", # GREEK CAPITAL LETTER PI
"\x{03A3}" => "\x18", # GREEK CAPITAL LETTER SIGMA
"\x{03A6}" => "\x12", # GREEK CAPITAL LETTER PHI
"\x{03A8}" => "\x17", # GREEK CAPITAL LETTER PSI
"\x{03A9}" => "\x15", # GREEK CAPITAL LETTER OMEGA
"\x{20AC}" => "\x1B\x65", # EURO SIGN
);
our %GSM2UNI = reverse %UNI2GSM;
our $ESC = "\x1b";
our $ATMARK = "\x40";
our $FBCHAR = "\x3F";
our $NBSP = "\x{00A0}";
#define ERR_DECODE_NOMAP "%s \"\\x%02" UVXf "\" does not map to Unicode"
sub decode ($$;$) {
my ( $obj, $bytes, $chk ) = @_;
my $str;
while ( length $bytes ) {
my $c = substr( $bytes, 0, 1, '' );
my $u;
if ( $c eq "\x00" ) {
my $c2 = substr( $bytes, 0, 1, '' );
$u =
!length $c2 ? $ATMARK
: $c2 eq "\x00" ? "\x{0000}"
: exists $GSM2UNI{$c2} ? $ATMARK . $GSM2UNI{$c2}
: $chk
? croak sprintf( "\\x%02X\\x%02X does not map to Unicode",
ord($c), ord($c2) )
: $ATMARK . $FBCHAR;
}
elsif ( $c eq $ESC ) {
my $c2 = substr( $bytes, 0, 1, '' );
$u =
exists $GSM2UNI{ $c . $c2 } ? $GSM2UNI{ $c . $c2 }
: exists $GSM2UNI{$c2} ? $NBSP . $GSM2UNI{$c2}
: $chk
? croak sprintf( "\\x%02X\\x%02X does not map to Unicode",
ord($c), ord($c2) )
: $NBSP . $FBCHAR;
}
else {
$u =
exists $GSM2UNI{$c}
? $GSM2UNI{$c}
: $chk ? ref $chk eq 'CODE'
? $chk->( ord $c )
: croak sprintf( "\\x%02X does not map to Unicode", ord($c) )
: $FBCHAR;
}
$str .= $u;
}
$_[1] = $bytes if $chk;
return $str;
}
#define ERR_ENCODE_NOMAP "\"\\x{%04" UVxf "}\" does not map to %s"
sub encode($$;$) {
my ( $obj, $str, $chk ) = @_;
my $bytes;
while ( length $str ) {
my $u = substr( $str, 0, 1, '' );
my $c;
$bytes .=
exists $UNI2GSM{$u}
? $UNI2GSM{$u}
: $chk ? ref $chk eq 'CODE'
? $chk->( ord($u) )
: croak sprintf( "\\x{%04x} does not map to %s",
ord($u), $obj->name )
: $FBCHAR;
}
$_[1] = $str if $chk;
return $bytes;
}
1;
__END__
=head1 NAME
Encode::GSM0338 -- ESTI GSM 03.38 Encoding
=head1 SYNOPSIS
use Encode qw/encode decode/;
$gsm0338 = encode("gsm0338", $utf8); # loads Encode::GSM0338 implicitly
$utf8 = decode("gsm0338", $gsm0338); # ditto
=head1 DESCRIPTION
GSM0338 is for GSM handsets. Though it shares alphanumerals with ASCII,
control character ranges and other parts are mapped very differently,
mainly to store Greek characters. There are also escape sequences
(starting with 0x1B) to cover e.g. the Euro sign.
This was once handled by L<Encode::Bytes> but because of all those
unusual specifications, Encode 2.20 has relocated the support to
this module.
=head1 NOTES
Unlike most other encodings, the following aways croaks on error
for any $chk that evaluates to true.
$gsm0338 = encode("gsm0338", $utf8 $chk);
$utf8 = decode("gsm0338", $gsm0338, $chk);
So if you want to check the validity of the encoding, surround the
expression with C<eval {}> block as follows;
eval {
$utf8 = decode("gsm0338", $gsm0338, $chk);
};
if ($@){
# handle exception here
}
=head1 BUGS
ESTI GSM 03.38 Encoding itself.
Mapping \x00 to '@' causes too much pain everywhere.
Its use of \x1b (escape) is also very questionable.
Because of those two, the code paging approach used use in ucm-based
Encoding SOMETIMES fails so this module was written.
=head1 SEE ALSO
L<Encode>
=cut
DARWIN-2LEVEL_ENCODE_GSM0338
$fatpacked{"darwin-2level/Encode/Guess.pm"} = <<'DARWIN-2LEVEL_ENCODE_GUESS';
package Encode::Guess;
use strict;
use warnings;
use Encode qw(:fallbacks find_encoding);
our $VERSION = do { my @r = ( q$Revision: 2.5 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
my $Canon = 'Guess';
use constant DEBUG => !!$ENV{PERL_ENCODE_DEBUG};
our %DEF_SUSPECTS = map { $_ => find_encoding($_) } qw(ascii utf8);
$Encode::Encoding{$Canon} = bless {
Name => $Canon,
Suspects => {%DEF_SUSPECTS},
} => __PACKAGE__;
use base qw(Encode::Encoding);
sub needs_lines { 1 }
sub perlio_ok { 0 }
our @EXPORT = qw(guess_encoding);
our $NoUTFAutoGuess = 0;
our $UTF8_BOM = pack( "C3", 0xef, 0xbb, 0xbf );
sub import { # Exporter not used so we do it on our own
my $callpkg = caller;
for my $item (@EXPORT) {
no strict 'refs';
*{"$callpkg\::$item"} = \&{"$item"};
}
set_suspects(@_);
}
sub set_suspects {
my $class = shift;
my $self = ref($class) ? $class : $Encode::Encoding{$Canon};
$self->{Suspects} = {%DEF_SUSPECTS};
$self->add_suspects(@_);
}
sub add_suspects {
my $class = shift;
my $self = ref($class) ? $class : $Encode::Encoding{$Canon};
for my $c (@_) {
my $e = find_encoding($c) or die "Unknown encoding: $c";
$self->{Suspects}{ $e->name } = $e;
DEBUG and warn "Added: ", $e->name;
}
}
sub decode($$;$) {
my ( $obj, $octet, $chk ) = @_;
my $guessed = guess( $obj, $octet );
unless ( ref($guessed) ) {
require Carp;
Carp::croak($guessed);
}
my $utf8 = $guessed->decode( $octet, $chk || 0 );
$_[1] = $octet if $chk;
return $utf8;
}
sub guess_encoding {
guess( $Encode::Encoding{$Canon}, @_ );
}
sub guess {
my $class = shift;
my $obj = ref($class) ? $class : $Encode::Encoding{$Canon};
my $octet = shift;
# sanity check
return "Empty string, empty guess" unless defined $octet and length $octet;
# cheat 0: utf8 flag;
if ( Encode::is_utf8($octet) ) {
return find_encoding('utf8') unless $NoUTFAutoGuess;
Encode::_utf8_off($octet);
}
# cheat 1: BOM
use Encode::Unicode;
unless ($NoUTFAutoGuess) {
my $BOM = pack( 'C3', unpack( "C3", $octet ) );
return find_encoding('utf8')
if ( defined $BOM and $BOM eq $UTF8_BOM );
$BOM = unpack( 'N', $octet );
return find_encoding('UTF-32')
if ( defined $BOM and ( $BOM == 0xFeFF or $BOM == 0xFFFe0000 ) );
$BOM = unpack( 'n', $octet );
return find_encoding('UTF-16')
if ( defined $BOM and ( $BOM == 0xFeFF or $BOM == 0xFFFe ) );
if ( $octet =~ /\x00/o )
{ # if \x00 found, we assume UTF-(16|32)(BE|LE)
my $utf;
my ( $be, $le ) = ( 0, 0 );
if ( $octet =~ /\x00\x00/o ) { # UTF-32(BE|LE) assumed
$utf = "UTF-32";
for my $char ( unpack( 'N*', $octet ) ) {
$char & 0x0000ffff and $be++;
$char & 0xffff0000 and $le++;
}
}
else { # UTF-16(BE|LE) assumed
$utf = "UTF-16";
for my $char ( unpack( 'n*', $octet ) ) {
$char & 0x00ff and $be++;
$char & 0xff00 and $le++;
}
}
DEBUG and warn "$utf, be == $be, le == $le";
$be == $le
and return
"Encodings ambiguous between $utf BE and LE ($be, $le)";
$utf .= ( $be > $le ) ? 'BE' : 'LE';
return find_encoding($utf);
}
}
my %try = %{ $obj->{Suspects} };
for my $c (@_) {
my $e = find_encoding($c) or die "Unknown encoding: $c";
$try{ $e->name } = $e;
DEBUG and warn "Added: ", $e->name;
}
my $nline = 1;
for my $line ( split /\r\n?|\n/, $octet ) {
# cheat 2 -- \e in the string
if ( $line =~ /\e/o ) {
my @keys = keys %try;
delete @try{qw/utf8 ascii/};
for my $k (@keys) {
ref( $try{$k} ) eq 'Encode::XS' and delete $try{$k};
}
}
my %ok = %try;
# warn join(",", keys %try);
for my $k ( keys %try ) {
my $scratch = $line;
$try{$k}->decode( $scratch, FB_QUIET );
if ( $scratch eq '' ) {
DEBUG and warn sprintf( "%4d:%-24s ok\n", $nline, $k );
}
else {
use bytes ();
DEBUG
and warn sprintf( "%4d:%-24s not ok; %d bytes left\n",
$nline, $k, bytes::length($scratch) );
delete $ok{$k};
}
}
%ok or return "No appropriate encodings found!";
if ( scalar( keys(%ok) ) == 1 ) {
my ($retval) = values(%ok);
return $retval;
}
%try = %ok;
$nline++;
}
$try{ascii}
or return "Encodings too ambiguous: ", join( " or ", keys %try );
return $try{ascii};
}
1;
__END__
=head1 NAME
Encode::Guess -- Guesses encoding from data
=head1 SYNOPSIS
# if you are sure $data won't contain anything bogus
use Encode;
use Encode::Guess qw/euc-jp shiftjis 7bit-jis/;
my $utf8 = decode("Guess", $data);
my $data = encode("Guess", $utf8); # this doesn't work!
# more elaborate way
use Encode::Guess;
my $enc = guess_encoding($data, qw/euc-jp shiftjis 7bit-jis/);
ref($enc) or die "Can't guess: $enc"; # trap error this way
$utf8 = $enc->decode($data);
# or
$utf8 = decode($enc->name, $data)
=head1 ABSTRACT
Encode::Guess enables you to guess in what encoding a given data is
encoded, or at least tries to.
=head1 DESCRIPTION
By default, it checks only ascii, utf8 and UTF-16/32 with BOM.
use Encode::Guess; # ascii/utf8/BOMed UTF
To use it more practically, you have to give the names of encodings to
check (I<suspects> as follows). The name of suspects can either be
canonical names or aliases.
CAVEAT: Unlike UTF-(16|32), BOM in utf8 is NOT AUTOMATICALLY STRIPPED.
# tries all major Japanese Encodings as well
use Encode::Guess qw/euc-jp shiftjis 7bit-jis/;
If the C<$Encode::Guess::NoUTFAutoGuess> variable is set to a true
value, no heuristics will be applied to UTF8/16/32, and the result
will be limited to the suspects and C<ascii>.
=over 4
=item Encode::Guess->set_suspects
You can also change the internal suspects list via C<set_suspects>
method.
use Encode::Guess;
Encode::Guess->set_suspects(qw/euc-jp shiftjis 7bit-jis/);
=item Encode::Guess->add_suspects
Or you can use C<add_suspects> method. The difference is that
C<set_suspects> flushes the current suspects list while
C<add_suspects> adds.
use Encode::Guess;
Encode::Guess->add_suspects(qw/euc-jp shiftjis 7bit-jis/);
# now the suspects are euc-jp,shiftjis,7bit-jis, AND
# euc-kr,euc-cn, and big5-eten
Encode::Guess->add_suspects(qw/euc-kr euc-cn big5-eten/);
=item Encode::decode("Guess" ...)
When you are content with suspects list, you can now
my $utf8 = Encode::decode("Guess", $data);
=item Encode::Guess->guess($data)
But it will croak if:
=over
=item *
Two or more suspects remain
=item *
No suspects left
=back
So you should instead try this;
my $decoder = Encode::Guess->guess($data);
On success, $decoder is an object that is documented in
L<Encode::Encoding>. So you can now do this;
my $utf8 = $decoder->decode($data);
On failure, $decoder now contains an error message so the whole thing
would be as follows;
my $decoder = Encode::Guess->guess($data);
die $decoder unless ref($decoder);
my $utf8 = $decoder->decode($data);
=item guess_encoding($data, [, I<list of suspects>])
You can also try C<guess_encoding> function which is exported by
default. It takes $data to check and it also takes the list of
suspects by option. The optional suspect list is I<not reflected> to
the internal suspects list.
my $decoder = guess_encoding($data, qw/euc-jp euc-kr euc-cn/);
die $decoder unless ref($decoder);
my $utf8 = $decoder->decode($data);
# check only ascii, utf8 and UTF-(16|32) with BOM
my $decoder = guess_encoding($data);
=back
=head1 CAVEATS
=over 4
=item *
Because of the algorithm used, ISO-8859 series and other single-byte
encodings do not work well unless either one of ISO-8859 is the only
one suspect (besides ascii and utf8).
use Encode::Guess;
# perhaps ok
my $decoder = guess_encoding($data, 'latin1');
# definitely NOT ok
my $decoder = guess_encoding($data, qw/latin1 greek/);
The reason is that Encode::Guess guesses encoding by trial and error.
It first splits $data into lines and tries to decode the line for each
suspect. It keeps it going until all but one encoding is eliminated
out of suspects list. ISO-8859 series is just too successful for most
cases (because it fills almost all code points in \x00-\xff).
=item *
Do not mix national standard encodings and the corresponding vendor
encodings.
# a very bad idea
my $decoder
= guess_encoding($data, qw/shiftjis MacJapanese cp932/);
The reason is that vendor encoding is usually a superset of national
standard so it becomes too ambiguous for most cases.
=item *
On the other hand, mixing various national standard encodings
automagically works unless $data is too short to allow for guessing.
# This is ok if $data is long enough
my $decoder =
guess_encoding($data, qw/euc-cn
euc-jp shiftjis 7bit-jis
euc-kr
big5-eten/);
=item *
DO NOT PUT TOO MANY SUSPECTS! Don't you try something like this!
my $decoder = guess_encoding($data,
Encode->encodings(":all"));
=back
It is, after all, just a guess. You should alway be explicit when it
comes to encodings. But there are some, especially Japanese,
environment that guess-coding is a must. Use this module with care.
=head1 TO DO
Encode::Guess does not work on EBCDIC platforms.
=head1 SEE ALSO
L<Encode>, L<Encode::Encoding>
=cut
DARWIN-2LEVEL_ENCODE_GUESS
$fatpacked{"darwin-2level/Encode/JP.pm"} = <<'DARWIN-2LEVEL_ENCODE_JP';
package Encode::JP;
BEGIN {
if ( ord("A") == 193 ) {
die "Encode::JP not supported on EBCDIC\n";
}
}
use strict;
use warnings;
use Encode;
our $VERSION = do { my @r = ( q$Revision: 2.4 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
use XSLoader;
XSLoader::load( __PACKAGE__, $VERSION );
use Encode::JP::JIS7;
1;
__END__
=head1 NAME
Encode::JP - Japanese Encodings
=head1 SYNOPSIS
use Encode qw/encode decode/;
$euc_jp = encode("euc-jp", $utf8); # loads Encode::JP implicitly
$utf8 = decode("euc-jp", $euc_jp); # ditto
=head1 ABSTRACT
This module implements Japanese charset encodings. Encodings
supported are as follows.
Canonical Alias Description
--------------------------------------------------------------------
euc-jp /\beuc.*jp$/i EUC (Extended Unix Character)
/\bjp.*euc/i
/\bujis$/i
shiftjis /\bshift.*jis$/i Shift JIS (aka MS Kanji)
/\bsjis$/i
7bit-jis /\bjis$/i 7bit JIS
iso-2022-jp ISO-2022-JP [RFC1468]
= 7bit JIS with all Halfwidth Kana
converted to Fullwidth
iso-2022-jp-1 ISO-2022-JP-1 [RFC2237]
= ISO-2022-JP with JIS X 0212-1990
support. See below
MacJapanese Shift JIS + Apple vendor mappings
cp932 /\bwindows-31j$/i Code Page 932
= Shift JIS + MS/IBM vendor mappings
jis0201-raw JIS0201, raw format
jis0208-raw JIS0201, raw format
jis0212-raw JIS0201, raw format
--------------------------------------------------------------------
=head1 DESCRIPTION
To find out how to use this module in detail, see L<Encode>.
=head1 Note on ISO-2022-JP(-1)?
ISO-2022-JP-1 (RFC2237) is a superset of ISO-2022-JP (RFC1468) which
adds support for JIS X 0212-1990. That means you can use the same
code to decode to utf8 but not vice versa.
$utf8 = decode('iso-2022-jp-1', $stream);
and
$utf8 = decode('iso-2022-jp', $stream);
yield the same result but
$with_0212 = encode('iso-2022-jp-1', $utf8);
is now different from
$without_0212 = encode('iso-2022-jp', $utf8 );
In the latter case, characters that map to 0212 are first converted
to U+3013 (0xA2AE in EUC-JP; a white square also known as 'Tofu' or
'geta mark') then fed to the decoding engine. U+FFFD is not used,
in order to preserve text layout as much as possible.
=head1 BUGS
The ASCII region (0x00-0x7f) is preserved for all encodings, even
though this conflicts with mappings by the Unicode Consortium.
=head1 SEE ALSO
L<Encode>
=cut
DARWIN-2LEVEL_ENCODE_JP
$fatpacked{"darwin-2level/Encode/JP/H2Z.pm"} = <<'DARWIN-2LEVEL_ENCODE_JP_H2Z';
#
# $Id: H2Z.pm,v 2.2 2006/06/03 20:28:48 dankogai Exp $
#
package Encode::JP::H2Z;
use strict;
use warnings;
our $RCSID = q$Id: H2Z.pm,v 2.2 2006/06/03 20:28:48 dankogai Exp $;
our $VERSION = do { my @r = ( q$Revision: 2.2 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
use Encode::CJKConstants qw(:all);
use vars qw(%_D2Z $_PAT_D2Z
%_Z2D $_PAT_Z2D
%_H2Z $_PAT_H2Z
%_Z2H $_PAT_Z2H);
%_H2Z = (
"\x8e\xa1" => "\xa1\xa3", #¡£
"\x8e\xa2" => "\xa1\xd6", #¡Ö
"\x8e\xa3" => "\xa1\xd7", #¡×
"\x8e\xa4" => "\xa1\xa2", #¡¢
"\x8e\xa5" => "\xa1\xa6", #¡¦
"\x8e\xa6" => "\xa5\xf2", #¥ò
"\x8e\xa7" => "\xa5\xa1", #¥¡
"\x8e\xa8" => "\xa5\xa3", #¥£
"\x8e\xa9" => "\xa5\xa5", #¥¥
"\x8e\xaa" => "\xa5\xa7", #¥§
"\x8e\xab" => "\xa5\xa9", #¥©
"\x8e\xac" => "\xa5\xe3", #¥ã
"\x8e\xad" => "\xa5\xe5", #¥å
"\x8e\xae" => "\xa5\xe7", #¥ç
"\x8e\xaf" => "\xa5\xc3", #¥Ã
"\x8e\xb0" => "\xa1\xbc", #¡¼
"\x8e\xb1" => "\xa5\xa2", #¥¢
"\x8e\xb2" => "\xa5\xa4", #¥¤
"\x8e\xb3" => "\xa5\xa6", #¥¦
"\x8e\xb4" => "\xa5\xa8", #¥¨
"\x8e\xb5" => "\xa5\xaa", #¥ª
"\x8e\xb6" => "\xa5\xab", #¥«
"\x8e\xb7" => "\xa5\xad", #¥
"\x8e\xb8" => "\xa5\xaf", #¥¯
"\x8e\xb9" => "\xa5\xb1", #¥±
"\x8e\xba" => "\xa5\xb3", #¥³
"\x8e\xbb" => "\xa5\xb5", #¥µ
"\x8e\xbc" => "\xa5\xb7", #¥·
"\x8e\xbd" => "\xa5\xb9", #¥¹
"\x8e\xbe" => "\xa5\xbb", #¥»
"\x8e\xbf" => "\xa5\xbd", #¥½
"\x8e\xc0" => "\xa5\xbf", #¥¿
"\x8e\xc1" => "\xa5\xc1", #¥Á
"\x8e\xc2" => "\xa5\xc4", #¥Ä
"\x8e\xc3" => "\xa5\xc6", #¥Æ
"\x8e\xc4" => "\xa5\xc8", #¥È
"\x8e\xc5" => "\xa5\xca", #¥Ê
"\x8e\xc6" => "\xa5\xcb", #¥Ë
"\x8e\xc7" => "\xa5\xcc", #¥Ì
"\x8e\xc8" => "\xa5\xcd", #¥Í
"\x8e\xc9" => "\xa5\xce", #¥Î
"\x8e\xca" => "\xa5\xcf", #¥Ï
"\x8e\xcb" => "\xa5\xd2", #¥Ò
"\x8e\xcc" => "\xa5\xd5", #¥Õ
"\x8e\xcd" => "\xa5\xd8", #¥Ø
"\x8e\xce" => "\xa5\xdb", #¥Û
"\x8e\xcf" => "\xa5\xde", #¥Þ
"\x8e\xd0" => "\xa5\xdf", #¥ß
"\x8e\xd1" => "\xa5\xe0", #¥à
"\x8e\xd2" => "\xa5\xe1", #¥á
"\x8e\xd3" => "\xa5\xe2", #¥â
"\x8e\xd4" => "\xa5\xe4", #¥ä
"\x8e\xd5" => "\xa5\xe6", #¥æ
"\x8e\xd6" => "\xa5\xe8", #¥è
"\x8e\xd7" => "\xa5\xe9", #¥é
"\x8e\xd8" => "\xa5\xea", #¥ê
"\x8e\xd9" => "\xa5\xeb", #¥ë
"\x8e\xda" => "\xa5\xec", #¥ì
"\x8e\xdb" => "\xa5\xed", #¥í
"\x8e\xdc" => "\xa5\xef", #¥ï
"\x8e\xdd" => "\xa5\xf3", #¥ó
"\x8e\xde" => "\xa1\xab", #¡«
"\x8e\xdf" => "\xa1\xac", #¡¬
);
%_D2Z = (
"\x8e\xb6\x8e\xde" => "\xa5\xac", #¥¬
"\x8e\xb7\x8e\xde" => "\xa5\xae", #¥®
"\x8e\xb8\x8e\xde" => "\xa5\xb0", #¥°
"\x8e\xb9\x8e\xde" => "\xa5\xb2", #¥²
"\x8e\xba\x8e\xde" => "\xa5\xb4", #¥´
"\x8e\xbb\x8e\xde" => "\xa5\xb6", #¥¶
"\x8e\xbc\x8e\xde" => "\xa5\xb8", #¥¸
"\x8e\xbd\x8e\xde" => "\xa5\xba", #¥º
"\x8e\xbe\x8e\xde" => "\xa5\xbc", #¥¼
"\x8e\xbf\x8e\xde" => "\xa5\xbe", #¥¾
"\x8e\xc0\x8e\xde" => "\xa5\xc0", #¥À
"\x8e\xc1\x8e\xde" => "\xa5\xc2", #¥Â
"\x8e\xc2\x8e\xde" => "\xa5\xc5", #¥Å
"\x8e\xc3\x8e\xde" => "\xa5\xc7", #¥Ç
"\x8e\xc4\x8e\xde" => "\xa5\xc9", #¥É
"\x8e\xca\x8e\xde" => "\xa5\xd0", #¥Ð
"\x8e\xcb\x8e\xde" => "\xa5\xd3", #¥Ó
"\x8e\xcc\x8e\xde" => "\xa5\xd6", #¥Ö
"\x8e\xcd\x8e\xde" => "\xa5\xd9", #¥Ù
"\x8e\xce\x8e\xde" => "\xa5\xdc", #¥Ü
"\x8e\xca\x8e\xdf" => "\xa5\xd1", #¥Ñ
"\x8e\xcb\x8e\xdf" => "\xa5\xd4", #¥Ô
"\x8e\xcc\x8e\xdf" => "\xa5\xd7", #¥×
"\x8e\xcd\x8e\xdf" => "\xa5\xda", #¥Ú
"\x8e\xce\x8e\xdf" => "\xa5\xdd", #¥Ý
"\x8e\xb3\x8e\xde" => "\xa5\xf4", #¥ô
);
# init only once;
#$_PAT_D2Z = join("|", keys %_D2Z);
#$_PAT_H2Z = join("|", keys %_H2Z);
%_Z2H = reverse %_H2Z;
%_Z2D = reverse %_D2Z;
#$_PAT_Z2H = join("|", keys %_Z2H);
#$_PAT_Z2D = join("|", keys %_Z2D);
sub h2z {
no warnings qw(uninitialized);
my $r_str = shift;
my ($keep_dakuten) = @_;
my $n = 0;
unless ($keep_dakuten) {
$n = (
$$r_str =~ s(
($RE{EUC_KANA}
(?:\x8e[\xde\xdf])?)
){
my $str = $1;
$_D2Z{$str} || $_H2Z{$str} ||
# in case dakuten and handakuten are side-by-side!
$_H2Z{substr($str,0,2)} . $_H2Z{substr($str,2,2)};
}eogx
);
}
else {
$n = (
$$r_str =~ s(
($RE{EUC_KANA})
){
$_H2Z{$1};
}eogx
);
}
$n;
}
sub z2h {
my $r_str = shift;
my $n = (
$$r_str =~ s(
($RE{EUC_C}|$RE{EUC_0212}|$RE{EUC_KANA})
){
$_Z2D{$1} || $_Z2H{$1} || $1;
}eogx
);
$n;
}
1;
__END__
=head1 NAME
Encode::JP::H2Z -- internally used by Encode::JP::2022_JP*
=cut
DARWIN-2LEVEL_ENCODE_JP_H2Z
$fatpacked{"darwin-2level/Encode/JP/JIS7.pm"} = <<'DARWIN-2LEVEL_ENCODE_JP_JIS7';
package Encode::JP::JIS7;
use strict;
use warnings;
our $VERSION = do { my @r = ( q$Revision: 2.4 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
use Encode qw(:fallbacks);
for my $name ( '7bit-jis', 'iso-2022-jp', 'iso-2022-jp-1' ) {
my $h2z = ( $name eq '7bit-jis' ) ? 0 : 1;
my $jis0212 = ( $name eq 'iso-2022-jp' ) ? 0 : 1;
$Encode::Encoding{$name} = bless {
Name => $name,
h2z => $h2z,
jis0212 => $jis0212,
} => __PACKAGE__;
}
use base qw(Encode::Encoding);
# we override this to 1 so PerlIO works
sub needs_lines { 1 }
use Encode::CJKConstants qw(:all);
#
# decode is identical for all 2022 variants
#
sub decode($$;$) {
my ( $obj, $str, $chk ) = @_;
my $residue = '';
if ($chk) {
$str =~ s/([^\x00-\x7f].*)$//so and $residue = $1;
}
$residue .= jis_euc( \$str );
$_[1] = $residue if $chk;
return Encode::decode( 'euc-jp', $str, FB_PERLQQ );
}
#
# encode is different
#
sub encode($$;$) {
require Encode::JP::H2Z;
my ( $obj, $utf8, $chk ) = @_;
# empty the input string in the stack so perlio is ok
$_[1] = '' if $chk;
my ( $h2z, $jis0212 ) = @$obj{qw(h2z jis0212)};
my $octet = Encode::encode( 'euc-jp', $utf8, $chk );
$h2z and &Encode::JP::H2Z::h2z( \$octet );
euc_jis( \$octet, $jis0212 );
return $octet;
}
#
# cat_decode
#
my $re_scan_jis_g = qr{
\G ( ($RE{JIS_0212}) | $RE{JIS_0208} |
($RE{ISO_ASC}) | ($RE{JIS_KANA}) | )
([^\e]*)
}x;
sub cat_decode { # ($obj, $dst, $src, $pos, $trm, $chk)
my ( $obj, undef, undef, $pos, $trm ) = @_; # currently ignores $chk
my ( $rdst, $rsrc, $rpos ) = \@_[ 1, 2, 3 ];
local ${^ENCODING};
use bytes;
my $opos = pos($$rsrc);
pos($$rsrc) = $pos;
while ( $$rsrc =~ /$re_scan_jis_g/gc ) {
my ( $esc, $esc_0212, $esc_asc, $esc_kana, $chunk ) =
( $1, $2, $3, $4, $5 );
unless ($chunk) { $esc or last; next; }
if ( $esc && !$esc_asc ) {
$chunk =~ tr/\x21-\x7e/\xa1-\xfe/;
if ($esc_kana) {
$chunk =~ s/([\xa1-\xdf])/\x8e$1/og;
}
elsif ($esc_0212) {
$chunk =~ s/([\xa1-\xfe][\xa1-\xfe])/\x8f$1/og;
}
$chunk = Encode::decode( 'euc-jp', $chunk, 0 );
}
elsif ( ( my $npos = index( $chunk, $trm ) ) >= 0 ) {
$$rdst .= substr( $chunk, 0, $npos + length($trm) );
$$rpos += length($esc) + $npos + length($trm);
pos($$rsrc) = $opos;
return 1;
}
$$rdst .= $chunk;
$$rpos = pos($$rsrc);
}
$$rpos = pos($$rsrc);
pos($$rsrc) = $opos;
return '';
}
# JIS<->EUC
my $re_scan_jis = qr{
(?:($RE{JIS_0212})|$RE{JIS_0208}|($RE{ISO_ASC})|($RE{JIS_KANA}))([^\e]*)
}x;
sub jis_euc {
local ${^ENCODING};
my $r_str = shift;
$$r_str =~ s($re_scan_jis)
{
my ($esc_0212, $esc_asc, $esc_kana, $chunk) =
($1, $2, $3, $4);
if (!$esc_asc) {
$chunk =~ tr/\x21-\x7e/\xa1-\xfe/;
if ($esc_kana) {
$chunk =~ s/([\xa1-\xdf])/\x8e$1/og;
}
elsif ($esc_0212) {
$chunk =~ s/([\xa1-\xfe][\xa1-\xfe])/\x8f$1/og;
}
}
$chunk;
}geox;
my ($residue) = ( $$r_str =~ s/(\e.*)$//so );
return $residue;
}
sub euc_jis {
no warnings qw(uninitialized);
local ${^ENCODING};
my $r_str = shift;
my $jis0212 = shift;
$$r_str =~ s{
((?:$RE{EUC_C})+|(?:$RE{EUC_KANA})+|(?:$RE{EUC_0212})+)
}{
my $chunk = $1;
my $esc =
( $chunk =~ tr/\x8E//d ) ? $ESC{KANA} :
( $chunk =~ tr/\x8F//d ) ? $ESC{JIS_0212} :
$ESC{JIS_0208};
if ($esc eq $ESC{JIS_0212} && !$jis0212){
# fallback to '?'
$chunk =~ tr/\xA1-\xFE/\x3F/;
}else{
$chunk =~ tr/\xA1-\xFE/\x21-\x7E/;
}
$esc . $chunk . $ESC{ASC};
}geox;
$$r_str =~ s/\Q$ESC{ASC}\E
(\Q$ESC{KANA}\E|\Q$ESC{JIS_0212}\E|\Q$ESC{JIS_0208}\E)/$1/gox;
$$r_str;
}
1;
__END__
=head1 NAME
Encode::JP::JIS7 -- internally used by Encode::JP
=cut
DARWIN-2LEVEL_ENCODE_JP_JIS7
$fatpacked{"darwin-2level/Encode/KR.pm"} = <<'DARWIN-2LEVEL_ENCODE_KR';
package Encode::KR;
BEGIN {
if ( ord("A") == 193 ) {
die "Encode::KR not supported on EBCDIC\n";
}
}
use strict;
use warnings;
use Encode;
our $VERSION = do { my @r = ( q$Revision: 2.3 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
use XSLoader;
XSLoader::load( __PACKAGE__, $VERSION );
use Encode::KR::2022_KR;
1;
__END__
=head1 NAME
Encode::KR - Korean Encodings
=head1 SYNOPSIS
use Encode qw/encode decode/;
$euc_kr = encode("euc-kr", $utf8); # loads Encode::KR implicitly
$utf8 = decode("euc-kr", $euc_kr); # ditto
=head1 DESCRIPTION
This module implements Korean charset encodings. Encodings supported
are as follows.
Canonical Alias Description
--------------------------------------------------------------------
euc-kr /\beuc.*kr$/i EUC (Extended Unix Character)
/\bkr.*euc$/i
ksc5601-raw Korean standard code set (as is)
cp949 /(?:x-)?uhc$/i
/(?:x-)?windows-949$/i
/\bks_c_5601-1987$/i
Code Page 949 (EUC-KR + 8,822
(additional Hangul syllables)
MacKorean EUC-KR + Apple Vendor Mappings
johab JOHAB A supplementary encoding defined in
Annex 3 of KS X 1001:1998
iso-2022-kr iso-2022-kr [RFC1557]
--------------------------------------------------------------------
To find how to use this module in detail, see L<Encode>.
=head1 BUGS
When you see C<charset=ks_c_5601-1987> on mails and web pages, they really
mean "cp949" encodings. To fix that, the following aliases are set;
qr/(?:x-)?uhc$/i => '"cp949"'
qr/(?:x-)?windows-949$/i => '"cp949"'
qr/ks_c_5601-1987$/i => '"cp949"'
The ASCII region (0x00-0x7f) is preserved for all encodings, even
though this conflicts with mappings by the Unicode Consortium.
=head1 SEE ALSO
L<Encode>
=cut
DARWIN-2LEVEL_ENCODE_KR
$fatpacked{"darwin-2level/Encode/KR/2022_KR.pm"} = <<'DARWIN-2LEVEL_ENCODE_KR_2022_KR';
package Encode::KR::2022_KR;
use strict;
use warnings;
our $VERSION = do { my @r = ( q$Revision: 2.2 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
use Encode qw(:fallbacks);
use base qw(Encode::Encoding);
__PACKAGE__->Define('iso-2022-kr');
sub needs_lines { 1 }
sub perlio_ok {
return 0; # for the time being
}
sub decode {
my ( $obj, $str, $chk ) = @_;
my $res = $str;
my $residue = iso_euc( \$res );
# This is for PerlIO
$_[1] = $residue if $chk;
return Encode::decode( 'euc-kr', $res, FB_PERLQQ );
}
sub encode {
my ( $obj, $utf8, $chk ) = @_;
# empty the input string in the stack so perlio is ok
$_[1] = '' if $chk;
my $octet = Encode::encode( 'euc-kr', $utf8, FB_PERLQQ );
euc_iso( \$octet );
return $octet;
}
use Encode::CJKConstants qw(:all);
# ISO<->EUC
sub iso_euc {
my $r_str = shift;
$$r_str =~ s/$RE{'2022_KR'}//gox; # remove the designator
$$r_str =~ s{ # replace characters in GL
\x0e # between SO(\x0e) and SI(\x0f)
([^\x0f]*) # with characters in GR
\x0f
}
{
my $out= $1;
$out =~ tr/\x21-\x7e/\xa1-\xfe/;
$out;
}geox;
my ($residue) = ( $$r_str =~ s/(\e.*)$//so );
return $residue;
}
sub euc_iso {
no warnings qw(uninitialized);
my $r_str = shift;
substr( $$r_str, 0, 0 ) =
$ESC{'2022_KR'}; # put the designator at the beg.
$$r_str =~
s{ # move KS X 1001 characters in GR to GL
($RE{EUC_C}+) # and enclose them with SO and SI
}{
my $str = $1;
$str =~ tr/\xA1-\xFE/\x21-\x7E/;
"\x0e" . $str . "\x0f";
}geox;
$$r_str;
}
1;
__END__
=head1 NAME
Encode::KR::2022_KR -- internally used by Encode::KR
=cut
DARWIN-2LEVEL_ENCODE_KR_2022_KR
$fatpacked{"darwin-2level/Encode/MIME/Header.pm"} = <<'DARWIN-2LEVEL_ENCODE_MIME_HEADER';
package Encode::MIME::Header;
use strict;
use warnings;
no warnings 'redefine';
our $VERSION = do { my @r = ( q$Revision: 2.13 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
use Encode qw(find_encoding encode_utf8 decode_utf8);
use MIME::Base64;
use Carp;
my %seed = (
decode_b => '1', # decodes 'B' encoding ?
decode_q => '1', # decodes 'Q' encoding ?
encode => 'B', # encode with 'B' or 'Q' ?
bpl => 75, # bytes per line
);
$Encode::Encoding{'MIME-Header'} =
bless { %seed, Name => 'MIME-Header', } => __PACKAGE__;
$Encode::Encoding{'MIME-B'} = bless {
%seed,
decode_q => 0,
Name => 'MIME-B',
} => __PACKAGE__;
$Encode::Encoding{'MIME-Q'} = bless {
%seed,
decode_q => 1,
encode => 'Q',
Name => 'MIME-Q',
} => __PACKAGE__;
use base qw(Encode::Encoding);
sub needs_lines { 1 }
sub perlio_ok { 0 }
sub decode($$;$) {
use utf8;
my ( $obj, $str, $chk ) = @_;
# zap spaces between encoded words
$str =~ s/\?=\s+=\?/\?==\?/gos;
# multi-line header to single line
$str =~ s/(?:\r\n|[\r\n])[ \t]//gos;
1 while ( $str =~
s/(=\?[-0-9A-Za-z_]+\?[Qq]\?)(.*?)\?=\1(.*?\?=)/$1$2$3/ )
; # Concat consecutive QP encoded mime headers
# Fixes breaking inside multi-byte characters
$str =~ s{
=\? # begin encoded word
([-0-9A-Za-z_]+) # charset (encoding)
(?:\*[A-Za-z]{1,8}(?:-[A-Za-z]{1,8})*)? # language (RFC 2231)
\?([QqBb])\? # delimiter
(.*?) # Base64-encodede contents
\?= # end encoded word
}{
if (uc($2) eq 'B'){
$obj->{decode_b} or croak qq(MIME "B" unsupported);
decode_b($1, $3, $chk);
} elsif (uc($2) eq 'Q'){
$obj->{decode_q} or croak qq(MIME "Q" unsupported);
decode_q($1, $3, $chk);
} else {
croak qq(MIME "$2" encoding is nonexistent!);
}
}egox;
$_[1] = $str if $chk;
return $str;
}
sub decode_b {
my $enc = shift;
my $d = find_encoding($enc) or croak qq(Unknown encoding "$enc");
my $db64 = decode_base64(shift);
my $chk = shift;
return $d->name eq 'utf8'
? Encode::decode_utf8($db64)
: $d->decode( $db64, $chk || Encode::FB_PERLQQ );
}
sub decode_q {
my ( $enc, $q, $chk ) = @_;
my $d = find_encoding($enc) or croak qq(Unknown encoding "$enc");
$q =~ s/_/ /go;
$q =~ s/=([0-9A-Fa-f]{2})/pack("C", hex($1))/ego;
return $d->name eq 'utf8'
? Encode::decode_utf8($q)
: $d->decode( $q, $chk || Encode::FB_PERLQQ );
}
my $especials =
join( '|' => map { quotemeta( chr($_) ) }
unpack( "C*", qq{()<>,;:"'/[]?=} ) );
my $re_encoded_word = qr{
=\? # begin encoded word
(?:[-0-9A-Za-z_]+) # charset (encoding)
(?:\*[A-Za-z]{1,8}(?:-[A-Za-z]{1,8})*)? # language (RFC 2231)
\?(?:[QqBb])\? # delimiter
(?:.*?) # Base64-encodede contents
\?= # end encoded word
}xo;
my $re_especials = qr{$re_encoded_word|$especials}xo;
sub encode($$;$) {
my ( $obj, $str, $chk ) = @_;
my @line = ();
for my $line ( split /\r\n|[\r\n]/o, $str ) {
my ( @word, @subline );
for my $word ( split /($re_especials)/o, $line ) {
if ( $word =~ /[^\x00-\x7f]/o
or $word =~ /^$re_encoded_word$/o )
{
push @word, $obj->_encode($word);
}
else {
push @word, $word;
}
}
my $subline = '';
for my $word (@word) {
use bytes ();
if ( bytes::length($subline) + bytes::length($word) >
$obj->{bpl} - 1 )
{
push @subline, $subline;
$subline = '';
}
$subline .= ' ' if ($subline =~ /\?=$/ and $word =~ /^=\?/);
$subline .= $word;
}
$subline and push @subline, $subline;
push @line, join( "\n " => @subline );
}
$_[1] = '' if $chk;
return join( "\n", @line );
}
use constant HEAD => '=?UTF-8?';
use constant TAIL => '?=';
use constant SINGLE => { B => \&_encode_b, Q => \&_encode_q, };
sub _encode {
my ( $o, $str ) = @_;
my $enc = $o->{encode};
my $llen = ( $o->{bpl} - length(HEAD) - 2 - length(TAIL) );
# to coerce a floating-point arithmetics, the following contains
# .0 in numbers -- dankogai
$llen *= $enc eq 'B' ? 3.0 / 4.0 : 1.0 / 3.0;
my @result = ();
my $chunk = '';
while ( length( my $chr = substr( $str, 0, 1, '' ) ) ) {
use bytes ();
if ( bytes::length($chunk) + bytes::length($chr) > $llen ) {
push @result, SINGLE->{$enc}($chunk);
$chunk = '';
}
$chunk .= $chr;
}
length($chunk) and push @result, SINGLE->{$enc}($chunk);
return @result;
}
sub _encode_b {
HEAD . 'B?' . encode_base64( encode_utf8(shift), '' ) . TAIL;
}
sub _encode_q {
my $chunk = shift;
$chunk = encode_utf8($chunk);
$chunk =~ s{
([^0-9A-Za-z])
}{
join("" => map {sprintf "=%02X", $_} unpack("C*", $1))
}egox;
return HEAD . 'Q?' . $chunk . TAIL;
}
1;
__END__
=head1 NAME
Encode::MIME::Header -- MIME 'B' and 'Q' header encoding
=head1 SYNOPSIS
use Encode qw/encode decode/;
$utf8 = decode('MIME-Header', $header);
$header = encode('MIME-Header', $utf8);
=head1 ABSTRACT
This module implements RFC 2047 Mime Header Encoding. There are 3
variant encoding names; C<MIME-Header>, C<MIME-B> and C<MIME-Q>. The
difference is described below
decode() encode()
----------------------------------------------
MIME-Header Both B and Q =?UTF-8?B?....?=
MIME-B B only; Q croaks =?UTF-8?B?....?=
MIME-Q Q only; B croaks =?UTF-8?Q?....?=
=head1 DESCRIPTION
When you decode(=?I<encoding>?I<X>?I<ENCODED WORD>?=), I<ENCODED WORD>
is extracted and decoded for I<X> encoding (B for Base64, Q for
Quoted-Printable). Then the decoded chunk is fed to
decode(I<encoding>). So long as I<encoding> is supported by Encode,
any source encoding is fine.
When you encode, it just encodes UTF-8 string with I<X> encoding then
quoted with =?UTF-8?I<X>?....?= . The parts that RFC 2047 forbids to
encode are left as is and long lines are folded within 76 bytes per
line.
=head1 BUGS
It would be nice to support encoding to non-UTF8, such as =?ISO-2022-JP?
and =?ISO-8859-1?= but that makes the implementation too complicated.
These days major mail agents all support =?UTF-8? so I think it is
just good enough.
Due to popular demand, 'MIME-Header-ISO_2022_JP' was introduced by
Makamaka. Thre are still too many MUAs especially cellular phone
handsets which does not grok UTF-8.
=head1 SEE ALSO
L<Encode>
RFC 2047, L<http://www.faqs.org/rfcs/rfc2047.html> and many other
locations.
=cut
DARWIN-2LEVEL_ENCODE_MIME_HEADER
$fatpacked{"darwin-2level/Encode/MIME/Header/ISO_2022_JP.pm"} = <<'DARWIN-2LEVEL_ENCODE_MIME_HEADER_ISO_2022_JP';
package Encode::MIME::Header::ISO_2022_JP;
use strict;
use warnings;
use base qw(Encode::MIME::Header);
$Encode::Encoding{'MIME-Header-ISO_2022_JP'} =
bless { encode => 'B', bpl => 76, Name => 'MIME-Header-ISO_2022_JP' } =>
__PACKAGE__;
use constant HEAD => '=?ISO-2022-JP?B?';
use constant TAIL => '?=';
use Encode::CJKConstants qw(%RE);
our $VERSION = do { my @r = ( q$Revision: 1.3 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
# I owe the below codes totally to
# Jcode by Dan Kogai & http://www.din.or.jp/~ohzaki/perl.htm#JP_Base64
sub encode {
my $self = shift;
my $str = shift;
utf8::encode($str) if ( Encode::is_utf8($str) );
Encode::from_to( $str, 'utf8', 'euc-jp' );
my ($trailing_crlf) = ( $str =~ /(\n|\r|\x0d\x0a)$/o );
$str = _mime_unstructured_header( $str, $self->{bpl} );
not $trailing_crlf and $str =~ s/(\n|\r|\x0d\x0a)$//o;
return $str;
}
sub _mime_unstructured_header {
my ( $oldheader, $bpl ) = @_;
my $crlf = $oldheader =~ /\n$/;
my ( $header, @words, @wordstmp, $i ) = ('');
$oldheader =~ s/\s+$//;
@wordstmp = split /\s+/, $oldheader;
for ( $i = 0 ; $i < $#wordstmp ; $i++ ) {
if ( $wordstmp[$i] !~ /^[\x21-\x7E]+$/
and $wordstmp[ $i + 1 ] !~ /^[\x21-\x7E]+$/ )
{
$wordstmp[ $i + 1 ] = "$wordstmp[$i] $wordstmp[$i + 1]";
}
else {
push( @words, $wordstmp[$i] );
}
}
push( @words, $wordstmp[-1] );
for my $word (@words) {
if ( $word =~ /^[\x21-\x7E]+$/ ) {
$header =~ /(?:.*\n)*(.*)/;
if ( length($1) + length($word) > $bpl ) {
$header .= "\n $word";
}
else {
$header .= $word;
}
}
else {
$header = _add_encoded_word( $word, $header, $bpl );
}
$header =~ /(?:.*\n)*(.*)/;
if ( length($1) == $bpl ) {
$header .= "\n ";
}
else {
$header .= ' ';
}
}
$header =~ s/\n? $//mg;
$crlf ? "$header\n" : $header;
}
sub _add_encoded_word {
my ( $str, $line, $bpl ) = @_;
my $result = '';
while ( length($str) ) {
my $target = $str;
$str = '';
if (
length($line) + 22 +
( $target =~ /^(?:$RE{EUC_0212}|$RE{EUC_C})/o ) * 8 > $bpl )
{
$line =~ s/[ \t\n\r]*$/\n/;
$result .= $line;
$line = ' ';
}
while (1) {
my $iso_2022_jp = $target;
Encode::from_to( $iso_2022_jp, 'euc-jp', 'iso-2022-jp' );
my $encoded =
HEAD . MIME::Base64::encode_base64( $iso_2022_jp, '' ) . TAIL;
if ( length($encoded) + length($line) > $bpl ) {
$target =~
s/($RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C}|$RE{ASCII})$//o;
$str = $1 . $str;
}
else {
$line .= $encoded;
last;
}
}
}
$result . $line;
}
1;
__END__
DARWIN-2LEVEL_ENCODE_MIME_HEADER_ISO_2022_JP
$fatpacked{"darwin-2level/Encode/MIME/Name.pm"} = <<'DARWIN-2LEVEL_ENCODE_MIME_NAME';
package Encode::MIME::Name;
use strict;
use warnings;
our $VERSION = do { my @r = ( q$Revision: 1.1 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
our %MIME_NAME_OF = (
'AdobeStandardEncoding' => 'Adobe-Standard-Encoding',
'AdobeSymbol' => 'Adobe-Symbol-Encoding',
'ascii' => 'US-ASCII',
'big5-hkscs' => 'Big5-HKSCS',
'cp1026' => 'IBM1026',
'cp1047' => 'IBM1047',
'cp1250' => 'windows-1250',
'cp1251' => 'windows-1251',
'cp1252' => 'windows-1252',
'cp1253' => 'windows-1253',
'cp1254' => 'windows-1254',
'cp1255' => 'windows-1255',
'cp1256' => 'windows-1256',
'cp1257' => 'windows-1257',
'cp1258' => 'windows-1258',
'cp37' => 'IBM037',
'cp424' => 'IBM424',
'cp437' => 'IBM437',
'cp500' => 'IBM500',
'cp775' => 'IBM775',
'cp850' => 'IBM850',
'cp852' => 'IBM852',
'cp855' => 'IBM855',
'cp857' => 'IBM857',
'cp860' => 'IBM860',
'cp861' => 'IBM861',
'cp862' => 'IBM862',
'cp863' => 'IBM863',
'cp864' => 'IBM864',
'cp865' => 'IBM865',
'cp866' => 'IBM866',
'cp869' => 'IBM869',
'cp936' => 'GBK',
'euc-jp' => 'EUC-JP',
'euc-kr' => 'EUC-KR',
#'gb2312-raw' => 'GB2312', # no, you're wrong, I18N::Charset
'hp-roman8' => 'hp-roman8',
'hz' => 'HZ-GB-2312',
'iso-2022-jp' => 'ISO-2022-JP',
'iso-2022-jp-1' => 'ISO-2022-JP',
'iso-2022-kr' => 'ISO-2022-KR',
'iso-8859-1' => 'ISO-8859-1',
'iso-8859-10' => 'ISO-8859-10',
'iso-8859-13' => 'ISO-8859-13',
'iso-8859-14' => 'ISO-8859-14',
'iso-8859-15' => 'ISO-8859-15',
'iso-8859-16' => 'ISO-8859-16',
'iso-8859-2' => 'ISO-8859-2',
'iso-8859-3' => 'ISO-8859-3',
'iso-8859-4' => 'ISO-8859-4',
'iso-8859-5' => 'ISO-8859-5',
'iso-8859-6' => 'ISO-8859-6',
'iso-8859-7' => 'ISO-8859-7',
'iso-8859-8' => 'ISO-8859-8',
'iso-8859-9' => 'ISO-8859-9',
#'jis0201-raw' => 'JIS_X0201',
#'jis0208-raw' => 'JIS_C6226-1983',
#'jis0212-raw' => 'JIS_X0212-1990',
'koi8-r' => 'KOI8-R',
'koi8-u' => 'KOI8-U',
#'ksc5601-raw' => 'KS_C_5601-1987',
'shiftjis' => 'Shift_JIS',
'UTF-16' => 'UTF-16',
'UTF-16BE' => 'UTF-16BE',
'UTF-16LE' => 'UTF-16LE',
'UTF-32' => 'UTF-32',
'UTF-32BE' => 'UTF-32BE',
'UTF-32LE' => 'UTF-32LE',
'UTF-7' => 'UTF-7',
'utf8' => 'UTF-8',
'utf-8-strict' => 'UTF-8',
'viscii' => 'VISCII',
);
sub get_mime_name($) { $MIME_NAME_OF{$_[0]} };
1;
__END__
=head1 NAME
Encode::MIME::NAME -- internally used by Encode
=head1 SEE ALSO
L<I18N::Charset>
=cut
DARWIN-2LEVEL_ENCODE_MIME_NAME
$fatpacked{"darwin-2level/Encode/Symbol.pm"} = <<'DARWIN-2LEVEL_ENCODE_SYMBOL';
package Encode::Symbol;
use strict;
use warnings;
use Encode;
our $VERSION = do { my @r = ( q$Revision: 2.2 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
use XSLoader;
XSLoader::load( __PACKAGE__, $VERSION );
1;
__END__
=head1 NAME
Encode::Symbol - Symbol Encodings
=head1 SYNOPSIS
use Encode qw/encode decode/;
$symbol = encode("symbol", $utf8); # loads Encode::Symbol implicitly
$utf8 = decode("", $symbol); # ditto
=head1 ABSTRACT
This module implements symbol and dingbats encodings. Encodings
supported are as follows.
Canonical Alias Description
--------------------------------------------------------------------
symbol
dingbats
AdobeZDingbat
AdobeSymbol
MacDingbats
=head1 DESCRIPTION
To find out how to use this module in detail, see L<Encode>.
=head1 SEE ALSO
L<Encode>
=cut
DARWIN-2LEVEL_ENCODE_SYMBOL
$fatpacked{"darwin-2level/Encode/TW.pm"} = <<'DARWIN-2LEVEL_ENCODE_TW';
package Encode::TW;
BEGIN {
if ( ord("A") == 193 ) {
die "Encode::TW not supported on EBCDIC\n";
}
}
use strict;
use warnings;
use Encode;
our $VERSION = do { my @r = ( q$Revision: 2.3 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
use XSLoader;
XSLoader::load( __PACKAGE__, $VERSION );
1;
__END__
=head1 NAME
Encode::TW - Taiwan-based Chinese Encodings
=head1 SYNOPSIS
use Encode qw/encode decode/;
$big5 = encode("big5", $utf8); # loads Encode::TW implicitly
$utf8 = decode("big5", $big5); # ditto
=head1 DESCRIPTION
This module implements tradition Chinese charset encodings as used
in Taiwan and Hong Kong.
Encodings supported are as follows.
Canonical Alias Description
--------------------------------------------------------------------
big5-eten /\bbig-?5$/i Big5 encoding (with ETen extensions)
/\bbig5-?et(en)?$/i
/\btca-?big5$/i
big5-hkscs /\bbig5-?hk(scs)?$/i
/\bhk(scs)?-?big5$/i
Big5 + Cantonese characters in Hong Kong
MacChineseTrad Big5 + Apple Vendor Mappings
cp950 Code Page 950
= Big5 + Microsoft vendor mappings
--------------------------------------------------------------------
To find out how to use this module in detail, see L<Encode>.
=head1 NOTES
Due to size concerns, C<EUC-TW> (Extended Unix Character), C<CCCII>
(Chinese Character Code for Information Interchange), C<BIG5PLUS>
(CMEX's Big5+) and C<BIG5EXT> (CMEX's Big5e) are distributed separately
on CPAN, under the name L<Encode::HanExtra>. That module also contains
extra China-based encodings.
=head1 BUGS
Since the original C<big5> encoding (1984) is not supported anywhere
(glibc and DOS-based systems uses C<big5> to mean C<big5-eten>; Microsoft
uses C<big5> to mean C<cp950>), a conscious decision was made to alias
C<big5> to C<big5-eten>, which is the de facto superset of the original
big5.
The C<CNS11643> encoding files are not complete. For common C<CNS11643>
manipulation, please use C<EUC-TW> in L<Encode::HanExtra>, which contains
planes 1-7.
The ASCII region (0x00-0x7f) is preserved for all encodings, even
though this conflicts with mappings by the Unicode Consortium.
=head1 SEE ALSO
L<Encode>
=cut
DARWIN-2LEVEL_ENCODE_TW
$fatpacked{"darwin-2level/Encode/Unicode.pm"} = <<'DARWIN-2LEVEL_ENCODE_UNICODE';
package Encode::Unicode;
use strict;
use warnings;
no warnings 'redefine';
our $VERSION = do { my @r = ( q$Revision: 2.7 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
use XSLoader;
XSLoader::load( __PACKAGE__, $VERSION );
#
# Object Generator 8 transcoders all at once!
#
require Encode;
our %BOM_Unknown = map { $_ => 1 } qw(UTF-16 UTF-32);
for my $name (
qw(UTF-16 UTF-16BE UTF-16LE
UTF-32 UTF-32BE UTF-32LE
UCS-2BE UCS-2LE)
)
{
my ( $size, $endian, $ucs2, $mask );
$name =~ /^(\w+)-(\d+)(\w*)$/o;
if ( $ucs2 = ( $1 eq 'UCS' ) ) {
$size = 2;
}
else {
$size = $2 / 8;
}
$endian = ( $3 eq 'BE' ) ? 'n' : ( $3 eq 'LE' ) ? 'v' : '';
$size == 4 and $endian = uc($endian);
$Encode::Encoding{$name} = bless {
Name => $name,
size => $size,
endian => $endian,
ucs2 => $ucs2,
} => __PACKAGE__;
}
use base qw(Encode::Encoding);
sub renew {
my $self = shift;
$BOM_Unknown{ $self->name } or return $self;
my $clone = bless {%$self} => ref($self);
$clone->{renewed}++; # so the caller knows it is renewed.
return $clone;
}
# There used to be a perl implemntation of (en|de)code but with
# XS version is ripe, perl version is zapped for optimal speed
*decode = \&decode_xs;
*encode = \&encode_xs;
1;
__END__
=head1 NAME
Encode::Unicode -- Various Unicode Transformation Formats
=cut
=head1 SYNOPSIS
use Encode qw/encode decode/;
$ucs2 = encode("UCS-2BE", $utf8);
$utf8 = decode("UCS-2BE", $ucs2);
=head1 ABSTRACT
This module implements all Character Encoding Schemes of Unicode that
are officially documented by Unicode Consortium (except, of course,
for UTF-8, which is a native format in perl).
=over 4
=item L<http://www.unicode.org/glossary/> says:
I<Character Encoding Scheme> A character encoding form plus byte
serialization. There are Seven character encoding schemes in Unicode:
UTF-8, UTF-16, UTF-16BE, UTF-16LE, UTF-32 (UCS-4), UTF-32BE (UCS-4BE) and
UTF-32LE (UCS-4LE), and UTF-7.
Since UTF-7 is a 7-bit (re)encoded version of UTF-16BE, It is not part of
Unicode's Character Encoding Scheme. It is separately implemented in
Encode::Unicode::UTF7. For details see L<Encode::Unicode::UTF7>.
=item Quick Reference
Decodes from ord(N) Encodes chr(N) to...
octet/char BOM S.P d800-dfff ord > 0xffff \x{1abcd} ==
---------------+-----------------+------------------------------
UCS-2BE 2 N N is bogus Not Available
UCS-2LE 2 N N bogus Not Available
UTF-16 2/4 Y Y is S.P S.P BE/LE
UTF-16BE 2/4 N Y S.P S.P 0xd82a,0xdfcd
UTF-16LE 2/4 N Y S.P S.P 0x2ad8,0xcddf
UTF-32 4 Y - is bogus As is BE/LE
UTF-32BE 4 N - bogus As is 0x0001abcd
UTF-32LE 4 N - bogus As is 0xcdab0100
UTF-8 1-4 - - bogus >= 4 octets \xf0\x9a\af\8d
---------------+-----------------+------------------------------
=back
=head1 Size, Endianness, and BOM
You can categorize these CES by 3 criteria: size of each character,
endianness, and Byte Order Mark.
=head2 by size
UCS-2 is a fixed-length encoding with each character taking 16 bits.
It B<does not> support I<surrogate pairs>. When a surrogate pair
is encountered during decode(), its place is filled with \x{FFFD}
if I<CHECK> is 0, or the routine croaks if I<CHECK> is 1. When a
character whose ord value is larger than 0xFFFF is encountered,
its place is filled with \x{FFFD} if I<CHECK> is 0, or the routine
croaks if I<CHECK> is 1.
UTF-16 is almost the same as UCS-2 but it supports I<surrogate pairs>.
When it encounters a high surrogate (0xD800-0xDBFF), it fetches the
following low surrogate (0xDC00-0xDFFF) and C<desurrogate>s them to
form a character. Bogus surrogates result in death. When \x{10000}
or above is encountered during encode(), it C<ensurrogate>s them and
pushes the surrogate pair to the output stream.
UTF-32 (UCS-4) is a fixed-length encoding with each character taking 32 bits.
Since it is 32-bit, there is no need for I<surrogate pairs>.
=head2 by endianness
The first (and now failed) goal of Unicode was to map all character
repertoires into a fixed-length integer so that programmers are happy.
Since each character is either a I<short> or I<long> in C, you have to
pay attention to the endianness of each platform when you pass data
to one another.
Anything marked as BE is Big Endian (or network byte order) and LE is
Little Endian (aka VAX byte order). For anything not marked either
BE or LE, a character called Byte Order Mark (BOM) indicating the
endianness is prepended to the string.
CAVEAT: Though BOM in utf8 (\xEF\xBB\xBF) is valid, it is meaningless
and as of this writing Encode suite just leave it as is (\x{FeFF}).
=over 4
=item BOM as integer when fetched in network byte order
16 32 bits/char
-------------------------
BE 0xFeFF 0x0000FeFF
LE 0xFFFe 0xFFFe0000
-------------------------
=back
This modules handles the BOM as follows.
=over 4
=item *
When BE or LE is explicitly stated as the name of encoding, BOM is
simply treated as a normal character (ZERO WIDTH NO-BREAK SPACE).
=item *
When BE or LE is omitted during decode(), it checks if BOM is at the
beginning of the string; if one is found, the endianness is set to
what the BOM says. If no BOM is found, the routine dies.
=item *
When BE or LE is omitted during encode(), it returns a BE-encoded
string with BOM prepended. So when you want to encode a whole text
file, make sure you encode() the whole text at once, not line by line
or each line, not file, will have a BOM prepended.
=item *
C<UCS-2> is an exception. Unlike others, this is an alias of UCS-2BE.
UCS-2 is already registered by IANA and others that way.
=back
=head1 Surrogate Pairs
To say the least, surrogate pairs were the biggest mistake of the
Unicode Consortium. But according to the late Douglas Adams in I<The
Hitchhiker's Guide to the Galaxy> Trilogy, C<In the beginning the
Universe was created. This has made a lot of people very angry and
been widely regarded as a bad move>. Their mistake was not of this
magnitude so let's forgive them.
(I don't dare make any comparison with Unicode Consortium and the
Vogons here ;) Or, comparing Encode to Babel Fish is completely
appropriate -- if you can only stick this into your ear :)
Surrogate pairs were born when the Unicode Consortium finally
admitted that 16 bits were not big enough to hold all the world's
character repertoires. But they already made UCS-2 16-bit. What
do we do?
Back then, the range 0xD800-0xDFFF was not allocated. Let's split
that range in half and use the first half to represent the C<upper
half of a character> and the second half to represent the C<lower
half of a character>. That way, you can represent 1024 * 1024 =
1048576 more characters. Now we can store character ranges up to
\x{10ffff} even with 16-bit encodings. This pair of half-character is
now called a I<surrogate pair> and UTF-16 is the name of the encoding
that embraces them.
Here is a formula to ensurrogate a Unicode character \x{10000} and
above;
$hi = ($uni - 0x10000) / 0x400 + 0xD800;
$lo = ($uni - 0x10000) % 0x400 + 0xDC00;
And to desurrogate;
$uni = 0x10000 + ($hi - 0xD800) * 0x400 + ($lo - 0xDC00);
Note this move has made \x{D800}-\x{DFFF} into a forbidden zone but
perl does not prohibit the use of characters within this range. To perl,
every one of \x{0000_0000} up to \x{ffff_ffff} (*) is I<a character>.
(*) or \x{ffff_ffff_ffff_ffff} if your perl is compiled with 64-bit
integer support!
=head1 Error Checking
Unlike most encodings which accept various ways to handle errors,
Unicode encodings simply croaks.
% perl -MEncode -e'$_ = "\xfe\xff\xd8\xd9\xda\xdb\0\n"' \
-e'Encode::from_to($_, "utf16","shift_jis", 0); print'
UTF-16:Malformed LO surrogate d8d9 at /path/to/Encode.pm line 184.
% perl -MEncode -e'$a = "BOM missing"' \
-e' Encode::from_to($a, "utf16", "shift_jis", 0); print'
UTF-16:Unrecognised BOM 424f at /path/to/Encode.pm line 184.
Unlike other encodings where mappings are not one-to-one against
Unicode, UTFs are supposed to map 100% against one another. So Encode
is more strict on UTFs.
Consider that "division by zero" of Encode :)
=head1 SEE ALSO
L<Encode>, L<Encode::Unicode::UTF7>, L<http://www.unicode.org/glossary/>,
L<http://www.unicode.org/unicode/faq/utf_bom.html>,
RFC 2781 L<http://www.ietf.org/rfc/rfc2781.txt>,
The whole Unicode standard L<http://www.unicode.org/unicode/uni2book/u2.html>
Ch. 15, pp. 403 of C<Programming Perl (3rd Edition)>
by Larry Wall, Tom Christiansen, Jon Orwant;
O'Reilly & Associates; ISBN 0-596-00027-8
=cut
DARWIN-2LEVEL_ENCODE_UNICODE
$fatpacked{"darwin-2level/Encode/Unicode/UTF7.pm"} = <<'DARWIN-2LEVEL_ENCODE_UNICODE_UTF7';
#
# $Id: UTF7.pm,v 2.6 2012/08/05 23:08:49 dankogai Exp $
#
package Encode::Unicode::UTF7;
use strict;
use warnings;
no warnings 'redefine';
use base qw(Encode::Encoding);
__PACKAGE__->Define('UTF-7');
our $VERSION = do { my @r = ( q$Revision: 2.6 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
use MIME::Base64;
use Encode;
#
# Algorithms taken from Unicode::String by Gisle Aas
#
our $OPTIONAL_DIRECT_CHARS = 1;
my $specials = quotemeta "\'(),-./:?";
$OPTIONAL_DIRECT_CHARS
and $specials .= quotemeta "!\"#$%&*;<=>@[]^_`{|}";
# \s will not work because it matches U+3000 DEOGRAPHIC SPACE
# We use qr/[\n\r\t\ ] instead
my $re_asis = qr/(?:[\n\r\t\ A-Za-z0-9$specials])/;
my $re_encoded = qr/(?:[^\n\r\t\ A-Za-z0-9$specials])/;
my $e_utf16 = find_encoding("UTF-16BE");
sub needs_lines { 1 }
sub encode($$;$) {
my ( $obj, $str, $chk ) = @_;
my $len = length($str);
pos($str) = 0;
my $bytes = '';
while ( pos($str) < $len ) {
if ( $str =~ /\G($re_asis+)/ogc ) {
my $octets = $1;
utf8::downgrade($octets);
$bytes .= $octets;
}
elsif ( $str =~ /\G($re_encoded+)/ogsc ) {
if ( $1 eq "+" ) {
$bytes .= "+-";
}
else {
my $s = $1;
my $base64 = encode_base64( $e_utf16->encode($s), '' );
$base64 =~ s/=+$//;
$bytes .= "+$base64-";
}
}
else {
die "This should not happen! (pos=" . pos($str) . ")";
}
}
$_[1] = '' if $chk;
return $bytes;
}
sub decode($$;$) {
my ( $obj, $bytes, $chk ) = @_;
my $len = length($bytes);
my $str = "";
pos($bytes) = 0;
no warnings 'uninitialized';
while ( pos($bytes) < $len ) {
if ( $bytes =~ /\G([^+]+)/ogc ) {
$str .= $1;
}
elsif ( $bytes =~ /\G\+-/ogc ) {
$str .= "+";
}
elsif ( $bytes =~ /\G\+([A-Za-z0-9+\/]+)-?/ogsc ) {
my $base64 = $1;
my $pad = length($base64) % 4;
$base64 .= "=" x ( 4 - $pad ) if $pad;
$str .= $e_utf16->decode( decode_base64($base64) );
}
elsif ( $bytes =~ /\G\+/ogc ) {
$^W and warn "Bad UTF7 data escape";
$str .= "+";
}
else {
die "This should not happen " . pos($bytes);
}
}
$_[1] = '' if $chk;
return $str;
}
1;
__END__
=head1 NAME
Encode::Unicode::UTF7 -- UTF-7 encoding
=head1 SYNOPSIS
use Encode qw/encode decode/;
$utf7 = encode("UTF-7", $utf8);
$utf8 = decode("UTF-7", $ucs2);
=head1 ABSTRACT
This module implements UTF-7 encoding documented in RFC 2152. UTF-7,
as its name suggests, is a 7-bit re-encoded version of UTF-16BE. It
is designed to be MTA-safe and expected to be a standard way to
exchange Unicoded mails via mails. But with the advent of UTF-8 and
8-bit compliant MTAs, UTF-7 is hardly ever used.
UTF-7 was not supported by Encode until version 1.95 because of that.
But Unicode::String, a module by Gisle Aas which adds Unicode supports
to non-utf8-savvy perl did support UTF-7, the UTF-7 support was added
so Encode can supersede Unicode::String 100%.
=head1 In Practice
When you want to encode Unicode for mails and web pages, however, do
not use UTF-7 unless you are sure your recipients and readers can
handle it. Very few MUAs and WWW Browsers support these days (only
Mozilla seems to support one). For general cases, use UTF-8 for
message body and MIME-Header for header instead.
=head1 SEE ALSO
L<Encode>, L<Encode::Unicode>, L<Unicode::String>
RFC 2781 L<http://www.ietf.org/rfc/rfc2152.txt>
=cut
DARWIN-2LEVEL_ENCODE_UNICODE_UTF7
$fatpacked{"darwin-2level/File/Spec.pm"} = <<'DARWIN-2LEVEL_FILE_SPEC';
package File::Spec;
use strict;
use vars qw(@ISA $VERSION);
$VERSION = '3.40';
$VERSION =~ tr/_//;
my %module = (MacOS => 'Mac',
MSWin32 => 'Win32',
os2 => 'OS2',
VMS => 'VMS',
epoc => 'Epoc',
NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare.
symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian.
dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP.
cygwin => 'Cygwin');
my $module = $module{$^O} || 'Unix';
require "File/Spec/$module.pm";
@ISA = ("File::Spec::$module");
1;
__END__
=head1 NAME
File::Spec - portably perform operations on file names
=head1 SYNOPSIS
use File::Spec;
$x=File::Spec->catfile('a', 'b', 'c');
which returns 'a/b/c' under Unix. Or:
use File::Spec::Functions;
$x = catfile('a', 'b', 'c');
=head1 DESCRIPTION
This module is designed to support operations commonly performed on file
specifications (usually called "file names", but not to be confused with the
contents of a file, or Perl's file handles), such as concatenating several
directory and file names into a single path, or determining whether a path
is rooted. It is based on code directly taken from MakeMaker 5.17, code
written by Andreas KE<ouml>nig, Andy Dougherty, Charles Bailey, Ilya
Zakharevich, Paul Schinder, and others.
Since these functions are different for most operating systems, each set of
OS specific routines is available in a separate module, including:
File::Spec::Unix
File::Spec::Mac
File::Spec::OS2
File::Spec::Win32
File::Spec::VMS
The module appropriate for the current OS is automatically loaded by
File::Spec. Since some modules (like VMS) make use of facilities available
only under that OS, it may not be possible to load all modules under all
operating systems.
Since File::Spec is object oriented, subroutines should not be called directly,
as in:
File::Spec::catfile('a','b');
but rather as class methods:
File::Spec->catfile('a','b');
For simple uses, L<File::Spec::Functions> provides convenient functional
forms of these methods.
=head1 METHODS
=over 2
=item canonpath
X<canonpath>
No physical check on the filesystem, but a logical cleanup of a
path.
$cpath = File::Spec->canonpath( $path ) ;
Note that this does *not* collapse F<x/../y> sections into F<y>. This
is by design. If F</foo> on your system is a symlink to F</bar/baz>,
then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
F<../>-removal would give you. If you want to do this kind of
processing, you probably want C<Cwd>'s C<realpath()> function to
actually traverse the filesystem cleaning up paths like this.
=item catdir
X<catdir>
Concatenate two or more directory names to form a complete path ending
with a directory. But remove the trailing slash from the resulting
string, because it doesn't look good, isn't necessary and confuses
OS/2. Of course, if this is the root directory, don't cut off the
trailing slash :-)
$path = File::Spec->catdir( @directories );
=item catfile
X<catfile>
Concatenate one or more directory names and a filename to form a
complete path ending with a filename
$path = File::Spec->catfile( @directories, $filename );
=item curdir
X<curdir>
Returns a string representation of the current directory.
$curdir = File::Spec->curdir();
=item devnull
X<devnull>
Returns a string representation of the null device.
$devnull = File::Spec->devnull();
=item rootdir
X<rootdir>
Returns a string representation of the root directory.
$rootdir = File::Spec->rootdir();
=item tmpdir
X<tmpdir>
Returns a string representation of the first writable directory from a
list of possible temporary directories. Returns the current directory
if no writable temporary directories are found. The list of directories
checked depends on the platform; e.g. File::Spec::Unix checks C<$ENV{TMPDIR}>
(unless taint is on) and F</tmp>.
$tmpdir = File::Spec->tmpdir();
=item updir
X<updir>
Returns a string representation of the parent directory.
$updir = File::Spec->updir();
=item no_upwards
Given a list of file names, strip out those that refer to a parent
directory. (Does not strip symlinks, only '.', '..', and equivalents.)
@paths = File::Spec->no_upwards( @paths );
=item case_tolerant
Returns a true or false value indicating, respectively, that alphabetic
case is not or is significant when comparing file specifications.
Cygwin and Win32 accept an optional drive argument.
$is_case_tolerant = File::Spec->case_tolerant();
=item file_name_is_absolute
Takes as its argument a path, and returns true if it is an absolute path.
$is_absolute = File::Spec->file_name_is_absolute( $path );
This does not consult the local filesystem on Unix, Win32, OS/2, or
Mac OS (Classic). It does consult the working environment for VMS
(see L<File::Spec::VMS/file_name_is_absolute>).
=item path
X<path>
Takes no argument. Returns the environment variable C<PATH> (or the local
platform's equivalent) as a list.
@PATH = File::Spec->path();
=item join
X<join, path>
join is the same as catfile.
=item splitpath
X<splitpath> X<split, path>
Splits a path in to volume, directory, and filename portions. On systems
with no concept of volume, returns '' for volume.
($volume,$directories,$file) =
File::Spec->splitpath( $path );
($volume,$directories,$file) =
File::Spec->splitpath( $path, $no_file );
For systems with no syntax differentiating filenames from directories,
assumes that the last file is a path unless C<$no_file> is true or a
trailing separator or F</.> or F</..> is present. On Unix, this means that C<$no_file>
true makes this return ( '', $path, '' ).
The directory portion may or may not be returned with a trailing '/'.
The results can be passed to L</catpath()> to get back a path equivalent to
(usually identical to) the original path.
=item splitdir
X<splitdir> X<split, dir>
The opposite of L</catdir>.
@dirs = File::Spec->splitdir( $directories );
C<$directories> must be only the directory portion of the path on systems
that have the concept of a volume or that have path syntax that differentiates
files from directories.
Unlike just splitting the directories on the separator, empty
directory names (C<''>) can be returned, because these are significant
on some OSes.
=item catpath()
Takes volume, directory and file portions and returns an entire path. Under
Unix, C<$volume> is ignored, and directory and file are concatenated. A '/' is
inserted if need be. On other OSes, C<$volume> is significant.
$full_path = File::Spec->catpath( $volume, $directory, $file );
=item abs2rel
X<abs2rel> X<absolute, path> X<relative, path>
Takes a destination path and an optional base path returns a relative path
from the base path to the destination path:
$rel_path = File::Spec->abs2rel( $path ) ;
$rel_path = File::Spec->abs2rel( $path, $base ) ;
If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is
relative, then it is converted to absolute form using
L</rel2abs()>. This means that it is taken to be relative to
L<Cwd::cwd()|Cwd>.
On systems with the concept of volume, if C<$path> and C<$base> appear to be
on two different volumes, we will not attempt to resolve the two
paths, and we will instead simply return C<$path>. Note that previous
versions of this module ignored the volume of C<$base>, which resulted in
garbage results part of the time.
On systems that have a grammar that indicates filenames, this ignores the
C<$base> filename as well. Otherwise all path components are assumed to be
directories.
If C<$path> is relative, it is converted to absolute form using L</rel2abs()>.
This means that it is taken to be relative to L<Cwd::cwd()|Cwd>.
No checks against the filesystem are made. On VMS, there is
interaction with the working environment, as logicals and
macros are expanded.
Based on code written by Shigio Yamaguchi.
=item rel2abs()
X<rel2abs> X<absolute, path> X<relative, path>
Converts a relative path to an absolute path.
$abs_path = File::Spec->rel2abs( $path ) ;
$abs_path = File::Spec->rel2abs( $path, $base ) ;
If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is relative,
then it is converted to absolute form using L</rel2abs()>. This means that it
is taken to be relative to L<Cwd::cwd()|Cwd>.
On systems with the concept of volume, if C<$path> and C<$base> appear to be
on two different volumes, we will not attempt to resolve the two
paths, and we will instead simply return C<$path>. Note that previous
versions of this module ignored the volume of C<$base>, which resulted in
garbage results part of the time.
On systems that have a grammar that indicates filenames, this ignores the
C<$base> filename as well. Otherwise all path components are assumed to be
directories.
If C<$path> is absolute, it is cleaned up and returned using L</canonpath>.
No checks against the filesystem are made. On VMS, there is
interaction with the working environment, as logicals and
macros are expanded.
Based on code written by Shigio Yamaguchi.
=back
For further information, please see L<File::Spec::Unix>,
L<File::Spec::Mac>, L<File::Spec::OS2>, L<File::Spec::Win32>, or
L<File::Spec::VMS>.
=head1 SEE ALSO
L<File::Spec::Unix>, L<File::Spec::Mac>, L<File::Spec::OS2>,
L<File::Spec::Win32>, L<File::Spec::VMS>, L<File::Spec::Functions>,
L<ExtUtils::MakeMaker>
=head1 AUTHOR
Currently maintained by Ken Williams C<< <KWILLIAMS@cpan.org> >>.
The vast majority of the code was written by
Kenneth Albanowski C<< <kjahds@kjahds.com> >>,
Andy Dougherty C<< <doughera@lafayette.edu> >>,
Andreas KE<ouml>nig C<< <A.Koenig@franz.ww.TU-Berlin.DE> >>,
Tim Bunce C<< <Tim.Bunce@ig.co.uk> >>.
VMS support by Charles Bailey C<< <bailey@newman.upenn.edu> >>.
OS/2 support by Ilya Zakharevich C<< <ilya@math.ohio-state.edu> >>.
Mac support by Paul Schinder C<< <schinder@pobox.com> >>, and
Thomas Wegner C<< <wegner_thomas@yahoo.com> >>.
abs2rel() and rel2abs() written by Shigio Yamaguchi C<< <shigio@tamacom.com> >>,
modified by Barrie Slaymaker C<< <barries@slaysys.com> >>.
splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker.
=head1 COPYRIGHT
Copyright (c) 2004-2013 by the Perl 5 Porters. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
DARWIN-2LEVEL_FILE_SPEC
$fatpacked{"darwin-2level/File/Spec/Cygwin.pm"} = <<'DARWIN-2LEVEL_FILE_SPEC_CYGWIN';
package File::Spec::Cygwin;
use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
$VERSION = '3.40';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
=head1 NAME
File::Spec::Cygwin - methods for Cygwin file specs
=head1 SYNOPSIS
require File::Spec::Cygwin; # Done internally by File::Spec if needed
=head1 DESCRIPTION
See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
implementation of these methods, not the semantics.
This module is still in beta. Cygwin-knowledgeable folks are invited
to offer patches and suggestions.
=cut
=pod
=over 4
=item canonpath
Any C<\> (backslashes) are converted to C</> (forward slashes),
and then File::Spec::Unix canonpath() is called on the result.
=cut
sub canonpath {
my($self,$path) = @_;
return unless defined $path;
$path =~ s|\\|/|g;
# Handle network path names beginning with double slash
my $node = '';
if ( $path =~ s@^(//[^/]+)(?:/|\z)@/@s ) {
$node = $1;
}
return $node . $self->SUPER::canonpath($path);
}
sub catdir {
my $self = shift;
return unless @_;
# Don't create something that looks like a //network/path
if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) {
shift;
return $self->SUPER::catdir('', @_);
}
$self->SUPER::catdir(@_);
}
=pod
=item file_name_is_absolute
True is returned if the file name begins with C<drive_letter:>,
and if not, File::Spec::Unix file_name_is_absolute() is called.
=cut
sub file_name_is_absolute {
my ($self,$file) = @_;
return 1 if $file =~ m{^([a-z]:)?[\\/]}is; # C:/test
return $self->SUPER::file_name_is_absolute($file);
}
=item tmpdir (override)
Returns a string representation of the first existing directory
from the following list:
$ENV{TMPDIR}
/tmp
$ENV{'TMP'}
$ENV{'TEMP'}
C:/temp
Since Perl 5.8.0, if running under taint mode, and if the environment
variables are tainted, they are not used.
=cut
my $tmpdir;
sub tmpdir {
return $tmpdir if defined $tmpdir;
$tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp' );
}
=item case_tolerant
Override Unix. Cygwin case-tolerance depends on managed mount settings and
as with MsWin32 on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
indicating the case significance when comparing file specifications.
Default: 1
=cut
sub case_tolerant {
return 1 unless $^O eq 'cygwin'
and defined &Cygwin::mount_flags;
my $drive = shift;
if (! $drive) {
my @flags = split(/,/, Cygwin::mount_flags('/cygwin'));
my $prefix = pop(@flags);
if (! $prefix || $prefix eq 'cygdrive') {
$drive = '/cygdrive/c';
} elsif ($prefix eq '/') {
$drive = '/c';
} else {
$drive = "$prefix/c";
}
}
my $mntopts = Cygwin::mount_flags($drive);
if ($mntopts and ($mntopts =~ /,managed/)) {
return 0;
}
eval { require Win32API::File; } or return 1;
my $osFsType = "\0"x256;
my $osVolName = "\0"x256;
my $ouFsFlags = 0;
Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
else { return 1; }
}
=back
=head1 COPYRIGHT
Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
1;
DARWIN-2LEVEL_FILE_SPEC_CYGWIN
$fatpacked{"darwin-2level/File/Spec/Epoc.pm"} = <<'DARWIN-2LEVEL_FILE_SPEC_EPOC';
package File::Spec::Epoc;
use strict;
use vars qw($VERSION @ISA);
$VERSION = '3.40';
$VERSION =~ tr/_//;
require File::Spec::Unix;
@ISA = qw(File::Spec::Unix);
=head1 NAME
File::Spec::Epoc - methods for Epoc file specs
=head1 SYNOPSIS
require File::Spec::Epoc; # Done internally by File::Spec if needed
=head1 DESCRIPTION
See File::Spec::Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
This package is still work in progress ;-)
=cut
sub case_tolerant {
return 1;
}
=pod
=over 4
=item canonpath()
No physical check on the filesystem, but a logical cleanup of a
path. On UNIX eliminated successive slashes and successive "/.".
=back
=cut
sub canonpath {
my ($self,$path) = @_;
return unless defined $path;
$path =~ s|/+|/|g; # xx////xx -> xx/xx
$path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx
$path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx
$path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx
$path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx
return $path;
}
=pod
=head1 AUTHOR
o.flebbe@gmx.de
=head1 COPYRIGHT
Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 SEE ALSO
See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
implementation of these methods, not the semantics.
=cut
1;
DARWIN-2LEVEL_FILE_SPEC_EPOC
$fatpacked{"darwin-2level/File/Spec/Functions.pm"} = <<'DARWIN-2LEVEL_FILE_SPEC_FUNCTIONS';
package File::Spec::Functions;
use File::Spec;
use strict;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
$VERSION = '3.40';
$VERSION =~ tr/_//;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(
canonpath
catdir
catfile
curdir
rootdir
updir
no_upwards
file_name_is_absolute
path
);
@EXPORT_OK = qw(
devnull
tmpdir
splitpath
splitdir
catpath
abs2rel
rel2abs
case_tolerant
);
%EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] );
foreach my $meth (@EXPORT, @EXPORT_OK) {
my $sub = File::Spec->can($meth);
no strict 'refs';
*{$meth} = sub {&$sub('File::Spec', @_)};
}
1;
__END__
=head1 NAME
File::Spec::Functions - portably perform operations on file names
=head1 SYNOPSIS
use File::Spec::Functions;
$x = catfile('a','b');
=head1 DESCRIPTION
This module exports convenience functions for all of the class methods
provided by File::Spec.
For a reference of available functions, please consult L<File::Spec::Unix>,
which contains the entire set, and which is inherited by the modules for
other platforms. For further information, please see L<File::Spec::Mac>,
L<File::Spec::OS2>, L<File::Spec::Win32>, or L<File::Spec::VMS>.
=head2 Exports
The following functions are exported by default.
canonpath
catdir
catfile
curdir
rootdir
updir
no_upwards
file_name_is_absolute
path
The following functions are exported only by request.
devnull
tmpdir
splitpath
splitdir
catpath
abs2rel
rel2abs
case_tolerant
All the functions may be imported using the C<:ALL> tag.
=head1 COPYRIGHT
Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 SEE ALSO
File::Spec, File::Spec::Unix, File::Spec::Mac, File::Spec::OS2,
File::Spec::Win32, File::Spec::VMS, ExtUtils::MakeMaker
=cut
DARWIN-2LEVEL_FILE_SPEC_FUNCTIONS
$fatpacked{"darwin-2level/File/Spec/Mac.pm"} = <<'DARWIN-2LEVEL_FILE_SPEC_MAC';
package File::Spec::Mac;
use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
$VERSION = '3.40';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
my $macfiles;
if ($^O eq 'MacOS') {
$macfiles = eval { require Mac::Files };
}
sub case_tolerant { 1 }
=head1 NAME
File::Spec::Mac - File::Spec for Mac OS (Classic)
=head1 SYNOPSIS
require File::Spec::Mac; # Done internally by File::Spec if needed
=head1 DESCRIPTION
Methods for manipulating file specifications.
=head1 METHODS
=over 2
=item canonpath
On Mac OS, there's nothing to be done. Returns what it's given.
=cut
sub canonpath {
my ($self,$path) = @_;
return $path;
}
=item catdir()
Concatenate two or more directory names to form a path separated by colons
(":") ending with a directory. Resulting paths are B<relative> by default,
but can be forced to be absolute (but avoid this, see below). Automatically
puts a trailing ":" on the end of the complete path, because that's what's
done in MacPerl's environment and helps to distinguish a file path from a
directory path.
B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the resulting
path is relative by default and I<not> absolute. This decision was made due
to portability reasons. Since C<File::Spec-E<gt>catdir()> returns relative paths
on all other operating systems, it will now also follow this convention on Mac
OS. Note that this may break some existing scripts.
The intended purpose of this routine is to concatenate I<directory names>.
But because of the nature of Macintosh paths, some additional possibilities
are allowed to make using this routine give reasonable results for some
common situations. In other words, you are also allowed to concatenate
I<paths> instead of directory names (strictly speaking, a string like ":a"
is a path, but not a name, since it contains a punctuation character ":").
So, beside calls like
catdir("a") = ":a:"
catdir("a","b") = ":a:b:"
catdir() = "" (special case)
calls like the following
catdir(":a:") = ":a:"
catdir(":a","b") = ":a:b:"
catdir(":a:","b") = ":a:b:"
catdir(":a:",":b:") = ":a:b:"
catdir(":") = ":"
are allowed.
Here are the rules that are used in C<catdir()>; note that we try to be as
compatible as possible to Unix:
=over 2
=item 1.
The resulting path is relative by default, i.e. the resulting path will have a
leading colon.
=item 2.
A trailing colon is added automatically to the resulting path, to denote a
directory.
=item 3.
Generally, each argument has one leading ":" and one trailing ":"
removed (if any). They are then joined together by a ":". Special
treatment applies for arguments denoting updir paths like "::lib:",
see (4), or arguments consisting solely of colons ("colon paths"),
see (5).
=item 4.
When an updir path like ":::lib::" is passed as argument, the number
of directories to climb up is handled correctly, not removing leading
or trailing colons when necessary. E.g.
catdir(":::a","::b","c") = ":::a::b:c:"
catdir(":::a::","::b","c") = ":::a:::b:c:"
=item 5.
Adding a colon ":" or empty string "" to a path at I<any> position
doesn't alter the path, i.e. these arguments are ignored. (When a ""
is passed as the first argument, it has a special meaning, see
(6)). This way, a colon ":" is handled like a "." (curdir) on Unix,
while an empty string "" is generally ignored (see
C<Unix-E<gt>canonpath()> ). Likewise, a "::" is handled like a ".."
(updir), and a ":::" is handled like a "../.." etc. E.g.
catdir("a",":",":","b") = ":a:b:"
catdir("a",":","::",":b") = ":a::b:"
=item 6.
If the first argument is an empty string "" or is a volume name, i.e. matches
the pattern /^[^:]+:/, the resulting path is B<absolute>.
=item 7.
Passing an empty string "" as the first argument to C<catdir()> is
like passingC<File::Spec-E<gt>rootdir()> as the first argument, i.e.
catdir("","a","b") is the same as
catdir(rootdir(),"a","b").
This is true on Unix, where C<catdir("","a","b")> yields "/a/b" and
C<rootdir()> is "/". Note that C<rootdir()> on Mac OS is the startup
volume, which is the closest in concept to Unix' "/". This should help
to run existing scripts originally written for Unix.
=item 8.
For absolute paths, some cleanup is done, to ensure that the volume
name isn't immediately followed by updirs. This is invalid, because
this would go beyond "root". Generally, these cases are handled like
their Unix counterparts:
Unix:
Unix->catdir("","") = "/"
Unix->catdir("",".") = "/"
Unix->catdir("","..") = "/" # can't go
# beyond root
Unix->catdir("",".","..","..","a") = "/a"
Mac:
Mac->catdir("","") = rootdir() # (e.g. "HD:")
Mac->catdir("",":") = rootdir()
Mac->catdir("","::") = rootdir() # can't go
# beyond root
Mac->catdir("",":","::","::","a") = rootdir() . "a:"
# (e.g. "HD:a:")
However, this approach is limited to the first arguments following
"root" (again, see C<Unix-E<gt>canonpath()> ). If there are more
arguments that move up the directory tree, an invalid path going
beyond root can be created.
=back
As you've seen, you can force C<catdir()> to create an absolute path
by passing either an empty string or a path that begins with a volume
name as the first argument. However, you are strongly encouraged not
to do so, since this is done only for backward compatibility. Newer
versions of File::Spec come with a method called C<catpath()> (see
below), that is designed to offer a portable solution for the creation
of absolute paths. It takes volume, directory and file portions and
returns an entire path. While C<catdir()> is still suitable for the
concatenation of I<directory names>, you are encouraged to use
C<catpath()> to concatenate I<volume names> and I<directory
paths>. E.g.
$dir = File::Spec->catdir("tmp","sources");
$abs_path = File::Spec->catpath("MacintoshHD:", $dir,"");
yields
"MacintoshHD:tmp:sources:" .
=cut
sub catdir {
my $self = shift;
return '' unless @_;
my @args = @_;
my $first_arg;
my $relative;
# take care of the first argument
if ($args[0] eq '') { # absolute path, rootdir
shift @args;
$relative = 0;
$first_arg = $self->rootdir;
} elsif ($args[0] =~ /^[^:]+:/) { # absolute path, volume name
$relative = 0;
$first_arg = shift @args;
# add a trailing ':' if need be (may be it's a path like HD:dir)
$first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/);
} else { # relative path
$relative = 1;
if ( $args[0] =~ /^::+\Z(?!\n)/ ) {
# updir colon path ('::', ':::' etc.), don't shift
$first_arg = ':';
} elsif ($args[0] eq ':') {
$first_arg = shift @args;
} else {
# add a trailing ':' if need be
$first_arg = shift @args;
$first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/);
}
}
# For all other arguments,
# (a) ignore arguments that equal ':' or '',
# (b) handle updir paths specially:
# '::' -> concatenate '::'
# '::' . '::' -> concatenate ':::' etc.
# (c) add a trailing ':' if need be
my $result = $first_arg;
while (@args) {
my $arg = shift @args;
unless (($arg eq '') || ($arg eq ':')) {
if ($arg =~ /^::+\Z(?!\n)/ ) { # updir colon path like ':::'
my $updir_count = length($arg) - 1;
while ((@args) && ($args[0] =~ /^::+\Z(?!\n)/) ) { # while updir colon path
$arg = shift @args;
$updir_count += (length($arg) - 1);
}
$arg = (':' x $updir_count);
} else {
$arg =~ s/^://s; # remove a leading ':' if any
$arg = "$arg:" unless ($arg =~ /:\Z(?!\n)/); # ensure trailing ':'
}
$result .= $arg;
}#unless
}
if ( ($relative) && ($result !~ /^:/) ) {
# add a leading colon if need be
$result = ":$result";
}
unless ($relative) {
# remove updirs immediately following the volume name
$result =~ s/([^:]+:)(:*)(.*)\Z(?!\n)/$1$3/;
}
return $result;
}
=item catfile
Concatenate one or more directory names and a filename to form a
complete path ending with a filename. Resulting paths are B<relative>
by default, but can be forced to be absolute (but avoid this).
B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the
resulting path is relative by default and I<not> absolute. This
decision was made due to portability reasons. Since
C<File::Spec-E<gt>catfile()> returns relative paths on all other
operating systems, it will now also follow this convention on Mac OS.
Note that this may break some existing scripts.
The last argument is always considered to be the file portion. Since
C<catfile()> uses C<catdir()> (see above) for the concatenation of the
directory portions (if any), the following with regard to relative and
absolute paths is true:
catfile("") = ""
catfile("file") = "file"
but
catfile("","") = rootdir() # (e.g. "HD:")
catfile("","file") = rootdir() . file # (e.g. "HD:file")
catfile("HD:","file") = "HD:file"
This means that C<catdir()> is called only when there are two or more
arguments, as one might expect.
Note that the leading ":" is removed from the filename, so that
catfile("a","b","file") = ":a:b:file" and
catfile("a","b",":file") = ":a:b:file"
give the same answer.
To concatenate I<volume names>, I<directory paths> and I<filenames>,
you are encouraged to use C<catpath()> (see below).
=cut
sub catfile {
my $self = shift;
return '' unless @_;
my $file = pop @_;
return $file unless @_;
my $dir = $self->catdir(@_);
$file =~ s/^://s;
return $dir.$file;
}
=item curdir
Returns a string representing the current directory. On Mac OS, this is ":".
=cut
sub curdir {
return ":";
}
=item devnull
Returns a string representing the null device. On Mac OS, this is "Dev:Null".
=cut
sub devnull {
return "Dev:Null";
}
=item rootdir
Returns a string representing the root directory. Under MacPerl,
returns the name of the startup volume, since that's the closest in
concept, although other volumes aren't rooted there. The name has a
trailing ":", because that's the correct specification for a volume
name on Mac OS.
If Mac::Files could not be loaded, the empty string is returned.
=cut
sub rootdir {
#
# There's no real root directory on Mac OS. The name of the startup
# volume is returned, since that's the closest in concept.
#
return '' unless $macfiles;
my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk,
&Mac::Files::kSystemFolderType);
$system =~ s/:.*\Z(?!\n)/:/s;
return $system;
}
=item tmpdir
Returns the contents of $ENV{TMPDIR}, if that directory exits or the
current working directory otherwise. Under MacPerl, $ENV{TMPDIR} will
contain a path like "MacintoshHD:Temporary Items:", which is a hidden
directory on your startup volume.
=cut
my $tmpdir;
sub tmpdir {
return $tmpdir if defined $tmpdir;
$tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR} );
}
=item updir
Returns a string representing the parent directory. On Mac OS, this is "::".
=cut
sub updir {
return "::";
}
=item file_name_is_absolute
Takes as argument a path and returns true, if it is an absolute path.
If the path has a leading ":", it's a relative path. Otherwise, it's an
absolute path, unless the path doesn't contain any colons, i.e. it's a name
like "a". In this particular case, the path is considered to be relative
(i.e. it is considered to be a filename). Use ":" in the appropriate place
in the path if you want to distinguish unambiguously. As a special case,
the filename '' is always considered to be absolute. Note that with version
1.2 of File::Spec::Mac, this does no longer consult the local filesystem.
E.g.
File::Spec->file_name_is_absolute("a"); # false (relative)
File::Spec->file_name_is_absolute(":a:b:"); # false (relative)
File::Spec->file_name_is_absolute("MacintoshHD:");
# true (absolute)
File::Spec->file_name_is_absolute(""); # true (absolute)
=cut
sub file_name_is_absolute {
my ($self,$file) = @_;
if ($file =~ /:/) {
return (! ($file =~ m/^:/s) );
} elsif ( $file eq '' ) {
return 1 ;
} else {
return 0; # i.e. a file like "a"
}
}
=item path
Returns the null list for the MacPerl application, since the concept is
usually meaningless under Mac OS. But if you're using the MacPerl tool under
MPW, it gives back $ENV{Commands} suitably split, as is done in
:lib:ExtUtils:MM_Mac.pm.
=cut
sub path {
#
# The concept is meaningless under the MacPerl application.
# Under MPW, it has a meaning.
#
return unless exists $ENV{Commands};
return split(/,/, $ENV{Commands});
}
=item splitpath
($volume,$directories,$file) = File::Spec->splitpath( $path );
($volume,$directories,$file) = File::Spec->splitpath( $path,
$no_file );
Splits a path into volume, directory, and filename portions.
On Mac OS, assumes that the last part of the path is a filename unless
$no_file is true or a trailing separator ":" is present.
The volume portion is always returned with a trailing ":". The directory portion
is always returned with a leading (to denote a relative path) and a trailing ":"
(to denote a directory). The file portion is always returned I<without> a leading ":".
Empty portions are returned as empty string ''.
The results can be passed to C<catpath()> to get back a path equivalent to
(usually identical to) the original path.
=cut
sub splitpath {
my ($self,$path, $nofile) = @_;
my ($volume,$directory,$file);
if ( $nofile ) {
( $volume, $directory ) = $path =~ m|^((?:[^:]+:)?)(.*)|s;
}
else {
$path =~
m|^( (?: [^:]+: )? )
( (?: .*: )? )
( .* )
|xs;
$volume = $1;
$directory = $2;
$file = $3;
}
$volume = '' unless defined($volume);
$directory = ":$directory" if ( $volume && $directory ); # take care of "HD::dir"
if ($directory) {
# Make sure non-empty directories begin and end in ':'
$directory .= ':' unless (substr($directory,-1) eq ':');
$directory = ":$directory" unless (substr($directory,0,1) eq ':');
} else {
$directory = '';
}
$file = '' unless defined($file);
return ($volume,$directory,$file);
}
=item splitdir
The opposite of C<catdir()>.
@dirs = File::Spec->splitdir( $directories );
$directories should be only the directory portion of the path on systems
that have the concept of a volume or that have path syntax that differentiates
files from directories. Consider using C<splitpath()> otherwise.
Unlike just splitting the directories on the separator, empty directory names
(C<"">) can be returned. Since C<catdir()> on Mac OS always appends a trailing
colon to distinguish a directory path from a file path, a single trailing colon
will be ignored, i.e. there's no empty directory name after it.
Hence, on Mac OS, both
File::Spec->splitdir( ":a:b::c:" ); and
File::Spec->splitdir( ":a:b::c" );
yield:
( "a", "b", "::", "c")
while
File::Spec->splitdir( ":a:b::c::" );
yields:
( "a", "b", "::", "c", "::")
=cut
sub splitdir {
my ($self, $path) = @_;
my @result = ();
my ($head, $sep, $tail, $volume, $directories);
return @result if ( (!defined($path)) || ($path eq '') );
return (':') if ($path eq ':');
( $volume, $sep, $directories ) = $path =~ m|^((?:[^:]+:)?)(:*)(.*)|s;
# deprecated, but handle it correctly
if ($volume) {
push (@result, $volume);
$sep .= ':';
}
while ($sep || $directories) {
if (length($sep) > 1) {
my $updir_count = length($sep) - 1;
for (my $i=0; $i<$updir_count; $i++) {
# push '::' updir_count times;
# simulate Unix '..' updirs
push (@result, '::');
}
}
$sep = '';
if ($directories) {
( $head, $sep, $tail ) = $directories =~ m|^((?:[^:]+)?)(:*)(.*)|s;
push (@result, $head);
$directories = $tail;
}
}
return @result;
}
=item catpath
$path = File::Spec->catpath($volume,$directory,$file);
Takes volume, directory and file portions and returns an entire path. On Mac OS,
$volume, $directory and $file are concatenated. A ':' is inserted if need be. You
may pass an empty string for each portion. If all portions are empty, the empty
string is returned. If $volume is empty, the result will be a relative path,
beginning with a ':'. If $volume and $directory are empty, a leading ":" (if any)
is removed form $file and the remainder is returned. If $file is empty, the
resulting path will have a trailing ':'.
=cut
sub catpath {
my ($self,$volume,$directory,$file) = @_;
if ( (! $volume) && (! $directory) ) {
$file =~ s/^:// if $file;
return $file ;
}
# We look for a volume in $volume, then in $directory, but not both
my ($dir_volume, $dir_dirs) = $self->splitpath($directory, 1);
$volume = $dir_volume unless length $volume;
my $path = $volume; # may be ''
$path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':'
if ($directory) {
$directory = $dir_dirs if $volume;
$directory =~ s/^://; # remove leading ':' if any
$path .= $directory;
$path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':'
}
if ($file) {
$file =~ s/^://; # remove leading ':' if any
$path .= $file;
}
return $path;
}
=item abs2rel
Takes a destination path and an optional base path and returns a relative path
from the base path to the destination path:
$rel_path = File::Spec->abs2rel( $path ) ;
$rel_path = File::Spec->abs2rel( $path, $base ) ;
Note that both paths are assumed to have a notation that distinguishes a
directory path (with trailing ':') from a file path (without trailing ':').
If $base is not present or '', then the current working directory is used.
If $base is relative, then it is converted to absolute form using C<rel2abs()>.
This means that it is taken to be relative to the current working directory.
If $path and $base appear to be on two different volumes, we will not
attempt to resolve the two paths, and we will instead simply return
$path. Note that previous versions of this module ignored the volume
of $base, which resulted in garbage results part of the time.
If $base doesn't have a trailing colon, the last element of $base is
assumed to be a filename. This filename is ignored. Otherwise all path
components are assumed to be directories.
If $path is relative, it is converted to absolute form using C<rel2abs()>.
This means that it is taken to be relative to the current working directory.
Based on code written by Shigio Yamaguchi.
=cut
# maybe this should be done in canonpath() ?
sub _resolve_updirs {
my $path = shift @_;
my $proceed;
# resolve any updirs, e.g. "HD:tmp::file" -> "HD:file"
do {
$proceed = ($path =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/);
} while ($proceed);
return $path;
}
sub abs2rel {
my($self,$path,$base) = @_;
# Clean up $path
if ( ! $self->file_name_is_absolute( $path ) ) {
$path = $self->rel2abs( $path ) ;
}
# Figure out the effective $base and clean it up.
if ( !defined( $base ) || $base eq '' ) {
$base = $self->_cwd();
}
elsif ( ! $self->file_name_is_absolute( $base ) ) {
$base = $self->rel2abs( $base ) ;
$base = _resolve_updirs( $base ); # resolve updirs in $base
}
else {
$base = _resolve_updirs( $base );
}
# Split up paths - ignore $base's file
my ( $path_vol, $path_dirs, $path_file ) = $self->splitpath( $path );
my ( $base_vol, $base_dirs ) = $self->splitpath( $base );
return $path unless lc( $path_vol ) eq lc( $base_vol );
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path_dirs );
my @basechunks = $self->splitdir( $base_dirs );
while ( @pathchunks &&
@basechunks &&
lc( $pathchunks[0] ) eq lc( $basechunks[0] ) ) {
shift @pathchunks ;
shift @basechunks ;
}
# @pathchunks now has the directories to descend in to.
# ensure relative path, even if @pathchunks is empty
$path_dirs = $self->catdir( ':', @pathchunks );
# @basechunks now contains the number of directories to climb out of.
$base_dirs = (':' x @basechunks) . ':' ;
return $self->catpath( '', $self->catdir( $base_dirs, $path_dirs ), $path_file ) ;
}
=item rel2abs
Converts a relative path to an absolute path:
$abs_path = File::Spec->rel2abs( $path ) ;
$abs_path = File::Spec->rel2abs( $path, $base ) ;
Note that both paths are assumed to have a notation that distinguishes a
directory path (with trailing ':') from a file path (without trailing ':').
If $base is not present or '', then $base is set to the current working
directory. If $base is relative, then it is converted to absolute form
using C<rel2abs()>. This means that it is taken to be relative to the
current working directory.
If $base doesn't have a trailing colon, the last element of $base is
assumed to be a filename. This filename is ignored. Otherwise all path
components are assumed to be directories.
If $path is already absolute, it is returned and $base is ignored.
Based on code written by Shigio Yamaguchi.
=cut
sub rel2abs {
my ($self,$path,$base) = @_;
if ( ! $self->file_name_is_absolute($path) ) {
# Figure out the effective $base and clean it up.
if ( !defined( $base ) || $base eq '' ) {
$base = $self->_cwd();
}
elsif ( ! $self->file_name_is_absolute($base) ) {
$base = $self->rel2abs($base) ;
}
# Split up paths
# ignore $path's volume
my ( $path_dirs, $path_file ) = ($self->splitpath($path))[1,2] ;
# ignore $base's file part
my ( $base_vol, $base_dirs ) = $self->splitpath($base) ;
# Glom them together
$path_dirs = ':' if ($path_dirs eq '');
$base_dirs =~ s/:$//; # remove trailing ':', if any
$base_dirs = $base_dirs . $path_dirs;
$path = $self->catpath( $base_vol, $base_dirs, $path_file );
}
return $path;
}
=back
=head1 AUTHORS
See the authors list in I<File::Spec>. Mac OS support by Paul Schinder
<schinder@pobox.com> and Thomas Wegner <wegner_thomas@yahoo.com>.
=head1 COPYRIGHT
Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 SEE ALSO
See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
implementation of these methods, not the semantics.
=cut
1;
DARWIN-2LEVEL_FILE_SPEC_MAC
$fatpacked{"darwin-2level/File/Spec/OS2.pm"} = <<'DARWIN-2LEVEL_FILE_SPEC_OS2';
package File::Spec::OS2;
use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
$VERSION = '3.40';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
sub devnull {
return "/dev/nul";
}
sub case_tolerant {
return 1;
}
sub file_name_is_absolute {
my ($self,$file) = @_;
return scalar($file =~ m{^([a-z]:)?[\\/]}is);
}
sub path {
my $path = $ENV{PATH};
$path =~ s:\\:/:g;
my @path = split(';',$path);
foreach (@path) { $_ = '.' if $_ eq '' }
return @path;
}
sub _cwd {
# In OS/2 the "require Cwd" is unnecessary bloat.
return Cwd::sys_cwd();
}
my $tmpdir;
sub tmpdir {
return $tmpdir if defined $tmpdir;
my @d = @ENV{qw(TMPDIR TEMP TMP)}; # function call could autovivivy
$tmpdir = $_[0]->_tmpdir( @d, '/tmp', '/' );
}
sub catdir {
my $self = shift;
my @args = @_;
foreach (@args) {
tr[\\][/];
# append a backslash to each argument unless it has one there
$_ .= "/" unless m{/$};
}
return $self->canonpath(join('', @args));
}
sub canonpath {
my ($self,$path) = @_;
return unless defined $path;
$path =~ s/^([a-z]:)/\l$1/s;
$path =~ s|\\|/|g;
$path =~ s|([^/])/+|$1/|g; # xx////xx -> xx/xx
$path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx
$path =~ s|^(\./)+(?=[^/])||s; # ./xx -> xx
$path =~ s|/\Z(?!\n)||
unless $path =~ m#^([a-z]:)?/\Z(?!\n)#si;# xx/ -> xx
$path =~ s{^/\.\.$}{/}; # /.. -> /
1 while $path =~ s{^/\.\.}{}; # /../xx -> /xx
return $path;
}
sub splitpath {
my ($self,$path, $nofile) = @_;
my ($volume,$directory,$file) = ('','','');
if ( $nofile ) {
$path =~
m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
(.*)
}xs;
$volume = $1;
$directory = $2;
}
else {
$path =~
m{^ ( (?: [a-zA-Z]: |
(?:\\\\|//)[^\\/]+[\\/][^\\/]+
)?
)
( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
(.*)
}xs;
$volume = $1;
$directory = $2;
$file = $3;
}
return ($volume,$directory,$file);
}
sub splitdir {
my ($self,$directories) = @_ ;
split m|[\\/]|, $directories, -1;
}
sub catpath {
my ($self,$volume,$directory,$file) = @_;
# If it's UNC, make sure the glue separator is there, reusing
# whatever separator is first in the $volume
$volume .= $1
if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
$directory =~ m@^[^\\/]@s
) ;
$volume .= $directory ;
# If the volume is not just A:, make sure the glue separator is
# there, reusing whatever separator is first in the $volume if possible.
if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
$volume =~ m@[^\\/]\Z(?!\n)@ &&
$file =~ m@[^\\/]@
) {
$volume =~ m@([\\/])@ ;
my $sep = $1 ? $1 : '/' ;
$volume .= $sep ;
}
$volume .= $file ;
return $volume ;
}
sub abs2rel {
my($self,$path,$base) = @_;
# Clean up $path
if ( ! $self->file_name_is_absolute( $path ) ) {
$path = $self->rel2abs( $path ) ;
} else {
$path = $self->canonpath( $path ) ;
}
# Figure out the effective $base and clean it up.
if ( !defined( $base ) || $base eq '' ) {
$base = $self->_cwd();
} elsif ( ! $self->file_name_is_absolute( $base ) ) {
$base = $self->rel2abs( $base ) ;
} else {
$base = $self->canonpath( $base ) ;
}
# Split up paths
my ( $path_volume, $path_directories, $path_file ) = $self->splitpath( $path, 1 ) ;
my ( $base_volume, $base_directories ) = $self->splitpath( $base, 1 ) ;
return $path unless $path_volume eq $base_volume;
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path_directories );
my @basechunks = $self->splitdir( $base_directories );
while ( @pathchunks &&
@basechunks &&
lc( $pathchunks[0] ) eq lc( $basechunks[0] )
) {
shift @pathchunks ;
shift @basechunks ;
}
# No need to catdir, we know these are well formed.
$path_directories = CORE::join( '/', @pathchunks );
$base_directories = CORE::join( '/', @basechunks );
# $base_directories now contains the directories the resulting relative
# path must ascend out of before it can descend to $path_directory. So,
# replace all names with $parentDir
#FA Need to replace between backslashes...
$base_directories =~ s|[^\\/]+|..|g ;
# Glue the two together, using a separator if necessary, and preventing an
# empty result.
#FA Must check that new directories are not empty.
if ( $path_directories ne '' && $base_directories ne '' ) {
$path_directories = "$base_directories/$path_directories" ;
} else {
$path_directories = "$base_directories$path_directories" ;
}
return $self->canonpath(
$self->catpath( "", $path_directories, $path_file )
) ;
}
sub rel2abs {
my ($self,$path,$base ) = @_;
if ( ! $self->file_name_is_absolute( $path ) ) {
if ( !defined( $base ) || $base eq '' ) {
$base = $self->_cwd();
}
elsif ( ! $self->file_name_is_absolute( $base ) ) {
$base = $self->rel2abs( $base ) ;
}
else {
$base = $self->canonpath( $base ) ;
}
my ( $path_directories, $path_file ) =
($self->splitpath( $path, 1 ))[1,2] ;
my ( $base_volume, $base_directories ) =
$self->splitpath( $base, 1 ) ;
$path = $self->catpath(
$base_volume,
$self->catdir( $base_directories, $path_directories ),
$path_file
) ;
}
return $self->canonpath( $path ) ;
}
1;
__END__
=head1 NAME
File::Spec::OS2 - methods for OS/2 file specs
=head1 SYNOPSIS
require File::Spec::OS2; # Done internally by File::Spec if needed
=head1 DESCRIPTION
See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
implementation of these methods, not the semantics.
Amongst the changes made for OS/2 are...
=over 4
=item tmpdir
Modifies the list of places temp directory information is looked for.
$ENV{TMPDIR}
$ENV{TEMP}
$ENV{TMP}
/tmp
/
=item splitpath
Volumes can be drive letters or UNC sharenames (\\server\share).
=back
=head1 COPYRIGHT
Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
DARWIN-2LEVEL_FILE_SPEC_OS2
$fatpacked{"darwin-2level/File/Spec/Unix.pm"} = <<'DARWIN-2LEVEL_FILE_SPEC_UNIX';
package File::Spec::Unix;
use strict;
use vars qw($VERSION);
$VERSION = '3.40';
$VERSION =~ tr/_//;
=head1 NAME
File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules
=head1 SYNOPSIS
require File::Spec::Unix; # Done automatically by File::Spec
=head1 DESCRIPTION
Methods for manipulating file specifications. Other File::Spec
modules, such as File::Spec::Mac, inherit from File::Spec::Unix and
override specific methods.
=head1 METHODS
=over 2
=item canonpath()
No physical check on the filesystem, but a logical cleanup of a
path. On UNIX eliminates successive slashes and successive "/.".
$cpath = File::Spec->canonpath( $path ) ;
Note that this does *not* collapse F<x/../y> sections into F<y>. This
is by design. If F</foo> on your system is a symlink to F</bar/baz>,
then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
F<../>-removal would give you. If you want to do this kind of
processing, you probably want C<Cwd>'s C<realpath()> function to
actually traverse the filesystem cleaning up paths like this.
=cut
sub canonpath {
my ($self,$path) = @_;
return unless defined $path;
# Handle POSIX-style node names beginning with double slash (qnx, nto)
# (POSIX says: "a pathname that begins with two successive slashes
# may be interpreted in an implementation-defined manner, although
# more than two leading slashes shall be treated as a single slash.")
my $node = '';
my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto';
if ( $double_slashes_special
&& ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) {
$node = $1;
}
# This used to be
# $path =~ s|/+|/|g unless ($^O eq 'cygwin');
# but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail
# (Mainly because trailing "" directories didn't get stripped).
# Why would cygwin avoid collapsing multiple slashes into one? --jhi
$path =~ s|/{2,}|/|g; # xx////xx -> xx/xx
$path =~ s{(?:/\.)+(?:/|\z)}{/}g; # xx/././xx -> xx/xx
$path =~ s|^(?:\./)+||s unless $path eq "./"; # ./xx -> xx
$path =~ s|^/(?:\.\./)+|/|; # /../../xx -> xx
$path =~ s|^/\.\.$|/|; # /.. -> /
$path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx
return "$node$path";
}
=item catdir()
Concatenate two or more directory names to form a complete path ending
with a directory. But remove the trailing slash from the resulting
string, because it doesn't look good, isn't necessary and confuses
OS2. Of course, if this is the root directory, don't cut off the
trailing slash :-)
=cut
sub catdir {
my $self = shift;
$self->canonpath(join('/', @_, '')); # '' because need a trailing '/'
}
=item catfile
Concatenate one or more directory names and a filename to form a
complete path ending with a filename
=cut
sub catfile {
my $self = shift;
my $file = $self->canonpath(pop @_);
return $file unless @_;
my $dir = $self->catdir(@_);
$dir .= "/" unless substr($dir,-1) eq "/";
return $dir.$file;
}
=item curdir
Returns a string representation of the current directory. "." on UNIX.
=cut
sub curdir { '.' }
=item devnull
Returns a string representation of the null device. "/dev/null" on UNIX.
=cut
sub devnull { '/dev/null' }
=item rootdir
Returns a string representation of the root directory. "/" on UNIX.
=cut
sub rootdir { '/' }
=item tmpdir
Returns a string representation of the first writable directory from
the following list or the current directory if none from the list are
writable:
$ENV{TMPDIR}
/tmp
If running under taint mode, and if $ENV{TMPDIR}
is tainted, it is not used.
=cut
my $tmpdir;
sub _tmpdir {
return $tmpdir if defined $tmpdir;
my $self = shift;
my @dirlist = @_;
{
no strict 'refs';
if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0
require Scalar::Util;
@dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist;
}
elsif ($] < 5.007) { # No ${^TAINT} before 5.8
@dirlist = grep { eval { eval('1'.substr $_,0,0) } } @dirlist;
}
}
foreach (@dirlist) {
next unless defined && -d && -w _;
$tmpdir = $_;
last;
}
$tmpdir = $self->curdir unless defined $tmpdir;
$tmpdir = defined $tmpdir && $self->canonpath($tmpdir);
return $tmpdir;
}
sub tmpdir {
return $tmpdir if defined $tmpdir;
$tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" );
}
=item updir
Returns a string representation of the parent directory. ".." on UNIX.
=cut
sub updir { '..' }
=item no_upwards
Given a list of file names, strip out those that refer to a parent
directory. (Does not strip symlinks, only '.', '..', and equivalents.)
=cut
sub no_upwards {
my $self = shift;
return grep(!/^\.{1,2}\z/s, @_);
}
=item case_tolerant
Returns a true or false value indicating, respectively, that alphabetic
is not or is significant when comparing file specifications.
=cut
sub case_tolerant { 0 }
=item file_name_is_absolute
Takes as argument a path and returns true if it is an absolute path.
This does not consult the local filesystem on Unix, Win32, OS/2 or Mac
OS (Classic). It does consult the working environment for VMS (see
L<File::Spec::VMS/file_name_is_absolute>).
=cut
sub file_name_is_absolute {
my ($self,$file) = @_;
return scalar($file =~ m:^/:s);
}
=item path
Takes no argument, returns the environment variable PATH as an array.
=cut
sub path {
return () unless exists $ENV{PATH};
my @path = split(':', $ENV{PATH});
foreach (@path) { $_ = '.' if $_ eq '' }
return @path;
}
=item join
join is the same as catfile.
=cut
sub join {
my $self = shift;
return $self->catfile(@_);
}
=item splitpath
($volume,$directories,$file) = File::Spec->splitpath( $path );
($volume,$directories,$file) = File::Spec->splitpath( $path,
$no_file );
Splits a path into volume, directory, and filename portions. On systems
with no concept of volume, returns '' for volume.
For systems with no syntax differentiating filenames from directories,
assumes that the last file is a path unless $no_file is true or a
trailing separator or /. or /.. is present. On Unix this means that $no_file
true makes this return ( '', $path, '' ).
The directory portion may or may not be returned with a trailing '/'.
The results can be passed to L</catpath()> to get back a path equivalent to
(usually identical to) the original path.
=cut
sub splitpath {
my ($self,$path, $nofile) = @_;
my ($volume,$directory,$file) = ('','','');
if ( $nofile ) {
$directory = $path;
}
else {
$path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs;
$directory = $1;
$file = $2;
}
return ($volume,$directory,$file);
}
=item splitdir
The opposite of L</catdir()>.
@dirs = File::Spec->splitdir( $directories );
$directories must be only the directory portion of the path on systems
that have the concept of a volume or that have path syntax that differentiates
files from directories.
Unlike just splitting the directories on the separator, empty
directory names (C<''>) can be returned, because these are significant
on some OSs.
On Unix,
File::Spec->splitdir( "/a/b//c/" );
Yields:
( '', 'a', 'b', '', 'c', '' )
=cut
sub splitdir {
return split m|/|, $_[1], -1; # Preserve trailing fields
}
=item catpath()
Takes volume, directory and file portions and returns an entire path. Under
Unix, $volume is ignored, and directory and file are concatenated. A '/' is
inserted if needed (though if the directory portion doesn't start with
'/' it is not added). On other OSs, $volume is significant.
=cut
sub catpath {
my ($self,$volume,$directory,$file) = @_;
if ( $directory ne '' &&
$file ne '' &&
substr( $directory, -1 ) ne '/' &&
substr( $file, 0, 1 ) ne '/'
) {
$directory .= "/$file" ;
}
else {
$directory .= $file ;
}
return $directory ;
}
=item abs2rel
Takes a destination path and an optional base path returns a relative path
from the base path to the destination path:
$rel_path = File::Spec->abs2rel( $path ) ;
$rel_path = File::Spec->abs2rel( $path, $base ) ;
If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
relative, then it is converted to absolute form using
L</rel2abs()>. This means that it is taken to be relative to
L<cwd()|Cwd>.
On systems that have a grammar that indicates filenames, this ignores the
$base filename. Otherwise all path components are assumed to be
directories.
If $path is relative, it is converted to absolute form using L</rel2abs()>.
This means that it is taken to be relative to L<cwd()|Cwd>.
No checks against the filesystem are made, so the result may not be correct if
C<$base> contains symbolic links. (Apply
L<Cwd::abs_path()|Cwd/abs_path> beforehand if that
is a concern.) On VMS, there is interaction with the working environment, as
logicals and macros are expanded.
Based on code written by Shigio Yamaguchi.
=cut
sub abs2rel {
my($self,$path,$base) = @_;
$base = $self->_cwd() unless defined $base and length $base;
($path, $base) = map $self->canonpath($_), $path, $base;
my $path_directories;
my $base_directories;
if (grep $self->file_name_is_absolute($_), $path, $base) {
($path, $base) = map $self->rel2abs($_), $path, $base;
my ($path_volume) = $self->splitpath($path, 1);
my ($base_volume) = $self->splitpath($base, 1);
# Can't relativize across volumes
return $path unless $path_volume eq $base_volume;
$path_directories = ($self->splitpath($path, 1))[1];
$base_directories = ($self->splitpath($base, 1))[1];
# For UNC paths, the user might give a volume like //foo/bar that
# strictly speaking has no directory portion. Treat it as if it
# had the root directory for that volume.
if (!length($base_directories) and $self->file_name_is_absolute($base)) {
$base_directories = $self->rootdir;
}
}
else {
my $wd= ($self->splitpath($self->_cwd(), 1))[1];
$path_directories = $self->catdir($wd, $path);
$base_directories = $self->catdir($wd, $base);
}
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path_directories );
my @basechunks = $self->splitdir( $base_directories );
if ($base_directories eq $self->rootdir) {
return $self->curdir if $path_directories eq $self->rootdir;
shift @pathchunks;
return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
}
my @common;
while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
push @common, shift @pathchunks ;
shift @basechunks ;
}
return $self->curdir unless @pathchunks || @basechunks;
# @basechunks now contains the directories the resulting relative path
# must ascend out of before it can descend to $path_directory. If there
# are updir components, we must descend into the corresponding directories
# (this only works if they are no symlinks).
my @reverse_base;
while( defined(my $dir= shift @basechunks) ) {
if( $dir ne $self->updir ) {
unshift @reverse_base, $self->updir;
push @common, $dir;
}
elsif( @common ) {
if( @reverse_base && $reverse_base[0] eq $self->updir ) {
shift @reverse_base;
pop @common;
}
else {
unshift @reverse_base, pop @common;
}
}
}
my $result_dirs = $self->catdir( @reverse_base, @pathchunks );
return $self->canonpath( $self->catpath('', $result_dirs, '') );
}
sub _same {
$_[1] eq $_[2];
}
=item rel2abs()
Converts a relative path to an absolute path.
$abs_path = File::Spec->rel2abs( $path ) ;
$abs_path = File::Spec->rel2abs( $path, $base ) ;
If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
relative, then it is converted to absolute form using
L</rel2abs()>. This means that it is taken to be relative to
L<cwd()|Cwd>.
On systems that have a grammar that indicates filenames, this ignores
the $base filename. Otherwise all path components are assumed to be
directories.
If $path is absolute, it is cleaned up and returned using L</canonpath()>.
No checks against the filesystem are made. On VMS, there is
interaction with the working environment, as logicals and
macros are expanded.
Based on code written by Shigio Yamaguchi.
=cut
sub rel2abs {
my ($self,$path,$base ) = @_;
# Clean up $path
if ( ! $self->file_name_is_absolute( $path ) ) {
# Figure out the effective $base and clean it up.
if ( !defined( $base ) || $base eq '' ) {
$base = $self->_cwd();
}
elsif ( ! $self->file_name_is_absolute( $base ) ) {
$base = $self->rel2abs( $base ) ;
}
else {
$base = $self->canonpath( $base ) ;
}
# Glom them together
$path = $self->catdir( $base, $path ) ;
}
return $self->canonpath( $path ) ;
}
=back
=head1 COPYRIGHT
Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
Please submit bug reports and patches to perlbug@perl.org.
=head1 SEE ALSO
L<File::Spec>
=cut
# Internal routine to File::Spec, no point in making this public since
# it is the standard Cwd interface. Most of the platform-specific
# File::Spec subclasses use this.
sub _cwd {
require Cwd;
Cwd::getcwd();
}
# Internal method to reduce xx\..\yy -> yy
sub _collapse {
my($fs, $path) = @_;
my $updir = $fs->updir;
my $curdir = $fs->curdir;
my($vol, $dirs, $file) = $fs->splitpath($path);
my @dirs = $fs->splitdir($dirs);
pop @dirs if @dirs && $dirs[-1] eq '';
my @collapsed;
foreach my $dir (@dirs) {
if( $dir eq $updir and # if we have an updir
@collapsed and # and something to collapse
length $collapsed[-1] and # and its not the rootdir
$collapsed[-1] ne $updir and # nor another updir
$collapsed[-1] ne $curdir # nor the curdir
)
{ # then
pop @collapsed; # collapse
}
else { # else
push @collapsed, $dir; # just hang onto it
}
}
return $fs->catpath($vol,
$fs->catdir(@collapsed),
$file
);
}
1;
DARWIN-2LEVEL_FILE_SPEC_UNIX
$fatpacked{"darwin-2level/File/Spec/VMS.pm"} = <<'DARWIN-2LEVEL_FILE_SPEC_VMS';
package File::Spec::VMS;
use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
$VERSION = '3.40';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
use File::Basename;
use VMS::Filespec;
=head1 NAME
File::Spec::VMS - methods for VMS file specs
=head1 SYNOPSIS
require File::Spec::VMS; # Done internally by File::Spec if needed
=head1 DESCRIPTION
See File::Spec::Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
The default behavior is to allow either VMS or Unix syntax on input and to
return VMS syntax on output unless Unix syntax has been explicity requested
via the C<DECC$FILENAME_UNIX_REPORT> CRTL feature.
=over 4
=cut
# Need to look up the feature settings. The preferred way is to use the
# VMS::Feature module, but that may not be available to dual life modules.
my $use_feature;
BEGIN {
if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
$use_feature = 1;
}
}
# Need to look up the UNIX report mode. This may become a dynamic mode
# in the future.
sub _unix_rpt {
my $unix_rpt;
if ($use_feature) {
$unix_rpt = VMS::Feature::current("filename_unix_report");
} else {
my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
$unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
}
return $unix_rpt;
}
=item canonpath (override)
Removes redundant portions of file specifications and returns results
in native syntax unless Unix filename reporting has been enabled.
=cut
sub canonpath {
my($self,$path) = @_;
return undef unless defined $path;
my $unix_rpt = $self->_unix_rpt;
if ($path =~ m|/|) {
my $pathify = $path =~ m|/\Z(?!\n)|;
$path = $self->SUPER::canonpath($path);
return $path if $unix_rpt;
$path = $pathify ? vmspath($path) : vmsify($path);
}
$path =~ s/(?<!\^)</[/; # < and > ==> [ and ]
$path =~ s/(?<!\^)>/]/;
$path =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][
$path =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [
$path =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [
$path =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ]
$path =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar
1 while ($path =~ s/(?<!\^)([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
# That loop does the following
# with any amount of dashes:
# .-.-. ==> .--.
# [-.-. ==> [--.
# .-.-] ==> .--]
# [-.-] ==> [--]
1 while ($path =~ s/(?<!\^)([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
# That loop does the following
# with any amount (minimum 2)
# of dashes:
# .foo.--. ==> .-.
# .foo.--] ==> .-]
# [foo.--. ==> [-.
# [foo.--] ==> [-]
#
# And then, the remaining cases
$path =~ s/(?<!\^)\[\.-/[-/; # [.- ==> [-
$path =~ s/(?<!\^)\.[^\]\.]+\.-\./\./g; # .foo.-. ==> .
$path =~ s/(?<!\^)\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [
$path =~ s/(?<!\^)\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ]
# [foo.-] ==> [000000]
$path =~ s/(?<!\^)\[[^\]\.]+\.-\]/\[000000\]/g;
# [] ==>
$path =~ s/(?<!\^)\[\]// unless $path eq '[]';
return $unix_rpt ? unixify($path) : $path;
}
=item catdir (override)
Concatenates a list of file specifications, and returns the result as a
native directory specification unless the Unix filename reporting feature
has been enabled. No check is made for "impossible" cases (e.g. elements
other than the first being absolute filespecs).
=cut
sub catdir {
my $self = shift;
my $dir = pop;
my $unix_rpt = $self->_unix_rpt;
my @dirs = grep {defined() && length()} @_;
my $rslt;
if (@dirs) {
my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
my ($spath,$sdir) = ($path,$dir);
$spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i;
if ($unix_rpt) {
$spath = unixify($spath) unless $spath =~ m#/#;
$sdir= unixify($sdir) unless $sdir =~ m#/#;
return $self->SUPER::catdir($spath, $sdir)
}
$sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
$rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
# Special case for VMS absolute directory specs: these will have
# had device prepended during trip through Unix syntax in
# eliminate_macros(), since Unix syntax has no way to express
# "absolute from the top of this device's directory tree".
if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
} else {
# Single directory. Return an empty string on null input; otherwise
# just return a canonical path.
if (not defined $dir or not length $dir) {
$rslt = '';
} else {
$rslt = $unix_rpt ? $dir : vmspath($dir);
}
}
return $self->canonpath($rslt);
}
=item catfile (override)
Concatenates a list of directory specifications with a filename specification
to build a path.
=cut
sub catfile {
my $self = shift;
my $tfile = pop();
my $file = $self->canonpath($tfile);
my @files = grep {defined() && length()} @_;
my $unix_rpt = $self->_unix_rpt;
my $rslt;
if (@files) {
my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
my $spath = $path;
# Something building a VMS path in pieces may try to pass a
# directory name in filename format, so normalize it.
$spath =~ s/\.dir\Z(?!\n)//i;
# If the spath ends with a directory delimiter and the file is bare,
# then just concatenate them.
if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
$rslt = "$spath$file";
} else {
$rslt = $self->eliminate_macros($spath);
$rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file);
$rslt = vmsify($rslt) unless $unix_rpt;
}
}
else {
# Only passed a single file?
my $xfile = (defined($file) && length($file)) ? $file : '';
$rslt = $unix_rpt ? $file : vmsify($file);
}
return $self->canonpath($rslt) unless $unix_rpt;
# In Unix report mode, do not strip off redundant path information.
return $rslt;
}
=item curdir (override)
Returns a string representation of the current directory: '[]' or '.'
=cut
sub curdir {
my $self = shift @_;
return '.' if ($self->_unix_rpt);
return '[]';
}
=item devnull (override)
Returns a string representation of the null device: '_NLA0:' or '/dev/null'
=cut
sub devnull {
my $self = shift @_;
return '/dev/null' if ($self->_unix_rpt);
return "_NLA0:";
}
=item rootdir (override)
Returns a string representation of the root directory: 'SYS$DISK:[000000]'
or '/'
=cut
sub rootdir {
my $self = shift @_;
if ($self->_unix_rpt) {
# Root may exist, try it first.
my $try = '/';
my ($dev1, $ino1) = stat('/');
my ($dev2, $ino2) = stat('.');
# Perl falls back to '.' if it can not determine '/'
if (($dev1 != $dev2) || ($ino1 != $ino2)) {
return $try;
}
# Fall back to UNIX format sys$disk.
return '/sys$disk/';
}
return 'SYS$DISK:[000000]';
}
=item tmpdir (override)
Returns a string representation of the first writable directory
from the following list or '' if none are writable:
/tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled.
sys$scratch:
$ENV{TMPDIR}
Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
is tainted, it is not used.
=cut
my $tmpdir;
sub tmpdir {
my $self = shift @_;
return $tmpdir if defined $tmpdir;
if ($self->_unix_rpt) {
$tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
return $tmpdir;
}
$tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
}
=item updir (override)
Returns a string representation of the parent directory: '[-]' or '..'
=cut
sub updir {
my $self = shift @_;
return '..' if ($self->_unix_rpt);
return '[-]';
}
=item case_tolerant (override)
VMS file specification syntax is case-tolerant.
=cut
sub case_tolerant {
return 1;
}
=item path (override)
Translate logical name DCL$PATH as a searchlist, rather than trying
to C<split> string value of C<$ENV{'PATH'}>.
=cut
sub path {
my (@dirs,$dir,$i);
while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
return @dirs;
}
=item file_name_is_absolute (override)
Checks for VMS directory spec as well as Unix separators.
=cut
sub file_name_is_absolute {
my ($self,$file) = @_;
# If it's a logical name, expand it.
$file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
return scalar($file =~ m!^/!s ||
$file =~ m![<\[][^.\-\]>]! ||
$file =~ /:[^<\[]/);
}
=item splitpath (override)
($volume,$directories,$file) = File::Spec->splitpath( $path );
($volume,$directories,$file) = File::Spec->splitpath( $path,
$no_file );
Passing a true value for C<$no_file> indicates that the path being
split only contains directory components, even on systems where you
can usually (when not supporting a foreign syntax) tell the difference
between directories and files at a glance.
=cut
sub splitpath {
my($self,$path, $nofile) = @_;
my($dev,$dir,$file) = ('','','');
my $vmsify_path = vmsify($path);
if ( $nofile ) {
#vmsify('d1/d2/d3') returns '[.d1.d2]d3'
#vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
if( $vmsify_path =~ /(.*)\](.+)/ ){
$vmsify_path = $1.'.'.$2.']';
}
$vmsify_path =~ /(.+:)?(.*)/s;
$dir = defined $2 ? $2 : ''; # dir can be '0'
return ($1 || '',$dir,$file);
}
else {
$vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
return ($1 || '',$2 || '',$3);
}
}
=item splitdir (override)
Split a directory specification into the components.
=cut
sub splitdir {
my($self,$dirspec) = @_;
my @dirs = ();
return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
$dirspec =~ s/(?<!\^)</[/; # < and > ==> [ and ]
$dirspec =~ s/(?<!\^)>/]/;
$dirspec =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][
$dirspec =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [
$dirspec =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [
$dirspec =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ]
$dirspec =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar
while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
# That loop does the following
# with any amount of dashes:
# .--. ==> .-.-.
# [--. ==> [-.-.
# .--] ==> .-.-]
# [--] ==> [-.-]
$dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal
$dirspec =~ s/^(\[|<)\./$1/;
@dirs = split /(?<!\^)\./, vmspath($dirspec);
$dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
@dirs;
}
=item catpath (override)
Construct a complete filespec.
=cut
sub catpath {
my($self,$dev,$dir,$file) = @_;
# We look for a volume in $dev, then in $dir, but not both
my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
$dev = $dir_volume unless length $dev;
$dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
if ($dev =~ m|^(?<!\^)/+([^/]+)|) { $dev = "$1:"; }
else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
if (length($dev) or length($dir)) {
$dir = "[$dir]" unless $dir =~ /(?<!\^)[\[<\/]/;
$dir = vmspath($dir);
}
$dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>');
"$dev$dir$file";
}
=item abs2rel (override)
Attempt to convert an absolute file specification to a relative specification.
=cut
sub abs2rel {
my $self = shift;
return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
if grep m{/}, @_;
my($path,$base) = @_;
$base = $self->_cwd() unless defined $base and length $base;
for ($path, $base) { $_ = $self->canonpath($_) }
# Are we even starting $path on the same (node::)device as $base? Note that
# logical paths or nodename differences may be on the "same device"
# but the comparison that ignores device differences so as to concatenate
# [---] up directory specs is not even a good idea in cases where there is
# a logical path difference between $path and $base nodename and/or device.
# Hence we fall back to returning the absolute $path spec
# if there is a case blind device (or node) difference of any sort
# and we do not even try to call $parse() or consult %ENV for $trnlnm()
# (this module needs to run on non VMS platforms after all).
my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
return $path unless lc($path_volume) eq lc($base_volume);
for ($path, $base) { $_ = $self->rel2abs($_) }
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path_directories );
my $pathchunks = @pathchunks;
unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
my @basechunks = $self->splitdir( $base_directories );
my $basechunks = @basechunks;
unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
while ( @pathchunks &&
@basechunks &&
lc( $pathchunks[0] ) eq lc( $basechunks[0] )
) {
shift @pathchunks ;
shift @basechunks ;
}
# @basechunks now contains the directories to climb out of,
# @pathchunks now has the directories to descend in to.
if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
$path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
}
else {
$path_directories = join '.', @pathchunks;
}
$path_directories = '['.$path_directories.']';
return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
}
=item rel2abs (override)
Return an absolute file specification from a relative one.
=cut
sub rel2abs {
my $self = shift ;
my ($path,$base ) = @_;
return undef unless defined $path;
if ($path =~ m/\//) {
$path = ( -d $path || $path =~ m/\/\z/ # educated guessing about
? vmspath($path) # whether it's a directory
: vmsify($path) );
}
$base = vmspath($base) if defined $base && $base =~ m/\//;
# Clean up and split up $path
if ( ! $self->file_name_is_absolute( $path ) ) {
# Figure out the effective $base and clean it up.
if ( !defined( $base ) || $base eq '' ) {
$base = $self->_cwd;
}
elsif ( ! $self->file_name_is_absolute( $base ) ) {
$base = $self->rel2abs( $base ) ;
}
else {
$base = $self->canonpath( $base ) ;
}
# Split up paths
my ( $path_directories, $path_file ) =
($self->splitpath( $path ))[1,2] ;
my ( $base_volume, $base_directories ) =
$self->splitpath( $base ) ;
$path_directories = '' if $path_directories eq '[]' ||
$path_directories eq '<>';
my $sep = '' ;
$sep = '.'
if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
$path_directories =~ m{^[^.\[<]}s
) ;
$base_directories = "$base_directories$sep$path_directories";
$base_directories =~ s{\.?[\]>][\[<]\.?}{.};
$path = $self->catpath( $base_volume, $base_directories, $path_file );
}
return $self->canonpath( $path ) ;
}
# eliminate_macros() and fixpath() are MakeMaker-specific methods
# which are used inside catfile() and catdir(). MakeMaker has its own
# copies as of 6.06_03 which are the canonical ones. We leave these
# here, in peace, so that File::Spec continues to work with MakeMakers
# prior to 6.06_03.
#
# Please consider these two methods deprecated. Do not patch them,
# patch the ones in ExtUtils::MM_VMS instead.
#
# Update: MakeMaker 6.48 is still using these routines on VMS.
# so they need to be kept up to date with ExtUtils::MM_VMS.
sub eliminate_macros {
my($self,$path) = @_;
return '' unless (defined $path) && ($path ne '');
$self = {} unless ref $self;
if ($path =~ /\s/) {
return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
}
my $npath = unixify($path);
# sometimes unixify will return a string with an off-by-one trailing null
$npath =~ s{\0$}{};
my($complex) = 0;
my($head,$macro,$tail);
# perform m##g in scalar context so it acts as an iterator
while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
if (defined $self->{$2}) {
($head,$macro,$tail) = ($1,$2,$3);
if (ref $self->{$macro}) {
if (ref $self->{$macro} eq 'ARRAY') {
$macro = join ' ', @{$self->{$macro}};
}
else {
print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
"\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
$macro = "\cB$macro\cB";
$complex = 1;
}
}
else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
$npath = "$head$macro$tail";
}
}
if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
$npath;
}
# Deprecated. See the note above for eliminate_macros().
# Catchall routine to clean up problem MM[SK]/Make macros. Expands macros
# in any directory specification, in order to avoid juxtaposing two
# VMS-syntax directories when MM[SK] is run. Also expands expressions which
# are all macro, so that we can tell how long the expansion is, and avoid
# overrunning DCL's command buffer when MM[KS] is running.
# fixpath() checks to see whether the result matches the name of a
# directory in the current default directory and returns a directory or
# file specification accordingly. C<$is_dir> can be set to true to
# force fixpath() to consider the path to be a directory or false to force
# it to be a file.
sub fixpath {
my($self,$path,$force_path) = @_;
return '' unless $path;
$self = bless {}, $self unless ref $self;
my($fixedpath,$prefix,$name);
if ($path =~ /\s/) {
return join ' ',
map { $self->fixpath($_,$force_path) }
split /\s+/, $path;
}
if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
$fixedpath = vmspath($self->eliminate_macros($path));
}
else {
$fixedpath = vmsify($self->eliminate_macros($path));
}
}
elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
my($vmspre) = $self->eliminate_macros("\$($prefix)");
# is it a dir or just a name?
$vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
$fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
$fixedpath = vmspath($fixedpath) if $force_path;
}
else {
$fixedpath = $path;
$fixedpath = vmspath($fixedpath) if $force_path;
}
# No hints, so we try to guess
if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
$fixedpath = vmspath($fixedpath) if -d $fixedpath;
}
# Trim off root dirname if it's had other dirs inserted in front of it.
$fixedpath =~ s/\.000000([\]>])/$1/;
# Special case for VMS absolute directory specs: these will have had device
# prepended during trip through Unix syntax in eliminate_macros(), since
# Unix syntax has no way to express "absolute from the top of this device's
# directory tree".
if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
$fixedpath;
}
=back
=head1 COPYRIGHT
Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 SEE ALSO
See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
implementation of these methods, not the semantics.
An explanation of VMS file specs can be found at
L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.
=cut
1;
DARWIN-2LEVEL_FILE_SPEC_VMS
$fatpacked{"darwin-2level/File/Spec/Win32.pm"} = <<'DARWIN-2LEVEL_FILE_SPEC_WIN32';
package File::Spec::Win32;
use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
$VERSION = '3.40';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
# Some regexes we use for path splitting
my $DRIVE_RX = '[a-zA-Z]:';
my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+';
my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)";
=head1 NAME
File::Spec::Win32 - methods for Win32 file specs
=head1 SYNOPSIS
require File::Spec::Win32; # Done internally by File::Spec if needed
=head1 DESCRIPTION
See File::Spec::Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
=over 4
=item devnull
Returns a string representation of the null device.
=cut
sub devnull {
return "nul";
}
sub rootdir { '\\' }
=item tmpdir
Returns a string representation of the first existing directory
from the following list:
$ENV{TMPDIR}
$ENV{TEMP}
$ENV{TMP}
SYS:/temp
C:\system\temp
C:/temp
/tmp
/
The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
for Symbian (the File::Spec::Win32 is used also for those platforms).
Since Perl 5.8.0, if running under taint mode, and if the environment
variables are tainted, they are not used.
=cut
my $tmpdir;
sub tmpdir {
return $tmpdir if defined $tmpdir;
$tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
'SYS:/temp',
'C:\system\temp',
'C:/temp',
'/tmp',
'/' );
}
=item case_tolerant
MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
indicating the case significance when comparing file specifications.
Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem.
See http://cygwin.com/ml/cygwin/2007-07/msg00891.html
Default: 1
=cut
sub case_tolerant {
eval { require Win32API::File; } or return 1;
my $drive = shift || "C:";
my $osFsType = "\0"x256;
my $osVolName = "\0"x256;
my $ouFsFlags = 0;
Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
else { return 1; }
}
=item file_name_is_absolute
As of right now, this returns 2 if the path is absolute with a
volume, 1 if it's absolute with no volume, 0 otherwise.
=cut
sub file_name_is_absolute {
my ($self,$file) = @_;
if ($file =~ m{^($VOL_RX)}o) {
my $vol = $1;
return ($vol =~ m{^$UNC_RX}o ? 2
: $file =~ m{^$DRIVE_RX[\\/]}o ? 2
: 0);
}
return $file =~ m{^[\\/]} ? 1 : 0;
}
=item catfile
Concatenate one or more directory names and a filename to form a
complete path ending with a filename
=cut
sub catfile {
shift;
# Legacy / compatibility support
#
shift, return _canon_cat( "/", @_ )
if $_[0] eq "";
# Compatibility with File::Spec <= 3.26:
# catfile('A:', 'foo') should return 'A:\foo'.
return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
if $_[0] =~ m{^$DRIVE_RX\z}o;
return _canon_cat( @_ );
}
sub catdir {
shift;
# Legacy / compatibility support
#
return ""
unless @_;
shift, return _canon_cat( "/", @_ )
if $_[0] eq "";
# Compatibility with File::Spec <= 3.26:
# catdir('A:', 'foo') should return 'A:\foo'.
return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
if $_[0] =~ m{^$DRIVE_RX\z}o;
return _canon_cat( @_ );
}
sub path {
my @path = split(';', $ENV{PATH});
s/"//g for @path;
@path = grep length, @path;
unshift(@path, ".");
return @path;
}
=item canonpath
No physical check on the filesystem, but a logical cleanup of a
path. On UNIX eliminated successive slashes and successive "/.".
On Win32 makes
dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
dir1\dir2\dir3\...\dir4 -> \dir\dir4
=cut
sub canonpath {
# Legacy / compatibility support
#
return $_[1] if !defined($_[1]) or $_[1] eq '';
return _canon_cat( $_[1] );
}
=item splitpath
($volume,$directories,$file) = File::Spec->splitpath( $path );
($volume,$directories,$file) = File::Spec->splitpath( $path,
$no_file );
Splits a path into volume, directory, and filename portions. Assumes that
the last file is a path unless the path ends in '\\', '\\.', '\\..'
or $no_file is true. On Win32 this means that $no_file true makes this return
( $volume, $path, '' ).
Separators accepted are \ and /.
Volumes can be drive letters or UNC sharenames (\\server\share).
The results can be passed to L</catpath> to get back a path equivalent to
(usually identical to) the original path.
=cut
sub splitpath {
my ($self,$path, $nofile) = @_;
my ($volume,$directory,$file) = ('','','');
if ( $nofile ) {
$path =~
m{^ ( $VOL_RX ? ) (.*) }sox;
$volume = $1;
$directory = $2;
}
else {
$path =~
m{^ ( $VOL_RX ? )
( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
(.*)
}sox;
$volume = $1;
$directory = $2;
$file = $3;
}
return ($volume,$directory,$file);
}
=item splitdir
The opposite of L<catdir()|File::Spec/catdir>.
@dirs = File::Spec->splitdir( $directories );
$directories must be only the directory portion of the path on systems
that have the concept of a volume or that have path syntax that differentiates
files from directories.
Unlike just splitting the directories on the separator, leading empty and
trailing directory entries can be returned, because these are significant
on some OSs. So,
File::Spec->splitdir( "/a/b/c" );
Yields:
( '', 'a', 'b', '', 'c', '' )
=cut
sub splitdir {
my ($self,$directories) = @_ ;
#
# split() likes to forget about trailing null fields, so here we
# check to be sure that there will not be any before handling the
# simple case.
#
if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
return split( m|[\\/]|, $directories );
}
else {
#
# since there was a trailing separator, add a file name to the end,
# then do the split, then replace it with ''.
#
my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
$directories[ $#directories ]= '' ;
return @directories ;
}
}
=item catpath
Takes volume, directory and file portions and returns an entire path. Under
Unix, $volume is ignored, and this is just like catfile(). On other OSs,
the $volume become significant.
=cut
sub catpath {
my ($self,$volume,$directory,$file) = @_;
# If it's UNC, make sure the glue separator is there, reusing
# whatever separator is first in the $volume
my $v;
$volume .= $v
if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
$directory =~ m@^[^\\/]@s
) ;
$volume .= $directory ;
# If the volume is not just A:, make sure the glue separator is
# there, reusing whatever separator is first in the $volume if possible.
if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
$volume =~ m@[^\\/]\Z(?!\n)@ &&
$file =~ m@[^\\/]@
) {
$volume =~ m@([\\/])@ ;
my $sep = $1 ? $1 : '\\' ;
$volume .= $sep ;
}
$volume .= $file ;
return $volume ;
}
sub _same {
lc($_[1]) eq lc($_[2]);
}
sub rel2abs {
my ($self,$path,$base ) = @_;
my $is_abs = $self->file_name_is_absolute($path);
# Check for volume (should probably document the '2' thing...)
return $self->canonpath( $path ) if $is_abs == 2;
if ($is_abs) {
# It's missing a volume, add one
my $vol = ($self->splitpath( $self->_cwd() ))[0];
return $self->canonpath( $vol . $path );
}
if ( !defined( $base ) || $base eq '' ) {
require Cwd ;
$base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
$base = $self->_cwd() unless defined $base ;
}
elsif ( ! $self->file_name_is_absolute( $base ) ) {
$base = $self->rel2abs( $base ) ;
}
else {
$base = $self->canonpath( $base ) ;
}
my ( $path_directories, $path_file ) =
($self->splitpath( $path, 1 ))[1,2] ;
my ( $base_volume, $base_directories ) =
$self->splitpath( $base, 1 ) ;
$path = $self->catpath(
$base_volume,
$self->catdir( $base_directories, $path_directories ),
$path_file
) ;
return $self->canonpath( $path ) ;
}
=back
=head2 Note For File::Spec::Win32 Maintainers
Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
=head1 COPYRIGHT
Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 SEE ALSO
See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
implementation of these methods, not the semantics.
=cut
sub _canon_cat # @path -> path
{
my ($first, @rest) = @_;
my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter
? ucfirst( $1 ).( $2 ? "\\" : "" )
: $first =~ s{ \A (?:\\\\|//) ([^\\/]+)
(?: [\\/] ([^\\/]+) )?
[\\/]? }{}xs # UNC volume
? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\"
: $first =~ s{ \A [\\/] }{}x # root dir
? "\\"
: "";
my $path = join "\\", $first, @rest;
$path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy
# xx/././yy --> xx/yy
$path =~ s{(?:
(?:\A|\\) # at begin or after a slash
\.
(?:\\\.)* # and more
(?:\\|\z) # at end or followed by slash
)+ # performance boost -- I do not know why
}{\\}gx;
# XXX I do not know whether more dots are supported by the OS supporting
# this ... annotation (NetWare or symbian but not MSWin32).
# Then .... could easily become ../../.. etc:
# Replace \.\.\. by (\.\.\.+) and substitute with
# { $1 . ".." . "\\.." x (length($2)-2) }gex
# ... --> ../..
$path =~ s{ (\A|\\) # at begin or after a slash
\.\.\.
(?=\\|\z) # at end or followed by slash
}{$1..\\..}gx;
# xx\yy\..\zz --> xx\zz
while ( $path =~ s{(?:
(?:\A|\\) # at begin or after a slash
[^\\]+ # rip this 'yy' off
\\\.\.
(?<!\A\.\.\\\.\.) # do *not* replace ^..\..
(?<!\\\.\.\\\.\.) # do *not* replace \..\..
(?:\\|\z) # at end or followed by slash
)+ # performance boost -- I do not know why
}{\\}sx ) {}
$path =~ s#\A\\##; # \xx --> xx NOTE: this is *not* root
$path =~ s#\\\z##; # xx\ --> xx
if ( $volume =~ m#\\\z# )
{ # <vol>\.. --> <vol>\
$path =~ s{ \A # at begin
\.\.
(?:\\\.\.)* # and more
(?:\\|\z) # at end or followed by slash
}{}x;
return $1 # \\HOST\SHARE\ --> \\HOST\SHARE
if $path eq ""
and $volume =~ m#\A(\\\\.*)\\\z#s;
}
return $path ne "" || $volume ? $volume.$path : ".";
}
1;
DARWIN-2LEVEL_FILE_SPEC_WIN32
$fatpacked{"darwin-2level/List/Util.pm"} = <<'DARWIN-2LEVEL_LIST_UTIL';
# List::Util.pm
#
# Copyright (c) 1997-2009 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# This module is normally only loaded if the XS module is not available
package List::Util;
use strict;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(first min max minstr maxstr reduce sum sum0 shuffle);
our $VERSION = "1.27";
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
require XSLoader;
XSLoader::load('List::Util', $XS_VERSION);
sub sum0
{
return 0 unless @_;
goto ∑
}
1;
__END__
=head1 NAME
List::Util - A selection of general-utility list subroutines
=head1 SYNOPSIS
use List::Util qw(first max maxstr min minstr reduce shuffle sum);
=head1 DESCRIPTION
C<List::Util> contains a selection of subroutines that people have
expressed would be nice to have in the perl core, but the usage would
not really be high enough to warrant the use of a keyword, and the size
so small such that being individual extensions would be wasteful.
By default C<List::Util> does not export any subroutines. The
subroutines defined are
=over 4
=item first BLOCK LIST
Similar to C<grep> in that it evaluates BLOCK setting C<$_> to each element
of LIST in turn. C<first> returns the first element where the result from
BLOCK is a true value. If BLOCK never returns true or LIST was empty then
C<undef> is returned.
$foo = first { defined($_) } @list # first defined value in @list
$foo = first { $_ > $value } @list # first value in @list which
# is greater than $value
This function could be implemented using C<reduce> like this
$foo = reduce { defined($a) ? $a : wanted($b) ? $b : undef } undef, @list
for example wanted() could be defined() which would return the first
defined value in @list
=item max LIST
Returns the entry in the list with the highest numerical value. If the
list is empty then C<undef> is returned.
$foo = max 1..10 # 10
$foo = max 3,9,12 # 12
$foo = max @bar, @baz # whatever
This function could be implemented using C<reduce> like this
$foo = reduce { $a > $b ? $a : $b } 1..10
=item maxstr LIST
Similar to C<max>, but treats all the entries in the list as strings
and returns the highest string as defined by the C<gt> operator.
If the list is empty then C<undef> is returned.
$foo = maxstr 'A'..'Z' # 'Z'
$foo = maxstr "hello","world" # "world"
$foo = maxstr @bar, @baz # whatever
This function could be implemented using C<reduce> like this
$foo = reduce { $a gt $b ? $a : $b } 'A'..'Z'
=item min LIST
Similar to C<max> but returns the entry in the list with the lowest
numerical value. If the list is empty then C<undef> is returned.
$foo = min 1..10 # 1
$foo = min 3,9,12 # 3
$foo = min @bar, @baz # whatever
This function could be implemented using C<reduce> like this
$foo = reduce { $a < $b ? $a : $b } 1..10
=item minstr LIST
Similar to C<min>, but treats all the entries in the list as strings
and returns the lowest string as defined by the C<lt> operator.
If the list is empty then C<undef> is returned.
$foo = minstr 'A'..'Z' # 'A'
$foo = minstr "hello","world" # "hello"
$foo = minstr @bar, @baz # whatever
This function could be implemented using C<reduce> like this
$foo = reduce { $a lt $b ? $a : $b } 'A'..'Z'
=item reduce BLOCK LIST
Reduces LIST by calling BLOCK, in a scalar context, multiple times,
setting C<$a> and C<$b> each time. The first call will be with C<$a>
and C<$b> set to the first two elements of the list, subsequent
calls will be done by setting C<$a> to the result of the previous
call and C<$b> to the next element in the list.
Returns the result of the last call to BLOCK. If LIST is empty then
C<undef> is returned. If LIST only contains one element then that
element is returned and BLOCK is not executed.
$foo = reduce { $a < $b ? $a : $b } 1..10 # min
$foo = reduce { $a lt $b ? $a : $b } 'aa'..'zz' # minstr
$foo = reduce { $a + $b } 1 .. 10 # sum
$foo = reduce { $a . $b } @bar # concat
If your algorithm requires that C<reduce> produce an identity value, then
make sure that you always pass that identity value as the first argument to prevent
C<undef> being returned
$foo = reduce { $a + $b } 0, @values; # sum with 0 identity value
=item shuffle LIST
Returns the elements of LIST in a random order
@cards = shuffle 0..51 # 0..51 in a random order
=item sum LIST
Returns the sum of all the elements in LIST. If LIST is empty then
C<undef> is returned.
$foo = sum 1..10 # 55
$foo = sum 3,9,12 # 24
$foo = sum @bar, @baz # whatever
This function could be implemented using C<reduce> like this
$foo = reduce { $a + $b } 1..10
If your algorithm requires that C<sum> produce an identity of 0, then
make sure that you always pass C<0> as the first argument to prevent
C<undef> being returned
$foo = sum 0, @values;
=item sum0 LIST
Similar to C<sum>, except this returns 0 when given an empty list, rather
than C<undef>.
=back
=head1 KNOWN BUGS
With perl versions prior to 5.005 there are some cases where reduce
will return an incorrect result. This will show up as test 7 of
reduce.t failing.
=head1 SUGGESTED ADDITIONS
The following are additions that have been requested, but I have been reluctant
to add due to them being very simple to implement in perl
# One argument is true
sub any { $_ && return 1 for @_; 0 }
# All arguments are true
sub all { $_ || return 0 for @_; 1 }
# All arguments are false
sub none { $_ && return 0 for @_; 1 }
# One argument is false
sub notall { $_ || return 1 for @_; 0 }
# How many elements are true
sub true { scalar grep { $_ } @_ }
# How many elements are false
sub false { scalar grep { !$_ } @_ }
=head1 SEE ALSO
L<Scalar::Util>, L<List::MoreUtils>
=head1 COPYRIGHT
Copyright (c) 1997-2007 Graham Barr <gbarr@pobox.com>. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
DARWIN-2LEVEL_LIST_UTIL
$fatpacked{"darwin-2level/List/Util/XS.pm"} = <<'DARWIN-2LEVEL_LIST_UTIL_XS';
package List::Util::XS;
use strict;
use List::Util;
our $VERSION = "1.27"; # FIXUP
$VERSION = eval $VERSION; # FIXUP
1;
__END__
=head1 NAME
List::Util::XS - Indicate if List::Util was compiled with a C compiler
=head1 SYNOPSIS
use List::Util::XS 1.20;
=head1 DESCRIPTION
C<List::Util::XS> can be used as a dependency to ensure List::Util was
installed using a C compiler and that the XS version is installed.
During installation C<$List::Util::XS::VERSION> will be set to
C<undef> if the XS was not compiled.
Starting with release 1.23_03, Scalar-List-Util is B<always> using
the XS implementation, but for backwards compatibility, we still
ship the C<List::Util::XS> module which just loads C<List::Util>.
=head1 SEE ALSO
L<Scalar::Util>, L<List::Util>, L<List::MoreUtils>
=head1 COPYRIGHT
Copyright (c) 2008 Graham Barr <gbarr@pobox.com>. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
DARWIN-2LEVEL_LIST_UTIL_XS
$fatpacked{"darwin-2level/Scalar/Util.pm"} = <<'DARWIN-2LEVEL_SCALAR_UTIL';
# Scalar::Util.pm
#
# Copyright (c) 1997-2007 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Scalar::Util;
use strict;
require Exporter;
require List::Util; # List::Util loads the XS
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
blessed
dualvar
isdual
isvstring
isweak
looks_like_number
openhandle
readonly
refaddr
reftype
set_prototype
tainted
weaken
);
our $VERSION = "1.27";
$VERSION = eval $VERSION;
our @EXPORT_FAIL;
unless (defined &weaken) {
push @EXPORT_FAIL, qw(weaken);
}
unless (defined &isweak) {
push @EXPORT_FAIL, qw(isweak isvstring);
}
unless (defined &isvstring) {
push @EXPORT_FAIL, qw(isvstring);
}
sub export_fail {
if (grep { /^(?:weaken|isweak)$/ } @_ ) {
require Carp;
Carp::croak("Weak references are not implemented in the version of perl");
}
if (grep { /^isvstring$/ } @_ ) {
require Carp;
Carp::croak("Vstrings are not implemented in the version of perl");
}
@_;
}
1;
__END__
=head1 NAME
Scalar::Util - A selection of general-utility scalar subroutines
=head1 SYNOPSIS
use Scalar::Util qw(blessed dualvar isdual readonly refaddr reftype
tainted weaken isweak isvstring looks_like_number
set_prototype);
# and other useful utils appearing below
=head1 DESCRIPTION
C<Scalar::Util> contains a selection of subroutines that people have
expressed would be nice to have in the perl core, but the usage would
not really be high enough to warrant the use of a keyword, and the size
so small such that being individual extensions would be wasteful.
By default C<Scalar::Util> does not export any subroutines. The
subroutines defined are
=over 4
=item blessed EXPR
If EXPR evaluates to a blessed reference the name of the package
that it is blessed into is returned. Otherwise C<undef> is returned.
$scalar = "foo";
$class = blessed $scalar; # undef
$ref = [];
$class = blessed $ref; # undef
$obj = bless [], "Foo";
$class = blessed $obj; # "Foo"
=item dualvar NUM, STRING
Returns a scalar that has the value NUM in a numeric context and the
value STRING in a string context.
$foo = dualvar 10, "Hello";
$num = $foo + 2; # 12
$str = $foo . " world"; # Hello world
=item isdual EXPR
If EXPR is a scalar that is a dualvar, the result is true.
$foo = dualvar 86, "Nix";
$dual = isdual($foo); # true
Note that a scalar can be made to have both string and numeric content
through numeric operations:
$foo = "10";
$dual = isdual($foo); # false
$bar = $foo + 0;
$dual = isdual($foo); # true
Note that although C<$!> appears to be dual-valued variable, it is
actually implemented using a tied scalar:
$! = 1;
print("$!\n"); # "Operation not permitted"
$dual = isdual($!); # false
You can capture its numeric and string content using:
$err = dualvar $!, $!;
$dual = isdual($err); # true
=item isvstring EXPR
If EXPR is a scalar which was coded as a vstring the result is true.
$vs = v49.46.48;
$fmt = isvstring($vs) ? "%vd" : "%s"; #true
printf($fmt,$vs);
=item looks_like_number EXPR
Returns true if perl thinks EXPR is a number. See
L<perlapi/looks_like_number>.
=item openhandle FH
Returns FH if FH may be used as a filehandle and is open, or FH is a tied
handle. Otherwise C<undef> is returned.
$fh = openhandle(*STDIN); # \*STDIN
$fh = openhandle(\*STDIN); # \*STDIN
$fh = openhandle(*NOTOPEN); # undef
$fh = openhandle("scalar"); # undef
=item readonly SCALAR
Returns true if SCALAR is readonly.
sub foo { readonly($_[0]) }
$readonly = foo($bar); # false
$readonly = foo(0); # true
=item refaddr EXPR
If EXPR evaluates to a reference the internal memory address of
the referenced value is returned. Otherwise C<undef> is returned.
$addr = refaddr "string"; # undef
$addr = refaddr \$var; # eg 12345678
$addr = refaddr []; # eg 23456784
$obj = bless {}, "Foo";
$addr = refaddr $obj; # eg 88123488
=item reftype EXPR
If EXPR evaluates to a reference the type of the variable referenced
is returned. Otherwise C<undef> is returned.
$type = reftype "string"; # undef
$type = reftype \$var; # SCALAR
$type = reftype []; # ARRAY
$obj = bless {}, "Foo";
$type = reftype $obj; # HASH
=item set_prototype CODEREF, PROTOTYPE
Sets the prototype of the given function, or deletes it if PROTOTYPE is
undef. Returns the CODEREF.
set_prototype \&foo, '$$';
=item tainted EXPR
Return true if the result of EXPR is tainted
$taint = tainted("constant"); # false
$taint = tainted($ENV{PWD}); # true if running under -T
=item weaken REF
REF will be turned into a weak reference. This means that it will not
hold a reference count on the object it references. Also when the reference
count on that object reaches zero, REF will be set to undef.
This is useful for keeping copies of references , but you don't want to
prevent the object being DESTROY-ed at its usual time.
{
my $var;
$ref = \$var;
weaken($ref); # Make $ref a weak reference
}
# $ref is now undef
Note that if you take a copy of a scalar with a weakened reference,
the copy will be a strong reference.
my $var;
my $foo = \$var;
weaken($foo); # Make $foo a weak reference
my $bar = $foo; # $bar is now a strong reference
This may be less obvious in other situations, such as C<grep()>, for instance
when grepping through a list of weakened references to objects that may have
been destroyed already:
@object = grep { defined } @object;
This will indeed remove all references to destroyed objects, but the remaining
references to objects will be strong, causing the remaining objects to never
be destroyed because there is now always a strong reference to them in the
@object array.
=item isweak EXPR
If EXPR is a scalar which is a weak reference the result is true.
$ref = \$foo;
$weak = isweak($ref); # false
weaken($ref);
$weak = isweak($ref); # true
B<NOTE>: Copying a weak reference creates a normal, strong, reference.
$copy = $ref;
$weak = isweak($copy); # false
=back
=head1 DIAGNOSTICS
Module use may give one of the following errors during import.
=over
=item Weak references are not implemented in the version of perl
The version of perl that you are using does not implement weak references, to use
C<isweak> or C<weaken> you will need to use a newer release of perl.
=item Vstrings are not implemented in the version of perl
The version of perl that you are using does not implement Vstrings, to use
C<isvstring> you will need to use a newer release of perl.
=item C<NAME> is only available with the XS version of Scalar::Util
C<Scalar::Util> contains both perl and C implementations of many of its functions
so that those without access to a C compiler may still use it. However some of the functions
are only available when a C compiler was available to compile the XS version of the extension.
At present that list is: weaken, isweak, dualvar, isvstring, set_prototype
=back
=head1 KNOWN BUGS
There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will
show up as tests 8 and 9 of dualvar.t failing
=head1 SEE ALSO
L<List::Util>
=head1 COPYRIGHT
Copyright (c) 1997-2007 Graham Barr <gbarr@pobox.com>. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
Except weaken and isweak which are
Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as perl itself.
=cut
DARWIN-2LEVEL_SCALAR_UTIL
$fatpacked{"darwin-2level/Socket.pm"} = <<'DARWIN-2LEVEL_SOCKET';
package Socket;
use strict;
{ use 5.006001; }
our $VERSION = '2.009';
=head1 NAME
C<Socket> - networking constants and support functions
=head1 SYNOPSIS
C<Socket> a low-level module used by, among other things, the L<IO::Socket>
family of modules. The following examples demonstrate some low-level uses but
a practical program would likely use the higher-level API provided by
C<IO::Socket> or similar instead.
use Socket qw(PF_INET SOCK_STREAM pack_sockaddr_in inet_aton);
socket(my $socket, PF_INET, SOCK_STREAM, 0)
or die "socket: $!";
my $port = getservbyname "echo", "tcp";
connect($socket, pack_sockaddr_in($port, inet_aton("localhost")))
or die "connect: $!";
print $socket "Hello, world!\n";
print <$socket>;
See also the L</EXAMPLES> section.
=head1 DESCRIPTION
This module provides a variety of constants, structure manipulators and other
functions related to socket-based networking. The values and functions
provided are useful when used in conjunction with Perl core functions such as
socket(), setsockopt() and bind(). It also provides several other support
functions, mostly for dealing with conversions of network addresses between
human-readable and native binary forms, and for hostname resolver operations.
Some constants and functions are exported by default by this module; but for
backward-compatibility any recently-added symbols are not exported by default
and must be requested explicitly. When an import list is provided to the
C<use Socket> line, the default exports are not automatically imported. It is
therefore best practice to always to explicitly list all the symbols required.
Also, some common socket "newline" constants are provided: the constants
C<CR>, C<LF>, and C<CRLF>, as well as C<$CR>, C<$LF>, and C<$CRLF>, which map
to C<\015>, C<\012>, and C<\015\012>. If you do not want to use the literal
characters in your programs, then use the constants provided here. They are
not exported by default, but can be imported individually, and with the
C<:crlf> export tag:
use Socket qw(:DEFAULT :crlf);
$sock->print("GET / HTTP/1.0$CRLF");
The entire getaddrinfo() subsystem can be exported using the tag C<:addrinfo>;
this exports the getaddrinfo() and getnameinfo() functions, and all the
C<AI_*>, C<NI_*>, C<NIx_*> and C<EAI_*> constants.
=cut
=head1 CONSTANTS
In each of the following groups, there may be many more constants provided
than just the ones given as examples in the section heading. If the heading
ends C<...> then this means there are likely more; the exact constants
provided will depend on the OS and headers found at compile-time.
=cut
=head2 PF_INET, PF_INET6, PF_UNIX, ...
Protocol family constants to use as the first argument to socket() or the
value of the C<SO_DOMAIN> or C<SO_FAMILY> socket option.
=head2 AF_INET, AF_INET6, AF_UNIX, ...
Address family constants used by the socket address structures, to pass to
such functions as inet_pton() or getaddrinfo(), or are returned by such
functions as sockaddr_family().
=head2 SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, ...
Socket type constants to use as the second argument to socket(), or the value
of the C<SO_TYPE> socket option.
=head2 SOCK_NONBLOCK. SOCK_CLOEXEC
Linux-specific shortcuts to specify the C<O_NONBLOCK> and C<FD_CLOEXEC> flags
during a C<socket(2)> call.
socket( my $sockh, PF_INET, SOCK_DGRAM|SOCK_NONBLOCK, 0 )
=head2 SOL_SOCKET
Socket option level constant for setsockopt() and getsockopt().
=head2 SO_ACCEPTCONN, SO_BROADCAST, SO_ERROR, ...
Socket option name constants for setsockopt() and getsockopt() at the
C<SOL_SOCKET> level.
=head2 IP_OPTIONS, IP_TOS, IP_TTL, ...
Socket option name constants for IPv4 socket options at the C<IPPROTO_IP>
level.
=head2 MSG_BCAST, MSG_OOB, MSG_TRUNC, ...
Message flag constants for send() and recv().
=head2 SHUT_RD, SHUT_RDWR, SHUT_WR
Direction constants for shutdown().
=head2 INADDR_ANY, INADDR_BROADCAST, INADDR_LOOPBACK, INADDR_NONE
Constants giving the special C<AF_INET> addresses for wildcard, broadcast,
local loopback, and invalid addresses.
Normally equivalent to inet_aton('0.0.0.0'), inet_aton('255.255.255.255'),
inet_aton('localhost') and inet_aton('255.255.255.255') respectively.
=head2 IPPROTO_IP, IPPROTO_IPV6, IPPROTO_TCP, ...
IP protocol constants to use as the third argument to socket(), the level
argument to getsockopt() or setsockopt(), or the value of the C<SO_PROTOCOL>
socket option.
=head2 TCP_CORK, TCP_KEEPALIVE, TCP_NODELAY, ...
Socket option name constants for TCP socket options at the C<IPPROTO_TCP>
level.
=head2 IN6ADDR_ANY, IN6ADDR_LOOPBACK
Constants giving the special C<AF_INET6> addresses for wildcard and local
loopback.
Normally equivalent to inet_pton(AF_INET6, "::") and
inet_pton(AF_INET6, "::1") respectively.
=head2 IPV6_ADD_MEMBERSHIP, IPV6_MTU, IPV6_V6ONLY, ...
Socket option name constants for IPv6 socket options at the C<IPPROTO_IPV6>
level.
=cut
# Still undocumented: SCM_*, SOMAXCONN, IOV_MAX, UIO_MAXIOV
=head1 STRUCTURE MANIPULATORS
The following functions convert between lists of Perl values and packed binary
strings representing structures.
=cut
=head2 $family = sockaddr_family $sockaddr
Takes a packed socket address (as returned by pack_sockaddr_in(),
pack_sockaddr_un() or the perl builtin functions getsockname() and
getpeername()). Returns the address family tag. This will be one of the
C<AF_*> constants, such as C<AF_INET> for a C<sockaddr_in> addresses or
C<AF_UNIX> for a C<sockaddr_un>. It can be used to figure out what unpack to
use for a sockaddr of unknown type.
=head2 $sockaddr = pack_sockaddr_in $port, $ip_address
Takes two arguments, a port number and an opaque string (as returned by
inet_aton(), or a v-string). Returns the C<sockaddr_in> structure with those
arguments packed in and C<AF_INET> filled in. For Internet domain sockets,
this structure is normally what you need for the arguments in bind(),
connect(), and send().
=head2 ($port, $ip_address) = unpack_sockaddr_in $sockaddr
Takes a C<sockaddr_in> structure (as returned by pack_sockaddr_in(),
getpeername() or recv()). Returns a list of two elements: the port and an
opaque string representing the IP address (you can use inet_ntoa() to convert
the address to the four-dotted numeric format). Will croak if the structure
does not represent an C<AF_INET> address.
In scalar context will return just the IP address.
=head2 $sockaddr = sockaddr_in $port, $ip_address
=head2 ($port, $ip_address) = sockaddr_in $sockaddr
A wrapper of pack_sockaddr_in() or unpack_sockaddr_in(). In list context,
unpacks its argument and returns a list consisting of the port and IP address.
In scalar context, packs its port and IP address arguments as a C<sockaddr_in>
and returns it.
Provided largely for legacy compatibility; it is better to use
pack_sockaddr_in() or unpack_sockaddr_in() explicitly.
=head2 $sockaddr = pack_sockaddr_in6 $port, $ip6_address, [$scope_id, [$flowinfo]]
Takes two to four arguments, a port number, an opaque string (as returned by
inet_pton()), optionally a scope ID number, and optionally a flow label
number. Returns the C<sockaddr_in6> structure with those arguments packed in
and C<AF_INET6> filled in. IPv6 equivalent of pack_sockaddr_in().
=head2 ($port, $ip6_address, $scope_id, $flowinfo) = unpack_sockaddr_in6 $sockaddr
Takes a C<sockaddr_in6> structure. Returns a list of four elements: the port
number, an opaque string representing the IPv6 address, the scope ID, and the
flow label. (You can use inet_ntop() to convert the address to the usual
string format). Will croak if the structure does not represent an C<AF_INET6>
address.
In scalar context will return just the IP address.
=head2 $sockaddr = sockaddr_in6 $port, $ip6_address, [$scope_id, [$flowinfo]]
=head2 ($port, $ip6_address, $scope_id, $flowinfo) = sockaddr_in6 $sockaddr
A wrapper of pack_sockaddr_in6() or unpack_sockaddr_in6(). In list context,
unpacks its argument according to unpack_sockaddr_in6(). In scalar context,
packs its arguments according to pack_sockaddr_in6().
Provided largely for legacy compatibility; it is better to use
pack_sockaddr_in6() or unpack_sockaddr_in6() explicitly.
=head2 $sockaddr = pack_sockaddr_un $path
Takes one argument, a pathname. Returns the C<sockaddr_un> structure with that
path packed in with C<AF_UNIX> filled in. For C<PF_UNIX> sockets, this
structure is normally what you need for the arguments in bind(), connect(),
and send().
=head2 ($path) = unpack_sockaddr_un $sockaddr
Takes a C<sockaddr_un> structure (as returned by pack_sockaddr_un(),
getpeername() or recv()). Returns a list of one element: the pathname. Will
croak if the structure does not represent an C<AF_UNIX> address.
=head2 $sockaddr = sockaddr_un $path
=head2 ($path) = sockaddr_un $sockaddr
A wrapper of pack_sockaddr_un() or unpack_sockaddr_un(). In a list context,
unpacks its argument and returns a list consisting of the pathname. In a
scalar context, packs its pathname as a C<sockaddr_un> and returns it.
Provided largely for legacy compatibility; it is better to use
pack_sockaddr_un() or unpack_sockaddr_un() explicitly.
These are only supported if your system has E<lt>F<sys/un.h>E<gt>.
=head2 $ip_mreq = pack_ip_mreq $multiaddr, $interface
Takes an IPv4 multicast address and optionally an interface address (or
C<INADDR_ANY>). Returns the C<ip_mreq> structure with those arguments packed
in. Suitable for use with the C<IP_ADD_MEMBERSHIP> and C<IP_DROP_MEMBERSHIP>
sockopts.
=head2 ($multiaddr, $interface) = unpack_ip_mreq $ip_mreq
Takes an C<ip_mreq> structure. Returns a list of two elements; the IPv4
multicast address and interface address.
=head2 $ip_mreq_source = pack_ip_mreq_source $multiaddr, $source, $interface
Takes an IPv4 multicast address, source address, and optionally an interface
address (or C<INADDR_ANY>). Returns the C<ip_mreq_source> structure with those
arguments packed in. Suitable for use with the C<IP_ADD_SOURCE_MEMBERSHIP>
and C<IP_DROP_SOURCE_MEMBERSHIP> sockopts.
=head2 ($multiaddr, $source, $interface) = unpack_ip_mreq_source $ip_mreq
Takes an C<ip_mreq_source> structure. Returns a list of three elements; the
IPv4 multicast address, source address and interface address.
=head2 $ipv6_mreq = pack_ipv6_mreq $multiaddr6, $ifindex
Takes an IPv6 multicast address and an interface number. Returns the
C<ipv6_mreq> structure with those arguments packed in. Suitable for use with
the C<IPV6_ADD_MEMBERSHIP> and C<IPV6_DROP_MEMBERSHIP> sockopts.
=head2 ($multiaddr6, $ifindex) = unpack_ipv6_mreq $ipv6_mreq
Takes an C<ipv6_mreq> structure. Returns a list of two elements; the IPv6
address and an interface number.
=cut
=head1 FUNCTIONS
=cut
=head2 $ip_address = inet_aton $string
Takes a string giving the name of a host, or a textual representation of an IP
address and translates that to an packed binary address structure suitable to
pass to pack_sockaddr_in(). If passed a hostname that cannot be resolved,
returns C<undef>. For multi-homed hosts (hosts with more than one address),
the first address found is returned.
For portability do not assume that the result of inet_aton() is 32 bits wide,
in other words, that it would contain only the IPv4 address in network order.
This IPv4-only function is provided largely for legacy reasons. Newly-written
code should use getaddrinfo() or inet_pton() instead for IPv6 support.
=head2 $string = inet_ntoa $ip_address
Takes a packed binary address structure such as returned by
unpack_sockaddr_in() (or a v-string representing the four octets of the IPv4
address in network order) and translates it into a string of the form
C<d.d.d.d> where the C<d>s are numbers less than 256 (the normal
human-readable four dotted number notation for Internet addresses).
This IPv4-only function is provided largely for legacy reasons. Newly-written
code should use getnameinfo() or inet_ntop() instead for IPv6 support.
=head2 $address = inet_pton $family, $string
Takes an address family (such as C<AF_INET> or C<AF_INET6>) and a string
containing a textual representation of an address in that family and
translates that to an packed binary address structure.
See also getaddrinfo() for a more powerful and flexible function to look up
socket addresses given hostnames or textual addresses.
=head2 $string = inet_ntop $family, $address
Takes an address family and a packed binary address structure and translates
it into a human-readable textual representation of the address; typically in
C<d.d.d.d> form for C<AF_INET> or C<hhhh:hhhh::hhhh> form for C<AF_INET6>.
See also getnameinfo() for a more powerful and flexible function to turn
socket addresses into human-readable textual representations.
=head2 ($err, @result) = getaddrinfo $host, $service, [$hints]
Given both a hostname and service name, this function attempts to resolve the
host name into a list of network addresses, and the service name into a
protocol and port number, and then returns a list of address structures
suitable to connect() to it.
Given just a host name, this function attempts to resolve it to a list of
network addresses, and then returns a list of address structures giving these
addresses.
Given just a service name, this function attempts to resolve it to a protocol
and port number, and then returns a list of address structures that represent
it suitable to bind() to. This use should be combined with the C<AI_PASSIVE>
flag; see below.
Given neither name, it generates an error.
If present, $hints should be a reference to a hash, where the following keys
are recognised:
=over 4
=item flags => INT
A bitfield containing C<AI_*> constants; see below.
=item family => INT
Restrict to only generating addresses in this address family
=item socktype => INT
Restrict to only generating addresses of this socket type
=item protocol => INT
Restrict to only generating addresses for this protocol
=back
The return value will be a list; the first value being an error indication,
followed by a list of address structures (if no error occurred).
The error value will be a dualvar; comparable to the C<EI_*> error constants,
or printable as a human-readable error message string. If no error occurred it
will be zero numerically and an empty string.
Each value in the results list will be a hash reference containing the following
fields:
=over 4
=item family => INT
The address family (e.g. C<AF_INET>)
=item socktype => INT
The socket type (e.g. C<SOCK_STREAM>)
=item protocol => INT
The protocol (e.g. C<IPPROTO_TCP>)
=item addr => STRING
The address in a packed string (such as would be returned by
pack_sockaddr_in())
=item canonname => STRING
The canonical name for the host if the C<AI_CANONNAME> flag was provided, or
C<undef> otherwise. This field will only be present on the first returned
address.
=back
The following flag constants are recognised in the $hints hash. Other flag
constants may exist as provided by the OS.
=over 4
=item AI_PASSIVE
Indicates that this resolution is for a local bind() for a passive (i.e.
listening) socket, rather than an active (i.e. connecting) socket.
=item AI_CANONNAME
Indicates that the caller wishes the canonical hostname (C<canonname>) field
of the result to be filled in.
=item AI_NUMERICHOST
Indicates that the caller will pass a numeric address, rather than a hostname,
and that getaddrinfo() must not perform a resolve operation on this name. This
flag will prevent a possibly-slow network lookup operation, and instead return
an error if a hostname is passed.
=back
=head2 ($err, $hostname, $servicename) = getnameinfo $sockaddr, [$flags, [$xflags]]
Given a packed socket address (such as from getsockname(), getpeername(), or
returned by getaddrinfo() in a C<addr> field), returns the hostname and
symbolic service name it represents. $flags may be a bitmask of C<NI_*>
constants, or defaults to 0 if unspecified.
The return value will be a list; the first value being an error condition,
followed by the hostname and service name.
The error value will be a dualvar; comparable to the C<EI_*> error constants,
or printable as a human-readable error message string. The host and service
names will be plain strings.
The following flag constants are recognised as $flags. Other flag constants may
exist as provided by the OS.
=over 4
=item NI_NUMERICHOST
Requests that a human-readable string representation of the numeric address be
returned directly, rather than performing a name resolve operation that may
convert it into a hostname. This will also avoid potentially-blocking network
IO.
=item NI_NUMERICSERV
Requests that the port number be returned directly as a number representation
rather than performing a name resolve operation that may convert it into a
service name.
=item NI_NAMEREQD
If a name resolve operation fails to provide a name, then this flag will cause
getnameinfo() to indicate an error, rather than returning the numeric
representation as a human-readable string.
=item NI_DGRAM
Indicates that the socket address relates to a C<SOCK_DGRAM> socket, for the
services whose name differs between TCP and UDP protocols.
=back
The following constants may be supplied as $xflags.
=over 4
=item NIx_NOHOST
Indicates that the caller is not interested in the hostname of the result, so
it does not have to be converted. C<undef> will be returned as the hostname.
=item NIx_NOSERV
Indicates that the caller is not interested in the service name of the result,
so it does not have to be converted. C<undef> will be returned as the service
name.
=back
=head1 getaddrinfo() / getnameinfo() ERROR CONSTANTS
The following constants may be returned by getaddrinfo() or getnameinfo().
Others may be provided by the OS.
=over 4
=item EAI_AGAIN
A temporary failure occurred during name resolution. The operation may be
successful if it is retried later.
=item EAI_BADFLAGS
The value of the C<flags> hint to getaddrinfo(), or the $flags parameter to
getnameinfo() contains unrecognised flags.
=item EAI_FAMILY
The C<family> hint to getaddrinfo(), or the family of the socket address
passed to getnameinfo() is not supported.
=item EAI_NODATA
The host name supplied to getaddrinfo() did not provide any usable address
data.
=item EAI_NONAME
The host name supplied to getaddrinfo() does not exist, or the address
supplied to getnameinfo() is not associated with a host name and the
C<NI_NAMEREQD> flag was supplied.
=item EAI_SERVICE
The service name supplied to getaddrinfo() is not available for the socket
type given in the $hints.
=back
=cut
=head1 EXAMPLES
=head2 Lookup for connect()
The getaddrinfo() function converts a hostname and a service name into a list
of structures, each containing a potential way to connect() to the named
service on the named host.
use IO::Socket;
use Socket qw(SOCK_STREAM getaddrinfo);
my %hints = (socktype => SOCK_STREAM);
my ($err, @res) = getaddrinfo("localhost", "echo", \%hints);
die "Cannot getaddrinfo - $err" if $err;
my $sock;
foreach my $ai (@res) {
my $candidate = IO::Socket->new();
$candidate->socket($ai->{family}, $ai->{socktype}, $ai->{protocol})
or next;
$candidate->connect($ai->{addr})
or next;
$sock = $candidate;
last;
}
die "Cannot connect to localhost:echo" unless $sock;
$sock->print("Hello, world!\n");
print <$sock>;
Because a list of potential candidates is returned, the C<while> loop tries
each in turn until it it finds one that succeeds both the socket() and
connect() calls.
This function performs the work of the legacy functions gethostbyname(),
getservbyname(), inet_aton() and pack_sockaddr_in().
In practice this logic is better performed by L<IO::Socket::IP>.
=head2 Making a human-readable string out of an address
The getnameinfo() function converts a socket address, such as returned by
getsockname() or getpeername(), into a pair of human-readable strings
representing the address and service name.
use IO::Socket::IP;
use Socket qw(getnameinfo);
my $server = IO::Socket::IP->new(LocalPort => 12345, Listen => 1) or
die "Cannot listen - $@";
my $socket = $server->accept or die "accept: $!";
my ($err, $hostname, $servicename) = getnameinfo($socket->peername);
die "Cannot getnameinfo - $err" if $err;
print "The peer is connected from $hostname\n";
Since in this example only the hostname was used, the redundant conversion of
the port number into a service name may be omitted by passing the
C<NIx_NOSERV> flag.
use Socket qw(getnameinfo NIx_NOSERV);
my ($err, $hostname) = getnameinfo($socket->peername, 0, NIx_NOSERV);
This function performs the work of the legacy functions unpack_sockaddr_in(),
inet_ntoa(), gethostbyaddr() and getservbyport().
In practice this logic is better performed by L<IO::Socket::IP>.
=head2 Resolving hostnames into IP addresses
To turn a hostname into a human-readable plain IP address use getaddrinfo()
to turn the hostname into a list of socket structures, then getnameinfo() on
each one to make it a readable IP address again.
use Socket qw(:addrinfo SOCK_RAW);
my ($err, @res) = getaddrinfo($hostname, "", {socktype => SOCK_RAW});
die "Cannot getaddrinfo - $err" if $err;
while( my $ai = shift @res ) {
my ($err, $ipaddr) = getnameinfo($ai->{addr}, NI_NUMERICHOST, NIx_NOSERV);
die "Cannot getnameinfo - $err" if $err;
print "$ipaddr\n";
}
The C<socktype> hint to getaddrinfo() filters the results to only include one
socket type and protocol. Without this most OSes return three combinations,
for C<SOCK_STREAM>, C<SOCK_DGRAM> and C<SOCK_RAW>, resulting in triplicate
output of addresses. The C<NI_NUMERICHOST> flag to getnameinfo() causes it to
return a string-formatted plain IP address, rather than reverse resolving it
back into a hostname.
This combination performs the work of the legacy functions gethostbyname()
and inet_ntoa().
=head2 Accessing socket options
The many C<SO_*> and other constants provide the socket option names for
getsockopt() and setsockopt().
use IO::Socket::INET;
use Socket qw(SOL_SOCKET SO_RCVBUF IPPROTO_IP IP_TTL);
my $socket = IO::Socket::INET->new(LocalPort => 0, Proto => 'udp')
or die "Cannot create socket: $@";
$socket->setsockopt(SOL_SOCKET, SO_RCVBUF, 64*1024) or
die "setsockopt: $!";
print "Receive buffer is ", $socket->getsockopt(SOL_SOCKET, SO_RCVBUF),
" bytes\n";
print "IP TTL is ", $socket->getsockopt(IPPROTO_IP, IP_TTL), "\n";
As a convenience, L<IO::Socket>'s setsockopt() method will convert a number
into a packed byte buffer, and getsockopt() will unpack a byte buffer of the
correct size back into a number.
=cut
=head1 AUTHOR
This module was originally maintained in Perl core by the Perl 5 Porters.
It was extracted to dual-life on CPAN at version 1.95 by
Paul Evans <leonerd@leonerd.org.uk>
=cut
use Carp;
use warnings::register;
require Exporter;
require XSLoader;
our @ISA = qw(Exporter);
# <@Nicholas> you can't change @EXPORT without breaking the implicit API
# Please put any new constants in @EXPORT_OK!
# List re-ordered to match documentation above. Try to keep the ordering
# consistent so it's easier to see which ones are or aren't documented.
our @EXPORT = qw(
PF_802 PF_AAL PF_APPLETALK PF_CCITT PF_CHAOS PF_CTF PF_DATAKIT
PF_DECnet PF_DLI PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_INET6
PF_ISO PF_KEY PF_LAST PF_LAT PF_LINK PF_MAX PF_NBS PF_NIT PF_NS PF_OSI
PF_OSINET PF_PUP PF_ROUTE PF_SNA PF_UNIX PF_UNSPEC PF_USER PF_WAN
PF_X25
AF_802 AF_AAL AF_APPLETALK AF_CCITT AF_CHAOS AF_CTF AF_DATAKIT
AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK AF_INET AF_INET6
AF_ISO AF_KEY AF_LAST AF_LAT AF_LINK AF_MAX AF_NBS AF_NIT AF_NS AF_OSI
AF_OSINET AF_PUP AF_ROUTE AF_SNA AF_UNIX AF_UNSPEC AF_USER AF_WAN
AF_X25
SOCK_DGRAM SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM
SOL_SOCKET
SO_ACCEPTCONN SO_ATTACH_FILTER SO_BACKLOG SO_BROADCAST SO_CHAMELEON
SO_DEBUG SO_DETACH_FILTER SO_DGRAM_ERRIND SO_DOMAIN SO_DONTLINGER
SO_DONTROUTE SO_ERROR SO_FAMILY SO_KEEPALIVE SO_LINGER SO_OOBINLINE
SO_PASSCRED SO_PASSIFNAME SO_PEERCRED SO_PROTOCOL SO_PROTOTYPE
SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO SO_REUSEADDR SO_REUSEPORT
SO_SECURITY_AUTHENTICATION SO_SECURITY_ENCRYPTION_NETWORK
SO_SECURITY_ENCRYPTION_TRANSPORT SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO
SO_STATE SO_TYPE SO_USELOOPBACK SO_XOPEN SO_XSE
IP_OPTIONS IP_HDRINCL IP_TOS IP_TTL IP_RECVOPTS IP_RECVRETOPTS
IP_RETOPTS
MSG_BCAST MSG_BTAG MSG_CTLFLAGS MSG_CTLIGNORE MSG_CTRUNC MSG_DONTROUTE
MSG_DONTWAIT MSG_EOF MSG_EOR MSG_ERRQUEUE MSG_ETAG MSG_FIN
MSG_MAXIOVLEN MSG_MCAST MSG_NOSIGNAL MSG_OOB MSG_PEEK MSG_PROXY MSG_RST
MSG_SYN MSG_TRUNC MSG_URG MSG_WAITALL MSG_WIRE
SHUT_RD SHUT_RDWR SHUT_WR
INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE
SCM_CONNECT SCM_CREDENTIALS SCM_CREDS SCM_RIGHTS SCM_TIMESTAMP
SOMAXCONN
IOV_MAX
UIO_MAXIOV
sockaddr_family
pack_sockaddr_in unpack_sockaddr_in sockaddr_in
pack_sockaddr_in6 unpack_sockaddr_in6 sockaddr_in6
pack_sockaddr_un unpack_sockaddr_un sockaddr_un
inet_aton inet_ntoa
);
# List re-ordered to match documentation above. Try to keep the ordering
# consistent so it's easier to see which ones are or aren't documented.
our @EXPORT_OK = qw(
CR LF CRLF $CR $LF $CRLF
SOCK_NONBLOCK SOCK_CLOEXEC
IP_ADD_MEMBERSHIP IP_ADD_SOURCE_MEMBERSHIP IP_DROP_MEMBERSHIP
IP_DROP_SOURCE_MEMBERSHIP IP_MULTICAST_IF IP_MULTICAST_LOOP
IP_MULTICAST_TTL
IPPROTO_IP IPPROTO_IPV6 IPPROTO_RAW IPPROTO_ICMP IPPROTO_TCP
IPPROTO_UDP
TCP_CONGESTION TCP_CONNECTIONTIMEOUT TCP_CORK TCP_DEFER_ACCEPT TCP_INFO
TCP_INIT_CWND TCP_KEEPALIVE TCP_KEEPCNT TCP_KEEPIDLE TCP_KEEPINTVL
TCP_LINGER2 TCP_MAXRT TCP_MAXSEG TCP_MD5SIG TCP_NODELAY TCP_NOOPT
TCP_NOPUSH TCP_QUICKACK TCP_SACK_ENABLE TCP_STDURG TCP_SYNCNT
TCP_WINDOW_CLAMP
IN6ADDR_ANY IN6ADDR_LOOPBACK
IPV6_ADD_MEMBERSHIP IPV6_DROP_MEMBERSHIP IPV6_JOIN_GROUP
IPV6_LEAVE_GROUP IPV6_MTU IPV6_MTU_DISCOVER IPV6_MULTICAST_HOPS
IPV6_MULTICAST_IF IPV6_MULTICAST_LOOP IPV6_UNICAST_HOPS IPV6_V6ONLY
pack_ip_mreq unpack_ip_mreq pack_ip_mreq_source unpack_ip_mreq_source
pack_ipv6_mreq unpack_ipv6_mreq
inet_pton inet_ntop
getaddrinfo getnameinfo
AI_ADDRCONFIG AI_ALL AI_CANONIDN AI_CANONNAME AI_IDN
AI_IDN_ALLOW_UNASSIGNED AI_IDN_USE_STD3_ASCII_RULES AI_NUMERICHOST
AI_NUMERICSERV AI_PASSIVE AI_V4MAPPED
NI_DGRAM NI_IDN NI_IDN_ALLOW_UNASSIGNED NI_IDN_USE_STD3_ASCII_RULES
NI_NAMEREQD NI_NOFQDN NI_NUMERICHOST NI_NUMERICSERV
NIx_NOHOST NIx_NOSERV
EAI_ADDRFAMILY EAI_AGAIN EAI_BADFLAGS EAI_BADHINTS EAI_FAIL EAI_FAMILY
EAI_NODATA EAI_NONAME EAI_PROTOCOL EAI_SERVICE EAI_SOCKTYPE EAI_SYSTEM
);
our %EXPORT_TAGS = (
crlf => [qw(CR LF CRLF $CR $LF $CRLF)],
addrinfo => [qw(getaddrinfo getnameinfo), grep m/^(?:AI|NI|NIx|EAI)_/, @EXPORT_OK],
all => [@EXPORT, @EXPORT_OK],
);
BEGIN {
sub CR () {"\015"}
sub LF () {"\012"}
sub CRLF () {"\015\012"}
# These are not gni() constants; they're extensions for the perl API
# The definitions in Socket.pm and Socket.xs must match
sub NIx_NOHOST() {1 << 0}
sub NIx_NOSERV() {1 << 1}
}
*CR = \CR();
*LF = \LF();
*CRLF = \CRLF();
sub sockaddr_in {
if (@_ == 6 && !wantarray) { # perl5.001m compat; use this && die
my($af, $port, @quad) = @_;
warnings::warn "6-ARG sockaddr_in call is deprecated"
if warnings::enabled();
pack_sockaddr_in($port, inet_aton(join('.', @quad)));
} elsif (wantarray) {
croak "usage: (port,iaddr) = sockaddr_in(sin_sv)" unless @_ == 1;
unpack_sockaddr_in(@_);
} else {
croak "usage: sin_sv = sockaddr_in(port,iaddr))" unless @_ == 2;
pack_sockaddr_in(@_);
}
}
sub sockaddr_in6 {
if (wantarray) {
croak "usage: (port,in6addr,scope_id,flowinfo) = sockaddr_in6(sin6_sv)" unless @_ == 1;
unpack_sockaddr_in6(@_);
}
else {
croak "usage: sin6_sv = sockaddr_in6(port,in6addr,[scope_id,[flowinfo]])" unless @_ >= 2 and @_ <= 4;
pack_sockaddr_in6(@_);
}
}
sub sockaddr_un {
if (wantarray) {
croak "usage: (filename) = sockaddr_un(sun_sv)" unless @_ == 1;
unpack_sockaddr_un(@_);
} else {
croak "usage: sun_sv = sockaddr_un(filename)" unless @_ == 1;
pack_sockaddr_un(@_);
}
}
XSLoader::load(__PACKAGE__, $VERSION);
my %errstr;
if( defined &getaddrinfo ) {
# These are not part of the API, nothing uses them, and deleting them
# reduces the size of %Socket:: by about 12K
delete $Socket::{fake_getaddrinfo};
delete $Socket::{fake_getnameinfo};
} else {
require Scalar::Util;
*getaddrinfo = \&fake_getaddrinfo;
*getnameinfo = \&fake_getnameinfo;
# These numbers borrowed from GNU libc's implementation, but since
# they're only used by our emulation, it doesn't matter if the real
# platform's values differ
my %constants = (
AI_PASSIVE => 1,
AI_CANONNAME => 2,
AI_NUMERICHOST => 4,
AI_V4MAPPED => 8,
AI_ALL => 16,
AI_ADDRCONFIG => 32,
# RFC 2553 doesn't define this but Linux does - lets be nice and
# provide it since we can
AI_NUMERICSERV => 1024,
EAI_BADFLAGS => -1,
EAI_NONAME => -2,
EAI_NODATA => -5,
EAI_FAMILY => -6,
EAI_SERVICE => -8,
NI_NUMERICHOST => 1,
NI_NUMERICSERV => 2,
NI_NOFQDN => 4,
NI_NAMEREQD => 8,
NI_DGRAM => 16,
# Constants we don't support. Export them, but croak if anyone tries to
# use them
AI_IDN => 64,
AI_CANONIDN => 128,
AI_IDN_ALLOW_UNASSIGNED => 256,
AI_IDN_USE_STD3_ASCII_RULES => 512,
NI_IDN => 32,
NI_IDN_ALLOW_UNASSIGNED => 64,
NI_IDN_USE_STD3_ASCII_RULES => 128,
# Error constants we'll never return, so it doesn't matter what value
# these have, nor that we don't provide strings for them
EAI_SYSTEM => -11,
EAI_BADHINTS => -1000,
EAI_PROTOCOL => -1001
);
foreach my $name ( keys %constants ) {
my $value = $constants{$name};
no strict 'refs';
defined &$name or *$name = sub () { $value };
}
%errstr = (
# These strings from RFC 2553
EAI_BADFLAGS() => "invalid value for ai_flags",
EAI_NONAME() => "nodename nor servname provided, or not known",
EAI_NODATA() => "no address associated with nodename",
EAI_FAMILY() => "ai_family not supported",
EAI_SERVICE() => "servname not supported for ai_socktype",
);
}
# The following functions are used if the system does not have a
# getaddrinfo(3) function in libc; and are used to emulate it for the AF_INET
# family
# Borrowed from Regexp::Common::net
my $REGEXP_IPv4_DECIMAL = qr/25[0-5]|2[0-4][0-9]|1?[0-9][0-9]{1,2}/;
my $REGEXP_IPv4_DOTTEDQUAD = qr/$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL/;
sub fake_makeerr
{
my ( $errno ) = @_;
my $errstr = $errno == 0 ? "" : ( $errstr{$errno} || $errno );
return Scalar::Util::dualvar( $errno, $errstr );
}
sub fake_getaddrinfo
{
my ( $node, $service, $hints ) = @_;
$node = "" unless defined $node;
$service = "" unless defined $service;
my ( $family, $socktype, $protocol, $flags ) = @$hints{qw( family socktype protocol flags )};
$family ||= Socket::AF_INET(); # 0 == AF_UNSPEC, which we want too
$family == Socket::AF_INET() or return fake_makeerr( EAI_FAMILY() );
$socktype ||= 0;
$protocol ||= 0;
$flags ||= 0;
my $flag_passive = $flags & AI_PASSIVE(); $flags &= ~AI_PASSIVE();
my $flag_canonname = $flags & AI_CANONNAME(); $flags &= ~AI_CANONNAME();
my $flag_numerichost = $flags & AI_NUMERICHOST(); $flags &= ~AI_NUMERICHOST();
my $flag_numericserv = $flags & AI_NUMERICSERV(); $flags &= ~AI_NUMERICSERV();
# These constants don't apply to AF_INET-only lookups, so we might as well
# just ignore them. For AI_ADDRCONFIG we just presume the host has ability
# to talk AF_INET. If not we'd have to return no addresses at all. :)
$flags &= ~(AI_V4MAPPED()|AI_ALL()|AI_ADDRCONFIG());
$flags & (AI_IDN()|AI_CANONIDN()|AI_IDN_ALLOW_UNASSIGNED()|AI_IDN_USE_STD3_ASCII_RULES()) and
croak "Socket::getaddrinfo() does not support IDN";
$flags == 0 or return fake_makeerr( EAI_BADFLAGS() );
$node eq "" and $service eq "" and return fake_makeerr( EAI_NONAME() );
my $canonname;
my @addrs;
if( $node ne "" ) {
return fake_makeerr( EAI_NONAME() ) if( $flag_numerichost and $node !~ m/^$REGEXP_IPv4_DOTTEDQUAD$/ );
( $canonname, undef, undef, undef, @addrs ) = gethostbyname( $node );
defined $canonname or return fake_makeerr( EAI_NONAME() );
undef $canonname unless $flag_canonname;
}
else {
$addrs[0] = $flag_passive ? Socket::inet_aton( "0.0.0.0" )
: Socket::inet_aton( "127.0.0.1" );
}
my @ports; # Actually ARRAYrefs of [ socktype, protocol, port ]
my $protname = "";
if( $protocol ) {
$protname = getprotobynumber( $protocol );
}
if( $service ne "" and $service !~ m/^\d+$/ ) {
return fake_makeerr( EAI_NONAME() ) if( $flag_numericserv );
getservbyname( $service, $protname ) or return fake_makeerr( EAI_SERVICE() );
}
foreach my $this_socktype ( Socket::SOCK_STREAM(), Socket::SOCK_DGRAM(), Socket::SOCK_RAW() ) {
next if $socktype and $this_socktype != $socktype;
my $this_protname = "raw";
$this_socktype == Socket::SOCK_STREAM() and $this_protname = "tcp";
$this_socktype == Socket::SOCK_DGRAM() and $this_protname = "udp";
next if $protname and $this_protname ne $protname;
my $port;
if( $service ne "" ) {
if( $service =~ m/^\d+$/ ) {
$port = "$service";
}
else {
( undef, undef, $port, $this_protname ) = getservbyname( $service, $this_protname );
next unless defined $port;
}
}
else {
$port = 0;
}
push @ports, [ $this_socktype, scalar getprotobyname( $this_protname ) || 0, $port ];
}
my @ret;
foreach my $addr ( @addrs ) {
foreach my $portspec ( @ports ) {
my ( $socktype, $protocol, $port ) = @$portspec;
push @ret, {
family => $family,
socktype => $socktype,
protocol => $protocol,
addr => Socket::pack_sockaddr_in( $port, $addr ),
canonname => undef,
};
}
}
# Only supply canonname for the first result
if( defined $canonname ) {
$ret[0]->{canonname} = $canonname;
}
return ( fake_makeerr( 0 ), @ret );
}
sub fake_getnameinfo
{
my ( $addr, $flags, $xflags ) = @_;
my ( $port, $inetaddr );
eval { ( $port, $inetaddr ) = Socket::unpack_sockaddr_in( $addr ) }
or return fake_makeerr( EAI_FAMILY() );
my $family = Socket::AF_INET();
$flags ||= 0;
my $flag_numerichost = $flags & NI_NUMERICHOST(); $flags &= ~NI_NUMERICHOST();
my $flag_numericserv = $flags & NI_NUMERICSERV(); $flags &= ~NI_NUMERICSERV();
my $flag_nofqdn = $flags & NI_NOFQDN(); $flags &= ~NI_NOFQDN();
my $flag_namereqd = $flags & NI_NAMEREQD(); $flags &= ~NI_NAMEREQD();
my $flag_dgram = $flags & NI_DGRAM() ; $flags &= ~NI_DGRAM();
$flags & (NI_IDN()|NI_IDN_ALLOW_UNASSIGNED()|NI_IDN_USE_STD3_ASCII_RULES()) and
croak "Socket::getnameinfo() does not support IDN";
$flags == 0 or return fake_makeerr( EAI_BADFLAGS() );
$xflags ||= 0;
my $node;
if( $xflags & NIx_NOHOST ) {
$node = undef;
}
elsif( $flag_numerichost ) {
$node = Socket::inet_ntoa( $inetaddr );
}
else {
$node = gethostbyaddr( $inetaddr, $family );
if( !defined $node ) {
return fake_makeerr( EAI_NONAME() ) if $flag_namereqd;
$node = Socket::inet_ntoa( $inetaddr );
}
elsif( $flag_nofqdn ) {
my ( $shortname ) = split m/\./, $node;
my ( $fqdn ) = gethostbyname $shortname;
$node = $shortname if defined $fqdn and $fqdn eq $node;
}
}
my $service;
if( $xflags & NIx_NOSERV ) {
$service = undef;
}
elsif( $flag_numericserv ) {
$service = "$port";
}
else {
my $protname = $flag_dgram ? "udp" : "";
$service = getservbyport( $port, $protname );
if( !defined $service ) {
$service = "$port";
}
}
return ( fake_makeerr( 0 ), $node, $service );
}
1;
DARWIN-2LEVEL_SOCKET
$fatpacked{"darwin-2level/encoding.pm"} = <<'DARWIN-2LEVEL_ENCODING';
# $Id: encoding.pm,v 2.11 2013/02/18 02:23:56 dankogai Exp $
package encoding;
our $VERSION = '2.6_01';
use Encode;
use strict;
use warnings;
use constant DEBUG => !!$ENV{PERL_ENCODE_DEBUG};
BEGIN {
if ( ord("A") == 193 ) {
require Carp;
Carp::croak("encoding: pragma does not support EBCDIC platforms");
}
}
our $HAS_PERLIO = 0;
eval { require PerlIO::encoding };
unless ($@) {
$HAS_PERLIO = ( PerlIO::encoding->VERSION >= 0.02 );
}
sub _exception {
my $name = shift;
$] > 5.008 and return 0; # 5.8.1 or higher then no
my %utfs = map { $_ => 1 }
qw(utf8 UCS-2BE UCS-2LE UTF-16 UTF-16BE UTF-16LE
UTF-32 UTF-32BE UTF-32LE);
$utfs{$name} or return 0; # UTFs or no
require Config;
Config->import();
our %Config;
return $Config{perl_patchlevel} ? 0 : 1 # maintperl then no
}
sub in_locale { $^H & ( $locale::hint_bits || 0 ) }
sub _get_locale_encoding {
my $locale_encoding;
# I18N::Langinfo isn't available everywhere
eval {
require I18N::Langinfo;
I18N::Langinfo->import(qw(langinfo CODESET));
$locale_encoding = langinfo( CODESET() );
};
my $country_language;
no warnings 'uninitialized';
if ( (not $locale_encoding) && in_locale() ) {
if ( $ENV{LC_ALL} =~ /^([^.]+)\.([^.@]+)(@.*)?$/ ) {
( $country_language, $locale_encoding ) = ( $1, $2 );
}
elsif ( $ENV{LANG} =~ /^([^.]+)\.([^.@]+)(@.*)?$/ ) {
( $country_language, $locale_encoding ) = ( $1, $2 );
}
# LANGUAGE affects only LC_MESSAGES only on glibc
}
elsif ( not $locale_encoding ) {
if ( $ENV{LC_ALL} =~ /\butf-?8\b/i
|| $ENV{LANG} =~ /\butf-?8\b/i )
{
$locale_encoding = 'utf8';
}
# Could do more heuristics based on the country and language
# parts of LC_ALL and LANG (the parts before the dot (if any)),
# since we have Locale::Country and Locale::Language available.
# TODO: get a database of Language -> Encoding mappings
# (the Estonian database at http://www.eki.ee/letter/
# would be excellent!) --jhi
}
if ( defined $locale_encoding
&& lc($locale_encoding) eq 'euc'
&& defined $country_language )
{
if ( $country_language =~ /^ja_JP|japan(?:ese)?$/i ) {
$locale_encoding = 'euc-jp';
}
elsif ( $country_language =~ /^ko_KR|korean?$/i ) {
$locale_encoding = 'euc-kr';
}
elsif ( $country_language =~ /^zh_CN|chin(?:a|ese)$/i ) {
$locale_encoding = 'euc-cn';
}
elsif ( $country_language =~ /^zh_TW|taiwan(?:ese)?$/i ) {
$locale_encoding = 'euc-tw';
}
else {
require Carp;
Carp::croak(
"encoding: Locale encoding '$locale_encoding' too ambiguous"
);
}
}
return $locale_encoding;
}
sub import {
if ($] >= 5.017) {
warnings::warnif("deprecated",
"Use of the encoding pragma is deprecated")
}
my $class = shift;
my $name = shift;
if (!$name){
require Carp;
Carp::croak("encoding: no encoding specified.");
}
if ( $name eq ':_get_locale_encoding' ) { # used by lib/open.pm
my $caller = caller();
{
no strict 'refs';
*{"${caller}::_get_locale_encoding"} = \&_get_locale_encoding;
}
return;
}
$name = _get_locale_encoding() if $name eq ':locale';
my %arg = @_;
$name = $ENV{PERL_ENCODING} unless defined $name;
my $enc = find_encoding($name);
unless ( defined $enc ) {
require Carp;
Carp::croak("encoding: Unknown encoding '$name'");
}
$name = $enc->name; # canonize
unless ( $arg{Filter} ) {
DEBUG and warn "_exception($name) = ", _exception($name);
_exception($name) or ${^ENCODING} = $enc;
$HAS_PERLIO or return 1;
}
else {
defined( ${^ENCODING} ) and undef ${^ENCODING};
# implicitly 'use utf8'
require utf8; # to fetch $utf8::hint_bits;
$^H |= $utf8::hint_bits;
eval {
require Filter::Util::Call;
Filter::Util::Call->import;
filter_add(
sub {
my $status = filter_read();
if ( $status > 0 ) {
$_ = $enc->decode( $_, 1 );
DEBUG and warn $_;
}
$status;
}
);
};
$@ eq '' and DEBUG and warn "Filter installed";
}
defined ${^UNICODE} and ${^UNICODE} != 0 and return 1;
for my $h (qw(STDIN STDOUT)) {
if ( $arg{$h} ) {
unless ( defined find_encoding( $arg{$h} ) ) {
require Carp;
Carp::croak(
"encoding: Unknown encoding for $h, '$arg{$h}'");
}
eval { binmode( $h, ":raw :encoding($arg{$h})" ) };
}
else {
unless ( exists $arg{$h} ) {
eval {
no warnings 'uninitialized';
binmode( $h, ":raw :encoding($name)" );
};
}
}
if ($@) {
require Carp;
Carp::croak($@);
}
}
return 1; # I doubt if we need it, though
}
sub unimport {
no warnings;
undef ${^ENCODING};
if ($HAS_PERLIO) {
binmode( STDIN, ":raw" );
binmode( STDOUT, ":raw" );
}
else {
binmode(STDIN);
binmode(STDOUT);
}
if ( $INC{"Filter/Util/Call.pm"} ) {
eval { filter_del() };
}
}
1;
__END__
=pod
=head1 NAME
encoding - allows you to write your script in non-ascii or non-utf8
=head1 WARNING
This module is deprecated under perl 5.18. It uses a mechanism provided by
perl that is deprecated under 5.18 and higher, and may be removed in a
future version.
=head1 SYNOPSIS
use encoding "greek"; # Perl like Greek to you?
use encoding "euc-jp"; # Jperl!
# or you can even do this if your shell supports your native encoding
perl -Mencoding=latin2 -e'...' # Feeling centrally European?
perl -Mencoding=euc-kr -e'...' # Or Korean?
# more control
# A simple euc-cn => utf-8 converter
use encoding "euc-cn", STDOUT => "utf8"; while(<>){print};
# "no encoding;" supported (but not scoped!)
no encoding;
# an alternate way, Filter
use encoding "euc-jp", Filter=>1;
# now you can use kanji identifiers -- in euc-jp!
# switch on locale -
# note that this probably means that unless you have a complete control
# over the environments the application is ever going to be run, you should
# NOT use the feature of encoding pragma allowing you to write your script
# in any recognized encoding because changing locale settings will wreck
# the script; you can of course still use the other features of the pragma.
use encoding ':locale';
=head1 ABSTRACT
Let's start with a bit of history: Perl 5.6.0 introduced Unicode
support. You could apply C<substr()> and regexes even to complex CJK
characters -- so long as the script was written in UTF-8. But back
then, text editors that supported UTF-8 were still rare and many users
instead chose to write scripts in legacy encodings, giving up a whole
new feature of Perl 5.6.
Rewind to the future: starting from perl 5.8.0 with the B<encoding>
pragma, you can write your script in any encoding you like (so long
as the C<Encode> module supports it) and still enjoy Unicode support.
This pragma achieves that by doing the following:
=over
=item *
Internally converts all literals (C<q//,qq//,qr//,qw///, qx//>) from
the encoding specified to utf8. In Perl 5.8.1 and later, literals in
C<tr///> and C<DATA> pseudo-filehandle are also converted.
=item *
Changing PerlIO layers of C<STDIN> and C<STDOUT> to the encoding
specified.
=back
=head2 Literal Conversions
You can write code in EUC-JP as follows:
my $Rakuda = "\xF1\xD1\xF1\xCC"; # Camel in Kanji
#<-char-><-char-> # 4 octets
s/\bCamel\b/$Rakuda/;
And with C<use encoding "euc-jp"> in effect, it is the same thing as
the code in UTF-8:
my $Rakuda = "\x{99F1}\x{99DD}"; # two Unicode Characters
s/\bCamel\b/$Rakuda/;
=head2 PerlIO layers for C<STD(IN|OUT)>
The B<encoding> pragma also modifies the filehandle layers of
STDIN and STDOUT to the specified encoding. Therefore,
use encoding "euc-jp";
my $message = "Camel is the symbol of perl.\n";
my $Rakuda = "\xF1\xD1\xF1\xCC"; # Camel in Kanji
$message =~ s/\bCamel\b/$Rakuda/;
print $message;
Will print "\xF1\xD1\xF1\xCC is the symbol of perl.\n",
not "\x{99F1}\x{99DD} is the symbol of perl.\n".
You can override this by giving extra arguments; see below.
=head2 Implicit upgrading for byte strings
By default, if strings operating under byte semantics and strings
with Unicode character data are concatenated, the new string will
be created by decoding the byte strings as I<ISO 8859-1 (Latin-1)>.
The B<encoding> pragma changes this to use the specified encoding
instead. For example:
use encoding 'utf8';
my $string = chr(20000); # a Unicode string
utf8::encode($string); # now it's a UTF-8 encoded byte string
# concatenate with another Unicode string
print length($string . chr(20000));
Will print C<2>, because C<$string> is upgraded as UTF-8. Without
C<use encoding 'utf8';>, it will print C<4> instead, since C<$string>
is three octets when interpreted as Latin-1.
=head2 Side effects
If the C<encoding> pragma is in scope then the lengths returned are
calculated from the length of C<$/> in Unicode characters, which is not
always the same as the length of C<$/> in the native encoding.
This pragma affects utf8::upgrade, but not utf8::downgrade.
=head1 FEATURES THAT REQUIRE 5.8.1
Some of the features offered by this pragma requires perl 5.8.1. Most
of these are done by Inaba Hiroto. Any other features and changes
are good for 5.8.0.
=over
=item "NON-EUC" doublebyte encodings
Because perl needs to parse script before applying this pragma, such
encodings as Shift_JIS and Big-5 that may contain '\' (BACKSLASH;
\x5c) in the second byte fails because the second byte may
accidentally escape the quoting character that follows. Perl 5.8.1
or later fixes this problem.
=item tr//
C<tr//> was overlooked by Perl 5 porters when they released perl 5.8.0
See the section below for details.
=item DATA pseudo-filehandle
Another feature that was overlooked was C<DATA>.
=back
=head1 USAGE
=over 4
=item use encoding [I<ENCNAME>] ;
Sets the script encoding to I<ENCNAME>. And unless ${^UNICODE}
exists and non-zero, PerlIO layers of STDIN and STDOUT are set to
":encoding(I<ENCNAME>)".
Note that STDERR WILL NOT be changed.
Also note that non-STD file handles remain unaffected. Use C<use
open> or C<binmode> to change layers of those.
If no encoding is specified, the environment variable L<PERL_ENCODING>
is consulted. If no encoding can be found, the error C<Unknown encoding
'I<ENCNAME>'> will be thrown.
=item use encoding I<ENCNAME> [ STDIN =E<gt> I<ENCNAME_IN> ...] ;
You can also individually set encodings of STDIN and STDOUT via the
C<< STDIN => I<ENCNAME> >> form. In this case, you cannot omit the
first I<ENCNAME>. C<< STDIN => undef >> turns the IO transcoding
completely off.
When ${^UNICODE} exists and non-zero, these options will completely
ignored. ${^UNICODE} is a variable introduced in perl 5.8.1. See
L<perlrun> see L<perlvar/"${^UNICODE}"> and L<perlrun/"-C"> for
details (perl 5.8.1 and later).
=item use encoding I<ENCNAME> Filter=E<gt>1;
This turns the encoding pragma into a source filter. While the
default approach just decodes interpolated literals (in qq() and
qr()), this will apply a source filter to the entire source code. See
L</"The Filter Option"> below for details.
=item no encoding;
Unsets the script encoding. The layers of STDIN, STDOUT are
reset to ":raw" (the default unprocessed raw stream of bytes).
=back
=head1 The Filter Option
The magic of C<use encoding> is not applied to the names of
identifiers. In order to make C<${"\x{4eba}"}++> ($human++, where human
is a single Han ideograph) work, you still need to write your script
in UTF-8 -- or use a source filter. That's what 'Filter=>1' does.
What does this mean? Your source code behaves as if it is written in
UTF-8 with 'use utf8' in effect. So even if your editor only supports
Shift_JIS, for example, you can still try examples in Chapter 15 of
C<Programming Perl, 3rd Ed.>. For instance, you can use UTF-8
identifiers.
This option is significantly slower and (as of this writing) non-ASCII
identifiers are not very stable WITHOUT this option and with the
source code written in UTF-8.
=head2 Filter-related changes at Encode version 1.87
=over
=item *
The Filter option now sets STDIN and STDOUT like non-filter options.
And C<< STDIN=>I<ENCODING> >> and C<< STDOUT=>I<ENCODING> >> work like
non-filter version.
=item *
C<use utf8> is implicitly declared so you no longer have to C<use
utf8> to C<${"\x{4eba}"}++>.
=back
=head1 CAVEATS
=head2 NOT SCOPED
The pragma is a per script, not a per block lexical. Only the last
C<use encoding> or C<no encoding> matters, and it affects
B<the whole script>. However, the <no encoding> pragma is supported and
B<use encoding> can appear as many times as you want in a given script.
The multiple use of this pragma is discouraged.
By the same reason, the use this pragma inside modules is also
discouraged (though not as strongly discouraged as the case above.
See below).
If you still have to write a module with this pragma, be very careful
of the load order. See the codes below;
# called module
package Module_IN_BAR;
use encoding "bar";
# stuff in "bar" encoding here
1;
# caller script
use encoding "foo"
use Module_IN_BAR;
# surprise! use encoding "bar" is in effect.
The best way to avoid this oddity is to use this pragma RIGHT AFTER
other modules are loaded. i.e.
use Module_IN_BAR;
use encoding "foo";
=head2 DO NOT MIX MULTIPLE ENCODINGS
Notice that only literals (string or regular expression) having only
legacy code points are affected: if you mix data like this
\xDF\x{100}
the data is assumed to be in (Latin 1 and) Unicode, not in your native
encoding. In other words, this will match in "greek":
"\xDF" =~ /\x{3af}/
but this will not
"\xDF\x{100}" =~ /\x{3af}\x{100}/
since the C<\xDF> (ISO 8859-7 GREEK SMALL LETTER IOTA WITH TONOS) on
the left will B<not> be upgraded to C<\x{3af}> (Unicode GREEK SMALL
LETTER IOTA WITH TONOS) because of the C<\x{100}> on the left. You
should not be mixing your legacy data and Unicode in the same string.
This pragma also affects encoding of the 0x80..0xFF code point range:
normally characters in that range are left as eight-bit bytes (unless
they are combined with characters with code points 0x100 or larger,
in which case all characters need to become UTF-8 encoded), but if
the C<encoding> pragma is present, even the 0x80..0xFF range always
gets UTF-8 encoded.
After all, the best thing about this pragma is that you don't have to
resort to \x{....} just to spell your name in a native encoding.
So feel free to put your strings in your encoding in quotes and
regexes.
=head2 tr/// with ranges
The B<encoding> pragma works by decoding string literals in
C<q//,qq//,qr//,qw///, qx//> and so forth. In perl 5.8.0, this
does not apply to C<tr///>. Therefore,
use encoding 'euc-jp';
#....
$kana =~ tr/\xA4\xA1-\xA4\xF3/\xA5\xA1-\xA5\xF3/;
# -------- -------- -------- --------
Does not work as
$kana =~ tr/\x{3041}-\x{3093}/\x{30a1}-\x{30f3}/;
=over
=item Legend of characters above
utf8 euc-jp charnames::viacode()
-----------------------------------------
\x{3041} \xA4\xA1 HIRAGANA LETTER SMALL A
\x{3093} \xA4\xF3 HIRAGANA LETTER N
\x{30a1} \xA5\xA1 KATAKANA LETTER SMALL A
\x{30f3} \xA5\xF3 KATAKANA LETTER N
=back
This counterintuitive behavior has been fixed in perl 5.8.1.
=head3 workaround to tr///;
In perl 5.8.0, you can work around as follows;
use encoding 'euc-jp';
# ....
eval qq{ \$kana =~ tr/\xA4\xA1-\xA4\xF3/\xA5\xA1-\xA5\xF3/ };
Note the C<tr//> expression is surrounded by C<qq{}>. The idea behind
is the same as classic idiom that makes C<tr///> 'interpolate'.
tr/$from/$to/; # wrong!
eval qq{ tr/$from/$to/ }; # workaround.
Nevertheless, in case of B<encoding> pragma even C<q//> is affected so
C<tr///> not being decoded was obviously against the will of Perl5
Porters so it has been fixed in Perl 5.8.1 or later.
=head1 EXAMPLE - Greekperl
use encoding "iso 8859-7";
# \xDF in ISO 8859-7 (Greek) is \x{3af} in Unicode.
$a = "\xDF";
$b = "\x{100}";
printf "%#x\n", ord($a); # will print 0x3af, not 0xdf
$c = $a . $b;
# $c will be "\x{3af}\x{100}", not "\x{df}\x{100}".
# chr() is affected, and ...
print "mega\n" if ord(chr(0xdf)) == 0x3af;
# ... ord() is affected by the encoding pragma ...
print "tera\n" if ord(pack("C", 0xdf)) == 0x3af;
# ... as are eq and cmp ...
print "peta\n" if "\x{3af}" eq pack("C", 0xdf);
print "exa\n" if "\x{3af}" cmp pack("C", 0xdf) == 0;
# ... but pack/unpack C are not affected, in case you still
# want to go back to your native encoding
print "zetta\n" if unpack("C", (pack("C", 0xdf))) == 0xdf;
=head1 KNOWN PROBLEMS
=over
=item literals in regex that are longer than 127 bytes
For native multibyte encodings (either fixed or variable length),
the current implementation of the regular expressions may introduce
recoding errors for regular expression literals longer than 127 bytes.
=item EBCDIC
The encoding pragma is not supported on EBCDIC platforms.
(Porters who are willing and able to remove this limitation are
welcome.)
=item format
This pragma doesn't work well with format because PerlIO does not
get along very well with it. When format contains non-ascii
characters it prints funny or gets "wide character warnings".
To understand it, try the code below.
# Save this one in utf8
# replace *non-ascii* with a non-ascii string
my $camel;
format STDOUT =
*non-ascii*@>>>>>>>
$camel
.
$camel = "*non-ascii*";
binmode(STDOUT=>':encoding(utf8)'); # bang!
write; # funny
print $camel, "\n"; # fine
Without binmode this happens to work but without binmode, print()
fails instead of write().
At any rate, the very use of format is questionable when it comes to
unicode characters since you have to consider such things as character
width (i.e. double-width for ideographs) and directions (i.e. BIDI for
Arabic and Hebrew).
=item Thread safety
C<use encoding ...> is not thread-safe (i.e., do not use in threaded
applications).
=back
=head2 The Logic of :locale
The logic of C<:locale> is as follows:
=over 4
=item 1.
If the platform supports the langinfo(CODESET) interface, the codeset
returned is used as the default encoding for the open pragma.
=item 2.
If 1. didn't work but we are under the locale pragma, the environment
variables LC_ALL and LANG (in that order) are matched for encodings
(the part after C<.>, if any), and if any found, that is used
as the default encoding for the open pragma.
=item 3.
If 1. and 2. didn't work, the environment variables LC_ALL and LANG
(in that order) are matched for anything looking like UTF-8, and if
any found, C<:utf8> is used as the default encoding for the open
pragma.
=back
If your locale environment variables (LC_ALL, LC_CTYPE, LANG)
contain the strings 'UTF-8' or 'UTF8' (case-insensitive matching),
the default encoding of your STDIN, STDOUT, and STDERR, and of
B<any subsequent file open>, is UTF-8.
=head1 HISTORY
This pragma first appeared in Perl 5.8.0. For features that require
5.8.1 and better, see above.
The C<:locale> subpragma was implemented in 2.01, or Perl 5.8.6.
=head1 SEE ALSO
L<perlunicode>, L<Encode>, L<open>, L<Filter::Util::Call>,
Ch. 15 of C<Programming Perl (3rd Edition)>
by Larry Wall, Tom Christiansen, Jon Orwant;
O'Reilly & Associates; ISBN 0-596-00027-8
=cut
DARWIN-2LEVEL_ENCODING
s/^ //mg for values %fatpacked;
unshift @INC, sub {
if (my $fat = $fatpacked{$_[1]}) {
if ($] < 5.008) {
return sub {
return 0 unless length $fat;
$fat =~ s/^([^\n]*\n?)//;
$_ = $1;
return 1;
};
}
open my $fh, '<', \$fat
or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
return $fh;
}
return
};
} # END OF FATPACK CODE
#!/usr/bin/env perl
use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/../lib/";
use Perl::Build;
use Getopt::Long;
use Pod::Usage;
use File::Spec;
my $test = undef;
my $patches;
my (@D, @A, @U);
Getopt::Long::Configure(
'pass_through',
'no_ignore_case',
'bundling',
);
GetOptions(
'test' => \$test,
'D=s@' => \@D,
'A=s@' => \@A,
'U=s@' => \@U,
'patches=s' => \$patches,
);
for (@D, @A, @U) {
s/^=//;
}
shift @ARGV if @ARGV >= 1 && $ARGV[0] eq '--';
my $stuff = shift @ARGV or pod2usage();
my $dest = shift @ARGV or pod2usage();
$dest = File::Spec->rel2abs($dest);
my @configure_options = @ARGV ? @ARGV : ('-de');
push @configure_options, map { "-D$_" } @D;
push @configure_options, map { "-A$_" } @A;
push @configure_options, map { "-U$_" } @U;
$ENV{PERL5_PATCHPERL_PLUGIN} = $patches if defined $patches;
if ($stuff =~ /\.(gz|bz2)$/) {
Perl::Build->install_from_tarball(
$stuff => (
dst_path => $dest,
configure_options => \@configure_options,
test => $test,
)
);
} else {
my $version = $stuff;
Perl::Build->install_from_cpan(
$version => (
dst_path => $dest,
configure_options => \@configure_options,
test => $test,
)
);
}
__END__
=head1 NAME
perl-build - perl binary builder
=head1 SYNOPSIS
perl-build src dst
perl-build 5.16.2 /usr/local/perl-5.16.2
# or
perl-build path/to/perl-5.16.2.tar.gz /usr/local/perl-5.16.2
=head1 DESCRIPTION
This script fetch/build/install perl5 from CPAN or tar ball.
=head1 OPTIONS
=over 4
=item -D, -A, -U
-Dxxx, -Axxx, -Uxxx options are pass through to ./Configure script.
=item --test
This option enables C<< make test >> after building.
(Default: disabled)
=item --patches=Asan
You can set I<PERL5_PATCHPERL_PLUGIN> environment variable by this option.
=back
=head1 FAQ
=over 4
=item How can I apply security fixes like CVE-2013-1667?
RURBAN provides L<Devel::PatchPerl::Plugin::Asan>. Install it and run C<< perl-build --patches=Asan 5.16.1 /opt/perl/5.16/ >>.
=back
=head1 SEE ALSO
L<perlbrew>, L<plenv>