| Server IP : 172.64.80.1 / Your IP : 216.73.216.175 Web Server : LiteSpeed System : Linux srv13.swhc.ca 4.18.0-553.126.2.lve.el8.x86_64 #1 SMP Thu May 28 14:12:30 UTC 2026 x86_64 User : hongluck ( 2522) PHP Version : 7.4.33 Disable Function : NONE MySQL : OFF | cURL : ON | WGET : ON | Perl : ON | Python : ON | Sudo : OFF | Pkexec : OFF Directory : /lib64/nagios/plugins/ |
Upload File : |
#!/usr/bin/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{"App/Monitoring/Plugin/CheckRaid.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID';
package App::Monitoring::Plugin::CheckRaid;
use Carp qw(croak);
use Module::Pluggable 5.1 instantiate => 'new', sub_name => '_plugins';
use strict;
use warnings;
# constructor
sub new {
my $class = shift;
croak 'Odd number of elements in argument hash' if @_ % 2;
my $self = {
@_,
};
my $obj = bless $self, $class;
# setup search path for Module::Pluggable
$self->search_path(add => __PACKAGE__ . '::Plugins');
# setup only certain plugins
if ($self->{enable_plugins}) {
my @plugins = map {
__PACKAGE__ . '::Plugins::' . $_
} @{$self->{enable_plugins}};
$self->only(\@plugins);
}
return $obj;
}
# create list of plugins
sub plugins {
my ($this) = @_;
# call this once
if (!defined $this->{plugins}) {
my @plugins = $this->_plugins(%$this);
$this->{plugins} = \@plugins;
}
wantarray ? @{$this->{plugins}} : $this->{plugins};
}
# get plugin by name
sub plugin {
my ($this, $name) = @_;
if (!defined $this->{plugin_names}) {
my %names;
foreach my $plugin ($this->plugins) {
my $name = $plugin->{name};
$names{$name} = $plugin;
}
$this->{plugin_names} = \%names;
}
croak "Plugin '$name' Can not be created" unless exists $this->{plugin_names}{$name};
$this->{plugin_names}{$name};
}
# Get active plugins.
# Returns the plugin objects
sub active_plugins {
my $this = shift;
# whether the query is for sudo rules
my $sudo = shift || 0;
my @plugins = ();
# go over all registered plugins
foreach my $plugin ($this->plugins) {
# skip if no check method (not standalone checker)
next unless $plugin->can('check');
# skip inactive plugins (disabled or no tools available)
next unless $plugin->active($sudo);
push(@plugins, $plugin);
}
return wantarray ? @plugins : \@plugins;
}
1;
APP_MONITORING_PLUGIN_CHECKRAID
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGIN';
package App::Monitoring::Plugin::CheckRaid::Plugin;
use Carp qw(croak);
use App::Monitoring::Plugin::CheckRaid::Utils;
use strict;
use warnings;
# Nagios standard error codes
my (%ERRORS) = (OK => 0, WARNING => 1, CRITICAL => 2, UNKNOWN => 3);
# default plugin options
our %options = (
# status to set when RAID is in resync state
resync_status => $ERRORS{WARNING},
# Status code to use when no raid volumes were detected
noraid_status => $ERRORS{UNKNOWN},
# status to set when RAID is in check state
check_status => $ERRORS{OK},
# status to set when PD is spare
spare_status => $ERRORS{OK},
# status to set when BBU is in learning cycle.
bbulearn_status => $ERRORS{WARNING},
# status to set when Write Cache has failed.
cache_fail_status => $ERRORS{WARNING},
# check status of BBU
bbu_monitoring => 0,
);
# return list of programs this plugin needs
# @internal
sub program_names {
}
# return hash of canonical commands that plugin can use
# @internal
sub commands {
{}
}
# return sudo rules if program needs it
# may be SCALAR or LIST of scalars
# @internal
sub sudo {
();
}
# constructor for plugins
sub new {
my $class = shift;
croak 'Odd number of elements in argument hash' if @_ % 2;
croak 'Class is already a reference' if ref $class;
# convert to hash
my %args = @_;
# merge 'options' from param and class defaults
my %opts = %options;
%opts = (%options, %{$args{options}}) if $args{options};
delete $args{options};
# merge commands
my %commands = %{$class->commands};
%commands = (%commands, %{$args{commands}}) if $args{commands};
delete $args{commands};
my $self = {
commands => \%commands,
sudo => $class->sudo ? find_sudo() : '',
options => \%opts,
%args,
# name of the plugin, without package namespace
name => ($class =~ /.*::([^:]+)$/),
status => undef,
message => undef,
perfdata => undef,
longoutput => undef,
};
my $this = bless $self, $class;
# lookup program, if not defined by params
if (!$self->{program}) {
$self->{program} = which($this->program_names);
}
return $this;
}
# see if plugin is active (disabled or no tools available)
sub active {
my $this = shift;
# no tool found, return false
return 0 unless $this->{program};
# program file must exist, don't check for execute bit. #104
-f $this->{program};
}
# set status code for plugin result
# does not overwrite status with lower value
# returns the current status code
sub status {
my ($this, $status) = @_;
if (defined $status) {
$this->{status} = $status unless defined($this->{status}) and $status < $this->{status};
}
$this->{status};
}
sub set_critical_as_warning {
$ERRORS{CRITICAL} = $ERRORS{WARNING};
}
# helper to set status to WARNING
# returns $this to allow fluent api
sub warning {
my ($this) = @_;
$this->status($ERRORS{WARNING});
return $this;
}
# helper to set status to CRITICAL
# returns $this to allow fluent api
sub critical {
my ($this) = @_;
$this->status($ERRORS{CRITICAL});
return $this;
}
# helper to set status to UNKNOWN
# returns $this to allow fluent api
sub unknown {
my ($this) = @_;
$this->status($ERRORS{UNKNOWN});
return $this;
}
# helper to set status to OK
sub ok {
my ($this) = @_;
$this->status($ERRORS{OK});
return $this;
}
# helper to set status for resync
# returns $this to allow fluent api
sub resync {
my ($this) = @_;
$this->status($this->{options}{resync_status});
return $this;
}
# helper to set status for check
# returns $this to allow fluent api
sub check_status {
my ($this) = @_;
$this->status($this->{options}{check_status});
return $this;
}
# helper to set status for no raid condition
# returns $this to allow fluent api
sub noraid {
my ($this) = @_;
$this->status($this->{options}{noraid_status});
return $this;
}
# helper to set status for spare
# returns $this to allow fluent api
sub spare {
my ($this) = @_;
$this->status($this->{options}{spare_status});
return $this;
}
# helper to set status for BBU learning cycle
# returns $this to allow fluent api
sub bbulearn {
my ($this) = @_;
$this->status($this->{options}{bbulearn_status});
return $this;
}
# helper to set status when Write Cache fails
# returns $this to allow fluent api
sub cache_fail {
my ($this) = @_;
$this->status($this->{options}{cache_fail_status});
return $this;
}
# helper to get/set bbu monitoring
sub bbu_monitoring {
my ($this, $val) = @_;
if (defined $val) {
$this->{options}{bbu_monitoring} = $val;
}
$this->{options}{bbu_monitoring};
}
# setup status message text
sub message {
my ($this, $message) = @_;
if (defined $message) {
# TODO: append if already something there
$this->{message} = $message;
}
$this->{message};
}
# Set performance data output.
sub perfdata {
my ($this, $perfdata) = @_;
if (defined $perfdata) {
# TODO: append if already something there
$this->{perfdata} = $perfdata;
}
$this->{perfdata};
}
# Set plugin long output.
sub longoutput {
my ($this, $longoutput) = @_;
if (defined $longoutput) {
# TODO: append if already something there
$this->{longoutput} = $longoutput;
}
$this->{longoutput};
}
# a helper to join similar statuses for items
# instead of printing
# 0: OK, 1: OK, 2: OK, 3: NOK, 4: OK
# it would print
# 0-2,4: OK, 3: NOK
# takes as input list:
# { status => @items }
sub join_status {
my $this = shift;
my %status = %{$_[0]};
my @status;
for my $status (sort {$a cmp $b} keys %status) {
my $disks = $status{$status};
my @s;
foreach my $disk (@$disks) {
push(@s, $disk);
}
push(@status, join(',', @s).'='.$status);
}
return join ' ', @status;
}
# return true if parameter is not in ignore list
sub valid {
my $this = shift;
my ($v) = lc $_[0];
foreach (@utils::ignore) {
return 0 if lc $_ eq $v;
}
return 1;
}
use constant K => 1024;
use constant M => K * 1024;
use constant G => M * 1024;
use constant T => G * 1024;
sub format_bytes {
my $this = shift;
my ($bytes) = @_;
if ($bytes > T) {
return sprintf("%.2f TiB", $bytes / T);
}
if ($bytes > G) {
return sprintf("%.2f GiB", $bytes / G);
}
if ($bytes > M) {
return sprintf("%.2f MiB", $bytes / M);
}
if ($bytes > K) {
return sprintf("%.2f KiB", $bytes / K);
}
return "$bytes B";
}
# disable sudo temporarily
sub nosudo_cmd {
my ($this, $command, $cb) = @_;
my ($res, @res);
my $sudo = $this->{sudo};
$this->{sudo} = 0;
if (wantarray) {
@res = $this->cmd($command, $cb);
} else {
$res = $this->cmd($command, $cb);
}
$this->{sudo} = $sudo;
return wantarray ? @res : $res;
}
# build up command for $command
# returns open filehandle to process output
# if command fails, program is exited (caller needs not to worry)
sub cmd {
my ($this, $command, $cb) = @_;
my $debug = $App::Monitoring::Plugin::CheckRaid::Utils::debug;
# build up command
my @CMD = $this->{program};
# add sudo if program needs
unshift(@CMD, @{$this->{sudo}}) if $> and $this->{sudo};
my $args = $this->{commands}{$command} or croak "command '$command' not defined";
# callback to replace args in command
my $cb_ = sub {
my $param = shift;
if ($cb) {
if (ref $cb eq 'HASH' and exists $cb->{$param}) {
return wantarray ? @{$cb->{$param}} : $cb->{$param};
}
return &$cb($param) if ref $cb eq 'CODE';
}
if ($param eq '@CMD') {
# command wanted, but not found
croak "Command for $this->{name} not found" unless defined $this->{program};
return @CMD;
}
return $param;
};
# add command arguments
my @cmd;
for my $arg (@$args) {
local $_ = $arg;
# can't do arrays with s///
# this limits that @arg must be single argument
if (/@/) {
push(@cmd, $cb_->($_));
} else {
s/([\$]\w+)/$cb_->($1)/ge;
push(@cmd, $_);
}
}
my $op = shift @cmd;
my $fh;
if ($op eq '=' and ref $cb eq 'SCALAR') {
# Special: use open2
use IPC::Open2;
warn "DEBUG EXEC: $op @cmd" if $debug;
my $pid = open2($fh, $$cb, @cmd) or croak "open2 failed: @cmd: $!";
} elsif ($op eq '>&2') {
# Special: same as '|-' but reads both STDERR and STDOUT
use IPC::Open3;
warn "DEBUG EXEC: $op @cmd" if $debug;
my $pid = open3(undef, $fh, $cb, @cmd);
} else {
warn "DEBUG EXEC: @cmd" if $debug;
open($fh, $op, @cmd) or croak "open failed: @cmd: $!";
}
# for dir handles, reopen as opendir
if (-d $fh) {
undef($fh);
warn "DEBUG OPENDIR: $cmd[0]" if $debug;
opendir($fh, $cmd[0]) or croak "opendir failed: @cmd: $!";
}
return $fh;
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGIN
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/aaccli.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_AACCLI';
package App::Monitoring::Plugin::CheckRaid::Plugins::aaccli;
# Adaptec ServeRAID
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub program_names {
shift->{name};
}
sub commands {
{
'container list' => ['=', '@CMD'],
}
}
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
my $cmd = $this->{program};
"CHECK_RAID ALL=(root) NOPASSWD: $cmd container list /full"
}
sub check {
my $this = shift;
# status messages pushed here
my @status;
my $write = "";
$write .= "open aac0\n";
$write .= "container list /full\n";
$write .= "exit\n";
my $read = $this->cmd('container list', \$write);
#File foo receiving all output.
#
#AAC0>
#COMMAND: container list /full=TRUE
#Executing: container list /full=TRUE
#Num Total Oth Stripe Scsi Partition Creation
#Label Type Size Ctr Size Usage C:ID:L Offset:Size State RO Lk Task Done% Ent Date Time
#----- ------ ------ --- ------ ------- ------ ------------- ------- -- -- ------- ------ --- ------ --------
# 0 Mirror 74.5GB Open 0:02:0 64.0KB:74.5GB Normal 0 051006 13:48:54
# /dev/sda Auth 0:03:0 64.0KB:74.5GB Normal 1 051006 13:48:54
#
#
#AAC0>
#COMMAND: logfile end
#Executing: logfile end
while (<$read>) {
if (my($dsk, $stat) = /(\d:\d\d?:\d+)\s+\S+:\S+\s+(\S+)/) {
next unless $this->valid($dsk);
$dsk =~ s#:#/#g;
next unless $this->valid($dsk);
push(@status, "$dsk:$stat");
$this->critical if ($stat eq "Broken");
$this->warning if ($stat eq "Rebuild");
$this->warning if ($stat eq "Bld/Vfy");
$this->critical if ($stat eq "Missing");
if ($stat eq "Verify") {
$this->resync;
}
$this->warning if ($stat eq "VfyRepl");
}
}
close $read;
return unless @status;
$this->message(join(', ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_AACCLI
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/afacli.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_AFACLI';
package App::Monitoring::Plugin::CheckRaid::Plugins::afacli;
# Adaptec AACRAID
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub program_names {
shift->{name};
}
sub commands {
{
'container list' => ['=', '@CMD'],
}
}
sub check {
my $this = shift;
# status messages pushed here
my @status;
my $write = "";
$write .= "open afa0\n";
$write .= "container list /full\n";
$write .= "exit\n";
my $read = $this->cmd('container list', \$write);
while (<$read>) {
# 0 Mirror 465GB Valid 0:00:0 64.0KB: 465GB Normal 0 032511 17:55:06
# /dev/sda root 0:01:0 64.0KB: 465GB Normal 1 032511 17:55:06
if (my($dsk, $stat) = /(\d:\d\d?:\d+)\s+\S+:\s?\S+\s+(\S+)/) {
next unless $this->valid($dsk);
$dsk =~ s#:#/#g;
next unless $this->valid($dsk);
push(@status, "$dsk:$stat");
$this->critical if ($stat eq "Broken");
$this->warning if ($stat eq "Rebuild");
$this->warning if ($stat eq "Bld/Vfy");
$this->critical if ($stat eq "Missing");
if ($stat eq "Verify") {
$this->resync;
}
$this->warning if ($stat eq "VfyRepl");
}
}
close $read;
return unless @status;
$this->ok->message(join(', ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_AFACLI
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/arcconf.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_ARCCONF';
package App::Monitoring::Plugin::CheckRaid::Plugins::arcconf;
# Adaptec AAC-RAID
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub program_names {
shift->{name};
}
sub commands {
{
'getstatus' => ['-|', '@CMD', 'GETSTATUS', '1'],
# 'nologs' does not exist in arcconf 6.50. #118
'getconfig' => ['-|', '@CMD', 'GETCONFIG', '$ctrl', 'AL'],
}
}
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
my $cmd = $this->{program};
(
"CHECK_RAID ALL=(root) NOPASSWD: $cmd GETSTATUS 1",
"CHECK_RAID ALL=(root) NOPASSWD: $cmd GETCONFIG * AL",
);
}
sub parse_error {
my ($this, $message) = @_;
warn "arcconf: parse error: $message";
$this->unknown->message("Parse Error: $message");
}
# parse GETSTATUS command
# parses
# - number of controllers
# - logical device tasks (if any running)
sub parse_status {
my ($this) = @_;
my $count = 0;
my $ok = 0;
my $fh = $this->cmd('getstatus');
my %s;
# controller task
my %task;
while (<$fh>) {
chomp;
# empty line or comment
next if /^$/ or /^#/;
# termination
if (/^Command completed successfully/) {
$ok = 1;
last;
}
if (my($c) = /^Controllers [Ff]ound: (\d+)/) {
$count = int($c);
next;
}
if (/^(\S.+) Task:$/) {
$task{type} = $1;
next;
}
if (/^\s+Logical device\s+: (\d+)/) {
$task{device} = $1;
} elsif (/^\s+Task ID\s+: (\d+)/) {
$task{id} = $1;
} elsif (/^\s+Current operation\s+: (.+)/) {
$task{operation} = $1;
} elsif (/^\s+Status\s+: (.+)/) {
$task{status} = $1;
} elsif (/^\s+Priority\s+: (.+)/) {
$task{priority} = $1;
} elsif (/^\s+Percentage complete\s+: (\d+)/) {
$task{percent} = $1;
} elsif (/^Invalid controller number/) {
;
} else {
warn "Unknown line: [$_]";
# FIXME: ->message() gets overwritten later on
$this->unknown->message("Unknown line: [$_]");
}
}
close($fh);
# Tasks seem to be Controller specific, but as we don't support over one controller, let it be global
$s{tasks} = { %task } if %task;
if ($count == 0) {
# if command completed, but no controllers,
# assume no hardware present
if (!$ok) {
$this->unknown->message("No controllers found!");
}
return undef;
}
$s{ctrl_count} = $count;
return \%s;
}
# parse GETCONFIG for all controllers
sub parse_config {
my ($this, $status) = @_;
my %c;
for (my $i = 1; $i <= $status->{ctrl_count}; $i++) {
$c{$i} = $this->parse_ctrl_config($i, $status->{ctrl_count});
}
return { controllers => \%c };
}
# parse GETCONFIG command for specific controller
sub parse_ctrl_config {
my ($this, $ctrl, $ctrl_count) = @_;
# Controller information, Logical/Physical device info
my ($ld, $ch, $pd);
my $res = { controller => {}, logical => [], physical => [] };
my $fh = $this->cmd('getconfig', { '$ctrl' => $ctrl });
my ($section, $subsection, $ok);
my %sectiondata = ();
# called when data for section needs to be processed
my $flush = sub {
my $method = 'process_' . lc($section);
$method =~ s/[.\s]+/_/g;
$this->$method($res, \%sectiondata);
%sectiondata = ();
};
my $subsection_reset = sub {
$ch = 0;
undef($ld);
undef($pd);
undef($subsection);
};
while (<$fh>) {
chomp;
# empty line or comment
if (/^$/ or /^#/) {
&$subsection_reset;
next;
}
if (/^Command completed successfully/) {
$ok = 1;
last;
}
if (my($c) = /^Controllers [Ff]ound: (\d+)/) {
if ($c != $ctrl_count) {
# internal error?!
$this->unknown->message("Controller count mismatch");
}
next;
}
# section start
if (/^---+/) {
if (my($s) = <$fh> =~ /^(\w.+)$/) {
# flush the lines
if (defined($section)) {
&$flush();
}
$section = $s;
unless (<$fh> =~ /^---+/) {
$this->parse_error($_);
}
&$subsection_reset;
next;
}
$this->parse_error($_);
}
# sub section start
# there are also sections in subsections, but currently section names
# are unique enough
if (/^\s+---+/) {
if (my($s) = <$fh> =~ /^\s+(\S.+?)\s*?$/) {
$subsection = $s;
unless (<$fh> =~ /^\s+---+/) {
$this->parse_error($_);
}
next;
}
$this->parse_error($_);
}
warn("SKIP without section: [$_]\n"),next unless defined $section;
# regex notes:
# - value portion may be missing
# - value may be empty
# - value may be truncated (t/data/arcconf/issue47/getconfig)
my ($key, $value) = /^\s*(.+?)(?:\s+:\s*(.*?))?$/;
if ($section =~ /Controller [Ii]nformation/) {
if (not defined $subsection) {
$sectiondata{$key} = $value;
} else {
$sectiondata{$subsection}{$key} = $value;
}
} elsif ($section =~ /Physical Device [Ii]nformation/) {
if (my($c) = /Channel #(\d+)/) {
$ch = int($c);
undef($pd);
next;
} elsif (my($n) = /^\s+Device #(\d+)/) {
$pd = int($n);
next;
} else {
if (not defined $pd) {
$sectiondata{$ch}{$key} = $value;
} elsif (not defined $subsection) {
$sectiondata{$ch}{'pd'}{$pd}{$key} = $value;
} else {
$sectiondata{$ch}{'pd'}{$pd}{$subsection}{$key} = $value;
}
}
} elsif ($section =~ /Logical ([Dd]evice|drive) [Ii]nformation/) {
if (my($n) = /Logical (?:[Dd]evice|drive) [Nn]umber (\d+)/) {
$ld = int($n);
} else {
# skip lone line: issue87/getconfig
if (/No logical devices configured/) {
next;
}
if (not defined $ld) {
warn "LD undefined:[$_]\n";
next;
}
if (not defined $subsection) {
$sectiondata{$ld}{$key} = $value;
} else {
$sectiondata{$ld}{$subsection}{$key} = $value;
}
}
} elsif ($section eq 'MaxCache 3.0 information') {
# not parsed yet
} elsif ($section eq 'Connector information') {
# not parsed yet
} else {
warn "NOT PARSED: [$section] [$_]";
}
}
close $fh;
&$flush() if $section;
$this->unknown->message("Command did not succeed") unless defined $ok;
return $res;
}
# Process Controller Information section
sub process_controller_information {
my ($this, $res, $data) = @_;
my $c = {};
my $s;
# current section
my $cs = $data;
$c->{status} = $cs->{'Controller Status'};
if (exists $cs->{$s = 'Defunct Disk Drive Count'} || exists $cs->{$s = 'Defunct disk drive count'}) {
$c->{defunct_count} = int($cs->{$s});
}
if ($s = $cs->{'Logical devices/Failed/Degraded'}) {
my($td, $fd, $dd) = $s =~ m{(\d+)/(\d+)/(\d+)};
$c->{logical_count} = int($td);
$c->{logical_failed} = int($fd);
$c->{logical_degraded} = int($dd);
}
# ARCCONF 9.30: Logical drives/Offline/Critical
if ($s = $cs->{'Logical drives/Offline/Critical'}) {
my($td2, $fd2, $dd2) = $s =~ m{(\d+)/(\d+)/(\d+)};
$c->{logical_count} = int($td2);
$c->{logical_offline} = int($fd2);
$c->{logical_critical} = int($dd2);
}
$cs = $data->{'Controller Battery Information'};
$c->{battery_status} = $cs->{Status} if exists $cs->{Status};
$c->{battery_overtemp} = $cs->{'Over temperature'} if exists $cs->{'Over temperature'};
if ($s = $cs->{'Capacity remaining'}) {
my ($bc) = $s =~ m{(\d+)\s*percent.*$};
$c->{battery_capacity} = int($bc);
}
if ($s = $cs->{'Time remaining (at current draw)'}) {
my($d, $h, $m) = $s =~ /(\d+) days, (\d+) hours, (\d+) minutes/;
$c->{battery_time} = int($d) * 1440 + int($h) * 60 + int($m);
$c->{battery_time_full} = "${d}d${h}h${m}m";
}
$cs = $data->{'Controller ZMM Information'};
$c->{zmm_status} = $cs->{Status} if exists $cs->{'Status'};
$res->{controller} = $c;
}
sub process_logical_device_information {
my ($this, $res, $data) = @_;
my $s;
my @ld;
while (my($ld, $cs) = each %$data) {
$ld[$ld]{id} = $ld;
if (exists $cs->{$s = 'RAID Level'} || exists $cs->{$s = 'RAID level'}) {
$ld[$ld]{raid} = $cs->{$s};
}
$ld[$ld]{size} = $cs->{'Size'};
$ld[$ld]{failed_stripes} = $cs->{'Failed stripes'} if exists $cs->{'Failed stripes'};
$ld[$ld]{defunct_segments} = $cs->{'Defunct segments'} if exists $cs->{'Defunct segments'};
if ($s = $cs->{'Status of Logical Device'} || $cs->{'Status of logical device'} || $cs->{'Status of logical drive'}) {
$ld[$ld]{status} = $s;
}
if ($s = $cs->{'Logical Device name'} || $cs->{'Logical device name'} || $cs->{'Logical drive name'}) {
$ld[$ld]{name} = $s;
}
# Write-cache mode : Not supported]
# Partitioned : Yes]
# Number of segments : 2]
# Drive(s) (Channel,Device) : 0,0 0,1]
# Defunct segments : No]
}
$res->{logical} = \@ld;
}
sub process_physical_device_information {
my ($this, $res, $data) = @_;
# Keys with no values:
# "Device #0"
# "Device is a Hard drive"
#
# ignored:
# /Transfer Speed\s+:\s+(.+)/
# /Initiator at SCSI ID/
# /No physical drives attached/
my (@pd, $cs, $s);
while (my($ch, $channel_data) = each %$data) {
while (my($pd, $cs) = each %{$channel_data->{pd}}) {
$pd[$ch][$pd]{device_id} = $pd;
$pd[$ch][$pd]{power_state} = $cs->{'Power State'} if exists $cs->{'Power State'};
$pd[$ch][$pd]{status} = $cs->{'State'} if exists $cs->{'State'};
$pd[$ch][$pd]{supported} = $cs->{'Supported'} if exists $cs->{'Supported'};
$pd[$ch][$pd]{spare} = $cs->{'Dedicated Spare for'} if exists $cs->{'Dedicated Spare for'};
$pd[$ch][$pd]{model} = $cs->{'Model'};
$pd[$ch][$pd]{serial} = $cs->{'Serial number'} if exists $cs->{'Serial number'};
$pd[$ch][$pd]{wwn} = $cs->{'World-wide name'} if exists $cs->{'World-wide name'};
$pd[$ch][$pd]{write_cache} = $cs->{'Write Cache'} if exists $cs->{'Write Cache'};
$pd[$ch][$pd]{ssd} = $cs->{'SSD'} if exists $cs->{'SSD'};
$pd[$ch][$pd]{fru} = $cs->{'FRU'} if exists $cs->{'FRU'};
$pd[$ch][$pd]{ncq} = $cs->{'NCQ status'} if exists $cs->{'NCQ status'};
$pd[$ch][$pd]{pfa} = $cs->{'PFA'} if exists $cs->{'PFA'};
$pd[$ch][$pd]{enclosure} = $cs->{'Enclosure ID'} if exists $cs->{'Enclosure ID'};
$pd[$ch][$pd]{type} = $cs->{'Type'} if exists $cs->{'Type'};
$pd[$ch][$pd]{smart} = $cs->{'S.M.A.R.T.'} if exists $cs->{'S.M.A.R.T.'};
$pd[$ch][$pd]{smart_warn} = $cs->{'S.M.A.R.T. warnings'} if exists $cs->{'S.M.A.R.T. warnings'};
$pd[$ch][$pd]{speed} = $cs->{'Transfer Speed'} if $cs->{'Transfer Speed'};
$pd[$ch][$pd]{power_states} = $cs->{'Supported Power States'} if exists $cs->{'Supported Power States'};
$pd[$ch][$pd]{fail_ldev_segs} = $cs->{'Failed logical device segments'} if exists $cs->{'Failed logical device segments'};
# allow edits, i.e removed 'Vendor'/'Firmware' value from test data
$pd[$ch][$pd]{vendor} = $cs->{'Vendor'} || '';
$pd[$ch][$pd]{firmware} = $cs->{'Firmware'} if exists $cs->{'Firmware'};
# previous parser was not exact line match
if ($s = $cs->{'Size'} || $cs->{'Total Size'}) {
$pd[$ch][$pd]{size} = $s;
}
$s = $cs->{'Reported ESD'} || $cs->{'Reported ESD(T:L)'};
$pd[$ch][$pd]{esd} = $s if $s;
if ($s = $cs->{'Reported Location'}) {
my($e, $s) = $s =~ /(?:Enclosure|Connector) (\d+), (?:Slot|Device) (\d+)/;
$pd[$ch][$pd]{location} = "$e:$s";
}
if ($s = $cs->{'Reported Channel,Device'} || $cs->{'Reported Channel,Device(T:L)'}) {
$pd[$ch][$pd]{cd} = $s;
}
if (exists $cs->{$s = 'Device is a Hard drive'}
|| exists $cs->{$s = 'Device is an Enclosure'}
|| exists $cs->{$s = 'Device is an Enclosure services device'}
|| exists $cs->{$s = 'Device is an Enclosure Services Device'}
) {
($pd[$ch][$pd]{devtype}) = $s =~ /Device is an?\s+(.+)/;
}
# TODO: normalize and other formats:
# Current Temperature : 27 deg C
# Life-time Temperature Recorded
# Temperature : 51 C/ 123 F (Normal)
# Temperature : Normal
# Temperature : Not Supported
# Temperature Sensor Status 1 : 21 C/ 69 F (Normal)
# Temperature Sensor Status 1 : 23 C/ 73 F (Normal)
# Temperature Sensor Status 1 : 27 C/ 80 F (Normal)
# Temperature Sensor Status 1 : 46 C/ 114 F (Abnormal)
# Temperature status : Normal
# Threshold Temperature : 51 deg C
# FIXME: previous code used last line with /Temperature/ match
if ($s = $cs->{'Temperature'} || $cs->{'Temperature Sensor Status 1'} || $cs->{'Temperature status'}) {
$pd[$ch][$pd]{temperature} = $s;
}
# ignored:
# Status of Enclosure
# (Fan \d+|Speaker) status/
# /Expander ID\s+:/
# /Enclosure Logical Identifier\s+:/
# /Expander SAS Address\s+:/
# /[Mm]axCache (Capable|Assigned)\s+:\s+(.+)/
# /Power supply \d+ status/
}
}
$res->{physical} = \@pd;
}
sub process_logical_drive_information {
shift->process_logical_device_information(@_);
}
sub process_maxcache_3_0_information {
}
# TODO: issue152/arc2_getconfig.txt
sub process_connector_information {
}
# NB: side effect: ARCCONF changes current directory to /var/log
sub parse {
my ($this) = @_;
# we chdir to /var/log, as tool is creating 'UcliEvt.log'
# this can be disabled with 'nologs' parameter, but not sure do all versions support it
chdir('/var/log') || chdir('/');
my ($status, $config);
$status = $this->parse_status or return;
$config = $this->parse_config($status) or return;
return { %$status, %$config };
}
# check for controller status
sub check_controller {
my ($this, $c) = @_;
my @status;
$this->critical if $c->{status} !~ /Optimal|Okay|OK/;
push(@status, "Controller:$c->{status}");
if ($c->{defunct_count} > 0) {
$this->critical;
push(@status, "Defunct drives:$c->{defunct_count}");
}
if (defined $c->{logical_failed} && $c->{logical_failed} > 0) {
$this->critical;
push(@status, "Failed drives:$c->{logical_failed}");
}
if (defined $c->{logical_degraded} && $c->{logical_degraded} > 0) {
$this->critical;
push(@status, "Degraded drives:$c->{logical_degraded}");
}
if (defined $c->{logical_offline} && $c->{logical_offline} > 0) {
$this->critical;
push(@status, "Offline drives:$c->{logical_offline}");
}
if (defined $c->{logical_critical} && $c->{logical_critical} > 0) {
$this->critical;
push(@status, "Critical drives:$c->{logical_critical}");
}
# ZMM (Zero-Maintenance Module) status
if (defined($c->{zmm_status})) {
push(@status, "ZMM Status: $c->{zmm_status}");
}
# Battery status
if ($this->bbu_monitoring) {
my @s = $this->battery_status($c);
push(@status, @s) if @s;
}
return @status;
}
# check for physical devices
sub check_physical {
my ($this, $p) = @_;
my %pd;
$this->{pd_resync} = 0;
for my $ch (@$p) {
for my $pd (@{$ch}) {
# skip not disks
next if not defined $pd;
next if $pd->{devtype} =~ m/Enclosure/;
if ($pd->{status} eq 'Rebuilding') {
$this->resync;
$this->{pd_resync}++;
} elsif ($pd->{status} eq 'Dedicated Hot-Spare') {
$this->spare;
$pd->{status} = "$pd->{status} for $pd->{spare}";
} elsif ($pd->{status} !~ /^Online|Hot[- ]Spare|Ready/) {
$this->critical;
}
my $id = $pd->{serial} || $pd->{wwn} || $pd->{location} || $pd->{cd};
push(@{$pd{$pd->{status}}}, $id);
}
}
return \%pd;
}
# check for logical devices
sub check_logical {
my ($this, $l) = @_;
my @status;
for my $ld (@$l) {
next unless $ld; # FIXME: fix that script assumes controllers start from '0'
if ($ld->{status} eq 'Degraded' && $this->{pd_resync}) {
$this->warning;
} elsif ($ld->{status} !~ /Optimal|Okay/) {
$this->critical;
}
my $id = $ld->{id};
if ($ld->{name}) {
$id = "$id($ld->{name})";
}
push(@status, "Logical Device $id:$ld->{status}");
if (defined $ld->{failed_stripes} && $ld->{failed_stripes} ne 'No') {
push(@status, "Failed stripes: $ld->{failed_stripes}");
}
if (defined $ld->{defunct_segments} && $ld->{defunct_segments} ne 'No') {
push(@status, "Defunct segments: $ld->{defunct_segments}");
}
}
return @status;
}
sub check {
my $this = shift;
my $data = $this->parse;
$this->unknown,return unless $data;
my @status;
for my $i (sort {$a cmp $b} keys %{$data->{controllers}}) {
my $c = $data->{controllers}->{$i};
push(@status, $this->check_controller($c->{controller}));
# current (logical device) tasks
if ($data->{tasks}->{operation} ne 'None') {
# just print it. no status change
my $task = $data->{tasks};
push(@status, "$task->{type} #$task->{device}: $task->{operation}: $task->{status} $task->{percent}%");
}
# check physical first, as it setups pd_resync flag
my $pd = $this->check_physical($c->{physical});
push(@status, $this->check_logical($c->{logical}));
# but report after logical devices
push(@status, "Drives: ".$this->join_status($pd)) if $pd;
}
$this->ok->message(join(', ', @status));
}
# check battery status in $c
sub battery_status {
my ($this, $c) = @_;
my @status;
if (!defined($c->{battery_status}) || $c->{battery_status} eq 'Not Installed') {
return;
}
push(@status, "Battery Status: $c->{battery_status}");
# if battery status is 'Failed', none of the details below are available. #105
if ($c->{battery_status} eq 'Failed') {
$this->critical;
return @status;
}
# detailed battery checks
if ($c->{battery_overtemp} ne 'No') {
$this->critical;
push(@status, "Battery Overtemp: $c->{battery_overtemp}");
}
push(@status, "Battery Capacity Remaining: $c->{battery_capacity}%");
if ($c->{battery_capacity} < 50) {
$this->critical;
}
if ($c->{battery_capacity} < 25) {
$this->warning;
}
if ($c->{battery_time} < 1440) {
$this->warning;
}
if ($c->{battery_time} < 720) {
$this->critical;
}
if ($c->{battery_time} < 60) {
push(@status, "Battery Time: $c->{battery_time}m");
} else {
push(@status, "Battery Time: $c->{battery_time_full}");
}
return @status;
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_ARCCONF
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/areca.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_ARECA';
package App::Monitoring::Plugin::CheckRaid::Plugins::areca;
## Areca SATA RAID Support
## requires cli64 or cli32 binaries
## For links to manuals and binaries, see this issue:
## https://github.com/glensc/nagios-plugin-check_raid/issues/10
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub program_names {
qw(areca-cli areca_cli64 areca_cli32 cli64 cli32);
}
sub commands {
{
'rsf info' => ['-|', '@CMD', 'rsf', 'info'],
'disk info' => ['-|', '@CMD', 'disk', 'info'],
}
}
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
my $cmd = $this->{program};
(
"CHECK_RAID ALL=(root) NOPASSWD: $cmd rsf info",
"CHECK_RAID ALL=(root) NOPASSWD: $cmd disk info",
);
}
# plugin check
# can store its exit code in $this->status
# can output its message in $this->message
sub check {
my $this = shift;
## Check Array Status
my (@status, %arrays);
my $fh = $this->cmd('rsf info');
while (<$fh>) {
=cut
# Name Disks TotalCap FreeCap MinDiskCap State
# Name Disks TotalCap FreeCap DiskChannels State
===============================================================================
1 Raid Set # 000 23 34500.0GB 0.0GB 1500.0GB Normal
1 Raid Set # 00 15 15000.0GB 0.0GB 123G567C9AB48EF Normal
1 data 15 11250.0GB 0.0GB 123456789ABCDEF Normal
1 data 15 11250.0GB 0.0GB 123456789ABCDEF Initializing
===============================================================================
=cut
next unless (my($id, $n, $s) = m{^
\s*(\d+) # Id
\s+(.+) # Name
\s+\d+ # Disks
\s+\S+ # TotalCap
\s+\S+ # FreeCap
\s+\S+ # MinDiskCap/DiskChannels
\s+(\S+)\s* # State
$}x);
# trim trailing spaces from name
$n =~ s/\s+$//;
if ($s =~ /[Rr]e[Bb]uild/) {
$this->warning;
} elsif ($s !~ /[Nn]ormal|[Rr]e[Bb]uild|Checking|Initializing/) {
$this->critical;
}
push(@status, "Array#$id($n): $s");
$arrays{$n} = [ $id, $s ];
}
close $fh;
## Check Drive Status
$fh = $this->cmd('disk info');
my %drivestatus;
while (<$fh>) {
chomp;
=cut
# Enc# Slot# ModelName Capacity Usage
===============================================================================
1 01 Slot#1 N.A. 0.0GB N.A.
8 01 Slot#8 N.A. 0.0GB N.A.
9 02 SLOT 01 ST31500341AS 1500.3GB Raid Set # 000
11 02 SLOT 03 ST31500341AS 1500.3GB Raid Set # 000
# Ch# ModelName Capacity Usage
===============================================================================
1 1 ST31000340NS 1000.2GB Raid Set # 00
6 6 ST31000340NS 1000.2GB Raid Set # 00
3 3 WDC WD7500AYYS-01RCA0 750.2GB data
4 4 WDC WD7500AYYS-01RCA0 750.2GB data
16 16 WDC WD7500AYYS-01RCA0 750.2GB HotSpare[Global]
=cut
next unless my($id, $model, $usage) = m{^
\s*(\d+) # Id
\s+\d+ # Channel/Enclosure (not reliable, tests 1,2,12 differ)
\s+(.+) # ModelName
\s+\d+.\d\S+ # Capacity
\s+(.+) # Usage (Raid Name)
}x;
# trim trailing spaces from name
$usage =~ s/\s+$//;
# Asssume model N.A. means the slot not in use
# we could also check for Capacity being zero, but this seems more
# reliable.
next if $usage eq 'N.A.';
# use array id in output: shorter
my $array_id = defined($arrays{$usage}) ? ($arrays{$usage})->[0] : undef;
my $array_name = defined $array_id ? "Array#$array_id" : $usage;
# assume critical if Usage is not one of:
# - existing Array name
# - HotSpare
# - Rebuild
if (defined($arrays{$usage})) {
# Disk in Array named $usage
push(@{$drivestatus{$array_name}}, $id);
} elsif ($usage =~ /[Rr]e[Bb]uild/) {
# rebuild marks warning
push(@{$drivestatus{$array_name}}, $id);
$this->warning;
} elsif ($usage =~ /HotSpare/) {
# hotspare is OK
push(@{$drivestatus{$array_name}}, $id);
} elsif ($usage =~ /Pass Through/) {
# Pass Through is OK
push(@{$drivestatus{$array_name}}, $id);
} else {
push(@{$drivestatus{$array_name}}, $id);
$this->critical;
}
}
close $fh;
push(@status, "Drive Assignment: ".$this->join_status(\%drivestatus)) if %drivestatus;
$this->ok->message(join(', ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_ARECA
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/cciss.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_CCISS';
package App::Monitoring::Plugin::CheckRaid::Plugins::cciss;
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use App::Monitoring::Plugin::CheckRaid::Plugins::lsscsi;
use App::Monitoring::Plugin::CheckRaid::Plugins::smartctl;
use strict;
use warnings;
sub program_names {
'cciss_vol_status';
}
sub commands {
{
'controller status' => ['-|', '@CMD', '@devs'],
'controller status verbose' => ['-|', '@CMD', '-V', '@devs'],
'cciss_vol_status version' => ['>&2', '@CMD', '-v'],
'detect hpsa' => ['<', '/sys/module/hpsa/refcnt'],
'detect cciss' => ['<', '/proc/driver/cciss'],
'cciss proc' => ['<', '/proc/driver/cciss/$controller'],
# for lsscsi, issue #109
'lsscsi list' => ['-|', '@CMD', '-g'],
}
}
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
my $cmd = $this->{program};
my $v1_10 = $this->cciss_vol_status_version >= 1.10;
my @sudo;
my @cciss_devs = $this->detect;
if (@cciss_devs) {
my $c = join(' ', @cciss_devs);
if ($v1_10) {
push(@sudo, "CHECK_RAID ALL=(root) NOPASSWD: $cmd -V $c");
} else {
push(@sudo, "CHECK_RAID ALL=(root) NOPASSWD: $cmd $c");
}
}
my @cciss_disks = $this->detect_disks(@cciss_devs);
if (!$v1_10 && @cciss_disks) {
my $smartctl = App::Monitoring::Plugin::CheckRaid::Plugins::smartctl->new();
if ($smartctl->active) {
my $cmd = $smartctl->{program};
foreach my $ref (@cciss_disks) {
my ($dev, $diskopt, $disk) = @$ref;
# escape comma for sudo
$diskopt =~ s/,/\\$&/g;
push(@sudo, "CHECK_RAID ALL=(root) NOPASSWD: $cmd -H $dev $diskopt$disk");
}
}
}
return @sudo;
}
# detects if hpsa (formerly cciss) is present in system
sub detect {
my $this = shift;
my ($fh, @devs);
# try lsscsi first if enabled and allowed
my $lsscsi = App::Monitoring::Plugin::CheckRaid::Plugins::lsscsi->new('commands' => $this->{commands});
my $use_lsscsi = defined($this->{use_lsscsi}) ? $this->{use_lsscsi} : $lsscsi->active;
if ($use_lsscsi) {
# for cciss_vol_status < 1.10 we need /dev/sgX nodes, columns which are type storage
@devs = $lsscsi->list_sg;
# cciss_vol_status 1.10 can process disk nodes too even if sg is not present
my $v1_10 = $this->cciss_vol_status_version >= 1.10;
if (!@devs && $v1_10) {
@devs = $lsscsi->list_dd;
}
return wantarray ? @devs : \@devs if @devs;
}
# check hpsa devs
eval { $fh = $this->cmd('detect hpsa'); };
if ($fh) {
my $refcnt = <$fh>;
close $fh;
if ($refcnt) {
# TODO: how to figure which sgX is actually in use?
# for now we collect all, and expect cciss_vol_status to ignore unknowns
# refcnt seems to match number of sg devs: /sys/class/scsi_generic/sg*
for (my $i = 0; $i < $refcnt; $i++) {
my $dev = "/dev/sg$i";
# filter via valid() so could exclude devs
push(@devs, $dev) if $this->valid($dev);
}
}
}
undef($fh);
# check legacy cciss devs
eval { $fh = $this->cmd('detect cciss'); };
if ($fh) {
my @c = grep { !/^\./ } readdir($fh);
close($fh);
# find controllers
# cciss0: HP Smart Array P400i Controller
# Board ID: 0x3235103c
# Firmware Version: 4.06
# IRQ: 98
# Logical drives: 1
# Current Q depth: 0
# Current # commands on controller: 0
# Max Q depth since init: 249
# Max # commands on controller since init: 275
# Max SG entries since init: 31
# Sequential access devices: 0
#
# cciss/c0d0: 220.12GB RAID 1(1+0)
for my $c (@c) {
my $fh = $this->cmd('cciss proc', { '$controller' => $c });
while (<$fh>) {
# check "c*d0" - iterate over each controller
next unless (my($dev) = m{^(cciss/c\d+d0):});
$dev = "/dev/$dev";
# filter via valid() so could exclude devs
push(@devs, $dev) if $this->valid($dev);
}
close $fh;
}
}
undef($fh);
return wantarray ? @devs : \@devs;
}
# build list of cciss disks
# used by smartctl check
# just return all disks (0..15) for each cciss dev found
sub detect_disks {
my $this = shift;
my @devs;
# build devices list for smartctl
foreach my $scsi_dev (@_) {
foreach my $disk (0..15) {
push(@devs, [ $scsi_dev, '-dcciss,', $disk ]);
}
}
return wantarray ? @devs : \@devs;
}
# parse version out of "cciss_vol_status version 1.09"
# NOTE: it prints the output to stderr, but may print to stdout in the future
sub cciss_vol_status_version {
my $this = shift;
# cache inside single run
return $this->{cciss_vol_status_version} if defined $this->{cciss_vol_status_version};
my $version = sub {
my $fh = $this->nosudo_cmd('cciss_vol_status version');
my ($line) = <$fh>;
close $fh;
return 0 unless $line;
if (my($v) = $line =~ /^cciss_vol_status version ([\d.]+)$/) {
return 0 + $v;
}
return 0;
};
return $this->{cciss_vol_status_version} = &$version();
}
sub trim { my $s = shift; $s =~ s/^\s+|\s+$//g; return $s };
# we process until we find end of sentence (dot at the end of the line)
sub consume_diagnostic {
my ($this, $fh) = @_;
my $diagnostic = '';
while (1) {
my $s = <$fh>;
last unless $s;
chomp;
$diagnostic .= ' '. trim($s);
last if $s =~ /\.$/;
}
return trim($diagnostic);
}
# process to skip lines with physical location:
# " connector 1I box 1 bay 4 ..."
sub consume_disk_map {
my ($this, $fh) = @_;
while (my $s = <$fh>) {
chomp $s;
# connector 1I box 1 bay 4
last unless $s =~ /^\s+connector\s/;
}
}
sub parse {
my $this = shift;
my @devs = @_;
my (%c, $cdev);
# cciss_vol_status 1.10 has -V option to print more info about controller and disks.
my $v1_10 = $this->cciss_vol_status_version >= 1.10;
# add all devs at once to commandline, cciss_vol_status can do that
my $fh = $this->cmd($v1_10 ? 'controller status verbose' : 'controller status', { '@devs' => \@devs });
while (<$fh>) {
chomp;
# skip empty lines and artificial comments (added by this project)
next if /^$/ or /^#/;
if (/Controller:/) {
# this is first item when new controller is found
# reset previous state
undef $cdev;
next;
}
# catch enclosures, print_bus_status()
# /dev/cciss/c1d0: (Smart Array P800) Enclosure MSA70 (S/N: SGA651004J) on Bus 2, Physical Port 1E status: OK.
# /dev/cciss/c0d0: (Smart Array 6i) Enclosure PROLIANT 6L2I (S/N: ) on Bus 0, Physical Port J1 status: OK.
if (my($file, $board_name, $name, $sn, $bus, $port1, $port2, $status) = m{
^(/dev/[^:]+):\s # File
\(([^)]+)\)\s # Board Name
Enclosure\s(.*?)\s # Enclosure Name
\(S/N:\s(\S*)\)\s # Enclosure SN
on\sBus\s(\d+),\s # Bus Number
Physical\sPort\s(.) # physical_port1
(.)\s # physical_port2
status:\s(.*?)\. # status (without a dot)
}x) {
$c{$file}{enclosures}{$bus} = {
board_name => $board_name,
name => $name,
sn => $sn,
bus => int($bus),
phys1 => $port1,
phys2 => $port2,
status => $status,
};
next;
}
# volume status, print_volume_status()
# /dev/cciss/c0d0: (Smart Array P400i) RAID 1 Volume 0 status: OK
# /dev/sda: (Smart Array P410i) RAID 1 Volume 0 status: OK.
# /dev/sda: (Smart Array P410i) RAID 5 Volume 0 status: OK. At least one spare drive designated. At least one spare drive has failed.
if (my($file, $board_name, $raid_level, $volume_number, $certain, $status, $spare_drive_status) = m{
^(/dev/[^:]+):\s # File
\(([^)]+)\)\s # Board Name
(RAID\s\d+|\([^)]+\))\s # RAID level
Volume\s(\d+) # Volume number
(\(\?\))?\s # certain?
status:\s(.*?)\. # status (without a dot)
(.*)? # spare drive status messages
}x) {
$cdev = $file;
$c{$file}{volumes}{$volume_number} = {
board_name => $board_name,
raid_level => $raid_level,
volume_number => $volume_number,
certain => int(not defined $certain),
status => $status,
spare_drive_status => trim($spare_drive_status),
};
$c{$file}{board_name} = $board_name;
next;
}
next unless $cdev;
if (my ($count) = /Physical drives: (\d+)/) {
$c{$cdev}{'pd count'} = $count;
next;
}
# check_physical_drives(file, fd);
# NOTE: check for physical drives is enabled with -V or -s option (-V enables -s)
# cciss_vol_status.c format_phys_drive_location()
if (my ($phys1, $phys2, $box, $bay, $model, $serial_no, $fw_rev, $status) = m{
\sconnector\s(.)(.)\s # Phys connector 1&2
box\s(\d+)\s # phys_box_on_bus
bay\s(\d+)\s # phys_bay_in_box
(.{40})\s # model
(.{40})\s # serial no
(.{8})\s # fw rev
(.+) # status
$}x) {
my $slot = "$phys1$phys2-$box-$bay";
$c{$cdev}{drives}{$slot} = {
'slot' => $slot,
'phys1' => $phys1,
'phys2' => $phys2,
'box' => int($box),
'bay' => int($bay),
'model' => trim($model),
'serial' => trim($serial_no),
'fw' => trim($fw_rev),
'status' => $status,
};
next;
}
# TODO
# check_fan_power_temp(file, ctlrtype, fd, num_controllers);
# check_nonvolatile_cache_status(file, ctlrtype, fd, num_controllers);
# /dev/cciss/c0d0(Smart Array P400i:0): Non-Volatile Cache status:
if (my($file, $board_name, $instance) = m{^(/dev/[^(]+)\((.+):(\d+)\): Non-Volatile Cache status}) {
# $file and $dev may differ, so store it
$c{$cdev}{cache} = {
'file' => $file,
'board' => $board_name,
'instance' => int($instance),
};
next;
}
if (defined($c{$cdev}{cache})) {
my $cache = $c{$cdev}{cache};
my %map = (
configured => qr/Cache configured: (.+)/,
read_cache_memory => qr/Read cache memory: (.+)/,
write_cache_memory => qr/Write cache memory: (.+)/,
write_cache_enabled => qr/Write cache enabled: (.+)/,
flash_cache => qr/Flash backed cache present/,
disabled_temporarily => qr/Write cache temporarily disabled/,
disabled_permanently => qr/Write Cache permanently disabled/,
);
my $got;
while (my($k, $r) = each %map) {
next unless (my($v) = $_ =~ $r);
$cache->{$k} = $v;
$got = 1;
# consume extended diagnostic
if ($k =~ /disabled_(temporari|permanentl)ly/) {
$cache->{"$k diagnostic"} = $this->consume_diagnostic($fh);
}
}
next if $got;
}
# show_disk_map(" Failed drives:", file, fd, id, controller_lun, ctlrtype,
# show_disk_map(" 'Replacement' drives:", file, fd, id, controller_lun, ctlrtype,
# show_disk_map(" Drives currently substituted for by spares:", file, fd, id, controller_lun, ctlrtype,
if (/^ Failed drives:/ ||
/^ 'Replacement' drives:/ ||
/^ Drives currently substituted for by spares:/
) {
# could store this somewhere, ignore for now
$this->consume_disk_map($fh);
next;
}
if (my($total_failed) = /Total of (\d+) failed physical drives detected on this logical drive\./) {
$c{$cdev}{phys_failed} = $total_failed;
next;
}
warn "Unparsed[$_]";
}
close($fh);
return \%c;
}
sub check {
my $this = shift;
my @devs = $this->detect;
unless (@devs) {
$this->warning;
$this->message("No Smart Array Adapters were found on this machine");
return;
}
# status messages pushed here
my @status;
my $res = $this->parse(@devs);
for my $dev (sort {$a cmp $b} keys %$res) {
my $c = $res->{$dev};
my @bstatus;
# check volumes
my @vstatus;
for my $vn (sort {$a cmp $b} keys %{$c->{volumes}}) {
my $v = $c->{volumes}->{$vn};
if ($v->{status} !~ '^OK') {
$this->critical;
}
push(@vstatus, "Volume $v->{volume_number} ($v->{raid_level}): $v->{status}");
}
push(@bstatus, @vstatus) if @vstatus;
# check physical devices
if ($c->{'pd count'}) {
my %pd;
for my $ps (sort {$a cmp $b} keys %{$c->{drives}}) {
my $pd = $c->{drives}{$ps};
if ($pd->{status} !~ '^OK') {
$this->critical;
$ps .= "($pd->{serial})";
}
push(@{$pd{$pd->{status}}}, $ps);
}
push(@bstatus, "Drives($c->{'pd count'}): ". $this->join_status(\%pd));
}
# check enclosures
if ($c->{enclosures}) {
my @e;
for my $i (sort {$a cmp $b} keys %{$c->{enclosures}}) {
my $e = $c->{enclosures}{$i};
# enclosure name may be missing, identify by connection
my $s = $e->{name} || "$e->{bus}-$e->{phys1}$e->{phys2}";
# enclosure S/N may be missing
$s .= "($e->{sn})" if $e->{sn};
$s .= ": $e->{status}";
if ($e->{status} !~ '^OK') {
$this->critical;
}
push(@e, $s);
}
push(@bstatus, "Enclosures: ". join(', ', @e));
}
# check cache
if ($c->{cache} && $c->{cache}->{configured} eq 'Yes') {
my $cache = $c->{cache};
my @cstatus = 'Cache:';
if ($cache->{write_cache_enabled} eq 'Yes') {
push(@cstatus, "WriteCache");
} elsif ($cache->{disabled_temporarily} || $cache->{disabled_permanently}) {
# disabled diagnostic is available, but it's too long to print here
push(@cstatus, "WriteCache:DISABLED");
$this->cache_fail;
}
push(@cstatus, "FlashCache") if $cache->{flash_cache};
push(@cstatus, "ReadMem:$cache->{read_cache_memory}") if $cache->{read_cache_memory};
push(@cstatus, "WriteMem:$cache->{write_cache_memory}") if $cache->{write_cache_memory};
push(@bstatus, join(' ', @cstatus));
}
push(@status, "$dev($c->{board_name}): ". join(', ', @bstatus));
}
unless (@status) {
return;
}
# denote this plugin as ran ok
$this->ok;
$this->message(join(', ', @status));
# cciss_vol_status 1.10 with -V (or -s) checks individual disk health anyway
my $v1_10 = $this->cciss_vol_status_version >= 1.10;
# no_smartctl: allow skip from tests
if (!$v1_10 && !$this->{no_smartctl}) {
# check also individual disk health
my @disks = $this->detect_disks(@devs);
if (@disks) {
# inherit smartctl command from our commands (testing)
my %params = ();
$params{commands}{smartctl} = $this->{commands}{smartctl} if $this->{commands}{smartctl};
my $smartctl = App::Monitoring::Plugin::CheckRaid::Plugins::smartctl->new(%params);
# do not perform check if smartctl is missing
if ($smartctl->active) {
$smartctl->check_devices(@disks);
# XXX this is hack, as we have no proper subcommand check support
$this->message($this->message . " " .$smartctl->message);
if ($smartctl->status > 0) {
$this->critical;
}
}
}
}
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_CCISS
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/cmdtool2.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_CMDTOOL2';
package App::Monitoring::Plugin::CheckRaid::Plugins::cmdtool2;
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub program_names {
'CmdTool2';
}
sub commands {
{
'adapter list' => ['-|', '@CMD', , '-AdpAllInfo', '-aALL', '-nolog'],
'adapter config' => ['-|', '@CMD', '-CfgDsply', '-a$adapter', '-nolog'],
}
}
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
my $cmd = $this->{program};
(
"CHECK_RAID ALL=(root) NOPASSWD: $cmd -AdpAllInfo -aALL -nolog",
"CHECK_RAID ALL=(root) NOPASSWD: $cmd -CfgDsply -a* -nolog",
);
}
sub check {
my $this = shift;
# status messages pushed here
my @status;
# get adapters
my $fh = $this->cmd('adapter list');
my @c;
while (<$fh>) {
if (my($c) = /^Adapter #(\d+)/) {
push(@c, $c);
}
}
close $fh;
unless (@c) {
$this->warning;
$this->message("No LSI adapters were found on this machine");
return;
}
foreach my $c (@c) {
my $fh = $this->cmd('adapter config', { '$adapter' => $c });
my ($d);
while (<$fh>) {
# DISK GROUPS: 0
if (my($s) = /^DISK GROUPS: (\d+)/) {
$d = int($s);
next;
}
# State: Optimal
if (my($s) = /^State: (\S+)$/) {
if ($s ne 'Optimal') {
$this->critical;
}
push(@status, "Logical Drive $c,$d: $s");
}
}
}
return unless @status;
# denote this plugin as ran ok
$this->ok;
$this->message(join(', ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_CMDTOOL2
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/dm.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_DM';
package App::Monitoring::Plugin::CheckRaid::Plugins::dm;
# Package to check Linux Device Mapper
# Linux LVM Mirrors
# https://access.redhat.com/documentation/en-US/Red_Hat_Enterprise_Linux/6/html/Logical_Volume_Manager_Administration/mirror_create.html
#
# Linux LVM RAID
# https://access.redhat.com/documentation/en-US/Red_Hat_Enterprise_Linux/6/html/Logical_Volume_Manager_Administration/raid_volumes.html
#
# Low-level:
# https://access.redhat.com/documentation/en-US/Red_Hat_Enterprise_Linux/6/html/Logical_Volume_Manager_Administration/device_mapper.html#mirror-map
# https://access.redhat.com/documentation/en-US/Red_Hat_Enterprise_Linux/6/html/Logical_Volume_Manager_Administration/device_mapper.html#dmraid-map
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub program_names {
qw(dmsetup);
}
sub active {
my ($this, $sudo) = @_;
# return if parent said NO
my $res = $this->SUPER::active(@_);
return $res unless $res;
# check if there really are any devices
my $c = $this->parse;
return !!@$c;
}
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
my $cmd = $this->{program};
(
"CHECK_RAID ALL=(root) NOPASSWD: $cmd status --noflush",
"CHECK_RAID ALL=(root) NOPASSWD: $cmd status",
);
}
sub commands {
{
'dmsetup' => [ '-|', '@CMD', 'status' ],
'dmsetup noflush' => [ '-|', '@CMD', 'status', '--noflush' ],
}
}
# https://www.kernel.org/doc/Documentation/device-mapper/dm-raid.txt
sub parse_raid {
local $_ = shift;
# https://github.com/torvalds/linux/blob/v3.18/drivers/md/dm-raid.c#L1377
# https://github.com/torvalds/linux/blob/v3.18/drivers/md/dm-raid.c#L1409-L1423
# https://github.com/torvalds/linux/blob/v3.18/drivers/md/dm-raid.c#L1425-L1435
# https://github.com/torvalds/linux/blob/v3.18/drivers/md/dm-raid.c#L1437-L1442
# https://github.com/torvalds/linux/blob/v3.18/drivers/md/dm-raid.c#L1444-L1452
my @cols = qw(
raid_type raid_disks
status_chars
sync_ratio
sync_action
mismatch_cnt
);
my %h;
@h{@cols} = split;
\%h;
}
# https://access.redhat.com/documentation/en-US/Red_Hat_Enterprise_Linux/6/html/Logical_Volume_Manager_Administration/device_mapper.html#mirror-map
sub parse_mirror {
local $_ = shift;
my %h;
# https://github.com/torvalds/linux/blob/v3.18/drivers/md/dm-raid1.c#L1355
my @parts = split;
# https://github.com/torvalds/linux/blob/v3.18/drivers/md/dm-raid1.c#L1365
$h{nr_mirrors} = shift @parts;
# https://github.com/torvalds/linux/blob/v3.18/drivers/md/dm-raid1.c#L1366-L1369
my @devs;
for (my $i = 0; $i < $h{nr_mirrors}; $i++) {
push(@devs, shift @parts);
}
$h{devices} = \@devs;
# https://github.com/torvalds/linux/blob/v3.18/drivers/md/dm-raid1.c#L1372-L1374
# some ratio?
$h{ratio} = shift @parts;
# param count? always '1'
shift @parts;
# the 'buffer' filled with status chars
$h{status_chars} = shift @parts;
# log device information
# https://github.com/torvalds/linux/blob/v3.18/drivers/md/dm-log.c#L807-L810
# log params, always '3'
shift @parts;
my %l;
$l{type} = shift @parts;
$l{device} = shift @parts;
# status: F->D->A
$l{status_char} = shift @parts;
$h{log} = { %l };
# for debugging. fill only if something remains not parsed
$h{_remaining} = join ' ', @parts if @parts;
\%h;
}
sub parse_target {
my ($target, $data) = @_;
return parse_raid($data) if $target eq 'raid';
return parse_mirror($data) if $target eq 'mirror';
undef;
}
sub get_fh {
my $this = shift;
# use dmsetup --noflush, requires LVM >= 2.02.97
# if that fails, fall back to just dmsetup
# https://github.com/glensc/nagios-plugin-check_raid/issues/130#issuecomment-194476070
my $fh = $this->cmd('dmsetup noflush');
$fh = $this->cmd('dmsetup') if eof $fh;
return $fh;
}
sub parse {
my $this = shift;
# cache for single run
if (!defined($this->{parsed})) {
$this->{parsed} = $this->_parse;
}
return $this->{parsed};
}
sub _parse {
my $this = shift;
my @devices;
my $fh = $this->get_fh();
while (<$fh>) {
# skip comments.
# not present in dmsetup output, but our test files may have.
next if /^#/;
last if /No devices found/;
if (my ($dmname, $s, $l, $target, $rest) = m{^
(\S+):\s+ # dmname
(\d+)\s+ # start
(\d+)\s+ # length
(\S+) # target
(?:\s+(.+))? # rest of the data
\s? # there may be trailing space
$}x) {
my $h = parse_target($target, $rest);
# skip target type not handled
next unless $h;
my %h = (
'dmname' => $dmname,
's' => $s,
'l' => $l,
'target' => $target,
%$h,
);
push @devices, \%h;
next;
}
warn "Unhandled:[$_]";
$this->unknown;
}
close $fh;
return \@devices;
}
sub check {
my $this = shift;
my $c = $this->parse;
if (!@$c) {
$this->noraid->message("No devices to check");
return;
}
my @status;
foreach my $dm (@$c)
{
# <status_chars> One char for each device, indicating:
# 'A' = alive and in-sync (mirror, raid1, raid)
# 'a' = alive but not in-sync (mirror, raid1)
# 'D' = dead/failed (mirror, raid1, raid)
# 'S' = Sync (mirror, raid1)
# 'mirror'/'raid1': https://github.com/torvalds/linux/blob/v3.18/drivers/md/dm-raid1.c#L1330-L1342
# 'raid': https://github.com/torvalds/linux/blob/v3.18/drivers/md/dm-raid.c#L1409-L1414
$this->critical if ($dm->{status_chars} =~ /D/);
$this->warning if ($dm->{status_chars} =~ /[aS]/);
my @s = "$dm->{dmname}:$dm->{status_chars}";
# <sync_action> One of the following possible states:
# idle - No synchronization action is being performed.
# frozen - The current action has been halted.
# resync - Array is undergoing its initial synchronization or...
# recover - A device in the array is being rebuilt or...
# check - A user-initiated full check of the array is...
# repair - The same as "check", but discrepancies are...
# reshape - The array is undergoing a reshape.
if ($dm->{sync_action}) {
push(@s, $dm->{sync_action});
if ($dm->{sync_action} =~ /^(check|repair|init)$/) {
$this->warning;
}
}
push(@status, join(' ', @s));
}
return unless @status;
$this->ok->message(join(', ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_DM
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/dmraid.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_DMRAID';
package App::Monitoring::Plugin::CheckRaid::Plugins::dmraid;
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub program_names {
shift->{name};
}
sub commands {
{
'dmraid' => ['-|', '@CMD', '-r'],
}
}
sub active {
my ($this) = @_;
# allow --plugin-option=dmraid-enabled to force this plugin to be enabled
return 1 if exists $this->{options}{'dmraid-enabled'};
# return if parent said NO
my $res = $this->SUPER::active(@_);
return $res unless $res;
# check if dmraid is empty
return keys %{$this->parse} > 0;
}
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
my $cmd = $this->{program};
"CHECK_RAID ALL=(root) NOPASSWD: $cmd -r";
}
# parse arrays, return data indexed by array name
sub parse {
my $this = shift;
my (%arrays);
my $fh = $this->cmd('dmraid');
while (<$fh>) {
chomp;
next unless (my($device, $format, $name, $type, $status, $sectors) = m{^
# /dev/sda: jmicron, "jmicron_JRAID", mirror, ok, 781385728 sectors, data@ 0
# /dev/sdb: ddf1, ".ddf1_disks", GROUP, ok, 1953253376 sectors, data@ 0
(/dev/\S+):\s # device
(\S+),\s # format
"([^"]+)",\s # name
(mirror|stripe[d]?|GROUP),\s # type
(\w+),\s # status
(\d+)\ssectors,.* # sectors
$}x);
next unless $this->valid($device);
# trim trailing spaces from name
$name =~ s/\s+$//;
my $member = {
'device' => $device,
'format' => $format,
'type' => $type,
'status' => $status,
'size' => $sectors,
};
push(@{$arrays{$name}}, $member);
}
close $fh;
return \%arrays;
}
# plugin check
# can store its exit code in $this->status
# can output its message in $this->message
sub check {
my $this = shift;
my (@status);
## Check Array and Drive Status
my $arrays = $this->parse;
while (my($name, $array) = each(%$arrays)) {
my @s;
foreach my $dev (@$array) {
if ($dev->{status} =~ m/sync|rebuild/i) {
$this->warning;
} elsif ($dev->{status} !~ m/ok/i) {
$this->critical;
}
my $size = $this->format_bytes($dev->{size});
push(@s, "$dev->{device}($dev->{type}, $size): $dev->{status}");
}
push(@status, "$name: " . join(', ', @s));
}
return unless @status;
# denote that this plugin as ran ok, not died unexpectedly
$this->ok->message(join(' ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_DMRAID
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/dpt_i2o.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_DPT_I2O';
package App::Monitoring::Plugin::CheckRaid::Plugins::dpt_i2o;
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub commands {
{
'proc' => ['<', '/proc/scsi/dpt_i2o'],
'proc entry' => ['<', '/proc/scsi/dpt_i2o/$controller'],
}
}
sub active {
my ($this) = @_;
return -d $this->{commands}{proc}[1];
}
sub check {
my $this = shift;
# status messages pushed here
my @status;
my $fh = $this->cmd('proc');
my @c = grep { !/^\./ } readdir($fh);
close($fh);
# TODO: check for failed disks!
for my $c (@c) {
my $fh = $this->cmd('proc entry', { '$controller' => $c });
while (<$fh>) {
if (my ($c, $t, $l, $s) = m/TID=\d+,\s+\(Channel=(\d+),\s+Target=(\d+),\s+Lun=(\d+)\)\s+\((\S+)\)/) {
if ($s ne "online") {
$this->critical;
}
push(@status, "$c,$t,$l:$s");
}
}
close($fh);
}
return unless @status;
# denote this plugin as ran ok
$this->ok;
$this->message(join(', ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_DPT_I2O
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/gdth.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_GDTH';
package App::Monitoring::Plugin::CheckRaid::Plugins::gdth;
# Linux gdth RAID
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub commands {
{
'proc' => ['<', '/proc/scsi/gdth'],
'proc entry' => ['<', '/proc/scsi/gdth/$controller'],
}
}
sub active {
my ($this) = @_;
return -d $this->{commands}{proc}[1];
}
sub parse {
my $this = shift;
my $fh = $this->cmd('proc');
my @c = grep { !/^\./ } readdir($fh);
close($fh);
my %c;
for my $c (@c) {
my (%ld, %ad, %pd, %l, %a, %p, $section);
my $fh = $this->cmd('proc entry', { '$controller' => $c });
while (<$fh>) {
chomp;
# new section start
if (my($s) = /^(\w.+):$/) {
$section = $s;
%a = %l = %p = ();
next;
}
# skip unknown sections
next unless /^\s/ or /^$/;
# process each section
if ($section eq 'Driver Parameters') {
# nothing useful
} elsif ($section eq 'Disk Array Controller Information') {
# nothing useful
} elsif ($section eq 'Physical Devices') {
# Chn/ID/LUN: B/05/0 Name: FUJITSU MAX3147NC 0104
# Capacity [MB]: 140239 To Log. Drive: 5
# Retries: 1 Reassigns: 0
# Grown Defects: 1
if (my($id, $n, $rv) = m{^\s+Chn/ID/LUN:\s+(\S+)\s+Name:\s+(.+)(.{4})$}) {
$n =~ s/\s+$//;
$p{id} = $id;
$p{name} = $n;
$p{revision} = $rv;
} elsif (my($unit, $c, $d) = m/^\s+Capacity\s\[(.B)\]:\s+(\d+)\s+To Log\. Drive:\s+(\d+|--)/) {
$p{capacity} = int($c);
$p{capacity_unit} = $unit;
$p{drive} = $d;
} elsif (my($r, $ra) = m/^\s+Retries:\s+(\d+)\s+Reassigns:\s+(\d+)/) {
$p{retries} = int($r);
$p{reassigns} = int($ra);
} elsif (my($gd) = m/^\s+Grown Defects:\s+(\d+)/) {
$p{defects} = int($gd);
} elsif (/^$/) {
if ($p{capacity} == 0 and $p{name} =~ /SCA HSBP/) {
# HSBP is not a disk, so do not consider this an error
# http://support.gateway.com/s/Servers/COMPO/MOTHERBD/4000832/4000832si69.shtml
# Raid Hot Swap Backplane driver (recognized as "ESG-SHV SCA HSBP M16 SCSI Processor Device")
# Chn/ID/LUN: B/06/0 Name: ESG-SHV SCA HSBP M16 0.05
# Capacity [MB]: 0 To Log. Drive: --
next;
}
$pd{$p{id}} = { %p };
} else {
warn "[$section] [$_]";
$this->unknown;
}
} elsif ($section eq 'Logical Drives') {
# Number: 3 Status: ok
# Slave Number: 15 Status: ok (older kernels)
# Capacity [MB]: 69974 Type: Disk
if (my($num, $s) = m/^\s+(?:Slave )?Number:\s+(\d+)\s+Status:\s+(\S+)/) {
$l{number} = int($num);
$l{status} = $s;
} elsif (my($unit, $c, $t) = m/^\s+Capacity\s\[(.B)\]:\s+(\d+)\s+Type:\s+(\S+)/) {
$l{capacity} = "$c $unit";
$l{type} = $t;
} elsif (my($md, $id) = m/^\s+Missing Drv\.:\s+(\d+)\s+Invalid Drv\.:\s+(\d+|--)/) {
$l{missing} = int($md);
$l{invalid} = int($id);
} elsif (my($n) = m/^\s+To Array Drv\.:\s+(\d+|--)/) {
$l{array} = $n;
} elsif (/^$/) {
$ld{$l{number}} = { %l };
} else {
warn "[$section] [$_]";
$this->unknown;
}
} elsif ($section eq 'Array Drives') {
# Number: 0 Status: fail
# Capacity [MB]: 349872 Type: RAID-5
if (my($num, $s) = m/^\s+Number:\s+(\d+)\s+Status:\s+(\S+)/) {
$a{number} = int($num);
$a{status} = $s;
} elsif (my($unit, $c, $t) = m/^\s+Capacity\s\[(.B)\]:\s+(\d+)\s+Type:\s+(\S+)/) {
$a{capacity} = "$c $unit";
$a{type} = $t;
} elsif (/^(?: --)?$/) {
if (%a) {
$ad{$a{number}} = { %a };
}
} else {
warn "[$section] [$_]";
$this->unknown;
}
} elsif ($section eq 'Host Drives') {
# nothing useful
} elsif ($section eq 'Controller Events') {
# nothing useful
}
}
close($fh);
$c{$c} = { id => $c, array => { %ad }, logical => { %ld }, physical => { %pd } };
}
return \%c;
}
sub check {
my $this = shift;
# status messages pushed here
my @status;
my $controllers = $this->parse;
# process each controller separately
for my $c (values %$controllers) {
# array status
my @ad;
for my $n (sort {$a cmp $b} keys %{$c->{array}}) {
my $ad = $c->{array}->{$n};
if ($ad->{status} ne "ready") {
$this->critical;
}
push(@ad, "Array $ad->{number}($ad->{type}) $ad->{status}");
}
# older raids have no Array drives, Look into Logical Drives for type!=Disk
unless (@ad) {
for my $n (sort {$a cmp $b} keys %{$c->{logical}}) {
my $ld = $c->{logical}->{$n};
if ($ld->{type} eq "Disk") {
next;
}
# emulate Array Drive
my $s = "Array($ld->{type}) $ld->{status}";
# check for missing drives
if ($ld->{missing} > 0) {
$this->warning;
$s .= " ($ld->{missing} missing drives)";
}
push(@ad, $s);
}
}
# logical drive status
my %ld;
for my $n (sort {$a cmp $b} keys %{$c->{logical}}) {
my $ld = $c->{logical}->{$n};
if ($ld->{status} ne "ok") {
$this->critical;
}
push(@{$ld{$ld->{status}}}, $ld->{number});
}
# physical drive status
my @pd;
for my $n (sort {$a cmp $b} keys %{$c->{physical}}) {
my $pd = $c->{physical}->{$n};
my @ds;
# TODO: make tresholds configurable
if ($pd->{defects} > 300) {
$this->critical;
push(@ds, "grown defects critical: $pd->{defects}");
} elsif ($pd->{defects} > 30) {
$this->warning;
push(@ds, "grown defects warning: $pd->{defects}");
}
# report disk being not assigned
if ($pd->{drive} eq '--') {
push(@ds, "not assigned");
}
if (@ds) {
push(@pd, "Disk $pd->{id}($pd->{name}) ". join(', ', @ds));
}
}
my @cd;
push(@cd, @ad) if @ad;
push(@cd, "Logical Drives: ". $this->join_status(\%ld));
push(@cd, @pd) if @pd;
push(@status, "Controller $c->{id}: ". join('; ', @cd));
}
return unless @status;
# denote this plugin as ran ok
$this->ok;
$this->message(join('; ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_GDTH
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/hp_msa.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_HP_MSA';
package App::Monitoring::Plugin::CheckRaid::Plugins::hp_msa;
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use App::Monitoring::Plugin::CheckRaid::SerialLine;
use strict;
use warnings;
sub active {
my $this = shift;
return $this->detect;
}
# check from /sys if there are any MSA VOLUME's present.
sub detect {
my $this = shift;
# allow --plugin-option=hp_msa-enabled to force this plugin to be enabled
return 1 if exists $this->{options}{'hp_msa-enabled'};
for my $file (</sys/block/*/device/model>) {
open my $fh, '<', $file or next;
my $model = <$fh>;
close($fh);
return 1 if ($model =~ /^MSA.+VOLUME/);
}
return 0;
}
sub check {
my $this = shift;
# allow --plugin-option=hp_msa-serial=/dev/ttyS2 to specify serial line
my $ctldevice = $this->{options}{'hp_msa-serial'} || '/dev/ttyS0';
# status messages pushed here
my @status;
my %opts = ();
$opts{lockdir} = $this->{lockdir} if $this->{lockdir};
my $modem = App::Monitoring::Plugin::CheckRaid::SerialLine->new($ctldevice, %opts);
my $fh = $modem->open();
unless ($fh) {
$this->warning;
$this->message("Can't open $ctldevice");
return;
}
# check first controller
print $fh "\r";
print $fh "show globals\r";
print $fh "show this_controller\r";
print $fh "show other_controller\r";
# this will issue termination match, ie. invalid command
print $fh "exit\r";
my ($c, %c, %t);
while (<$fh>) {
chomp;
s/[\n\r]$//;
last if /Invalid CLI command/;
# Temperature:
# EMU: 23 Celsius, 73 Fahrenheit
# PS1: 22 Celsius, 71 Fahrenheit
# PS2: 22 Celsius, 71 Fahrenheit
if (my($s, $c) = /(\S+): (\d+) Celsius,\s+\d+ Fahrenheit/) {
$t{$s} = int($c);
next;
}
# Controller 1 (right controller):
if (my($s) = /^(Controller \d+)/) {
$c = $s;
$c{$c} = [];
next;
}
# Surface Scan: Running, LUN 10 (68% Complete)
if (my($s, $m) = /Surface Scan:\s+(\S+)[,.]\s*(.*)/) {
if ($s eq 'Running') {
my ($l, $p) = $m =~ m{(LUN \d+) \((\d+)% Complete\)};
push(@{$c{$c}}, "Surface: $l ($p%)");
$this->warning;
} elsif ($s ne 'Complete') {
push(@{$c{$c}}, "Surface: $s, $m");
$this->warning;
}
next;
}
# Rebuild Status: Running, LUN 0 (67% Complete)
if (my($s, $m) = /Rebuild Status:\s+(\S+)[,.]\s*(.*)/) {
if ($s eq 'Running') {
my ($l, $p) = $m =~ m{(LUN \d+) \((\d+)% Complete\)};
push(@{$c{$c}}, "Rebuild: $l ($p%)");
$this->warning;
} elsif ($s ne 'Complete') {
push(@{$c{$c}}, "Rebuild: $s, $m");
$this->warning;
}
next;
}
# Expansion: Complete.
if (my($s, $m) = /Expansion:\s+(\S+)[.,]\s*(.*)/) {
if ($s eq 'Running') {
my ($l, $p) = $m =~ m{(LUN \d+) \((\d+)% Complete\)};
push(@{$c{$c}}, "Expansion: $l ($p%)");
$this->warning;
} elsif ($s ne 'Complete') {
push(@{$c{$c}}, "Expansion: $s, $m");
$this->warning;
}
next;
}
}
$modem->close();
foreach $c (sort { $a cmp $b } keys %c) {
my $s = $c{$c};
$s = join(', ', @$s);
$s = 'OK' unless $s;
push(@status, "$c: $s");
}
# check that no temp is over the treshold
my $warn = 28;
my $crit = 33;
while (my($t, $c) = each %t) {
if ($c > $crit) {
push(@status, "$t: ${c}C");
$this->critical;
} elsif ($c > $warn) {
push(@status, "$t: ${c}C");
$this->warning;
}
}
return unless @status;
$this->message(join(', ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_HP_MSA
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/hpacucli.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_HPACUCLI';
package App::Monitoring::Plugin::CheckRaid::Plugins::hpacucli;
## hpacucli/hpssacli support
#
# driver developers recommend to use cciss_vol_status for monitoring,
# hpacucli/hpssacli shouldn't be used for monitoring due they obtaining global
# kernel lock while cciss_vol_status does not. cciss_vol_status is designed for
# monitoring
# https://github.com/glensc/nagios-plugin-check_raid/issues/114#issuecomment-138866801
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
use constant E_NO_LOGICAL_DEVS => 'The specified device does not have any logical drives';
sub program_names {
shift->{name};
}
sub commands {
{
'controller status' => ['-|', '@CMD', 'controller', 'all', 'show', 'status'],
'logicaldrive status' => ['-|', '@CMD', 'controller', '$target', 'logicaldrive', 'all', 'show'],
}
}
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
my $cmd = $this->{program};
(
"CHECK_RAID ALL=(root) NOPASSWD: $cmd controller all show status",
"CHECK_RAID ALL=(root) NOPASSWD: $cmd controller * logicaldrive all show",
);
}
# if --plugin-option=hpacucli-target=slot=0 is specified
# filter only allowed values
sub filter_targets {
my ($this, $targets) = @_;
my $cli_opts = $this->{options}{'hpacucli-target'};
if (!$cli_opts) {
return $targets;
}
my %res;
my @filters = split(/,/, $cli_opts);
for my $filter (@filters) {
if (exists $targets->{$filter}) {
$res{$filter} = $targets->{$filter};
} else {
$this->critical->message("Controller $filter not found");
}
}
return \%res;
}
# split:
# '(Embedded) (RAID Mode)'
# to:
# [ 'Embedded', 'RAID Mode' ]
sub split_controller_modes {
my ($modes) = @_;
my @parts;
push @parts, $1 while $modes =~ /\((.*?)\)/g;
return \@parts;
}
sub scan_targets {
my $this = shift;
# TODO: allow target customize:
# hpacucli <target> is of format:
# [controller all|slot=#|wwn=#|chassisname="AAA"|serialnumber=#|chassisserialnumber=#|ctrlpath=#:# ]
# [array all|<id>]
# [physicaldrive all|allunassigned|[#:]#:#|[#:]#:#-[#:]#:#]
# [logicaldrive all|#]
# [enclosure all|#:#|serialnumber=#|chassisname=#]
# [licensekey all|<key>]
# Scan controllers
my (%targets, $target);
my $fh = $this->cmd('controller status');
while (<$fh>) {
chomp;
# skip empty lines and artificial comments (added by this project)
next if /^$/ or /^#/;
# skip known noise
if (
/FIRMWARE UPGRADE REQUIRED: /
|| /^\s{27}/
) {
next;
}
# Numeric slot
if (my($controller, $slot, $modes) = /
^(\S.+)\sin\sSlot
\s(\S+?) # slot number
(?: # optional mode
\s(\(.+\))
)?$
/x) {
$target = "slot=$slot";
$targets{$target} = {
target => $target,
controller => $controller,
slot => $slot,
modes => split_controller_modes($modes || ''),
};
$this->unknown if $slot !~ /^\d+/;
next;
}
# Named Entry
if (my($controller, $cn) = /^(\S.+) in (.+)/) {
$target = "chassisname=$cn";
$targets{$target} = {
target => $target,
controller => $controller,
chassisname => $cn,
};
next;
}
# Other statuses, try "key: value" pairs
if (my ($key, $value) = /^\s*(.+?):\s+(.+?)$/) {
$targets{$target}{$key} = $value;
next;
}
warn "Unparsed: [$_]\n";
}
close $fh;
return $this->filter_targets(\%targets);
}
# Scan logical drives
sub scan_luns {
my ($this, $targets) = @_;
my @luns;
# sort by target to ensure consistent results
for my $target (sort {$a->{target} cmp $b->{target}} values(%$targets)) {
# check each controller
my $fh = $this->cmd('logicaldrive status', { '$target' => $target->{target} });
my $index = -1;
my @array;
my %array;
while (<$fh>) {
chomp;
# skip empty lines and artificial comments (added by this project)
next if /^$/ or /^#/;
# Error: The controller identified by "slot=attr_value_slot_unknown" was not detected.
if (/^Error:\s/) {
# store it somewhere. should it be appended?
($target->{'error'}) = /^Error:\s+(.+?)\.?\s*$/;
$this->unknown;
next;
}
# "array A"
# "array A (Failed)"
# "array B (Failed)"
if (my($a, $s) = /^\s+array (\S+)(?:\s*\((\S+)\))?$/) {
$index++;
# Offset 0 is Array own status
# XXX: I don't like this one: undef could be false positive
$target->{'array'}[$index]{status} = $s || 'OK';
$target->{'array'}[$index]{name} = $a;
next;
}
# logicaldrive 1 (68.3 GB, RAID 1, OK)
# capture only status
if (my($drive, $size, $raid, $status) = /^\s+logicaldrive (\d+) \(([\d.]+ .B), ([^,]+), ([^\)]+)\)$/) {
warn "Index out of bounds" if $index < 0; # XXX should not happen
# Offset 1 is each logical drive status
my $ld = {
'id' => $drive,
'status' => $status,
'size' => $size,
'raid' => $raid,
};
push(@{$target->{'array'}[$index]{logicaldrives}}, $ld);
next;
}
# skip known noise
if (
/\s+Type "help" for more details/
# Controller name: exact match
|| /^\Q$target->{controller}\E\s/
# loose match, some test data seems malformed
|| / in Slot \d/
|| /^FIRMWARE UPGRADE REQUIRED:/
|| /^\s{27}/
) {
next;
}
warn "Unhandled: [$_]\n";
}
$this->unknown unless close $fh;
push(@luns, $target);
}
return \@luns;
}
# parse hpacucli output into logical structure
sub parse {
my $this = shift;
my $targets = $this->scan_targets;
if (!$targets) {
return $targets;
}
return $this->scan_luns($targets);
}
# format lun (logicaldevice) status
# update check status if problems found
sub lstatus {
my ($this, $ld) = @_;
my $s = $ld->{status};
if ($s eq 'OK' or $s eq 'Disabled') {
} elsif ($s eq 'Failed' or $s eq 'Interim Recovery Mode') {
$this->critical;
} elsif ($s eq 'Rebuild' or $s eq 'Recover') {
$this->warning;
}
return "LUN$ld->{id}:$s";
}
# format array status
# update check status if problems found
sub astatus {
my ($this, $array) = @_;
if ($array->{status} ne 'OK') {
$this->critical;
}
return "Array $array->{name}($array->{status})";
}
# format controller status
# updates check status if problems found
sub cstatus {
my ($this, $c) = @_;
my (@s, $s);
# always include controller status
push(@s, $c->{'Controller Status'} || 'ERROR');
if ($c->{'Controller Status'} ne 'OK') {
$this->critical;
}
if ($c->{error}) {
if ($c->{error} eq E_NO_LOGICAL_DEVS) {
$this->noraid;
push(@s, 'Not configured');
} else {
$this->unknown;
push(@s, $c->{error});
}
}
# print those only if not ok and configured
if (($s = $c->{'Cache Status'}) && $s !~ /^(OK|Not Configured)/) {
push(@s, "Cache: $s");
$this->critical;
}
if (($s = $c->{'Battery/Capacitor Status'}) && $s !~ /^(OK|Not Configured)/) {
push(@s, "Battery: $s");
$this->critical;
}
# start with identifyier
my $name = $c->{chassisname} || $c->{controller};
return $name . '[' . join(', ', @s) . ']';
}
sub check {
my $this = shift;
my $ctrls = $this->parse;
unless ($ctrls) {
$this->warning->message("No Controllers were found on this machine");
return;
}
my @status;
foreach my $ctrl (@$ctrls) {
my @astatus;
foreach my $array (@{$ctrl->{array}}) {
my @lstatus;
foreach my $ld (@{$array->{logicaldrives}}) {
push(@lstatus, $this->lstatus($ld));
}
push(@astatus, $this->astatus($array). '['. join(',', @lstatus). ']');
}
my $cstatus = $this->cstatus($ctrl);
$cstatus .= ': '. join(', ', @astatus) if @astatus;
push(@status, $cstatus);
}
return unless @status;
$this->ok->message(join(', ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_HPACUCLI
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/hpssacli.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_HPSSACLI';
package App::Monitoring::Plugin::CheckRaid::Plugins::hpssacli;
# This plugin extends hpacucli plugin,
# with the only difference that different program name will be used.
use base 'App::Monitoring::Plugin::CheckRaid::Plugins::hpacucli';
use strict;
use warnings;
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_HPSSACLI
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/ips.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_IPS';
package App::Monitoring::Plugin::CheckRaid::Plugins::ips;
# Serveraid IPS
# Tested on IBM xSeries 346 servers with Adaptec ServeRAID 7k controllers.
# The ipssend version was v7.12.14.
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub program_names {
qw(ipssend);
}
sub commands {
{
'list logical drive' => ['-|', '@CMD', 'GETCONFIG', '1', 'LD'],
}
}
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
my $cmd = $this->{program};
"CHECK_RAID ALL=(root) NOPASSWD: $cmd getconfig 1 LD"
}
sub check {
my $this = shift;
# status messages pushed here
my @status;
my $n;
my $fh = $this->cmd('list logical drive');
while (<$fh>) {
if (/drive number (\d+)/i){
$n = $1;
next;
}
next unless $n;
next unless $this->valid($n);
next unless (my($s, $c) = /Status .*: (\S+)\s+(\S+)/);
if ($c =~ /SYN|RBL/i) { # resynching
$this->resync;
} elsif ($c !~ /OKY/i) { # not OK
$this->critical;
}
push(@status, "$n:$s");
}
close $fh;
return unless @status;
$this->ok->message(join(', ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_IPS
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/lsraid.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_LSRAID';
package App::Monitoring::Plugin::CheckRaid::Plugins::lsraid;
# Linux, software RAID
# Broken: missing test data
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub program_names {
shift->{name};
}
sub commands {
{
'list' => ['-|', '@CMD', '-A', '-p'],
}
}
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
my $cmd = $this->{program};
"CHECK_RAID ALL=(root) NOPASSWD: $cmd -A -p"
}
sub check {
my $this = shift;
# status messages pushed here
my @status;
my $fh = $this->cmd('list');
while (<$fh>) {
next unless (my($n, $s) = m{/dev/(\S+) \S+ (\S+)});
next unless $this->valid($n);
if ($s =~ /good|online/) {
# no worries
} elsif ($s =~ /sync/) {
$this->warning;
} else {
$this->critical;
}
push(@status, "$n:$s");
}
close $fh;
return unless @status;
$this->message(join(', ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_LSRAID
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/lsscsi.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_LSSCSI';
package App::Monitoring::Plugin::CheckRaid::Plugins::lsscsi;
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub program_names {
shift->{name};
}
sub commands {
{
'lsscsi list' => ['-|', '@CMD', '-g'],
}
}
# lists contoller devices (type=storage)
# this will fail (return empty list) if sg module is not present
# return /dev/sgX nodes
sub list_sg {
my $this = shift;
my @scan = $this->scan;
my @devs = map { $_->{sgnode} } grep { $_->{type} eq 'storage' && $_->{sgnode} ne '-' } @scan;
return wantarray ? @devs : \@devs;
}
# list disk nodes one for each controller
# return /dev/sdX nodes
sub list_dd {
my $this = shift;
my @scan = $this->scan;
my @devs = map { $_->{devnode} } grep { $_->{type} eq 'disk' && $_->{devnode} ne '-' && $_->{sgnode} } @scan;
return wantarray ? @devs : \@devs;
}
# scan lsscsi output
sub scan {
my $this = shift;
# cache inside single run
return wantarray ? @{$this->{sdevs}} : $this->{sdevs} if $this->{sdevs};
# Scan such output:
# [0:0:0:0] disk HP LOGICAL VOLUME 3.00 /dev/sda /dev/sg0
# [0:3:0:0] storage HP P410i 3.00 - /dev/sg1
# or without sg driver:
# [0:0:0:0] disk HP LOGICAL VOLUME 3.00 /dev/sda -
# [0:3:0:0] storage HP P410i 3.00 - -
my $fh = $this->cmd('lsscsi list');
my @sdevs;
while (<$fh>) {
chop;
if (my($hctl, $type, $vendor, $model, $rev, $devnode, $sgnode) = m{^
\[([\d:]+)\] # SCSI Controller, SCSI bus, SCSI target, and SCSI LUN
\s+(\S+) # type
\s+(\S+) # vendor
\s+(.*?) # model, match everything as it may contain spaces
\s+(\S+) # revision
\s+((?:/dev/\S+|-)) # /dev node
\s+((?:/dev/\S+|-)) # /dev/sg node
}x) {
push(@sdevs, {
'hctl' => $hctl,
'type' => $type,
'vendor' => $vendor,
'model' => $model,
'rev' => $rev,
'devnode' => $devnode,
'sgnode' => $sgnode,
});
}
}
close $fh;
$this->{sdevs} = \@sdevs;
return wantarray ? @sdevs : \@sdevs;
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_LSSCSI
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/lsvg.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_LSVG';
package App::Monitoring::Plugin::CheckRaid::Plugins::lsvg;
# AIX LVM
# Status: broken (no test data)
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub program_names {
shift->{name};
}
sub commands {
{
'lsvg' => ['-|', '@CMD'],
'lsvg list' => ['-|', '@CMD', '-l', '$vg'],
}
}
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
my $cmd = $this->{program};
(
"CHECK_RAID ALL=(root) NOPASSWD: $cmd",
"CHECK_RAID ALL=(root) NOPASSWD: $cmd -l *",
)
}
sub check {
my $this = shift;
# status messages pushed here
my @status;
my @vg;
my $fh = $this->cmd('lsvg');
while (<$fh>) {
chomp;
push @vg, $_;
}
close $fh;
foreach my $vg (@vg) {
next unless $this->valid($vg); # skip entire VG
my $fh = $this->cmd('lsvg list', { '$vg' => $vg });
while (<$fh>) {
my @f = split /\s/;
my ($n, $s) = ($f[0], $f[5]);
next if (!$this->valid($n) or !$s);
next if ($f[3] eq $f[2]); # not a mirrored LV
if ($s =~ m#open/(\S+)#i) {
$s = $1;
if ($s ne 'syncd') {
$this->critical;
}
push(@status, "lvm:$n:$s");
}
}
close $fh;
}
return unless @status;
$this->message(join(', ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_LSVG
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/mdstat.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_MDSTAT';
package App::Monitoring::Plugin::CheckRaid::Plugins::mdstat;
# Linux Multi-Device (md)
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub commands {
{
'mdstat' => ['<', '/proc/mdstat'],
}
}
sub active {
my ($this) = @_;
# easy way out. no /proc/mdstat
return 0 unless -e $this->{commands}{mdstat}[1];
# extra check if mdstat is empty
my @md = $this->parse;
return $#md >= 0;
}
sub parse {
my $this = shift;
my (@md, %md);
my $fh = $this->cmd('mdstat');
my $arr_checking = 0;
while (<$fh>) {
chomp;
# skip first line
next if (/^Personalities : /);
# kernel-3.0.101/drivers/md/md.c, md_seq_show
# md1 : active raid1 sdb2[0] sda2[1]
if (my($dev, $active, $ro, $rest) = m{^
(\S+)\s+:\s+ # mdname
(\S+)\s+ # active: "inactive", "active"
(\((?:auto-)?read-only\)\s+)? # readonly
(.+) # personality name + disks
}x) {
my @parts = split /\s/, $rest;
my $re = qr{^
(\S+) # devname
(?:\[(\d+)\]) # desc_nr
(?:\((.)\))? # flags: (W|F|S) - WriteMostly, Faulty, Spare
$}x;
my @disks = ();
my $personality;
while (my($disk) = pop @parts) {
last if !$disk;
if ($disk !~ $re) {
$personality = $disk;
last;
}
my($dev, $number, $flags) = $disk =~ $re;
push(@disks, {
'dev' => $dev,
'number' => int($number),
'flags' => $flags || '',
});
}
die "Unexpected parse" if @parts;
# first line resets %md
%md = (dev => $dev, personality => $personality, readonly => $ro, active => $active, disks => [ @disks ]);
next;
}
# variations:
#" 8008320 blocks [2/2] [UU]"
#" 58291648 blocks 64k rounding" - linear
#" 5288 blocks super external:imsm"
#" 20969472 blocks super 1.2 512k chunks"
#
# Metadata version:
# This is one of
# - 'none' for arrays with no metadata (good luck...)
# - 'external' for arrays with externally managed metadata,
# - or N.M for internally known formats
#
if (my($b, $mdv, $status) = m{^
\s+(\d+)\sblocks\s+ # blocks
# metadata version
(super\s(?:
(?:\d+\.\d+) | # N.M
(?:external:\S+) |
(?:non-persistent)
))?\s*
(.+) # mddev->pers->status (raid specific)
$}x) {
# linux-2.6.33/drivers/md/dm-raid1.c, device_status_char
# A => Alive - No failures
# D => Dead - A write failure occurred leaving mirror out-of-sync
# S => Sync - A sychronization failure occurred, mirror out-of-sync
# R => Read - A read failure occurred, mirror data unaffected
# U => for the rest
my ($s) = $status =~ /\s+\[([ADSRU_]+)\]/;
$md{status} = $s || '';
$md{blocks} = int($b);
$md{md_version} = $mdv;
# if external try to parse dev
if ($mdv) {
($md{md_external}) = $mdv =~ m{external:(\S+)};
}
next;
}
# linux-2.6.33/drivers/md/md.c, md_seq_show
if (my($action) = m{(resync=(?:PENDING|DELAYED))}) {
$md{resync_status} = $action;
next;
}
# linux-2.6.33/drivers/md/md.c, status_resync
# [==>..................] resync = 13.0% (95900032/732515712) finish=175.4min speed=60459K/sec
# [=>...................] check = 8.8% (34390144/390443648) finish=194.2min speed=30550K/sec
if (my($action, $perc, $eta, $speed) = m{(resync|recovery|reshape)\s+=\s+([\d.]+%) \(\d+/\d+\) finish=([\d.]+min) speed=(\d+K/sec)}) {
$md{resync_status} = "$action:$perc $speed ETA: $eta";
next;
} elsif (($perc, $eta, $speed) = m{check\s+=\s+([\d.]+%) \(\d+/\d+\) finish=([\d.]+min) speed=(\d+K/sec)}) {
$md{check_status} = "check:$perc $speed ETA: $eta";
$arr_checking = 1;
next;
}
# we need empty line denoting end of one md
next unless /^\s*$/;
next unless $this->valid($md{dev});
push(@md, { %md } ) if %md;
}
close $fh;
# One of the arrays is in checking state, which could be because there is a scheduled sync of all MD arrays
# In such a case, all of the arrays are scheduled to by checked, but only one of them is actually running the check
# while the others are in "resync=DELAYED" state.
# We don't want to receive notifications in such case, so we check for this particular case here
if ($arr_checking && scalar(@md) >= 2) {
foreach my $dev (@md) {
if ($dev->{resync_status} && $dev->{resync_status} eq "resync=DELAYED") {
delete $dev->{resync_status};
$dev->{check_status} = "check=DELAYED";
}
}
}
return wantarray ? @md : \@md;
}
sub check {
my $this = shift;
my (@status);
my @md = $this->parse;
foreach (@md) {
my %md = %$_;
# common status
my $size = $this->format_bytes($md{blocks} * 1024);
my $personality = $md{personality} ? " $md{personality}" : "";
my $s = "$md{dev}($size$personality):";
# failed disks
my @fd = map { $_->{dev} } grep { $_->{flags} =~ /F/ } @{$md{disks}};
# raid0 is just there or its not. raid0 can't degrade.
# same for linear, no $md_status available
if ($personality =~ /linear|raid0/) {
$s .= "OK";
} elsif ($md{resync_status}) {
$this->resync;
$s .= "$md{status} ($md{resync_status})";
} elsif ($md{check_status}) {
$this->check_status;
$s .= "$md{status} ($md{check_status})";
} elsif ($md{status} =~ /_/) {
$this->critical;
my $fd = join(',', @fd);
$s .= "F:$fd:$md{status}";
} elsif (@fd > 0) {
# FIXME: this is same as above?
$this->warning;
$s .= "hot-spare failure:". join(",", @fd) .":$md{status}";
} else {
$s .= "$md{status}";
}
push(@status, $s);
}
return unless @status;
# denote this plugin as ran ok
$this->ok;
$this->message(join(', ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_MDSTAT
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/megacli.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_MEGACLI';
package App::Monitoring::Plugin::CheckRaid::Plugins::megacli;
# MegaRAID SAS 8xxx controllers
# based on info from here:
# http://www.bxtra.net/Articles/2008-09-16/Dell-Perc6i-RAID-Monitoring-Script-using-MegaCli-LSI-CentOS-52-64-bits
# TODO: http://www.techno-obscura.com/~delgado/code/check_megaraid_sas
# TODO: process several adapters
# TODO: process drive temperatures
# TODO: check error counts
# TODO: hostspare information
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub program_names {
qw(MegaCli64 MegaCli megacli);
}
sub commands {
{
'pdlist' => ['-|', '@CMD', '-PDList', '-aALL', '-NoLog'],
'ldinfo' => ['-|', '@CMD', '-LdInfo', '-Lall', '-aALL', '-NoLog'],
'battery' => ['-|', '@CMD', '-AdpBbuCmd', '-GetBbuStatus', '-aALL', '-NoLog'],
}
}
# TODO: process from COMMANDS
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
my $cmd = $this->{program};
(
"CHECK_RAID ALL=(root) NOPASSWD: $cmd -PDList -aALL -NoLog",
"CHECK_RAID ALL=(root) NOPASSWD: $cmd -LdInfo -Lall -aALL -NoLog",
"CHECK_RAID ALL=(root) NOPASSWD: $cmd -AdpBbuCmd -GetBbuStatus -aALL -NoLog",
);
}
# parse physical devices
sub parse_pd {
my $this = shift;
my (@pd, %pd);
my $rc = -1;
my $fh = $this->cmd('pdlist');
while (<$fh>) {
if (my($s) = /Device Id: (\S+)/) {
push(@pd, { %pd }) if %pd;
%pd = ( dev => $s, state => undef, name => undef, predictive => undef );
next;
}
if (my($s) = /Firmware state: (.+)/) {
# strip the extra state:
# 'Hotspare, Spun Up'
# 'Hotspare, Spun down'
# 'Online, Spun Up'
# 'Online, Spun Up'
# 'Online, Spun down'
# 'Unconfigured(bad)'
# 'Unconfigured(good), Spun Up'
# 'Unconfigured(good), Spun down'
$s =~ s/,.+//;
$pd{state} = $s;
if (defined($pd{predictive})) {
$pd{state} = $pd{predictive};
}
next;
}
if (my($s) = /Predictive Failure Count: (\d+)/) {
if ($s > 0) {
$pd{predictive} = 'Predictive';
}
next;
}
if (my($s) = /Inquiry Data: (.+)/) {
# trim some spaces
$s =~ s/\s+/ /g; $s =~ s/^\s+|\s+$//g;
$pd{name} = $s;
next;
}
if (my($s) = /Exit Code: (\d+x\d+)/) {
$rc = hex($s);
}
else {
$rc = 0;
}
}
push(@pd, { %pd }) if %pd;
$this->critical unless close $fh;
$this->critical if $rc;
return \@pd;
}
sub parse_ld {
my $this = shift;
my (@ld, %ld);
my $rc = -1;
my $fh = $this->cmd('ldinfo');
while (<$fh>) {
if (my($drive_id, $target_id) = /Virtual (?:Disk|Drive)\s*:\s*(\d+)\s*\(Target Id:\s*(\d+)\)/i) {
push(@ld, { %ld }) if %ld;
# Default to DriveID:TargetID in case no Name is given ...
%ld = ( name => "DISK$drive_id.$target_id", state => undef );
next;
}
if (my($name) = /Name\s*:\s*(\S+)/) {
# Add a symbolic name, if given
$ld{name} = $name;
next;
}
if (my($s) = /Virtual Drive Type\s*:\s*(\S+)/) {
$ld{type} = $s;
next;
}
if (my($s) = /State\s*:\s*(\S+)/) {
$ld{state} = $s;
next;
}
if (my($s) = /Default Cache Policy\s*:\s*(.+)/) {
$ld{default_cache} = [split /,\s*/, $s];
next;
}
if (my($s) = /Current Cache Policy\s*:\s*(.+)/) {
$ld{current_cache} = [split /,\s*/, $s];
next;
}
if (my($s) = /Exit Code: (\d+x\d+)/) {
$rc = hex($s);
} else {
$rc = 0;
}
}
push(@ld, { %ld }) if %ld;
$this->critical unless close $fh;
$this->critical if $rc;
return \@ld;
}
# check battery
sub parse_bbu {
my $this = shift;
return undef unless $this->bbu_monitoring;
my %default_bbu = (
name => undef, state => '???', charging_status => '???', missing => undef,
learn_requested => undef, replacement_required => undef,
learn_cycle_requested => undef, learn_cycle_active => '???',
pack_will_fail => undef, temperature => undef, temperature_state => undef,
voltage => undef, voltage_state => undef
);
my (@bbu, %bbu);
my $fh = $this->cmd('battery');
while (<$fh>) {
# handle when bbu status get gives an error. see issue #32
if (my($s) = /Get BBU Status Failed/) {
last;
}
if (my($s) = /BBU status for Adapter: (.+)/) {
push(@bbu, { %bbu }) if %bbu;
%bbu = %default_bbu;
$bbu{name} = $s;
next;
}
#=cut
# according to current sample data, Battery State never has value
if (my($s) = /Battery State\s*: ?(.*)/i) {
if (!$s) { $s = 'Faulty'; };
$bbu{state} = $s;
next;
}
#=cut
if (my($s) = /Charging Status\s*: (\w*)/) {
$bbu{charging_status} = $s;
next;
}
if (my($s) = /Battery Pack Missing\s*: (\w*)/) {
$bbu{missing} = $s;
next;
}
if (my($s) = /Battery Replacement required\s*: (\w*)/) {
$bbu{replacement_required} = $s;
next;
}
if (my($s) = /Learn Cycle Requested\s*: (\w*)/) {
$bbu{learn_cycle_requested} = $s;
next;
}
if (my($s) = /Learn Cycle Active\s*: (\w*)/) {
$bbu{learn_cycle_active} = $s;
next;
}
if (my($s) = /Pack is about to fail & should be replaced\s*: (\w*)/) {
$bbu{pack_will_fail} = $s;
next;
}
# Temperature: 18 C
if (my($s) = /Temperature: (\d+) C/) {
$bbu{temperature} = $s;
next;
}
# Temperature : OK
if (my($s) = / Temperature\s*: (\w*)/) {
$bbu{temperature_state} = $s;
next;
}
# Voltage: 4074 mV
if (my($s) = /Voltage: (\d+) mV/) {
$bbu{voltage} = $s;
next;
}
# Voltage : OK
if (my($s) = /Voltage\s*: (\w*)/) {
$bbu{voltage_state} = $s;
next;
}
}
$this->critical unless close $fh;
push(@bbu, { %bbu }) if %bbu;
return \@bbu;
}
sub parse {
my $this = shift;
my $pd = $this->parse_pd;
my $ld = $this->parse_ld;
my $bbu = $this->parse_bbu;
my @devs = @$pd if $pd;
my @vols = @$ld if $ld;
my @bats = @$bbu if $bbu;
return {
logical => $ld,
physical => $pd,
battery => $bbu,
};
}
sub check {
my $this = shift;
my $c = $this->parse;
my @vstatus;
foreach my $vol (@{$c->{logical}}) {
# skip CacheCade for now. #91
if ($vol->{type} && $vol->{type} eq 'CacheCade') {
next;
}
push(@vstatus, sprintf "%s:%s", $vol->{name}, $vol->{state});
if ($vol->{state} ne 'Optimal') {
$this->critical;
}
# check cache policy, #65
my @wt = grep { /WriteThrough/ } @{$vol->{current_cache}};
if (@wt) {
my @default = grep { /WriteThrough/ } @{$vol->{default_cache}};
# alert if WriteThrough is configured in default
$this->cache_fail unless @default;
push(@vstatus, "WriteCache:DISABLED");
}
}
my %dstatus;
foreach my $dev (@{$c->{physical}}) {
if ($dev->{state} eq 'Online' || $dev->{state} eq 'Hotspare' || $dev->{state} eq 'Unconfigured(good)' || $dev->{state} eq 'JBOD') {
push(@{$dstatus{$dev->{state}}}, sprintf "%02d", $dev->{dev});
} elsif ($dev->{state} eq 'Predictive') {
$this->warning;
push(@{$dstatus{$dev->{state}}}, sprintf "%02d (%s)", $dev->{dev}, $dev->{name});
} else {
$this->critical;
# TODO: process other statuses
push(@{$dstatus{$dev->{state}}}, sprintf "%02d (%s)", $dev->{dev}, $dev->{name});
}
}
my (%bstatus, @bpdata, @blongout);
foreach my $bat (@{$c->{battery}}) {
if ($bat->{state} !~ /^(Operational|Optimal)$/) {
# BBU learn cycle in progress.
if ($bat->{charging_status} =~ /^(Charging|Discharging)$/ && $bat->{learn_cycle_active} eq 'Yes') {
$this->bbulearn;
} else {
$this->critical;
}
}
if ($bat->{missing} ne 'No') {
$this->critical;
}
if ($bat->{replacement_required} ne 'No') {
$this->critical;
}
if (defined($bat->{pack_will_fail}) && $bat->{pack_will_fail} ne 'No') {
$this->critical;
}
if ($bat->{temperature_state} ne 'OK') {
$this->critical;
}
if ($bat->{voltage_state} ne 'OK') {
$this->critical;
}
# Short output.
#
# CRITICAL: megacli:[Volumes(1): NoName:Optimal; Devices(2): 06,07=Online; Batteries(1): 0=Non Operational]
push(@{$bstatus{$bat->{state}}}, sprintf "%d", $bat->{name});
# Performance data.
# Return current battery temparature & voltage.
#
# Battery0=18;4074
push(@bpdata, sprintf "Battery%s_T=%s;;;; Battery%s_V=%s;;;;", $bat->{name}, $bat->{temperature}, $bat->{name}, $bat->{voltage});
# Long output.
# Detailed plugin output.
#
# Battery0:
# - State: Non Operational
# - Missing: No
# - Replacement required: Yes
# - About to fail: No
# - Temperature: OK (18 °C)
# - Voltage: OK (4015 mV)
push(@blongout, join("\n", grep {/./}
"Battery$bat->{name}:",
" - State: $bat->{state}",
" - Charging status: $bat->{charging_status}",
" - Learn cycle requested: $bat->{learn_cycle_requested}",
" - Learn cycle active: $bat->{learn_cycle_active}",
" - Missing: $bat->{missing}",
" - Replacement required: $bat->{replacement_required}",
defined($bat->{pack_will_fail}) ? " - About to fail: $bat->{pack_will_fail}" : "",
" - Temperature: $bat->{temperature_state} ($bat->{temperature} C)",
" - Voltage: $bat->{voltage_state} ($bat->{voltage} mV)",
));
}
my @cstatus;
push(@cstatus, 'Volumes(' . ($#{$c->{logical}} + 1) . '): ' . join(',', @vstatus));
push(@cstatus, 'Devices(' . ($#{$c->{physical}} + 1) . '): ' . $this->join_status(\%dstatus));
push(@cstatus, 'Batteries(' . ($#{$c->{battery}} + 1) . '): ' . $this->join_status(\%bstatus)) if @{$c->{battery}};
my @status = join('; ', @cstatus);
my @pdata;
push(@pdata,
join('\n', @bpdata)
);
my @longout;
push(@longout,
join('\n', @blongout)
);
return unless @status;
# denote this plugin as ran ok
$this->ok;
$this->message(join(' ', @status));
$this->perfdata(join(' ', @pdata));
$this->longoutput(join(' ', @longout));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_MEGACLI
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/megaide.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_MEGAIDE';
package App::Monitoring::Plugin::CheckRaid::Plugins::megaide;
# MegaIDE RAID controller
# Status: BROKEN: no test data
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub sudo {
my ($this) = @_;
my $cat = $this->which('cat');
"CHECK_RAID ALL=(root) NOPASSWD: $cat /proc/megaide/0/status";
}
sub check {
my $this = shift;
my $fh;
# status messages pushed here
my @status;
foreach my $f (</proc/megaide/*/status>) { # / silly comment to fix vim syntax hilighting
if (-r $f) {
open $fh, '<', $f or next;
=cut
} else {
my @CMD = ($cat, $f);
unshift(@CMD, $sudo) if $> and $sudo;
open($fh , '-|', @CMD) or next;
=cut
}
while (<$fh>) {
next unless (my($s, $n) = /Status\s*:\s*(\S+).*Logical Drive.*:\s*(\d+)/i);
next unless $this->valid($n);
if ($s ne 'ONLINE') {
$this->critical;
push(@status, "$n:$s");
} else {
push(@status, "$n:$s");
}
last;
}
close $fh;
}
return unless @status;
$this->message(join(' ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_MEGAIDE
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/megaraid.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_MEGARAID';
package App::Monitoring::Plugin::CheckRaid::Plugins::megaraid;
# MegaRAID
# Status: BROKEN: no test data
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub sudo {
my ($this) = @_;
my $cat = $this->which('cat');
my @sudo;
foreach my $mr (</proc/mega*/*/raiddrives*>) {
push(@sudo, "CHECK_RAID ALL=(root) NOPASSWD: $cat $mr") if -d $mr;
}
@sudo;
}
sub check {
my $this = shift;
# status messages pushed here
my @status;
foreach my $f (</proc/megaraid/*/raiddrives*>) { # vim/
my $fh;
if (-r $f) {
open $fh, '<', $f or next;
=cut
} else {
my @CMD = ($cat, $f);
unshift(@CMD, $sudo) if $> and $sudo;
open($fh , '-|', @CMD) or next;
=cut
}
my ($n) = $f =~ m{/proc/megaraid/([^/]+)};
while (<$fh>) {
if (my($s) = /logical drive\s*:\s*\d+.*, state\s*:\s*(\S+)/i) {
if ($s ne 'optimal') {
$this->critical;
}
push(@status, "$n: $s");
last;
}
}
close $fh;
}
return unless @status;
$this->message(join(', ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_MEGARAID
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/megarc.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_MEGARC';
package App::Monitoring::Plugin::CheckRaid::Plugins::megarc;
# LSI MegaRaid or Dell Perc arrays
# Check the status of all arrays on all Lsi MegaRaid controllers on the local
# machine. Uses the megarc program written by Lsi to get the status of all
# arrays on all local Lsi MegaRaid controllers.
#
# check designed from check_lsi_megaraid:
# http://www.monitoringexchange.org/cgi-bin/page.cgi?g=Detailed/2416.html;d=1
# Perl port (check_raid) by Elan Ruusamäe.
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub program_names {
shift->{name};
}
sub commands {
{
'controller list' => ['-|', '@CMD', '-AllAdpInfo', '-nolog'],
'controller config' => ['-|', '@CMD', '-dispCfg', '-a$controller', '-nolog'],
}
}
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
my $cmd = $this->{program};
(
"CHECK_RAID ALL=(root) NOPASSWD: $cmd -AllAdpInfo -nolog",
"CHECK_RAID ALL=(root) NOPASSWD: $cmd -dispCfg -a* -nolog",
);
}
sub check {
my $this = shift;
# status messages pushed here
my @status;
# get controllers
my $fh = $this->cmd('controller list');
my @lines = <$fh>;
close $fh;
if ($lines[11] =~ /No Adapters Found/) {
$this->warning;
$this->message("No LSI adapters were found on this machine");
return;
}
my @c;
foreach (@lines[12..$#lines]) {
if (my ($id) = /^\s*(\d+)/) {
push(@c, int($id));
}
}
unless (@c) {
$this->warning;
$this->message("No LSI adapters were found on this machine");
return;
}
foreach my $c (@c) {
my $fh = $this->cmd('controller config', { '$controller' => $c });
my (%d, %s, $ld);
while (<$fh>) {
# Logical Drive : 0( Adapter: 0 ): Status: OPTIMAL
if (my($d, $s) = /Logical Drive\s+:\s+(\d+).+Status:\s+(\S+)/) {
$ld = $d;
$s{$ld} = $s;
next;
}
# SpanDepth :01 RaidLevel: 5 RdAhead : Adaptive Cache: DirectIo
if (my($s) = /RaidLevel:\s+(\S+)/) {
$d{$ld} = $s if defined $ld;
next;
}
}
close $fh;
# now process the details
unless (keys %d) {
$this->message("No arrays found on controller $c");
$this->warning;
return;
}
while (my($d, $s) = each %s) {
if ($s ne 'OPTIMAL') {
# The Array number here is incremented by one because of the
# inconsistent way that the LSI tools count arrays.
# This brings it back in line with the view in the bios
# and from megamgr.bin where the array counting starts at
# 1 instead of 0
push(@status, "Array ".(int($d) + 1)." status is ".$s{$d}." (Raid-$s on adapter $c)");
$this->critical;
next;
}
push(@status, "Logical Drive $d: $s");
}
}
return unless @status;
$this->ok->message(join(', ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_MEGARC
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/metastat.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_METASTAT';
package App::Monitoring::Plugin::CheckRaid::Plugins::metastat;
# Solaris, software RAID
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub program_names {
shift->{name};
}
sub commands {
{
'metastat' => ['>&2', '@CMD'],
}
}
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
my $cmd = $this->{program};
"CHECK_RAID ALL=(root) NOPASSWD: $cmd"
}
sub active {
my ($this) = @_;
# return if parent said NO
my $res = $this->SUPER::active(@_);
return $res unless $res;
my $output = $this->get_metastat;
return !!@$output;
}
sub get_metastat {
my $this = shift;
# cache inside single run
return $this->{output} if defined $this->{output};
my $fh = $this->cmd('metastat');
my @data;
while (<$fh>) {
chomp;
last if /there are no existing databases/;
push(@data, $_);
}
return $this->{output} = \@data;
}
sub check {
my $this = shift;
my ($d, $sd);
# status messages pushed here
my @status;
my $output = $this->get_metastat;
foreach (@$output) {
if (/^(\S+):/) { $d = $1; $sd = ''; next; }
if (/Submirror \d+:\s+(\S+)/) { $sd = $1; next; }
if (/Device:\s+(\S+)/) { $sd = $1; next; }
if (my($s) = /State: (\S.+\w)/) {
if ($sd and $this->valid($sd) and $this->valid($d)) {
if ($s =~ /Okay/i) {
# no worries...
} elsif ($s =~ /Resync/i) {
$this->resync;
} else {
$this->critical;
}
push(@status, "$d:$sd:$s");
}
}
if (defined $d && $d =~ /hsp/) {
if (/(c[0-9]+t[0-9]+d[0-9]+s[0-9]+)\s+(\w+)/) {
$sd = $1;
my $s = $2;
$this->warning if ($s !~ /Available/);
push(@status, "$d:$sd:$s");
}
}
}
return unless @status;
$this->ok->message(join(', ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_METASTAT
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/mpt.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_MPT';
package App::Monitoring::Plugin::CheckRaid::Plugins::mpt;
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub program_names {
qw(mpt-status);
}
sub commands {
{
'get_controller_no' => ['-|', '@CMD', '-p'],
'status' => ['-|', '@CMD', '-i', '$id'],
'sync status' => ['-|', '@CMD', '-n'],
}
}
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
my $cmd = $this->{program};
(
"CHECK_RAID ALL=(root) NOPASSWD: $cmd -i [0-9]",
"CHECK_RAID ALL=(root) NOPASSWD: $cmd -i [1-9][0-9]",
"CHECK_RAID ALL=(root) NOPASSWD: $cmd -n",
"CHECK_RAID ALL=(root) NOPASSWD: $cmd -p",
);
}
sub active {
my ($this) = @_;
# return if parent said NO
my $res = $this->SUPER::active(@_);
return $res unless $res;
# there should be a controller. #95
my $id = $this->get_controller;
return defined($id);
}
# get controller from mpt-status -p
# FIXME: could there be multiple controllers?
sub get_controller {
my $this = shift;
my $fh = $this->cmd('get_controller_no');
my $id;
while (<$fh>) {
chomp;
if (/^Found.*id=(\d{1,2}),.*/) {
$id = $1;
last;
}
}
close $fh;
return $id;
}
sub parse {
my ($this, $id) = @_;
my (%ld, %pd);
my $fh = $this->cmd('status', { '$id' => $id });
my %VolumeTypesHuman = (
IS => 'RAID-0',
IME => 'RAID-1E',
IM => 'RAID-1',
);
while (<$fh>) {
chomp;
# mpt-status.c __print_volume_classic
# ioc0 vol_id 0 type IM, 2 phy, 136 GB, state OPTIMAL, flags ENABLED
if (my($vioc, $vol_id, $type, $disks, $vol_size, $vol_state, $vol_flags) =
/^ioc(\d+)\s+ vol_id\s(\d+)\s type\s(\S+),\s (\d+)\sphy,\s (\d+)\sGB,\s state\s(\S+),\s flags\s(.+)/x) {
$ld{$vol_id} = {
ioc => int($vioc),
vol_id => int($vol_id),
# one of: IS, IME, IM
vol_type => $type,
raid_level => $VolumeTypesHuman{$type},
phy_disks => int($disks),
size => int($vol_size),
# one of: OPTIMAL, DEGRADED, FAILED, UNKNOWN
status => $vol_state,
# array of: ENABLED, QUIESCED, RESYNC_IN_PROGRESS, VOLUME_INACTIVE or NONE
flags => [ split ' ', $vol_flags ],
};
}
# ./include/lsi/mpi_cnfg.h
# typedef struct _RAID_PHYS_DISK_INQUIRY_DATA
# {
# U8 VendorID[8]; /* 00h */
# U8 ProductID[16]; /* 08h */
# U8 ProductRevLevel[4]; /* 18h */
# U8 Info[32]; /* 1Ch */
# }
# mpt-status.c __print_physdisk_classic
# ioc0 phy 0 scsi_id 0 IBM-ESXS PYH146C3-ETS10FN RXQN, 136 GB, state ONLINE, flags NONE
# ioc0 phy 0 scsi_id 1 ATA ST3808110AS J , 74 GB, state ONLINE, flags NONE
# ioc0 phy 0 scsi_id 1 ATA Hitachi HUA72101 AJ0A, 931 GB, state ONLINE, flags NONE
elsif (my($pioc, $num, $phy_id, $vendor, $prod_id, $rev, $size, $state, $flags) =
/^ioc(\d+)\s+ phy\s(\d+)\s scsi_id\s(\d+)\s (.{8})\s+(.{16})\s+(.{4})\s*,\s (\d+)\sGB,\s state\s(\S+),\s flags\s(.+)/x) {
$pd{$num} = {
ioc => int($pioc),
num => int($num),
phy_id => int($phy_id),
vendor => $vendor,
prod_id => $prod_id,
rev => $rev,
size => int($size),
# one of: ONLINE, MISSING, NOT_COMPATIBLE, FAILED, INITIALIZING, OFFLINE_REQUESTED, FAILED_REQUESTED, OTHER_OFFLINE, UNKNOWN
status => $state,
# array of: OUT_OF_SYNC, QUIESCED or NONE
flags => [ split ' ', $flags ],
};
} else {
warn "mpt unparsed: [$_]";
$this->unknown;
}
}
close $fh;
# extra parse, if mpt-status has -n flag, can process also resync state
# TODO: if -n becames default can do this all in one run
my $resyncing = grep {/RESYNC_IN_PROGRESS/} map { @{$_->{flags}} } values %ld;
if ($resyncing) {
my $fh = $this->cmd('sync status');
while (<$fh>) {
if (/^ioc:\d+/) {
# ignore
}
# mpt-status.c GetResyncPercentage
# scsi_id:0 70%
elsif (my($scsi_id, $percent) = /^scsi_id:(\d+) (\d+)%/) {
$pd{$scsi_id}{resync} = int($percent);
} else {
warn "mpt unparsed: [$_]";
$this->unknown;
}
}
close $fh;
}
return {
'logical' => { %ld },
'physical' => { %pd },
};
}
sub check {
my $this = shift;
# status messages pushed here
my @status;
my $id = $this->get_controller;
my $status = $this->parse($id);
# process logical units
while (my($d, $u) = each %{$status->{logical}}) {
next unless $this->valid($d);
my $s = $u->{status};
if ($s =~ /INITIAL|INACTIVE/) {
$this->warning;
} elsif ($s =~ /RESYNC/) {
$this->resync;
} elsif ($s =~ /DEGRADED|FAILED/) {
$this->critical;
} elsif ($s !~ /ONLINE|OPTIMAL/) {
$this->unknown;
}
# FIXME: this resync_in_progress is separate state of same as value in status?
if (grep { /RESYNC_IN_PROGRESS/ } @{$u->{flags}}) {
# find matching disks
my @disks = grep {$_->{ioc} eq $u->{ioc} } values %{$status->{physical}};
# collect percent for each disk
my @percent = map { $_->{resync}.'%'} @disks;
$s .= ' RESYNCING: '.join('/', @percent);
}
push(@status, "Volume $d ($u->{raid_level}, $u->{phy_disks} disks, $u->{size} GiB): $s");
}
# process physical units
while (my($d, $u) = each %{$status->{physical}}) {
my $s = $u->{status};
# remove uninteresting flags
my @flags = grep {!/NONE/} @{$u->{flags}};
# skip print if nothing in flags and disk is ONLINE
next unless @flags and $s eq 'ONLINE';
$s .= ' ' . join(' ', @flags);
push(@status, "Disk $d ($u->{size} GiB):$s");
$this->critical;
}
return unless @status;
$this->ok->message(join(', ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_MPT
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/mvcli.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_MVCLI';
package App::Monitoring::Plugin::CheckRaid::Plugins::mvcli;
# Status: BROKEN: not finished
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub program_names {
shift->{name};
}
sub commands {
{
'mvcli blk' => ['-|', '@CMD'],
'mvcli smart' => ['-|', '@CMD'],
}
}
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
my $cmd = $this->{program};
"CHECK_RAID ALL=(root) NOPASSWD: $cmd"
}
sub parse_blk {
my $this = shift;
my (@blk, %blk);
my $fh = $this->cmd('mvcli blk');
while (<$fh>) {
chomp;
if (my ($blk_id) = /Block id:\s+(\d+)/) {
# block id is first item, so push previous item to list
if (%blk) {
push(@blk, { %blk });
%blk = ();
}
$blk{blk_id} = int($blk_id);
} elsif (my($pd_id) = /PD id:\s+(\d+)/) {
$blk{pd_id} = int($pd_id);
} elsif (my($vd_id) = /VD id:\s+(\d+)/) {
$blk{vd_id} = int($vd_id);
} elsif (my($bstatus) = /Block status:\s+(.+)/) {
$blk{block_status} = $bstatus;
} elsif (my($size) = /Size:\s+(\d+) K/) {
$blk{size} = int($size);
} elsif (my($offset) = /Starting offset:\s+(\d+) K/) {
$blk{offset} = int($offset);
} else {
# warn "[$_]\n";
}
}
close $fh;
if (%blk) {
push(@blk, { %blk });
}
return wantarray ? @blk : \@blk;
}
sub parse_smart {
my ($this, $blk) = @_;
# collect pd numbers
my @pd = map { $_->{pd_id} } @$blk;
my %smart;
foreach my $pd (@pd) {
my $fh = $this->cmd('mvcli smart', { '$pd' => $pd });
my %attrs = ();
while (<$fh>) {
chomp;
if (my($id, $name, $current, $worst, $treshold, $raw) = /
([\dA-F]{2})\s+ # attr
(.*?)\s+ # name
(\d+)\s+ # current
(\d+)\s+ # worst
(\d+)\s+ # treshold
([\dA-F]+) # raw
/x) {
my %attr = ();
$attr{id} = $id;
$attr{name} = $name;
$attr{current} = int($current);
$attr{worst} = int($worst);
$attr{treshold} = int($treshold);
$attr{raw} = $raw;
$attrs{$id} = { %attr };
} else {
# warn "[$_]\n";
}
}
$smart{$pd} = { %attrs };
}
return \%smart;
}
sub parse {
my $this = shift;
my $blk = $this->parse_blk;
my $smart = $this->parse_smart($blk);
return {
blk => $blk,
smart => $smart,
};
}
sub check {
my $this = shift;
my (@status);
my @d = $this->parse;
# not implemented yet
$this->unknown;
$this->message(join('; ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_MVCLI
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/sas2ircu.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_SAS2IRCU';
package App::Monitoring::Plugin::CheckRaid::Plugins::sas2ircu;
# LSI SAS-2 controllers using the SAS-2 Integrated RAID Configuration Utility (SAS2IRCU)
# Based on the SAS-2 Integrated RAID Configuration Utility (SAS2IRCU) User Guide
# http://www.lsi.com/downloads/Public/Host%20Bus%20Adapters/Host%20Bus%20Adapters%20Common%20Files/SAS_SATA_6G_P12/SAS2IRCU_User_Guide.pdf
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub program_names {
shift->{name};
}
sub commands {
{
'controller list' => ['-|', '@CMD', 'LIST'],
'controller status' => ['-|', '@CMD', '$controller', 'STATUS'],
'device status' => ['-|', '@CMD', '$controller', 'DISPLAY'],
}
}
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
my $cmd = $this->{program};
(
"CHECK_RAID ALL=(root) NOPASSWD: $cmd LIST",
"CHECK_RAID ALL=(root) NOPASSWD: $cmd * STATUS",
"CHECK_RAID ALL=(root) NOPASSWD: $cmd * DISPLAY",
);
}
# detect controllers for sas2ircu
sub detect {
my $this = shift;
my @ctrls;
my $fh = $this->cmd('controller list');
my $success = 0;
my $state="";
my $noctrlstate="No Controllers";
while (<$fh>) {
chomp;
# Adapter Vendor Device SubSys SubSys
# Index Type ID ID Pci Address Ven ID Dev ID
# ----- ------------ ------ ------ ----------------- ------ ------
# 0 SAS2008 1000h 72h 00h:03h:00h:00h 1028h 1f1eh
if (my($c) = /^\s*(\d+)\s+\S+\s+\S+\s+\S+\s+\S+\s+\S+\s+\S+\s*$/) {
push(@ctrls, $c);
}
$success = 1 if /SAS2IRCU: Utility Completed Successfully/;
# handle the case where there's no hardware present.
# when there is no controller, we get
# root@i41:/tmp$ /usr/sbin/sas2ircudsr LIST
# LSI Corporation SAS2 IR Configuration Utility.
# Version 18.00.00.00 (2013.11.18)
# Copyright (c) 2009-2013 LSI Corporation. All rights reserved.
# SAS2IRCU: MPTLib2 Error 1
# root@i41:/tmp$ echo $?
# 1
if (/SAS2IRCU: MPTLib2 Error 1/) {
$state = $noctrlstate;
$success = 1 ;
}
}
unless (close $fh) {
#sas2ircu exits 1 (but close exits 256) when we close fh if we have no controller, so handle that, too
if ($? != 256 && $state eq $noctrlstate) {
$this->critical;
}
}
unless ($success) {
$this->critical;
}
return wantarray ? @ctrls : \@ctrls;
}
sub trim { my $s = shift; $s =~ s/^\s+|\s+$//g; return $s };
sub ltrim { my $s = shift; $s =~ s/^\s+//; return $s };
sub rtrim { my $s = shift; $s =~ s/\s+$//; return $s };
sub check {
my $this = shift;
my @ctrls = $this->detect;
my @status;
my $numvols=0;
# determine the RAID states of each controller
foreach my $c (@ctrls) {
my $fh = $this->cmd('controller status', { '$controller' => $c });
my $novolsstate="No Volumes";
my $state;
my $success = 0;
while (<$fh>) {
chomp;
# match adapter lines
if (my($s) = /^\s*Volume state\s*:\s*(\w+)\s*$/) {
$state = $s;
$numvols++;
if ($state ne "Optimal") {
$this->critical;
}
}
$success = 1 if /SAS2IRCU: Utility Completed Successfully/;
##handle the case where there are no volumes configured
#
# SAS2IRCU: there are no IR volumes on the controller!
# SAS2IRCU: Error executing command STATUS.
if (/SAS2IRCU: there are no IR volumes on the controller/
or /The STATUS command is not supported by the firmware currently loaded on controller/
) {
# even though this isn't the last line, go ahead and set success.
$success = 1;
$state = $novolsstate;
}
}
unless (close $fh) {
#sas2ircu exits 256 when we close fh if we have no volumes, so handle that, too
if ($? != 256 && $state eq $novolsstate) {
$this->critical;
$state = $!;
}
}
unless ($success) {
$this->critical;
$state = "SAS2IRCU Unknown exit";
}
unless ($state) {
$state = "Unknown Error";
}
my $finalvolstate=$state;
#push(@status, "ctrl #$c: $numvols Vols: $state");
##### now look at the devices.
# Device is a Hard disk
# Enclosure # : 2
# Slot # : 0
# SAS Address : 500065b-3-6789-abe0
# State : Ready (RDY)
# Size (in MB)/(in sectors) : 3815447/7814037167
# Manufacturer : ATA
# Model Number : ST4000DM000-1F21
# Firmware Revision : CC52
# Serial No : S30086G4
# GUID : 5000c5006d27b344
# Protocol : SATA
# Drive Type : SATA_HDD
$fh = $this->cmd('device status', { '$controller' => $c });
$state="";
$success = 0;
my $enc="";
my $slot="";
my @data;
my $device="";
my $numslots=0;
my $finalstate;
my $finalerrors="";
while (my $line = <$fh>) {
chomp $line;
# Device is a Hard disk
# Device is a Hard disk
# Device is a Enclosure services device
#
#lets make sure we're only checking disks. we dont support other devices right now
if ("$line" eq 'Device is a Hard disk') {
$device='disk';
} elsif ($line =~ /^Device/) {
$device='other';
}
if ("$device" eq 'disk') {
if ($line =~ /Enclosure #|Slot #|State /) {
#find our enclosure #
if ($line =~ /^ Enclosure # /) {
@data = split /:/, $line;
$enc=trim($data[1]);
#every time we hit a new enclosure line, reset our state and slot
undef $state;
undef $slot;
}
#find our slot #
if ($line =~ /^ Slot # /) {
@data = split /:/, $line;
$slot=trim($data[1]);
$numslots++
}
#find our state
if ($line =~ /^ State /) {
@data = split /:/, $line;
$state=ltrim($data[1]);
#for test
#if ($numslots == 10 ) { $state='FREDFISH';}
#when we get a state, test on it and report it..
if ($state =~ /Optimal|Ready/) {
#do nothing at the moment.
} else {
$this->critical;
$finalstate=$state;
$finalerrors="$finalerrors ERROR:Ctrl$c:Enc$enc:Slot$slot:$state";
}
}
}
}
if ($line =~ /SAS2IRCU: Utility Completed Successfully/) {
$success = 1;
}
} #end while
unless (close $fh) {
$this->critical;
$state = $!;
}
unless ($success) {
$this->critical;
$state = "SAS2IRCU Unknown exit";
}
unless ($state) {
$state = "Unknown Error";
}
unless($finalstate) {
$finalstate=$state;
}
#per controller overall report
#push(@status, ":$numslots Drives:$finalstate:$finalerrors");
push(@status, "ctrl #$c: $numvols Vols: $finalvolstate: $numslots Drives: $finalstate:$finalerrors:");
}
##if we didn't get a status out of the controllers and an empty ctrls array, we must not have any.
unless (@status && @ctrls) {
push(@status, "No Controllers");
}
return unless @status;
$this->ok->message(join(', ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_SAS2IRCU
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/smartctl.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_SMARTCTL';
package App::Monitoring::Plugin::CheckRaid::Plugins::smartctl;
# NOTE: not standalone plugin
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
use strict;
use warnings;
sub program_names {
shift->{name};
}
sub commands {
{
'smartctl' => ['-|', '@CMD', '-H', '$dev', '$diskopt$disk'],
}
}
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
# nothing, as not standalone plugin yet
}
# check for -H parameter for physical disks
# this is currently called out from cciss plugin
# @param device list
# device list being an array of:
# - device to check (/dev/cciss/c0d0)
# - disk options (-dcciss)
# - disk number (0..15)
sub check_devices {
my $this = shift;
my @devs = @_;
unless (@devs) {
$this->warning;
$this->message("No devices to check");
return;
}
# status message for devs, latter just joined for shorter messages
my %status;
foreach my $ref (@devs) {
my ($dev, $diskopt, $disk) = @$ref;
my $fh = $this->cmd('smartctl', { '$dev' => $dev, '$diskopt' => $diskopt => '$disk' => $disk });
while (<$fh>) {
chomp;
# SMART Health Status: HARDWARE IMPENDING FAILURE GENERAL HARD DRIVE FAILURE [asc=5d, ascq=10]
if (my($s, $sc) = /SMART Health Status: (.*?)(\s*\[asc=\w+, ascq=\w+\])?$/) {
# use shorter output, message that hpacucli would use
if ($s eq 'HARDWARE IMPENDING FAILURE GENERAL HARD DRIVE FAILURE') {
$s = 'Predictive Failure';
}
if ($s eq 'Predictive Failure') {
$this->warning;
} elsif ($s !~ '^OK') {
$this->critical;
}
push(@{$status{$s}}, $dev.'#'.$disk);
}
}
close($fh);
}
return unless %status;
$this->ok->message($this->join_status(\%status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_SMARTCTL
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Plugins/tw_cli.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_TW_CLI';
package App::Monitoring::Plugin::CheckRaid::Plugins::tw_cli;
# tw_cli(8) is a Command Line Interface Storage Management Software for
# AMCC/3ware ATA RAID Controller(s).
# Owned by LSI currently: https://en.wikipedia.org/wiki/3ware
#
# http://www.cyberciti.biz/files/tw_cli.8.html
use base 'App::Monitoring::Plugin::CheckRaid::Plugin';
# not yet, see:
# https://github.com/glensc/nagios-plugin-check_raid/pull/131#issuecomment-189957806
#use Date::Parse qw(strptime);
#use DateTime;
use strict;
use warnings;
sub program_names {
qw(tw_cli-9xxx tw_cli tw-cli);
}
sub commands {
{
'show' => ['-|', '@CMD', 'show'], # This is 'info' output AND enclosure summary
'unitstatus' => ['-|', '@CMD', 'info', '$controller', 'unitstatus'],
'drivestatus' => ['-|', '@CMD', 'info', '$controller', 'drivestatus'],
'bbustatus' => ['-|', '@CMD', 'info', '$controller', 'bbustatus'],
'enc_show_all' => ['-|', '@CMD', '$encid', 'show all'],
}
}
sub sudo {
my ($this, $deep) = @_;
# quick check when running check
return 1 unless $deep;
my $cmd = $this->{program};
(
"CHECK_RAID ALL=(root) NOPASSWD: $cmd info",
"CHECK_RAID ALL=(root) NOPASSWD: $cmd info *",
"CHECK_RAID ALL=(root) NOPASSWD: $cmd show",
"CHECK_RAID ALL=(root) NOPASSWD: $cmd * show all",
);
}
sub trim { my $s = shift; $s =~ s/^\s+|\s+$//g; return $s };
sub to_i {
my $i = shift;
return $i if $i !~ /^\d+$/;
return int($i);
}
sub parse {
my $this = shift;
my (%c);
# scan controllers
my ($sect_ctl, $sect_enc) = 0;
my $fh = $this->cmd('show');
while (<$fh>) {
# Section break
if(/^\s*$/) { ($sect_ctl,$sect_enc) = (0,0); next; };
# header line
if(/^-+$/) { next; };
# section headers: Controller
# Ctl Model Ports Drives Units NotOpt RRate VRate BBU
# Ctl Model (V)Ports Drives Units NotOpt RRate VRate BBU
if (/^Ctl.*Model.*Rate/) { $sect_ctl = 1; next; };
# section headers: Enclosure
# Encl Slots Drives Fans TSUnits Ctls
# Encl Slots Drives Fans TSUnits PSUnits
# Enclosure Slots Drives Fans TSUnits PSUnits Alarms
if (/^Encl.*Drive/) { $sect_enc = 1; next; };
# controller section
if ($sect_ctl and my($ctl, $model, $ports, $drives, $units, $notopt, $rrate, $vrate, $bbu) = m{^
(c\d+)\s+ # Controller
(\S+)\s+ # Model
(\d+)\s+ # (V)Ports
(\d+)\s+ # Drives
(\d+)\s+ # Units
(\d+)\s+ # NotOpt: Not Optional
# Not Optimal refers to any state except OK and VERIFYING.
# Other states include INITIALIZING, INIT-PAUSED,
# REBUILDING, REBUILD-PAUSED, DEGRADED, MIGRATING,
# MIGRATE-PAUSED, RECOVERY, INOPERABLE, and UNKNOWN.
(\d+)\s+ # RRate: Rebuild Rate
(\d+|-)\s+ # VRate: Verify Rate
(\S+|-)? # BBU
}x) {
$c{$ctl} = {
model => $model,
ports => int($ports),
drives => int($drives),
units => int($units),
optimal => int(!$notopt),
rrate => int($rrate),
vrate => to_i($vrate),
bbu => $bbu,
};
}
# enclosure section
if ($sect_enc and my($enc, $slots, $drives, $fans, $tsunits, $psunits, $alarms) = m{^
((?:/c\d+)?/e\d+)\s+ # Controller, Enclosure
# 9650SE reports enclosures as /eX
# 9690SA+ report enclosures as /cX/eX
(\d+)\s+ # Slots
(\d+)\s+ # Drives
(\d+)\s+ # Fans
(\d+)\s+ # TSUnits - Temp Sensor
(\d+)?\s+ # PSUnits - Power Supply, not always present!
(\d+)?\s+ # Controller OR Alarms, not always present!
}x) {
# This will be filled in later by the enclosure pass
$c{$enc} = {};
}
}
close $fh;
# no controllers? skip early
return unless %c;
for my $c (grep /^\/?c\d+$/, keys %c) {
# get each unit on controllers
$fh = $this->cmd('unitstatus', { '$controller' => $c });
while (<$fh>) {
if (my($u, $type, $status, $p_rebuild, $p_vim, $strip, $size, $cache, $avrify) = m{^
(u\d+)\s+ # Unit
(\S+)\s+ # UnitType
(\S+)\s+ # Status
(\S+)\s+ # %RCmpl: The %RCompl reports the percent completion
# of the unit's Rebuild, if this task is in progress.
(\S+)\s+ # %V/I/M: The %V/I/M reports the percent completion
# of the unit's Verify, Initialize, or Migrate,
# if one of these are in progress.
(\S+)\s+ # Strip
(\S+)\s+ # Size(GB)
(\S+)\s+ # Cache
(\S+) # AVrify
}x) {
$c{$c}{unitstatus}{$u} = {
type => $type,
status => $status,
rebuild_percent => $p_rebuild,
vim_percent => $p_vim,
strip => $strip,
size => $size,
cache => $cache,
avrify => $avrify,
};
next;
}
if (m{^u\d+}) {
$this->unknown;
warn "unparsed: [$_]";
}
}
close $fh;
# get individual disk status
$fh = $this->cmd('drivestatus', { '$controller' => $c });
# common regexp
my $r = qr{^
(p\d+)\s+ # Port
(\S+)\s+ # Status
(\S+)\s+ # Unit
([\d.]+\s[TG]B|-)\s+ # Size
}x;
while (<$fh>) {
# skip empty line
next if /^$/;
# Detect version
if (/^Port/) {
# <=9.5.1: Blocks Serial
$r .= qr{
(\S+)\s+ # Blocks
(.+) # Serial
}x;
next;
} elsif (/^VPort/) {
# >=9.5.2: Type Phy Encl-Slot Model
$r .= qr{
(\S+)\s+ # Type
(\S+)\s+ # Phy
(\S+)\s+ # Encl-Slot
(.+) # Model
}x;
next;
}
if (my($port, $status, $unit, $size, @rest) = ($_ =~ $r)) {
# do not report disks not present
# tw_cli 9.5.2 and above do not list these at all
next if $status eq 'NOT-PRESENT';
my %p;
if (@rest <= 2) {
my ($blocks, $serial) = @rest;
%p = (
blocks => to_i($blocks),
serial => trim($serial),
);
} else {
my ($type, $phy, $encl, $model) = @rest;
%p = (
type => $type,
phy => to_i($phy),
encl => $encl,
model => $model,
);
}
$c{$c}{drivestatus}{$port} = {
status => $status,
unit => $unit,
size => $size,
%p,
};
next;
}
if (m{^p\d+}) {
$this->unknown;
warn "unparsed: [$_]";
}
}
close $fh;
# get BBU status
$fh = $this->cmd('bbustatus', { '$controller' => $c });
while (<$fh>) {
next if /^$/;
next if /^-{10,}$/;
if (my($bbu, $onlinestate, $bbuready, $status, $volt, $temp, $hours, $lastcaptest) = m{^
(bbu\d*)\s+ # BBU, possibly numbered (RARE)
(\S+)\s+ # OnlineState
(\S+)\s+ # BBUReady
(\S+)\s+ # Status
(\S+)\s+ # Volt
(\S+)\s+ # Temp
(\d+)\s+ # Hours
(\S+)\s+ # LastCapTest
}x) {
$c{$c}{bbustatus}{$bbu} = {
OnlineState => $onlinestate,
BBUReady => $bbuready,
Status => $status,
Volt => $volt,
Temp => $temp,
Hours => $hours,
LastCapTest => $lastcaptest,
};
next;
}
if (m{^\S+\+}) {
$this->unknown;
warn "unparsed: [$_]";
}
}
close $fh;
}
# Do enclosures now, which might NOT be attached the controllers
# WARNING: This data section has not always been consistent over versions of tw_cli.
# You should try to use the newest version of the driver, as it deliberately uses the newer style of output
# rather than the output for the tw_cli versions released with 9550SX/9590SE/9650SE
for my $encid (grep /\/e\d+$/, keys %c) {
$fh = $this->cmd('enc_show_all', { '$encid' => $encid });
# Variable names chose to be 'sect_XXX' explicitly.
# This says what section we are in right now
my ($sect_enc, $sect_fan, $sect_tmp, $sect_psu, $sect_slt, $sect_alm) = (0,0,0,0,0,0);
# This says what section we have seen, it gets reset at the start of each enclosure block;
my ($seen_enc, $seen_fan, $seen_tmp, $seen_psu, $seen_slt, $seen_alm) = (0,0,0,0,0,0);
while (<$fh>) {
# Skip the header break lines
next if /^-+$/;
# and the partial indented header that is ABOVE the fan header
next if /^\s+-+Speed-+\s*$/;
# If the line is blank, reset our section headers
if(/^\s*$/){
($sect_enc, $sect_fan, $sect_tmp, $sect_psu, $sect_slt, $sect_alm) = (0,0,0,0,0,0);
# If we have SEEN all of the sections, also reset the seen markers
# This is needed when the output contains multiple enclosures
if($sect_enc and $sect_fan and $sect_tmp and $sect_psu and $sect_slt and $sect_alm) {
($seen_enc, $seen_fan, $seen_tmp, $seen_psu, $seen_slt, $seen_alm) = (0,0,0,0,0,0);
}
next;
}
if (/^Encl.*Status/) { $seen_enc = $sect_enc = 1; next; }
if (/^Fan.*Status/) { $seen_fan = $sect_fan = 1; next; }
if (/^TempSensor.*Status/) { $seen_tmp = $sect_tmp = 1; next; }
if (/^PowerSupply.*Status/) { $seen_psu = $sect_psu = 1; next; }
if (/^Slot.*Status/) { $seen_slt = $sect_slt = 1; next; }
if (/^Alarm.*Status/) { $seen_alm = $sect_alm = 1; next; }
# ------ Start of new enclosure
if ($sect_enc and my($encl, $encl_status) = m{^
((?:/c\d+)?/e\d+)\s+ # Controller, Enclosure
(\S+)\s+ # Status
}x) {
# This is a special case for the test environment, as it is
# hard to feed MULTI command inputs into the mock.
if($ENV{'HARNESS_ACTIVE'} and $encl ne $encid) {
$encid = $encl;
}
$c{$encid} = {
encl => $encl, # Dupe of $encid to verify
status => $encl_status,
# This is the top-level enclosure object
fans => {},
tempsensor => {},
powersupply => {},
slot => {},
alarm => {},
};
}
# ------ Fans
elsif ($sect_fan and my($fan, $fan_status, $fan_state, $fan_step, $fan_rpm, $fan_identify) = m{^
(fan\S+)\s+ # Fan
(\S+)\s+ # Status
(\S+)\s+ # State
(\S+)\s+ # Step
(\d+|N/A)\s+ # RPM
(\S+)\s+ # Identify
}x) {
$c{$encid}{fans}{$fan} = {
status => $fan_status,
state => $fan_state,
step => $fan_step,
rpm => $fan_rpm,
identify => $fan_identify,
};
next;
}
# ------ TempSensor
elsif ($sect_tmp and my($tmp, $tmp_status, $tmp_temperature, $tmp_identify) = m{^
(temp\S+)\s+ # TempSensor
(\S+)\s+ # Status
(\S+)\s+ # Temperature
(\S+)\s+ # Identify
}x) {
$c{$encid}{tempsensor}{$tmp} = {
status => $tmp_status,
temperature => $tmp_temperature,
identify => $tmp_identify,
};
next;
}
# ------ PowerSupply
elsif ($sect_psu and my($psu, $psu_status, $psu_state, $psu_voltage, $psu_current, $psu_identify) = m{^
((?:pw|psu)\S+)\s+ # PowerSupply
(\S+)\s+ # Status
(\S+)\s+ # State
(\S+)\s+ # Voltage
(\S+)\s+ # Current
(\S+)\s+ # Identify
}x) {
$c{$encid}{powersupply}{$psu} = {
status => $psu_status,
state => $psu_state,
voltage => $psu_voltage,
current => $psu_current,
identify => $psu_identify,
};
next;
}
# ------ Slot
elsif ($sect_slt and my($slt, $slt_status, $slt_vport, $slt_identify) = m{^
(slo?t\S+)\s+ # Slot
(\S+)\s+ # Status
(\S+)\s+ # (V)Port
(\S+)\s+ # Identify
}x) {
$c{$encid}{slot}{$slt} = {
status => $slt_status,
vport => $slt_vport,
identify => $slt_identify,
};
next;
}
# ------ Alarm
elsif ($sect_alm and my($alm, $alm_status, $alm_state, $alm_audibility) = m{^
(alm\S+)\s+ # Alarm
(\S+)\s+ # Status
(\S+)\s+ # State
(\S+)\s+ # Audibility
}x) {
$c{$encid}{alarm}{$alm} = {
status => $alm_status,
state => $alm_state,
audibility => $alm_audibility,
};
next;
}
# ---- End of known data
elsif (m{^\S+\+}) {
$this->unknown;
warn "unparsed: [$_]";
}
}
close $fh;
}
return \%c;
}
sub check {
my $this = shift;
# status messages pushed here
my @status;
my $c = $this->parse;
if (!$c) {
$this->unknown;
$this->message("No Adapters were found on this machine");
}
# process each controller
for my $cid (sort grep !/e\d+/, keys %$c) {
my $c = $c->{$cid};
my @cstatus;
for my $uid (sort keys %{$c->{unitstatus}}) {
my $u = $c->{unitstatus}->{$uid};
my $s = $u->{status};
if ($s =~ /INITIALIZING|MIGRATING/) {
$this->warning;
$s .= " $u->{vim_percent}";
} elsif ($s eq 'VERIFYING') {
$this->check_status;
$s .= " $u->{vim_percent}";
} elsif ($s eq 'REBUILDING') {
$this->resync;
$s .= " $u->{rebuild_percent}";
} elsif ($s eq 'DEGRADED') {
$this->critical;
} elsif ($s ne 'OK') {
$this->critical;
}
my @ustatus = $s;
# report cache, no checking
if ($u->{cache} && $u->{cache} ne '-') {
push(@ustatus, "Cache:$u->{cache}");
}
push(@status, "$cid($c->{model}): $uid($u->{type}): ".join(', ', @ustatus));
}
# check individual disk status
my %ds;
foreach my $p (sort { $a cmp $b } keys %{$c->{drivestatus}}) {
my $d = $c->{drivestatus}->{$p};
my $ds = $d->{status};
if ($ds eq 'VERIFYING') {
$this->check_status;
} elsif ($ds ne 'OK') {
$this->critical;
}
if ($d->{unit} eq '-') {
$ds = 'SPARE';
}
push(@{$ds{$ds}}, $p);
}
push(@status, "Drives($c->{drives}): ".$this->join_status(\%ds)) if %ds;
# check BBU, but be prepared that BBU status might not report anything
if ($this->{options}{bbu_monitoring} && $c->{bbu} && $c->{bbu} ne '-') {
# On old controllers, bbustatus did not exist; and the only BBU status
# you got was on the controller listing.
if(scalar(keys %{$c->{bbustatus}}) < 1) {
$this->critical if $c->{bbu} ne 'OK';
push(@status, "BBU: $c->{bbu}");
} else {
foreach my $bbuid (sort { $a cmp $b } keys %{$c->{bbustatus}}) {
my $bat = $c->{bbustatus}->{$bbuid};
my $bs = $bat->{Status}; # We might override this later
my @batmsg;
if($bs eq 'Testing' or $bs eq 'Charging') {
$this->bbulearn;
} elsif($bs eq 'WeakBat') {
# Time to replace your battery
$this->warning;
} elsif($bs ne 'OK') {
$this->critical;
}
# We do NOT check BBUReady, as it doesn't private granular
# info.
# Check OnlineState flag as well
# A battery can be GOOD, but disabled; this is only reflected in OnlineState.
if($bat->{OnlineState} ne 'On') {
push @batmsg, 'OnlineStatus='.$bat->{OnlineState};
$this->critical;
}
# Check voltage & temps
push @batmsg, 'Volt='.$bat->{Volt};
push @batmsg, 'Temp='.$bat->{Temp};
if ($bat->{Volt} =~ /^(LOW|HIGH)$/) {
$this->critical;
} elsif ($bat->{Volt} =~ /^(LOW|HIGH)$/) {
$this->warning;
}
if ($bat->{Temp} =~ /^(LOW|HIGH)$/) {
$this->critical;
} elsif ($bat->{Temp} =~ /^(LOW|HIGH)$/) {
$this->warning;
}
# Check runtime estimate
# Warn if too low
my $bbulearn = '';
if ($bat->{Hours} ne '-' and int($bat->{Hours}) <= 1) {
# TODO: make this configurable before going live
#$this->warning;
$this->bbulearn;
$bbulearn = '/LEARN';
}
push @batmsg, 'Hours='.$bat->{Hours};
# Check date of last capacity test
if ($bat->{LastCapTest} eq 'xx-xxx-xxxx') {
$this->bbulearn;
$bbulearn = '/LEARN';
} elsif ($bat->{LastCapTest} ne '-') {
# TODO: is the short name of month localized by tw_cli?
#my ($mday, $mon, $year) = (strptime($bat->{LastCapTest}, '%d-%b-%Y'))[3,4,5];
#my $lastcaptest_epoch = DateTime->new(year => $year, month => $mon, day => $mday, hour => 0, minute => 0, second => 0);
#my $present_time = time;
## TODO: this value should be configurable before going live, also need to mock system date for testing
#if (($present_time-$lastcaptest_epoch) > 86400*365) {
# $this->bbulearn;
#}
}
push @batmsg, 'LastCapTest='.$bat->{LastCapTest};
my $msg = join(',', @batmsg);
my $bbustatus = $bs.$bbulearn;
$bbustatus = "$bbuid=$bs" if $bbuid ne 'bbu'; # If we have multiple BBU, specify which one
push(@status, "BBU: $bbustatus($msg)");
}
}
}
}
# process each enclosure
for my $eid (sort grep /\/e\d+/, keys %$c) {
my $e = $c->{$eid};
# If the enclosure command returned nothing, we have no status to
# report.
next unless defined($e->{status});
# Something is wrong, but we are not sure what yet.
$this->warning unless $e->{status} eq 'OK';
my @estatus;
for my $fan_id (sort keys %{$e->{fans}}) {
my $f = $e->{fans}->{$fan_id};
my $s = $f->{status};
next if $s eq 'NOT-REPORTABLE' or $s eq 'NOT-INSTALLED' or $s eq 'NO-DEVICE';
$this->warning if $s ne 'OK';
push(@estatus, "$fan_id=$s($f->{rpm})");
}
for my $tmp_id (sort keys %{$e->{tempsensor}}) {
my $t = $e->{tempsensor}->{$tmp_id};
my $s = $t->{status};
next if $s eq 'NOT-REPORTABLE' or $s eq 'NOT-INSTALLED' or $s eq 'NO-DEVICE';
$this->warning if $s ne 'OK';
$t->{temperature} =~ s/\(\d+F\)//; # get rid of extra units
push(@estatus, "$tmp_id=$s($t->{temperature})");
}
for my $psu_id (sort keys %{$e->{powersupply}}) {
my $t = $e->{powersupply}->{$psu_id};
my $s = $t->{status};
next if $s eq 'NOT-REPORTABLE' or $s eq 'NOT-INSTALLED' or $s eq 'NO-DEVICE';
$this->warning if $s ne 'OK';
push(@estatus, "$psu_id=$s(status=$t->{state},voltage=$t->{voltage},current=$t->{current})");
}
for my $slot_id (sort keys %{$e->{slot}}) {
my $t = $e->{slot}->{$slot_id};
my $s = $t->{status};
next if $s eq 'NOT-REPORTABLE' or $s eq 'NOT-INSTALLED' or $s eq 'NO-DEVICE';
$this->warning if $s ne 'OK';
push(@estatus, "$slot_id=$s");
}
for my $alarm_id (sort keys %{$e->{alarm}}) {
my $t = $e->{alarm}->{$alarm_id};
my $s = $t->{status};
next if $s eq 'NOT-REPORTABLE' or $s eq 'NOT-INSTALLED' or $s eq 'NO-DEVICE';
$this->warning if $s ne 'OK';
push(@estatus, "$alarm_id=$s(State=$t->{state},Audibility=$t->{audibility})");
}
#warn join("\n", @estatus);
push(@status, "Enclosure: $eid(".join(',', @estatus).")");
}
return unless @status;
$this->ok->message(join(', ', @status));
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_PLUGINS_TW_CLI
$fatpacked{"App/Monitoring/Plugin/CheckRaid/SerialLine.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_SERIALLINE';
package App::Monitoring::Plugin::CheckRaid::SerialLine;
# Package dealing with connecting to serial line and handling UUCP style locks.
use Carp;
use strict;
use warnings;
sub new {
my $self = shift;
my $class = ref($self) || $self;
my $device = shift;
my $this = {
lockdir => "/var/lock",
@_,
lockfile => undef,
device => $device,
fh => undef,
};
bless($this, $class);
}
sub lock {
my $self = shift;
# create lock in style: /var/lock/LCK..ttyS0
my $device = shift;
my ($lockfile) = $self->{device} =~ m#/dev/(.+)#;
$lockfile = "$self->{lockdir}/LCK..$lockfile";
if (-e $lockfile) {
return 0;
}
open(my $fh, '>', $lockfile) || croak "Can't create lock: $lockfile\n";
print $fh $$;
close($fh);
$self->{lockfile} = $lockfile;
}
sub open {
my $self = shift;
$self->lock or return;
# open the device
open(my $fh, '+>', $self->{device}) || croak "Couldn't open $self->{device}, $!\n";
$self->{fh} = $fh;
}
sub close {
my $self = shift;
if ($self->{fh}) {
close($self->{fh});
undef($self->{fh});
unlink $self->{lockfile} or carp $!;
}
}
sub DESTROY {
my $self = shift;
$self->close();
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_SERIALLINE
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Sudoers.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_SUDOERS';
package App::Monitoring::Plugin::CheckRaid::Sudoers;
use App::Monitoring::Plugin::CheckRaid::Utils;
use warnings;
use strict;
use Exporter 'import';
our @EXPORT = qw(sudoers);
our @EXPORT_OK = @EXPORT;
# update sudoers file
#
# if sudoers config has "#includedir" directive, add file to that dir
# otherwise update main sudoers file
# @returns true if file was updated
sub sudoers {
my $dry_run = shift;
my @plugins = @_;
# build values to be added
# go over all active plugins
my @sudo;
foreach my $plugin (@plugins) {
# collect sudo rules
my @rules = $plugin->sudo(1) or next;
push(@sudo, @rules);
}
unless (@sudo) {
warn "Your configuration does not need to use sudo, sudoers not updated\n";
return 0;
}
my @rules = join "\n", (
"",
# setup alias, so we could easily remove these later by matching lines with 'CHECK_RAID'
# also this avoids installing ourselves twice.
"# Lines matching CHECK_RAID added by $0 -S on ". scalar localtime,
"User_Alias CHECK_RAID=nagios, icinga",
"Defaults:CHECK_RAID !requiretty",
# actual rules from plugins
join("\n", @sudo),
"",
);
if ($dry_run) {
warn "Content to be inserted to sudo rules:\n";
warn "--- sudoers ---\n";
print @rules;
warn "--- sudoers ---\n";
return 0;
}
my $sudoers = find_file('/usr/local/etc/sudoers', '/etc/sudoers');
my $visudo = which('visudo');
die "Unable to find sudoers file.\n" unless -f $sudoers;
die "Unable to write to sudoers file '$sudoers'.\n" unless -w $sudoers;
die "visudo program not found\n" unless -x $visudo;
# parse sudoers file for "#includedir" directive
my $sudodir = parse_sudoers_includedir($sudoers);
if ($sudodir) {
# sudo will read each file in /etc/sudoers.d, skipping file names that
# end in ~ or contain a . character to avoid causing problems with
# package manager or editor temporary/backup files
$sudoers = "$sudodir/check_raid";
}
warn "Updating file $sudoers\n";
# NOTE: secure as visudo itself: /etc is root owned
my $new = $sudoers.".new.".$$;
# setup to have sane perm for new sudoers file
umask(0227);
open my $fh, '>', $new or die $!;
# insert old sudoers
if (!$sudodir) {
open my $old, '<', $sudoers or die $!;
while (<$old>) {
print $fh $_;
}
close $old or die $!;
}
# insert the rules
print $fh @rules;
close $fh;
# validate sudoers
system($visudo, '-c', '-f', $new) == 0 or unlink($new),exit $? >> 8;
# check if they differ
if (filediff($sudoers, $new)) {
# use the new file
rename($new, $sudoers) or die $!;
warn "$sudoers file updated.\n";
return 1;
}
warn "$sudoers file not changed.\n";
unlink($new);
return 0;
}
# return first "#includedir" directive from $sudoers file
sub parse_sudoers_includedir {
my ($sudoers) = @_;
open my $fh, '<', $sudoers or die "Can't open: $sudoers: $!";
while (<$fh>) {
if (my ($dir) = /^#includedir\s+(.+)$/) {
return $dir;
}
}
close $fh or die $!;
return undef;
}
# return FALSE if files are identical
# return TRUE if files are different
# return TRUE if any of the files is missing
sub filediff {
my ($file1, $file2) = @_;
# return TRUE if neither of them exist
return 1 unless -f $file1;
return 1 unless -f $file2;
my $f1 = cat($file1);
my $f2 = cat($file2);
# wipe comments
$f1 =~ s/^#.+$//m;
$f2 =~ s/^#.+$//m;
# return TRUE if they differ
return $f1 ne $f2;
}
# get contents of a file
sub cat {
my ($file) = @_;
open(my $fh, '<', $file) or die "Can't open $file: $!";
local $/ = undef;
local $_ = <$fh>;
close($fh) or die $!;
return $_;
}
# find first existing file from list of file paths
sub find_file {
for my $file (@_) {
return $file if -f $file;
}
return undef;
}
APP_MONITORING_PLUGIN_CHECKRAID_SUDOERS
$fatpacked{"App/Monitoring/Plugin/CheckRaid/Utils.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_MONITORING_PLUGIN_CHECKRAID_UTILS';
package App::Monitoring::Plugin::CheckRaid::Utils;
use warnings;
use strict;
use Exporter 'import';
our @EXPORT = qw(which find_sudo);
our @EXPORT_OK = @EXPORT;
# registered plugins
our @plugins;
# devices to ignore
our @ignore;
# debug level
our $debug = 0;
# paths for which()
our @paths = split /:/, $ENV{'PATH'};
unshift(@paths, qw(/usr/local/nrpe /usr/local/bin /sbin /usr/sbin /bin /usr/sbin /opt/bin /opt/MegaRAID/MegaCli /usr/StorMan));
# lookup program from list of possible filenames
# search is performed from $PATH plus additional hardcoded @paths
# NOTE: we do not check for execute bit as it may fail for non-root. #104
sub which {
for my $prog (@_) {
for my $path (@paths) {
return "$path/$prog" if -f "$path/$prog";
}
}
return undef;
}
our @sudo;
sub find_sudo {
# no sudo needed if already root
return [] unless $>;
# detect once
return \@sudo if @sudo;
my $sudo = which('sudo') or die "Can't find sudo";
push(@sudo, $sudo);
# detect if sudo supports -A, issue #88
use IPC::Open3;
my $fh;
my @cmd = ($sudo, '-h');
my $pid = open3(undef, $fh, undef, @cmd) or die "Can't run 'sudo -h': $!";
local $/ = undef;
local $_ = <$fh>;
close($fh) or die $!;
# prefer -n to skip password prompt
push(@sudo, '-n') if /-n/;
# ..if not supported, add -A as well
push(@sudo, '-A') if /-A/;
return \@sudo;
}
1;
APP_MONITORING_PLUGIN_CHECKRAID_UTILS
$fatpacked{"App/Prove.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PROVE';
package App::Prove;use strict;use warnings;use TAP::Harness::Env;use Text::ParseWords qw(shellwords);use File::Spec;use Getopt::Long;use App::Prove::State;use Carp;use base 'TAP::Object';our$VERSION='3.39';use constant IS_WIN32=>($^O =~ /^(MS)?Win32$/);use constant IS_VMS=>$^O eq 'VMS';use constant IS_UNIXY=>!(IS_VMS || IS_WIN32);use constant STATE_FILE=>IS_UNIXY ? '.prove' : '_prove';use constant RC_FILE=>IS_UNIXY ? '.proverc' : '_proverc';use constant PLUGINS=>'App::Prove::Plugin';my@ATTR;BEGIN {@ATTR=qw(archive argv blib show_count color directives exec failures comments formatter harness includes modules plugins jobs lib merge parse quiet really_quiet recurse backwards shuffle taint_fail taint_warn timer verbose warnings_fail warnings_warn show_help show_man show_version state_class test_args state dry extensions ignore_exit rules state_manager normalize sources tapversion trap);__PACKAGE__->mk_methods(@ATTR)}sub _initialize {my$self=shift;my$args=shift || {};my@is_array=qw(argv rc_opts includes modules state plugins rules sources);for my$key (@is_array){$self->{$key}=[]}for my$attr (@ATTR){if (exists$args->{$attr}){$self->{$attr}=$args->{$attr}}}$self->state_class('App::Prove::State');return$self}sub add_rc_file {my ($self,$rc_file)=@_;local*RC;open RC,"<$rc_file" or croak "Can't read $rc_file ($!)";while (defined(my$line=<RC>)){push @{$self->{rc_opts}},grep {defined and not /^#/}$line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S+) }xg}close RC}sub process_args {my$self=shift;my@rc=RC_FILE;unshift@rc,glob '~/' .RC_FILE if IS_UNIXY;my@args;while (defined(my$arg=shift)){if ($arg eq '--norc'){@rc=()}elsif ($arg eq '--rc'){defined(my$rc=shift)or croak "Missing argument to --rc";push@rc,$rc}elsif ($arg =~ m{^--rc=(.+)$}){push@rc,$1}else {push@args,$arg}}if (defined(my$stop_at=_first_pos('::',@args))){my@test_args=splice@args,$stop_at;shift@test_args;$self->{test_args}=\@test_args}$self->add_rc_file($_)for grep -f,@rc;unshift@args,@{$self->{rc_opts}};if (my@bad=map {"-$_"}grep {/^-(man|help)$/}@args){die "Long options should be written with two dashes: ",join(', ',@bad),"\n"}{local@ARGV=@args;Getopt::Long::Configure(qw(no_ignore_case bundling pass_through));GetOptions('v|verbose'=>\$self->{verbose},'f|failures'=>\$self->{failures},'o|comments'=>\$self->{comments},'l|lib'=>\$self->{lib},'b|blib'=>\$self->{blib},'s|shuffle'=>\$self->{shuffle},'color!'=>\$self->{color},'colour!'=>\$self->{color},'count!'=>\$self->{show_count},'c'=>\$self->{color},'D|dry'=>\$self->{dry},'ext=s@'=>sub {my ($opt,$val)=@_;push @{$self->{extensions}||= []},$val},'harness=s'=>\$self->{harness},'ignore-exit'=>\$self->{ignore_exit},'source=s@'=>$self->{sources},'formatter=s'=>\$self->{formatter},'r|recurse'=>\$self->{recurse},'reverse'=>\$self->{backwards},'p|parse'=>\$self->{parse},'q|quiet'=>\$self->{quiet},'Q|QUIET'=>\$self->{really_quiet},'e|exec=s'=>\$self->{exec},'m|merge'=>\$self->{merge},'I=s@'=>$self->{includes},'M=s@'=>$self->{modules},'P=s@'=>$self->{plugins},'state=s@'=>$self->{state},'directives'=>\$self->{directives},'h|help|?'=>\$self->{show_help},'H|man'=>\$self->{show_man},'V|version'=>\$self->{show_version},'a|archive=s'=>\$self->{archive},'j|jobs=i'=>\$self->{jobs},'timer'=>\$self->{timer},'T'=>\$self->{taint_fail},'t'=>\$self->{taint_warn},'W'=>\$self->{warnings_fail},'w'=>\$self->{warnings_warn},'normalize'=>\$self->{normalize},'rules=s@'=>$self->{rules},'tapversion=s'=>\$self->{tapversion},'trap'=>\$self->{trap},)or croak('Unable to continue');$self->{argv}=[@ARGV]}return}sub _first_pos {my$want=shift;for (0 .. $#_){return $_ if $_[$_]eq $want}return}sub _help {my ($self,$verbosity)=@_;eval('use Pod::Usage 1.12 ()');if (my$err=$@){die 'Please install Pod::Usage for the --help option ' .'(or try `perldoc prove`.)' ."\n ($@)"}Pod::Usage::pod2usage({-verbose=>$verbosity });return}sub _color_default {my$self=shift;return -t STDOUT &&!$ENV{HARNESS_NOTTY}&&!IS_WIN32}sub _get_args {my$self=shift;my%args;$args{trap}=1 if$self->trap;if (defined$self->color ? $self->color : $self->_color_default){$args{color}=1}if (!defined$self->show_count){$args{show_count}=1}else {$args{show_count}=$self->show_count}if ($self->archive){$self->require_harness(archive=>'TAP::Harness::Archive');$args{archive}=$self->archive}if (my$jobs=$self->jobs){$args{jobs}=$jobs}if (my$harness_opt=$self->harness){$self->require_harness(harness=>$harness_opt)}if (my$formatter=$self->formatter){$args{formatter_class}=$formatter}for my$handler (@{$self->sources}){my ($name,$config)=$self->_parse_source($handler);$args{sources}->{$name}=$config}if ($self->ignore_exit){$args{ignore_exit}=1}if ($self->taint_fail && $self->taint_warn){die '-t and -T are mutually exclusive'}if ($self->warnings_fail && $self->warnings_warn){die '-w and -W are mutually exclusive'}for my$a (qw(lib switches)){my$method="_get_$a";my$val=$self->$method();$args{$a}=$val if defined$val}my%verb_map=(verbose=>1,quiet=>-1,really_quiet=>-2,);my@verb_adj=grep {$_}map {$self->$_()? $verb_map{$_}: 0}keys%verb_map;die "Only one of verbose, quiet or really_quiet should be specified\n" if@verb_adj > 1;$args{verbosity}=shift@verb_adj || 0;for my$a (qw(merge failures comments timer directives normalize)){$args{$a}=1 if$self->$a()}$args{errors}=1 if$self->parse;$args{exec}=[split(/\s+/,$self->exec)]if (defined($self->exec));$args{version}=$self->tapversion if defined($self->tapversion);if (defined(my$test_args=$self->test_args)){$args{test_args}=$test_args}if (@{$self->rules}){my@rules;for (@{$self->rules}){if (/^par=(.*)/){push@rules,$1}elsif (/^seq=(.*)/){push@rules,{seq=>$1 }}}$args{rules}={par=>[@rules]}}$args{harness_class}=$self->{harness_class}if$self->{harness_class};return \%args}sub _find_module {my ($self,$class,@search)=@_;croak "Bad module name $class" unless$class =~ /^ \w+ (?: :: \w+ ) *$/x;for my$pfx (@search){my$name=join('::',$pfx,$class);eval "require $name";return$name unless $@}eval "require $class";return$class unless $@;return}sub _load_extension {my ($self,$name,@search)=@_;my@args=();if ($name =~ /^(.*?)=(.*)/){$name=$1;@args=split(/,/,$2)}if (my$class=$self->_find_module($name,@search)){$class->import(@args);if ($class->can('load')){$class->load({app_prove=>$self,args=>[@args]})}}else {croak "Can't load module $name"}}sub _load_extensions {my ($self,$ext,@search)=@_;$self->_load_extension($_,@search)for @$ext}sub _parse_source {my ($self,$handler)=@_;(my$opt_name=lc$handler)=~ s/::/-/g;local@ARGV=@{$self->{argv}};my%config;Getopt::Long::GetOptions("$opt_name-option=s%"=>sub {my ($name,$k,$v)=@_;if ($v =~ /(?<!\\)=/){croak "Option $name must be consistently used as a hash" if exists$config{$k}&& ref$config{$k}ne 'HASH';$config{$k}||= {};my ($hk,$hv)=split /(?<!\\)=/,$v,2;$config{$k}{$hk}=$hv}else {$v =~ s/\\=/=/g;if (exists$config{$k}){$config{$k}=[$config{$k}]unless ref$config{$k}eq 'ARRAY';push @{$config{$k}}=>$v}else {$config{$k}=$v}}});$self->{argv}=\@ARGV;return ($handler,\%config)}sub run {my$self=shift;unless ($self->state_manager){$self->state_manager($self->state_class->new({store=>STATE_FILE }))}if ($self->show_help){$self->_help(1)}elsif ($self->show_man){$self->_help(2)}elsif ($self->show_version){$self->print_version}elsif ($self->dry){print "$_\n" for$self->_get_tests}else {$self->_load_extensions($self->modules);$self->_load_extensions($self->plugins,PLUGINS);local$ENV{TEST_VERBOSE}=1 if$self->verbose;return$self->_runtests($self->_get_args,$self->_get_tests)}return 1}sub _get_tests {my$self=shift;my$state=$self->state_manager;my$ext=$self->extensions;$state->extensions($ext)if defined$ext;if (defined(my$state_switch=$self->state)){$state->apply_switch(@$state_switch)}my@tests=$state->get_tests($self->recurse,@{$self->argv});$self->_shuffle(@tests)if$self->shuffle;@tests=reverse@tests if$self->backwards;return@tests}sub _runtests {my ($self,$args,@tests)=@_;my$harness=TAP::Harness::Env->create($args);my$state=$self->state_manager;$harness->callback(after_test=>sub {$state->observe_test(@_)});$harness->callback(after_runtests=>sub {$state->commit(@_)});my$aggregator=$harness->runtests(@tests);return!$aggregator->has_errors}sub _get_switches {my$self=shift;my@switches;if ($self->taint_fail){push@switches,'-T'}elsif ($self->taint_warn){push@switches,'-t'}if ($self->warnings_fail){push@switches,'-W'}elsif ($self->warnings_warn){push@switches,'-w'}return@switches ? \@switches : ()}sub _get_lib {my$self=shift;my@libs;if ($self->lib){push@libs,'lib'}if ($self->blib){push@libs,'blib/lib','blib/arch'}if (@{$self->includes}){push@libs,@{$self->includes}}@libs=map {File::Spec->rel2abs($_)}@libs;return@libs ? \@libs : ()}sub _shuffle {my$self=shift;my$i=@_;while ($i){my$j=rand$i--;@_[$i,$j ]=@_[$j,$i ]}return}sub require_harness {my ($self,$for,$class)=@_;my ($class_name)=$class =~ /^(\w+(?:::\w+)*)/;$class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!;eval("use $class;");die "$class_name is required to use the --$for feature: $@" if $@;$self->{harness_class}=$class_name;return}sub print_version {my$self=shift;require TAP::Harness;printf("TAP::Harness v%s and Perl v%vd\n",$TAP::Harness::VERSION,$^V);return}1;
APP_PROVE
$fatpacked{"App/Prove/State.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PROVE_STATE';
package App::Prove::State;use strict;use warnings;use File::Find;use File::Spec;use Carp;use App::Prove::State::Result;use TAP::Parser::YAMLish::Reader ();use TAP::Parser::YAMLish::Writer ();use base 'TAP::Base';BEGIN {__PACKAGE__->mk_methods('result_class')}use constant IS_WIN32=>($^O =~ /^(MS)?Win32$/);use constant NEED_GLOB=>IS_WIN32;our$VERSION='3.39';sub new {my$class=shift;my%args=%{shift || {}};my$self=bless {select=>[],seq=>1,store=>delete$args{store},extensions=>(delete$args{extensions}|| ['.t']),result_class=>(delete$args{result_class}|| 'App::Prove::State::Result'),},$class;$self->{_}=$self->result_class->new({tests=>{},generation=>1,});my$store=$self->{store};$self->load($store)if defined$store && -f $store;return$self}sub extensions {my$self=shift;$self->{extensions}=shift if @_;return$self->{extensions}}sub results {my$self=shift;$self->{_}|| $self->result_class->new}sub commit {my$self=shift;if ($self->{should_save}){$self->save}}sub apply_switch {my$self=shift;my@opts=@_;my$last_gen=$self->results->generation - 1;my$last_run_time=$self->results->last_run_time;my$now=$self->get_time;my@switches=map {split /,/}@opts;my%handler=(last=>sub {$self->_select(limit=>shift,where=>sub {$_->generation >= $last_gen},order=>sub {$_->sequence})},failed=>sub {$self->_select(limit=>shift,where=>sub {$_->result!=0},order=>sub {-$_->result})},passed=>sub {$self->_select(limit=>shift,where=>sub {$_->result==0})},all=>sub {$self->_select(limit=>shift)},todo=>sub {$self->_select(limit=>shift,where=>sub {$_->num_todo!=0},order=>sub {-$_->num_todo})},hot=>sub {$self->_select(limit=>shift,where=>sub {defined $_->last_fail_time},order=>sub {$now - $_->last_fail_time})},slow=>sub {$self->_select(limit=>shift,order=>sub {-$_->elapsed})},fast=>sub {$self->_select(limit=>shift,order=>sub {$_->elapsed})},new=>sub {$self->_select(limit=>shift,order=>sub {-$_->mtime})},old=>sub {$self->_select(limit=>shift,order=>sub {$_->mtime})},fresh=>sub {$self->_select(limit=>shift,where=>sub {$_->mtime >= $last_run_time})},save=>sub {$self->{should_save}++},adrian=>sub {unshift@switches,qw(hot all save)},);while (defined(my$ele=shift@switches)){my ($opt,$arg)=($ele =~ /^([^:]+):(.*)/)? ($1,$2): ($ele,undef);my$code=$handler{$opt}|| croak "Illegal state option: $opt";$code->($arg)}return}sub _select {my ($self,%spec)=@_;push @{$self->{select}},\%spec}sub get_tests {my$self=shift;my$recurse=shift;my@argv=@_;my%seen;my@selected=$self->_query;unless (@argv || @{$self->{select}}){@argv=$recurse ? '.' : 't';croak qq{No tests named and '@argv' directory not found} unless -d $argv[0]}push@selected,$self->_get_raw_tests($recurse,@argv)if@argv;return grep {!$seen{$_}++}@selected}sub _query {my$self=shift;if (my@sel=@{$self->{select}}){warn "No saved state, selection will be empty\n" unless$self->results->num_tests;return map {$self->_query_clause($_)}@sel}return}sub _query_clause {my ($self,$clause)=@_;my@got;my$results=$self->results;my$where=$clause->{where}|| sub {1};for my$name ($results->test_names){next unless -f $name;local $_=$results->test($name);push@got,$name if$where->()}if (my$order=$clause->{order}){@got=map {$_->[0]}sort {(defined$b->[1]<=> defined$a->[1])|| (($a->[1]|| 0)<=> ($b->[1]|| 0))}map {[$_,do {local $_=$results->test($_);$order->()}]}@got}if (my$limit=$clause->{limit}){@got=splice@got,0,$limit if@got > $limit}return@got}sub _get_raw_tests {my$self=shift;my$recurse=shift;my@argv=@_;my@tests;if (NEED_GLOB){eval "use File::Glob::Windows";@argv=map {glob "$_"}@argv}my$extensions=$self->{extensions};for my$arg (@argv){if ('-' eq $arg){push@argv=><STDIN>;chomp(@argv);next}push@tests,sort -d $arg ? $recurse ? $self->_expand_dir_recursive($arg,$extensions): map {glob(File::Spec->catfile($arg,"*$_"))}@{$extensions}: $arg}return@tests}sub _expand_dir_recursive {my ($self,$dir,$extensions)=@_;my@tests;my$ext_string=join('|',map {quotemeta}@{$extensions});find({follow=>1,follow_skip=>2,wanted=>sub {-f && /(?:$ext_string)$/ && push@tests=>$File::Find::name}},$dir);return@tests}sub observe_test {my ($self,$test_info,$parser)=@_;my$name=$test_info->[0];my$fail=scalar($parser->failed)+ ($parser->has_problems ? 1 : 0);my$todo=scalar($parser->todo);my$start_time=$parser->start_time;my$end_time=$parser->end_time,my$test=$self->results->test($name);$test->sequence($self->{seq}++);$test->generation($self->results->generation);$test->run_time($end_time);$test->result($fail);$test->num_todo($todo);$test->elapsed($end_time - $start_time);$test->parser($parser);if ($fail){$test->total_failures($test->total_failures + 1);$test->last_fail_time($end_time)}else {$test->total_passes($test->total_passes + 1);$test->last_pass_time($end_time)}}sub save {my ($self)=@_;my$store=$self->{store}or return;$self->results->last_run_time($self->get_time);my$writer=TAP::Parser::YAMLish::Writer->new;local*FH;open FH,">$store" or croak "Can't write $store ($!)";$writer->write($self->results->raw,\*FH);close FH}sub load {my ($self,$name)=@_;my$reader=TAP::Parser::YAMLish::Reader->new;local*FH;open FH,"<$name" or croak "Can't read $name ($!)";$self->{_}=$self->result_class->new($reader->read(sub {my$line=<FH>;defined$line && chomp$line;return$line}));close FH;$self->_regen_seq;$self->_prune_and_stamp;$self->results->generation($self->results->generation + 1)}sub _prune_and_stamp {my$self=shift;my$results=$self->results;my@tests=$self->results->tests;for my$test (@tests){my$name=$test->name;if (my@stat=stat$name){$test->mtime($stat[9])}else {$results->remove($name)}}}sub _regen_seq {my$self=shift;for my$test ($self->results->tests){$self->{seq}=$test->sequence + 1 if defined$test->sequence && $test->sequence >= $self->{seq}}}1;
APP_PROVE_STATE
$fatpacked{"App/Prove/State/Result.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PROVE_STATE_RESULT';
package App::Prove::State::Result;use strict;use warnings;use Carp 'croak';use App::Prove::State::Result::Test;use constant STATE_VERSION=>1;our$VERSION='3.39';sub new {my ($class,$arg_for)=@_;$arg_for ||= {};my%instance_data=%$arg_for;$instance_data{version}=$class->state_version;my$tests=delete$instance_data{tests}|| {};my$self=bless \%instance_data=>$class;$self->_initialize($tests);return$self}sub _initialize {my ($self,$tests)=@_;my%tests;while (my ($name,$test)=each %$tests){$tests{$name}=$self->test_class->new({%$test,name=>$name})}$self->tests(\%tests);return$self}sub state_version {STATE_VERSION}sub test_class {return 'App::Prove::State::Result::Test'}my%methods=(generation=>{method=>'generation',default=>0 },last_run_time=>{method=>'last_run_time',default=>undef },);while (my ($key,$description)=each%methods){my$default=$description->{default};no strict 'refs';*{$description->{method}}=sub {my$self=shift;if (@_){$self->{$key}=shift;return$self}return$self->{$key}|| $default}}sub tests {my$self=shift;if (@_){$self->{tests}=shift;return$self}my%tests=%{$self->{tests}};my@tests=sort {$a->sequence <=> $b->sequence}values%tests;return wantarray ? @tests : \@tests}sub test {my ($self,$name)=@_;croak("test() requires a test name")unless defined$name;my$tests=$self->{tests}||= {};if (my$test=$tests->{$name}){return$test}else {my$test=$self->test_class->new({name=>$name });$self->{tests}->{$name}=$test;return$test}}sub test_names {my$self=shift;return map {$_->name}$self->tests}sub remove {my ($self,$name)=@_;delete$self->{tests}->{$name};return$self}sub num_tests {keys %{shift->{tests}}}sub raw {my$self=shift;my%raw=%$self;my%tests;for my$test ($self->tests){$tests{$test->name }=$test->raw}$raw{tests}=\%tests;return \%raw}1;
APP_PROVE_STATE_RESULT
$fatpacked{"App/Prove/State/Result/Test.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PROVE_STATE_RESULT_TEST';
package App::Prove::State::Result::Test;use strict;use warnings;our$VERSION='3.39';my%methods=(name=>{method=>'name' },elapsed=>{method=>'elapsed',default=>0 },gen=>{method=>'generation',default=>1 },last_pass_time=>{method=>'last_pass_time',default=>undef },last_fail_time=>{method=>'last_fail_time',default=>undef },last_result=>{method=>'result',default=>0 },last_run_time=>{method=>'run_time',default=>undef },last_todo=>{method=>'num_todo',default=>0 },mtime=>{method=>'mtime',default=>undef },seq=>{method=>'sequence',default=>1 },total_passes=>{method=>'total_passes',default=>0 },total_failures=>{method=>'total_failures',default=>0 },parser=>{method=>'parser' },);while (my ($key,$description)=each%methods){my$default=$description->{default};no strict 'refs';*{$description->{method}}=sub {my$self=shift;if (@_){$self->{$key}=shift;return$self}return$self->{$key}|| $default}}sub new {my ($class,$arg_for)=@_;$arg_for ||= {};bless$arg_for=>$class}sub raw {my$self=shift;my%raw=%$self;delete$raw{name};delete$raw{parser};return \%raw}1;
APP_PROVE_STATE_RESULT_TEST
$fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_REQUIREMENTS';
use 5.006;use strict;use warnings;package CPAN::Meta::Requirements;our$VERSION='2.140';use Carp ();BEGIN {eval "use version ()";if (my$err=$@){eval "use ExtUtils::MakeMaker::version" or die$err}}*_is_qv=version->can('is_qv')? sub {$_[0]->is_qv}: sub {exists $_[0]->{qv}};my$V0=version->new(0);my@valid_options=qw(bad_version_hook);sub new {my ($class,$options)=@_;$options ||= {};Carp::croak "Argument to $class\->new() must be a hash reference" unless ref$options eq 'HASH';my%self=map {;$_=>$options->{$_}}@valid_options;return bless \%self=>$class}sub _find_magic_vstring {my$value=shift;my$tvalue='';require B;my$sv=B::svref_2object(\$value);my$magic=ref($sv)eq 'B::PVMG' ? $sv->MAGIC : undef;while ($magic){if ($magic->TYPE eq 'V'){$tvalue=$magic->PTR;$tvalue =~ s/^v?(.+)$/v$1/;last}else {$magic=$magic->MOREMAGIC}}return$tvalue}sub _isa_version {UNIVERSAL::isa($_[0],'UNIVERSAL')&& $_[0]->isa('version')}sub _version_object {my ($self,$module,$version)=@_;my ($vobj,$err);if (not defined$version or (!ref($version)&& $version eq '0')){return$V0}elsif (ref($version)eq 'version' || (ref($version)&& _isa_version($version))){$vobj=$version}else {if ($INC{'version/vpp.pm'}|| $INC{'ExtUtils/MakeMaker/version/vpp.pm'}){my$magic=_find_magic_vstring($version);$version=$magic if length$magic}if ($] < 5.008001 && $version !~ /\A[0-9]/ && substr($version,0,1)ne 'v' && length($version)< 3){$version .= "\0" x (3 - length($version))}eval {local$SIG{__WARN__}=sub {die "Invalid version: $_[0]"};die "Invalid version: $version" if$version eq 'version';$vobj=version->new($version)};if (my$err=$@){my$hook=$self->{bad_version_hook};$vobj=eval {$hook->($version,$module)}if ref$hook eq 'CODE';unless (eval {$vobj->isa("version")}){$err =~ s{ at .* line \d+.*$}{};die "Can't convert '$version': $err"}}}if ($vobj =~ m{\A\.}){$vobj=version->new("0$vobj")}if (_is_qv($vobj)){$vobj=version->new($vobj->normal)}return$vobj}BEGIN {for my$type (qw(maximum exclusion exact_version)){my$method="with_$type";my$to_add=$type eq 'exact_version' ? $type : "add_$type";my$code=sub {my ($self,$name,$version)=@_;$version=$self->_version_object($name,$version);$self->__modify_entry_for($name,$method,$version);return$self};no strict 'refs';*$to_add=$code}}sub add_minimum {my ($self,$name,$version)=@_;if (not defined$version or "$version" eq '0'){return$self if$self->__entry_for($name);Carp::confess("can't add new requirements to finalized requirements")if$self->is_finalized;$self->{requirements}{$name }=CPAN::Meta::Requirements::_Range::Range->with_minimum($V0,$name)}else {$version=$self->_version_object($name,$version);$self->__modify_entry_for($name,'with_minimum',$version)}return$self}sub add_requirements {my ($self,$req)=@_;for my$module ($req->required_modules){my$modifiers=$req->__entry_for($module)->as_modifiers;for my$modifier (@$modifiers){my ($method,@args)=@$modifier;$self->$method($module=>@args)}}return$self}sub accepts_module {my ($self,$module,$version)=@_;$version=$self->_version_object($module,$version);return 1 unless my$range=$self->__entry_for($module);return$range->_accepts($version)}sub clear_requirement {my ($self,$module)=@_;return$self unless$self->__entry_for($module);Carp::confess("can't clear requirements on finalized requirements")if$self->is_finalized;delete$self->{requirements}{$module };return$self}sub requirements_for_module {my ($self,$module)=@_;my$entry=$self->__entry_for($module);return unless$entry;return$entry->as_string}sub structured_requirements_for_module {my ($self,$module)=@_;my$entry=$self->__entry_for($module);return unless$entry;return$entry->as_struct}sub required_modules {keys %{$_[0]{requirements}}}sub clone {my ($self)=@_;my$new=(ref$self)->new;return$new->add_requirements($self)}sub __entry_for {$_[0]{requirements}{$_[1]}}sub __modify_entry_for {my ($self,$name,$method,$version)=@_;my$fin=$self->is_finalized;my$old=$self->__entry_for($name);Carp::confess("can't add new requirements to finalized requirements")if$fin and not $old;my$new=($old || 'CPAN::Meta::Requirements::_Range::Range')->$method($version,$name);Carp::confess("can't modify finalized requirements")if$fin and $old->as_string ne $new->as_string;$self->{requirements}{$name }=$new}sub is_simple {my ($self)=@_;for my$module ($self->required_modules){return if$self->__entry_for($module)->as_string =~ /\s/}return 1}sub is_finalized {$_[0]{finalized}}sub finalize {$_[0]{finalized}=1}sub as_string_hash {my ($self)=@_;my%hash=map {;$_=>$self->{requirements}{$_}->as_string}$self->required_modules;return \%hash}my%methods_for_op=('=='=>[qw(exact_version) ],'!='=>[qw(add_exclusion) ],'>='=>[qw(add_minimum) ],'<='=>[qw(add_maximum) ],'>'=>[qw(add_minimum add_exclusion) ],'<'=>[qw(add_maximum add_exclusion) ],);sub add_string_requirement {my ($self,$module,$req)=@_;unless (defined$req && length$req){$req=0;$self->_blank_carp($module)}my$magic=_find_magic_vstring($req);if (length$magic){$self->add_minimum($module=>$magic);return}my@parts=split qr{\s*,\s*},$req;for my$part (@parts){my ($op,$ver)=$part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z};if (!defined$op){$self->add_minimum($module=>$part)}else {Carp::confess("illegal requirement string: $req")unless my$methods=$methods_for_op{$op };$self->$_($module=>$ver)for @$methods}}}sub _blank_carp {my ($self,$module)=@_;Carp::carp("Undefined requirement for $module treated as '0'")}sub from_string_hash {my ($class,$hash,$options)=@_;my$self=$class->new($options);for my$module (keys %$hash){my$req=$hash->{$module};unless (defined$req && length$req){$req=0;$class->_blank_carp($module)}$self->add_string_requirement($module,$req)}return$self}{package CPAN::Meta::Requirements::_Range::Exact;sub _new {bless {version=>$_[1]}=>$_[0]}sub _accepts {return $_[0]{version}==$_[1]}sub as_string {return "== $_[0]{version}"}sub as_struct {return [['==',"$_[0]{version}" ]]}sub as_modifiers {return [[exact_version=>$_[0]{version}]]}sub _reject_requirements {my ($self,$module,$error)=@_;Carp::confess("illegal requirements for $module: $error")}sub _clone {(ref $_[0])->_new(version->new($_[0]{version}))}sub with_exact_version {my ($self,$version,$module)=@_;$module='module' unless defined$module;return$self->_clone if$self->_accepts($version);$self->_reject_requirements($module,"can't be exactly $version when exact requirement is already $self->{version}",)}sub with_minimum {my ($self,$minimum,$module)=@_;$module='module' unless defined$module;return$self->_clone if$self->{version}>= $minimum;$self->_reject_requirements($module,"minimum $minimum exceeds exact specification $self->{version}",)}sub with_maximum {my ($self,$maximum,$module)=@_;$module='module' unless defined$module;return$self->_clone if$self->{version}<= $maximum;$self->_reject_requirements($module,"maximum $maximum below exact specification $self->{version}",)}sub with_exclusion {my ($self,$exclusion,$module)=@_;$module='module' unless defined$module;return$self->_clone unless$exclusion==$self->{version};$self->_reject_requirements($module,"tried to exclude $exclusion, which is already exactly specified",)}}{package CPAN::Meta::Requirements::_Range::Range;sub _self {ref($_[0])? $_[0]: (bless {}=>$_[0])}sub _clone {return (bless {}=>$_[0])unless ref $_[0];my ($s)=@_;my%guts=((exists$s->{minimum}? (minimum=>version->new($s->{minimum})): ()),(exists$s->{maximum}? (maximum=>version->new($s->{maximum})): ()),(exists$s->{exclusions}? (exclusions=>[map {version->new($_)}@{$s->{exclusions}}]): ()),);bless \%guts=>ref($s)}sub as_modifiers {my ($self)=@_;my@mods;push@mods,[add_minimum=>$self->{minimum}]if exists$self->{minimum};push@mods,[add_maximum=>$self->{maximum}]if exists$self->{maximum};push@mods,map {;[add_exclusion=>$_ ]}@{$self->{exclusions}|| []};return \@mods}sub as_struct {my ($self)=@_;return 0 if!keys %$self;my@exclusions=@{$self->{exclusions}|| []};my@parts;for my$tuple ([qw(>= > minimum) ],[qw(<= < maximum) ],){my ($op,$e_op,$k)=@$tuple;if (exists$self->{$k}){my@new_exclusions=grep {$_!=$self->{$k }}@exclusions;if (@new_exclusions==@exclusions){push@parts,[$op,"$self->{ $k }" ]}else {push@parts,[$e_op,"$self->{ $k }" ];@exclusions=@new_exclusions}}}push@parts,map {;["!=","$_" ]}@exclusions;return \@parts}sub as_string {my ($self)=@_;my@parts=@{$self->as_struct};return$parts[0][1]if@parts==1 and $parts[0][0]eq '>=';return join q{, },map {;join q{ },@$_}@parts}sub _reject_requirements {my ($self,$module,$error)=@_;Carp::confess("illegal requirements for $module: $error")}sub with_exact_version {my ($self,$version,$module)=@_;$module='module' unless defined$module;$self=$self->_clone;unless ($self->_accepts($version)){$self->_reject_requirements($module,"exact specification $version outside of range " .$self->as_string)}return CPAN::Meta::Requirements::_Range::Exact->_new($version)}sub _simplify {my ($self,$module)=@_;if (defined$self->{minimum}and defined$self->{maximum}){if ($self->{minimum}==$self->{maximum}){if (grep {$_==$self->{minimum}}@{$self->{exclusions}|| []}){$self->_reject_requirements($module,"minimum and maximum are both $self->{minimum}, which is excluded",)}return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum})}if ($self->{minimum}> $self->{maximum}){$self->_reject_requirements($module,"minimum $self->{minimum} exceeds maximum $self->{maximum}",)}}if ($self->{exclusions}){my%seen;@{$self->{exclusions}}=grep {(!defined$self->{minimum}or $_ >= $self->{minimum})and (!defined$self->{maximum}or $_ <= $self->{maximum})and !$seen{$_}++}@{$self->{exclusions}}}return$self}sub with_minimum {my ($self,$minimum,$module)=@_;$module='module' unless defined$module;$self=$self->_clone;if (defined (my$old_min=$self->{minimum})){$self->{minimum}=(sort {$b cmp $a}($minimum,$old_min))[0]}else {$self->{minimum}=$minimum}return$self->_simplify($module)}sub with_maximum {my ($self,$maximum,$module)=@_;$module='module' unless defined$module;$self=$self->_clone;if (defined (my$old_max=$self->{maximum})){$self->{maximum}=(sort {$a cmp $b}($maximum,$old_max))[0]}else {$self->{maximum}=$maximum}return$self->_simplify($module)}sub with_exclusion {my ($self,$exclusion,$module)=@_;$module='module' unless defined$module;$self=$self->_clone;push @{$self->{exclusions}||= []},$exclusion;return$self->_simplify($module)}sub _accepts {my ($self,$version)=@_;return if defined$self->{minimum}and $version < $self->{minimum};return if defined$self->{maximum}and $version > $self->{maximum};return if defined$self->{exclusions}and grep {$version==$_}@{$self->{exclusions}};return 1}}1;
CPAN_META_REQUIREMENTS
$fatpacked{"CPAN/Meta/YAML.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_YAML';
use 5.008001;use strict;use warnings;package CPAN::Meta::YAML;$CPAN::Meta::YAML::VERSION='0.018';;use Exporter;our@ISA=qw{Exporter};our@EXPORT=qw{Load Dump};our@EXPORT_OK=qw{LoadFile DumpFile freeze thaw};sub Dump {return CPAN::Meta::YAML->new(@_)->_dump_string}sub Load {my$self=CPAN::Meta::YAML->_load_string(@_);if (wantarray){return @$self}else {return$self->[-1]}}BEGIN {*freeze=\&Dump;*thaw=\&Load}sub DumpFile {my$file=shift;return CPAN::Meta::YAML->new(@_)->_dump_file($file)}sub LoadFile {my$file=shift;my$self=CPAN::Meta::YAML->_load_file($file);if (wantarray){return @$self}else {return$self->[-1]}}sub new {my$class=shift;bless [@_ ],$class}sub read_string {my$self=shift;$self->_load_string(@_)}sub write_string {my$self=shift;$self->_dump_string(@_)}sub read {my$self=shift;$self->_load_file(@_)}sub write {my$self=shift;$self->_dump_file(@_)}my@UNPRINTABLE=qw(0 x01 x02 x03 x04 x05 x06 a b t n v f r x0E x0F x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x1A e x1C x1D x1E x1F);my%UNESCAPES=(0=>"\x00",z=>"\x00",N=>"\x85",a=>"\x07",b=>"\x08",t=>"\x09",n=>"\x0a",v=>"\x0b",f=>"\x0c",r=>"\x0d",e=>"\x1b",'\\'=>'\\',);my%QUOTE=map {$_=>1}qw{null true false};my$re_capture_double_quoted=qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;my$re_capture_single_quoted=qr/\'([^\']*(?:\'\'[^\']*)*)\'/;my$re_capture_unquoted_key=qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;my$re_trailing_comment=qr/(?:\s+\#.*)?/;my$re_key_value_separator=qr/\s*:(?:\s+(?:\#.*)?|$)/;sub _load_file {my$class=ref $_[0]? ref shift : shift;my$file=shift or $class->_error('You did not specify a file name');$class->_error("File '$file' does not exist")unless -e $file;$class->_error("'$file' is a directory, not a file")unless -f _;$class->_error("Insufficient permissions to read '$file'")unless -r _;open(my$fh,"<:unix:encoding(UTF-8)",$file);unless ($fh){$class->_error("Failed to open file '$file': $!")}if (_can_flock()){flock($fh,Fcntl::LOCK_SH())or warn "Couldn't lock '$file' for reading: $!"}my$contents=eval {use warnings FATAL=>'utf8';local $/;<$fh>};if (my$err=$@){$class->_error("Error reading from file '$file': $err")}unless (close$fh){$class->_error("Failed to close file '$file': $!")}$class->_load_string($contents)}sub _load_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"}if (utf8::is_utf8($string)&&!utf8::valid($string)){die \<<'...'}utf8::upgrade($string);$string =~ s/^\x{FEFF}//;return$self unless length$string;my@lines=grep {!/^\s*(?:\#.*)?\z/}split /(?:\015{1,2}\012|\015|\012)/,$string;@lines and $lines[0]=~ /^\%YAML[: ][\d\.]+.*\z/ and shift@lines;my$in_document=0;while (@lines){if ($lines[0]=~ /^---\s*(?:(.+)\s*)?\z/){shift@lines;if (defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/){push @$self,$self->_load_scalar("$1",[undef ],\@lines);next}$in_document=1}if (!@lines or $lines[0]=~ /^(?:---|\.\.\.)/){push @$self,undef;while (@lines and $lines[0]!~ /^---/){shift@lines}$in_document=0}elsif (!$in_document && @$self){die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"}elsif ($lines[0]=~ /^\s*\-(?:\s|$|-+$)/){my$document=[];push @$self,$document;$self->_load_array($document,[0 ],\@lines)}elsif ($lines[0]=~ /^(\s*)\S/){my$document={};push @$self,$document;$self->_load_hash($document,[length($1)],\@lines)}else {die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"}}};my$err=$@;if (ref$err eq 'SCALAR'){$self->_error(${$err})}elsif ($err){$self->_error($err)}return$self}sub _unquote_single {my ($self,$string)=@_;return '' unless length$string;$string =~ s/\'\'/\'/g;return$string}sub _unquote_double {my ($self,$string)=@_;return '' unless length$string;$string =~ s/\\"/"/g;$string =~ s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))}
Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
...
{(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;return$string}sub _load_scalar {my ($self,$string,$indent,$lines)=@_;$string =~ s/\s*\z//;return undef if$string eq '~';if ($string =~ /^$re_capture_single_quoted$re_trailing_comment\z/){return$self->_unquote_single($1)}if ($string =~ /^$re_capture_double_quoted$re_trailing_comment\z/){return$self->_unquote_double($1)}if ($string =~ /^[\'\"!&]/){die \"CPAN::Meta::YAML does not support a feature in line '$string'"}return {}if$string =~ /^{}(?:\s+\#.*)?\z/;return []if$string =~ /^\[\](?:\s+\#.*)?\z/;if ($string !~ /^[>|]/){die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'" if$string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or $string =~ /:(?:\s|$)/;$string =~ s/\s+#.*\z//;return$string}die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;$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]'"}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}sub _load_array {my ($self,$array,$indent,$lines)=@_;while (@$lines){if ($lines->[0]=~ /^(?:---|\.\.\.)/){while (@$lines and $lines->[0]!~ /^---/){shift @$lines}return 1}$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+|$)/){my$indent2=length("$1");$lines->[0]=~ s/-/ /;push @$array,{};$self->_load_hash($array->[-1],[@$indent,$indent2 ],$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){push @$array,undef}else {push @$array,[];$self->_load_array($array->[-1],[@$indent,$indent2 ],$lines)}}elsif ($lines->[0]=~ /^(\s*)\S/){push @$array,{};$self->_load_hash($array->[-1],[@$indent,length("$1")],$lines)}else {die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"}}elsif ($lines->[0]=~ /^\s*\-(\s*)(.+?)\s*\z/){shift @$lines;push @$array,$self->_load_scalar("$2",[@$indent,undef ],$lines)}elsif (defined$indent->[-2]and $indent->[-1]==$indent->[-2]){return 1}else {die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"}}return 1}sub _load_hash {my ($self,$hash,$indent,$lines)=@_;while (@$lines){if ($lines->[0]=~ /^(?:---|\.\.\.)/){while (@$lines and $lines->[0]!~ /^---/){shift @$lines}return 1}$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]'"}my$key;if ($lines->[0]=~ s/^\s*$re_capture_single_quoted$re_key_value_separator//){$key=$self->_unquote_single($1)}elsif ($lines->[0]=~ s/^\s*$re_capture_double_quoted$re_key_value_separator//){$key=$self->_unquote_double($1)}elsif ($lines->[0]=~ s/^\s*$re_capture_unquoted_key$re_key_value_separator//){$key=$1;$key =~ s/\s+$//}elsif ($lines->[0]=~ /^\s*\?/){die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'"}else {die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"}if (exists$hash->{$key}){warn "CPAN::Meta::YAML found a duplicate key '$key' in line '$lines->[0]'"}if (length$lines->[0]){$hash->{$key}=$self->_load_scalar(shift(@$lines),[@$indent,undef ],$lines)}else {shift @$lines;unless (@$lines){$hash->{$key}=undef;return 1}if ($lines->[0]=~ /^(\s*)-/){$hash->{$key}=[];$self->_load_array($hash->{$key},[@$indent,length($1)],$lines)}elsif ($lines->[0]=~ /^(\s*)./){my$indent2=length("$1");if ($indent->[-1]>= $indent2){$hash->{$key}=undef}else {$hash->{$key}={};$self->_load_hash($hash->{$key},[@$indent,length($1)],$lines)}}}}return 1}sub _dump_file {my$self=shift;require Fcntl;my$file=shift or $self->_error('You did not specify a file name');my$fh;if (_can_flock()){my$flags=Fcntl::O_WRONLY()|Fcntl::O_CREAT();sysopen($fh,$file,$flags);unless ($fh){$self->_error("Failed to open file '$file' for writing: $!")}binmode($fh,":raw:encoding(UTF-8)");flock($fh,Fcntl::LOCK_EX())or warn "Couldn't lock '$file' for reading: $!";truncate$fh,0;seek$fh,0,0}else {open$fh,">:unix:encoding(UTF-8)",$file}print {$fh}$self->_dump_string;unless (close$fh){$self->_error("Failed to close file '$file': $!")}return 1}sub _dump_string {my$self=shift;return '' unless ref$self && @$self;my$indent=0;my@lines=();eval {for my$cursor (@$self){push@lines,'---';if (!defined$cursor){}elsif (!ref$cursor){$lines[-1].= ' ' .$self->_dump_scalar($cursor)}elsif (ref$cursor eq 'ARRAY'){unless (@$cursor){$lines[-1].= ' []';next}push@lines,$self->_dump_array($cursor,$indent,{})}elsif (ref$cursor eq 'HASH'){unless (%$cursor){$lines[-1].= ' {}';next}push@lines,$self->_dump_hash($cursor,$indent,{})}else {die \("Cannot serialize " .ref($cursor))}}};if (ref $@ eq 'SCALAR'){$self->_error(${$@})}elsif ($@){$self->_error($@)}join '',map {"$_\n"}@lines}sub _has_internal_string_value {my$value=shift;my$b_obj=B::svref_2object(\$value);return$b_obj->FLAGS & B::SVf_POK()}sub _dump_scalar {my$string=$_[1];my$is_key=$_[2];my$has_string_flag=_has_internal_string_value($string);return '~' unless defined$string;return "''" unless length$string;if (Scalar::Util::looks_like_number($string)){if ($is_key || $has_string_flag){return qq['$string']}else {return$string}}if ($string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/){$string =~ s/\\/\\\\/g;$string =~ s/"/\\"/g;$string =~ s/\n/\\n/g;$string =~ s/[\x85]/\\N/g;$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;$string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;return qq|"$string"|}if ($string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or $QUOTE{$string}){return "'$string'"}return$string}sub _dump_array {my ($self,$array,$indent,$seen)=@_;if ($seen->{refaddr($array)}++){die \"CPAN::Meta::YAML does not support circular references"}my@lines=();for my$el (@$array){my$line=(' ' x $indent).'-';my$type=ref$el;if (!$type){$line .= ' ' .$self->_dump_scalar($el);push@lines,$line}elsif ($type eq 'ARRAY'){if (@$el){push@lines,$line;push@lines,$self->_dump_array($el,$indent + 1,$seen)}else {$line .= ' []';push@lines,$line}}elsif ($type eq 'HASH'){if (keys %$el){push@lines,$line;push@lines,$self->_dump_hash($el,$indent + 1,$seen)}else {$line .= ' {}';push@lines,$line}}else {die \"CPAN::Meta::YAML does not support $type references"}}@lines}sub _dump_hash {my ($self,$hash,$indent,$seen)=@_;if ($seen->{refaddr($hash)}++){die \"CPAN::Meta::YAML does not support circular references"}my@lines=();for my$name (sort keys %$hash){my$el=$hash->{$name};my$line=(' ' x $indent).$self->_dump_scalar($name,1).":";my$type=ref$el;if (!$type){$line .= ' ' .$self->_dump_scalar($el);push@lines,$line}elsif ($type eq 'ARRAY'){if (@$el){push@lines,$line;push@lines,$self->_dump_array($el,$indent + 1,$seen)}else {$line .= ' []';push@lines,$line}}elsif ($type eq 'HASH'){if (keys %$el){push@lines,$line;push@lines,$self->_dump_hash($el,$indent + 1,$seen)}else {$line .= ' {}';push@lines,$line}}else {die \"CPAN::Meta::YAML does not support $type references"}}@lines}our$errstr='';sub _error {require Carp;$errstr=$_[1];$errstr =~ s/ at \S+ line \d+.*//;Carp::croak($errstr)}my$errstr_warned;sub errstr {require Carp;Carp::carp("CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated")unless$errstr_warned++;$errstr}use B;my$HAS_FLOCK;sub _can_flock {if (defined$HAS_FLOCK){return$HAS_FLOCK}else {require Config;my$c=\%Config::Config;$HAS_FLOCK=grep {$c->{$_}}qw/d_flock d_fcntl_can_lock d_lockf/;require Fcntl if$HAS_FLOCK;return$HAS_FLOCK}}use Scalar::Util ();BEGIN {local $@;if (eval {Scalar::Util->VERSION(1.18)}){*refaddr=*Scalar::Util::refaddr}else {eval <<'END_PERL'}}delete$CPAN::Meta::YAML::{refaddr};1;
# 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 { no warnings 'portable'; hex $1 };
bless $_[0], $pkg if defined $pkg;
$i;
}
END_PERL
CPAN_META_YAML
$fatpacked{"Class/Accessor.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CLASS_ACCESSOR';
package Class::Accessor;require 5.00502;use strict;$Class::Accessor::VERSION='0.34';sub new {my($proto,$fields)=@_;my($class)=ref$proto || $proto;$fields={}unless defined$fields;bless {%$fields},$class}sub mk_accessors {my($self,@fields)=@_;$self->_mk_accessors('rw',@fields)}if (eval {require Sub::Name}){Sub::Name->import}{no strict 'refs';sub import {my ($class,@what)=@_;my$caller=caller;for (@what){if (/^(?:antlers|moose-?like)$/i){*{"${caller}::has"}=sub {my ($f,%args)=@_;$caller->_mk_accessors(($args{is}||"rw"),$f)};*{"${caller}::extends"}=sub {@{"${caller}::ISA"}=@_;unless (grep $_->can("_mk_accessors"),@_){push @{"${caller}::ISA"},$class}};&{"${caller}::extends"}(@{"${caller}::ISA"})}}}sub follow_best_practice {my($self)=@_;my$class=ref$self || $self;*{"${class}::accessor_name_for"}=\&best_practice_accessor_name_for;*{"${class}::mutator_name_for"}=\&best_practice_mutator_name_for}sub _mk_accessors {my($self,$access,@fields)=@_;my$class=ref$self || $self;my$ra=$access eq 'rw' || $access eq 'ro';my$wa=$access eq 'rw' || $access eq 'wo';for my$field (@fields){my$accessor_name=$self->accessor_name_for($field);my$mutator_name=$self->mutator_name_for($field);if($accessor_name eq 'DESTROY' or $mutator_name eq 'DESTROY'){$self->_carp("Having a data accessor named DESTROY in '$class' is unwise.")}if ($accessor_name eq $mutator_name){my$accessor;if ($ra && $wa){$accessor=$self->make_accessor($field)}elsif ($ra){$accessor=$self->make_ro_accessor($field)}else {$accessor=$self->make_wo_accessor($field)}my$fullname="${class}::$accessor_name";my$subnamed=0;unless (defined &{$fullname}){subname($fullname,$accessor)if defined&subname;$subnamed=1;*{$fullname}=$accessor}if ($accessor_name eq $field){my$alias="${class}::_${field}_accessor";subname($alias,$accessor)if defined&subname and not $subnamed;*{$alias}=$accessor unless defined &{$alias}}}else {my$fullaccname="${class}::$accessor_name";my$fullmutname="${class}::$mutator_name";if ($ra and not defined &{$fullaccname}){my$accessor=$self->make_ro_accessor($field);subname($fullaccname,$accessor)if defined&subname;*{$fullaccname}=$accessor}if ($wa and not defined &{$fullmutname}){my$mutator=$self->make_wo_accessor($field);subname($fullmutname,$mutator)if defined&subname;*{$fullmutname}=$mutator}}}}}sub mk_ro_accessors {my($self,@fields)=@_;$self->_mk_accessors('ro',@fields)}sub mk_wo_accessors {my($self,@fields)=@_;$self->_mk_accessors('wo',@fields)}sub best_practice_accessor_name_for {my ($class,$field)=@_;return "get_$field"}sub best_practice_mutator_name_for {my ($class,$field)=@_;return "set_$field"}sub accessor_name_for {my ($class,$field)=@_;return$field}sub mutator_name_for {my ($class,$field)=@_;return$field}sub set {my($self,$key)=splice(@_,0,2);if(@_==1){$self->{$key}=$_[0]}elsif(@_ > 1){$self->{$key}=[@_]}else {$self->_croak("Wrong number of arguments received")}}sub get {my$self=shift;if(@_==1){return$self->{$_[0]}}elsif(@_ > 1){return @{$self}{@_}}else {$self->_croak("Wrong number of arguments received")}}sub make_accessor {my ($class,$field)=@_;return sub {my$self=shift;if(@_){return$self->set($field,@_)}else {return$self->get($field)}}}sub make_ro_accessor {my($class,$field)=@_;return sub {my$self=shift;if (@_){my$caller=caller;$self->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'")}else {return$self->get($field)}}}sub make_wo_accessor {my($class,$field)=@_;return sub {my$self=shift;unless (@_){my$caller=caller;$self->_croak("'$caller' cannot access the value of '$field' on objects of class '$class'")}else {return$self->set($field,@_)}}}use Carp ();sub _carp {my ($self,$msg)=@_;Carp::carp($msg || $self);return}sub _croak {my ($self,$msg)=@_;Carp::croak($msg || $self);return}1;
CLASS_ACCESSOR
$fatpacked{"Class/Accessor/Fast.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CLASS_ACCESSOR_FAST';
package Class::Accessor::Fast;use base 'Class::Accessor';use strict;$Class::Accessor::Fast::VERSION='0.34';sub make_accessor {my($class,$field)=@_;return sub {return $_[0]->{$field}if scalar(@_)==1;return $_[0]->{$field}=scalar(@_)==2 ? $_[1]: [@_[1..$#_]]}}sub make_ro_accessor {my($class,$field)=@_;return sub {return $_[0]->{$field}if @_==1;my$caller=caller;$_[0]->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'")}}sub make_wo_accessor {my($class,$field)=@_;return sub {if (@_==1){my$caller=caller;$_[0]->_croak("'$caller' cannot access the value of '$field' on objects of class '$class'")}else {return $_[0]->{$field}=$_[1]if @_==2;return (shift)->{$field}=\@_}}}1;
CLASS_ACCESSOR_FAST
$fatpacked{"Class/Accessor/Faster.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CLASS_ACCESSOR_FASTER';
package Class::Accessor::Faster;use base 'Class::Accessor';use strict;$Class::Accessor::Faster::VERSION='0.34';my%slot;sub _slot {my($class,$field)=@_;my$n=$slot{$class}->{$field};return$n if defined$n;$n=keys %{$slot{$class}};$slot{$class}->{$field}=$n;return$n}sub new {my($proto,$fields)=@_;my($class)=ref$proto || $proto;my$self=bless [],$class;$fields={}unless defined$fields;for my$k (keys %$fields){my$n=$class->_slot($k);$self->[$n]=$fields->{$k}}return$self}sub make_accessor {my($class,$field)=@_;my$n=$class->_slot($field);return sub {return $_[0]->[$n]if scalar(@_)==1;return $_[0]->[$n]=scalar(@_)==2 ? $_[1]: [@_[1..$#_]]}}sub make_ro_accessor {my($class,$field)=@_;my$n=$class->_slot($field);return sub {return $_[0]->[$n]if @_==1;my$caller=caller;$_[0]->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'")}}sub make_wo_accessor {my($class,$field)=@_;my$n=$class->_slot($field);return sub {if (@_==1){my$caller=caller;$_[0]->_croak("'$caller' cannot access the value of '$field' on objects of class '$class'")}else {return $_[0]->[$n]=$_[1]if @_==2;return (shift)->[$n]=\@_}}}1;
CLASS_ACCESSOR_FASTER
$fatpacked{"Config/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CONFIG_TINY';
package Config::Tiny;use strict;our$VERSION='2.23';BEGIN {require 5.008001;$Config::Tiny::errstr=''}sub new {return bless {},shift}sub read {my($class)=ref $_[0]? ref shift : shift;my($file,$encoding)=@_;return$class -> _error('No file name provided')if (!defined$file || ($file eq ''));$encoding=$encoding ? "<:$encoding" : '<';local $/=undef;open(CFG,$encoding,$file)or return$class -> _error("Failed to open file '$file' for reading: $!");my$contents=<CFG>;close(CFG);return$class -> _error("Reading from '$file' returned undef")if (!defined$contents);return$class -> read_string($contents)}sub read_string {my($class)=ref $_[0]? ref shift : shift;my($self)=bless {},$class;return undef unless defined $_[0];my$ns='_';my$counter=0;for (split /(?:\015{1,2}\012|\015|\012)/,shift){$counter++;next if /^\s*(?:\#|\;|$)/;s/\s\;\s.+$//g;if (/^\s*\[\s*(.+?)\s*\]\s*$/){$self->{$ns=$1}||= {};next}if (/^\s*([^=]+?)\s*=\s*(.*?)\s*$/){$self->{$ns}->{$1}=$2;next}return$self -> _error("Syntax error at line $counter: '$_'")}return$self}sub write {my($self)=shift;my($file,$encoding)=@_;return$self -> _error('No file name provided')if (!defined$file or ($file eq ''));$encoding=$encoding ? ">:$encoding" : '>';my($string)=$self->write_string;return undef unless defined$string;open(CFG,$encoding,$file)or return$self->_error("Failed to open file '$file' for writing: $!");print CFG$string;close CFG;return 1}sub write_string {my($self)=shift;my($contents)='';for my$section (sort {(($b eq '_')<=> ($a eq '_'))|| ($a cmp $b)}keys %$self){return$self->_error("Illegal whitespace in section name '$section'")if$section =~ /(?:^\s|\n|\s$)/s;my$block=$self->{$section};$contents .= "\n" if length$contents;$contents .= "[$section]\n" unless$section eq '_';for my$property (sort keys %$block){return$self->_error("Illegal newlines in property '$section.$property'")if$block->{$property}=~ /(?:\012|\015)/s;$contents .= "$property=$block->{$property}\n"}}return$contents}sub errstr {$Config::Tiny::errstr}sub _error {$Config::Tiny::errstr=$_[1];undef}1;
CONFIG_TINY
$fatpacked{"Devel/InnerPackage.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DEVEL_INNERPACKAGE';
package Devel::InnerPackage;use strict;use Exporter 5.57 'import';use vars qw($VERSION @EXPORT_OK);use if $] > 5.017,'deprecate';$VERSION='0.4';@EXPORT_OK=qw(list_packages);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);push@packs,@children}return grep {$_ !~ /::(::ISA::CACHE|SUPER)/}@packs}sub _loaded {my ($class,$name)=@_;no strict 'refs';return 1 if defined ${"${name}::VERSION"};return 1 if @{"${name}::ISA"};for (keys %{"${name}::"}){next if substr($_,-2,2)eq '::';return 1 if defined &{"${name}::$_"}}my$filename=join('/',split /(?:'|::)/,$name).'.pm';return 1 if defined$INC{$filename};''}1;
DEVEL_INNERPACKAGE
$fatpacked{"ExtUtils/CBuilder.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_CBUILDER';
package ExtUtils::CBuilder;$ExtUtils::CBuilder::VERSION='0.280226';use File::Spec ();use File::Path ();use File::Basename ();use Perl::OSType qw/os_type/;use warnings;use strict;use vars qw(@ISA);my$load=sub {my$mod=shift;eval "use $mod";die $@ if $@;@ISA=($mod)};{my@package=split /::/,__PACKAGE__;my$ostype=os_type();if (grep {-e File::Spec->catfile($_,@package,'Platform',$^O).'.pm'}@INC){$load->(__PACKAGE__ ."::Platform::$^O")}elsif ($ostype && grep {-e File::Spec->catfile($_,@package,'Platform',$ostype).'.pm'}@INC){$load->(__PACKAGE__ ."::Platform::$ostype")}else {$load->(__PACKAGE__ ."::Base")}}1;
EXTUTILS_CBUILDER
$fatpacked{"ExtUtils/CBuilder/Base.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_CBUILDER_BASE';
package ExtUtils::CBuilder::Base;$ExtUtils::CBuilder::Base::VERSION='0.280226';use strict;use warnings;use File::Spec;use File::Basename;use Cwd ();use Config;use Text::ParseWords;use IPC::Cmd qw(can_run);use File::Temp qw(tempfile);my%cc2cxx=(cc=>['c++','CC','aCC','cxx',],gcc=>['g++' ],xlc=>['xlC' ],xlc_r=>['xlC_r' ],cl=>['cl' ],);sub new {my$class=shift;my$self=bless {@_},$class;$self->{properties}{perl}=$class->find_perl_interpreter or warn "Warning: Can't locate your perl binary";while (my ($k,$v)=each%Config){$self->{config}{$k}=$v unless exists$self->{config}{$k}}$self->{config}{cc}=$ENV{CC}if defined$ENV{CC};$self->{config}{ccflags}=join(" ",$self->{config}{ccflags},$ENV{CFLAGS})if defined$ENV{CFLAGS};$self->{config}{cxx}=$ENV{CXX}if defined$ENV{CXX};$self->{config}{cxxflags}=$ENV{CXXFLAGS}if defined$ENV{CXXFLAGS};$self->{config}{ld}=$ENV{LD}if defined$ENV{LD};$self->{config}{ldflags}=join(" ",$self->{config}{ldflags},$ENV{LDFLAGS})if defined$ENV{LDFLAGS};unless (exists$self->{config}{cxx}){my ($ccbase,$ccpath,$ccsfx)=fileparse($self->{config}{cc},qr/\.[^.]*/);$ccpath="" if$self->{config}{cc}=~ /^$ccbase$ccsfx$/;for my$cxx (@{$cc2cxx{$ccbase}}){my$cxx1=File::Spec->catfile($ccpath,$cxx .$ccsfx);if(can_run($cxx1)){$self->{config}{cxx}=$cxx1;last}my$cxx2=$cxx .$ccsfx;if(can_run($cxx2)){$self->{config}{cxx}=$cxx2;last}if(can_run($cxx)){$self->{config}{cxx}=$cxx;last}}unless (exists$self->{config}{cxx}){$self->{config}{cxx}=$self->{config}{cc};my$cflags=$self->{config}{ccflags};$self->{config}{cxxflags}='-x c++';$self->{config}{cxxflags}.= " $cflags" if defined$cflags}}return$self}sub find_perl_interpreter {my$perl;File::Spec->file_name_is_absolute($perl=$^X)or -f ($perl=$Config::Config{perlpath})or ($perl=$^X);return$perl}sub add_to_cleanup {my$self=shift;for (@_){$self->{files_to_clean}{$_}=1}}sub cleanup {my$self=shift;for my$file (keys %{$self->{files_to_clean}}){unlink$file}}sub get_config {return %{$_[0]->{config}}}sub object_file {my ($self,$filename)=@_;(my$file_base=$filename)=~ s/\.[^.]+$//;return "$file_base$self->{config}{obj_ext}"}sub arg_include_dirs {my$self=shift;return map {"-I$_"}@_}sub arg_nolink {'-c'}sub arg_object_file {my ($self,$file)=@_;return ('-o',$file)}sub arg_share_object_file {my ($self,$file)=@_;return ($self->split_like_shell($self->{config}{lddlflags}),'-o',$file)}sub arg_exec_file {my ($self,$file)=@_;return ('-o',$file)}sub arg_defines {my ($self,%args)=@_;return map "-D$_=$args{$_}",sort keys%args}sub compile {my ($self,%args)=@_;die "Missing 'source' argument to compile()" unless defined$args{source};my$cf=$self->{config};my$object_file=$args{object_file}? $args{object_file}: $self->object_file($args{source});my$include_dirs_ref=(exists($args{include_dirs})&& ref($args{include_dirs})ne "ARRAY")? [$args{include_dirs}]: $args{include_dirs};my@include_dirs=$self->arg_include_dirs(@{$include_dirs_ref || []},$self->perl_inc(),);my@defines=$self->arg_defines(%{$args{defines}|| {}});my@extra_compiler_flags=$self->split_like_shell($args{extra_compiler_flags});my@cccdlflags=$self->split_like_shell($cf->{cccdlflags});my@ccflags=$self->split_like_shell($args{'C++'}? $cf->{cxxflags}: $cf->{ccflags});my@optimize=$self->split_like_shell($cf->{optimize});my@flags=(@include_dirs,@defines,@cccdlflags,@extra_compiler_flags,$self->arg_nolink,@ccflags,@optimize,$self->arg_object_file($object_file),);my@cc=$self->split_like_shell($args{'C++'}? $cf->{cxx}: $cf->{cc});$self->do_system(@cc,@flags,$args{source})or die "error building $object_file from '$args{source}'";return$object_file}sub have_compiler {my ($self,$is_cplusplus)=@_;my$have_compiler_flag=$is_cplusplus ? "have_cxx" : "have_cc";my$suffix=$is_cplusplus ? ".cc" : ".c";return$self->{$have_compiler_flag}if defined$self->{$have_compiler_flag};my$result;my$attempts=3;my ($FH,$tmpfile)=tempfile("compilet-XXXXX",SUFFIX=>$suffix);binmode$FH;if ($is_cplusplus){print$FH "class Bogus { public: int boot_compilet() { return 1; } };\n"}else {print$FH "int boot_compilet() { return 1; }\n"}close$FH;my ($obj_file,@lib_files);eval {local $^W=0;local$self->{quiet}=1;$obj_file=$self->compile('C++'=>$is_cplusplus,source=>$tmpfile);@lib_files=$self->link(objects=>$obj_file,module_name=>'compilet')};$result=$@ ? 0 : 1;for (grep defined,$tmpfile,$obj_file,@lib_files){1 while unlink}return$self->{$have_compiler_flag}=$result}sub have_cplusplus {push @_,1;goto&have_compiler}sub lib_file {my ($self,$dl_file,%args)=@_;$dl_file =~ s/\.[^.]+$//;$dl_file =~ tr/"//d;if (defined$args{module_name}and length$args{module_name}){require DynaLoader;if (defined&DynaLoader::mod2fname){my$lib=DynaLoader::mod2fname([split /::/,$args{module_name}]);my ($dev,$lib_dir,undef)=File::Spec->splitpath($dl_file);$dl_file=File::Spec->catpath($dev,$lib_dir,$lib)}}$dl_file .= ".$self->{config}{dlext}";return$dl_file}sub exe_file {my ($self,$dl_file)=@_;$dl_file =~ s/\.[^.]+$//;$dl_file =~ tr/"//d;return "$dl_file$self->{config}{_exe}"}sub need_prelink {0}sub extra_link_args_after_prelink {return}sub prelink {my ($self,%args)=@_;my ($dl_file_out,$mksymlists_args)=_prepare_mksymlists_args(\%args);require ExtUtils::Mksymlists;ExtUtils::Mksymlists::Mksymlists(%{$mksymlists_args});return grep -e,map "$dl_file_out.$_",qw(ext def opt)}sub _prepare_mksymlists_args {my$args=shift;($args->{dl_file}=$args->{dl_name})=~ s/.*::// unless$args->{dl_file};my%mksymlists_args=(DL_VARS=>$args->{dl_vars}|| [],DL_FUNCS=>$args->{dl_funcs}|| {},FUNCLIST=>$args->{dl_func_list}|| [],IMPORTS=>$args->{dl_imports}|| {},NAME=>$args->{dl_name},DLBASE=>$args->{dl_base},FILE=>$args->{dl_file},VERSION=>(defined$args->{dl_version}? $args->{dl_version}: '0.0'),);return ($args->{dl_file},\%mksymlists_args)}sub link {my ($self,%args)=@_;return$self->_do_link('lib_file',lddl=>1,%args)}sub link_executable {my ($self,%args)=@_;return$self->_do_link('exe_file',lddl=>0,%args)}sub _do_link {my ($self,$type,%args)=@_;my$cf=$self->{config};my$objects=delete$args{objects};$objects=[$objects]unless ref$objects;my$out=$args{$type}|| $self->$type($objects->[0],%args);my@temp_files;@temp_files=$self->prelink(%args,dl_name=>$args{module_name})if$args{lddl}&& $self->need_prelink;my@linker_flags=($self->split_like_shell($args{extra_linker_flags}),$self->extra_link_args_after_prelink(%args,dl_name=>$args{module_name},prelink_res=>\@temp_files));my@output=$args{lddl}? $self->arg_share_object_file($out): $self->arg_exec_file($out);my@shrp=$self->split_like_shell($cf->{shrpenv});my@ld=$self->split_like_shell($cf->{ld});$self->do_system(@shrp,@ld,@output,@$objects,@linker_flags)or die "error building $out from @$objects";return wantarray ? ($out,@temp_files): $out}sub do_system {my ($self,@cmd)=@_;print "@cmd\n" if!$self->{quiet};return!system(@cmd)}sub split_like_shell {my ($self,$string)=@_;return ()unless defined($string);return @$string if UNIVERSAL::isa($string,'ARRAY');$string =~ s/^\s+|\s+$//g;return ()unless length($string);$string =~ s@\\@/@g if $^O eq 'MSWin32';return Text::ParseWords::shellwords($string)}sub perl_src {return unless$ENV{PERL_CORE};my$Updir=File::Spec->updir;my$dir=File::Spec->curdir;for (0..10){if (-f File::Spec->catfile($dir,"config_h.SH")&& -f File::Spec->catfile($dir,"perl.h")&& -f File::Spec->catfile($dir,"lib","Exporter.pm")){return Cwd::realpath($dir)}$dir=File::Spec->catdir($dir,$Updir)}warn "PERL_CORE is set but I can't find your perl source!\n";return ''}sub perl_inc {my$self=shift;$self->perl_src()|| File::Spec->catdir($self->{config}{archlibexp},"CORE")}sub DESTROY {my$self=shift;local($.,$@,$!,$^E,$?);$self->cleanup()}1;
EXTUTILS_CBUILDER_BASE
$fatpacked{"ExtUtils/CBuilder/Platform/Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_CBUILDER_PLATFORM_UNIX';
package ExtUtils::CBuilder::Platform::Unix;$ExtUtils::CBuilder::Platform::Unix::VERSION='0.280226';use warnings;use strict;use ExtUtils::CBuilder::Base;use vars qw(@ISA);@ISA=qw(ExtUtils::CBuilder::Base);sub link_executable {my$self=shift;local$self->{config}{ld}=$self->{config}{cc}." " .$self->{config}{ldflags};return$self->SUPER::link_executable(@_)}sub link {my$self=shift;my$cf=$self->{config};local$cf->{ld}=$cf->{ld};if (ref$cf->{ld}){unshift @{$cf->{ld}},'env' if$cf->{ld}[0]=~ /^\s*\w+=/}else {$cf->{ld}=~ s/^(\s*\w+=)/env $1/}return$self->SUPER::link(@_)}1;
EXTUTILS_CBUILDER_PLATFORM_UNIX
$fatpacked{"ExtUtils/CBuilder/Platform/VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_CBUILDER_PLATFORM_VMS';
package ExtUtils::CBuilder::Platform::VMS;$ExtUtils::CBuilder::Platform::VMS::VERSION='0.280226';use warnings;use strict;use ExtUtils::CBuilder::Base;use vars qw(@ISA);@ISA=qw(ExtUtils::CBuilder::Base);use File::Spec::Functions qw(catfile catdir);use Config;sub need_prelink {0}sub arg_defines {my ($self,%args)=@_;s/"/""/g foreach values%args;my@config_defines;if ($self->{config}{ccflags}=~ s{/ def[^=]+ =+ \(? ([^\/\)]*) } {}ix){push@config_defines,$1}return '' unless keys(%args)|| @config_defines;return ('/define=(' .join(',',@config_defines,map "\"$_" .(length($args{$_})? "=$args{$_}" : '')."\"",sort keys%args).')')}sub arg_include_dirs {my ($self,@dirs)=@_;if ($self->{config}{ccflags}=~ s{/inc[^=]+(?:=)+(?:\()?([^\/\)]*)} {}i){unshift@dirs,$1}return unless@dirs;return ('/include=(' .join(',',@dirs).')')}sub compile {my ($self,%args)=@_;$self->{config}{ccflags}=$Config{ccflags};$self->{config}{ccflags}=$ENV{CFLAGS}if defined$ENV{CFLAGS};return$self->SUPER::compile(%args)}sub _do_link {my ($self,$type,%args)=@_;my$objects=delete$args{objects};$objects=[$objects]unless ref$objects;if ($args{lddl}){my@temp_files=$self->prelink(%args,dl_name=>$args{module_name});my@optlibs=$self->_liblist_ext($args{'libs'});my$optfile='sys$disk:[]' .$temp_files[0];open my$opt_fh,'>>',$optfile or die "_do_link: Unable to open $optfile: $!";for my$lib (@optlibs){print$opt_fh "$lib\n" if length$lib}close$opt_fh;$objects->[-1].= ',';push @$objects,$optfile .'/OPTIONS,';push @$objects,$self->perl_inc().'perlshr_attr.opt/OPTIONS'}return$self->SUPER::_do_link($type,%args,objects=>$objects)}sub arg_nolink {return}sub arg_object_file {my ($self,$file)=@_;return "/obj=$file"}sub arg_exec_file {my ($self,$file)=@_;return ("/exe=$file")}sub arg_share_object_file {my ($self,$file)=@_;return ("$self->{config}{lddlflags}=$file")}sub _liblist_ext {my($self,$potential_libs,$verbose,$give_libs)=@_;$verbose ||= 0;my(@crtls,$crtlstr);@crtls=(($self->{'config'}{'ldflags'}=~ m-/Debug-i ? $self->{'config'}{'dbgprefix'}: '').'PerlShr/Share');push(@crtls,grep {not /\(/}split /\s+/,$self->{'config'}{'perllibs'});push(@crtls,grep {not /\(/}split /\s+/,$self->{'config'}{'libc'});if ($self->perl_src){my($lib,$locspec,$type);for$lib (@crtls){if (($locspec,$type)=$lib =~ m{^([\w\$-]+)(/\w+)?} and $locspec =~ /perl/i){if (lc$type eq '/share'){$locspec .= $self->{'config'}{'exe_ext'}}elsif (lc$type eq '/library'){$locspec .= $self->{'config'}{'lib_ext'}}else {$locspec .= $self->{'config'}{'obj_ext'}}$locspec=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(@dirs,@libs,$dir,$lib,%found,@fndlibs,$ldlib);my$cwd=cwd();my($so,$lib_ext,$obj_ext)=@{$self->{'config'}}{'so','lib_ext','obj_ext'};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');warn "Potential libraries are '$potential_libs'\n" if$verbose;for$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(' ',$self->{'config'}{'libpth'}));for$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=catdir($cwd,$dir)}}@dirs=grep {length($_)}@dirs;unshift(@dirs,'');LIB: foreach$lib (@libs){if (exists$libmap{$lib}){next unless length$libmap{$lib};$lib=$libmap{$lib}}my(@variants,$variant,$cand);my($ctype)='';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;for$variant (@variants){my($fullname,$name);for$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){if ($fullname =~ /(?:$so|exe)$/i){$type='SHR'}elsif ($fullname =~ /(?:$lib_ext|olb)$/i){$type='OLB'}elsif ($fullname =~ /(?:$obj_ext|obj)$/i){warn "Note (probably harmless): " ."Plain object file $fullname found in library list\n";$type='OBJ'}else {warn "Note (probably 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 (-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 (-f ($fullname=VMS::Filespec::rmsexpand($name,$obj_ext))or -f ($fullname=VMS::Filespec::rmsexpand($name,'.obj')))){warn "Note (probably 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){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 "Note (probably 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};$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_CBUILDER_PLATFORM_VMS
$fatpacked{"ExtUtils/CBuilder/Platform/Windows.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_CBUILDER_PLATFORM_WINDOWS';
package ExtUtils::CBuilder::Platform::Windows;$ExtUtils::CBuilder::Platform::Windows::VERSION='0.280226';use strict;use warnings;use File::Basename;use File::Spec;use ExtUtils::CBuilder::Base;use IO::File;use vars qw(@ISA);@ISA=qw(ExtUtils::CBuilder::Base);sub new {my$class=shift;my$self=$class->SUPER::new(@_);my$cf=$self->{config};my$driver="ExtUtils::CBuilder::Platform::Windows::" .$self->_compiler_type;eval "require $driver" or die "Could not load compiler driver: $@";unshift@ISA,$driver;return$self}sub _compiler_type {my$self=shift;my$cc=$self->{config}{cc};return ($cc =~ /cl(\.exe)?$/ ? 'MSVC' : $cc =~ /bcc32(\.exe)?$/ ? 'BCC' : 'GCC')}sub split_like_shell {(my$self,local $_)=@_;return @$_ if defined()&& UNIVERSAL::isa($_,'ARRAY');return unless defined()&& length();return ($_)}sub do_system {my$self=shift;my$cmd=join(" ",grep length,map {$a=$_;$a=~s/\t/ /g;$a=~s/^\s+|\s+$//;$a}grep defined,@_);return$self->SUPER::do_system($cmd)}sub arg_defines {my ($self,%args)=@_;s/"/\\"/g foreach values%args;return map qq{"-D$_=$args{$_}"},sort keys%args}sub compile {my ($self,%args)=@_;my$cf=$self->{config};die "Missing 'source' argument to compile()" unless defined$args{source};$args{include_dirs}=[$args{include_dirs}]if exists($args{include_dirs})&& ref($args{include_dirs})ne "ARRAY";my ($basename,$srcdir)=(File::Basename::fileparse($args{source},'\.[^.]+$'))[0,1];$srcdir ||= File::Spec->curdir();my@defines=$self->arg_defines(%{$args{defines}|| {}});my%spec=(srcdir=>$srcdir,builddir=>$srcdir,basename=>$basename,source=>$args{source},output=>$args{object_file}|| File::Spec->catfile($srcdir,$basename).$cf->{obj_ext},cc=>$cf->{cc},cflags=>[$self->split_like_shell($cf->{ccflags}),$self->split_like_shell($cf->{cccdlflags}),$self->split_like_shell($args{extra_compiler_flags}),],optimize=>[$self->split_like_shell($cf->{optimize})],defines=>\@defines,includes=>[@{$args{include_dirs}|| []}],perlinc=>[$self->perl_inc(),$self->split_like_shell($cf->{incpath}),],use_scripts=>1,);$self->normalize_filespecs(\$spec{source},\$spec{output},$spec{includes},$spec{perlinc},);my@cmds=$self->format_compiler_cmd(%spec);while (my$cmd=shift@cmds){$self->do_system(@$cmd)or die "error building $cf->{dlext} file from '$args{source}'"}(my$out=$spec{output})=~ tr/'"//d;return$out}sub need_prelink {1}sub link {my ($self,%args)=@_;my$cf=$self->{config};my@objects=(ref$args{objects}eq 'ARRAY' ? @{$args{objects}}: $args{objects});my$to=join '',(File::Spec->splitpath($objects[0]))[0,1];$to ||= File::Spec->curdir();(my$file_base=$args{module_name})=~ s/.*:://;my$output=$args{lib_file}|| File::Spec->catfile($to,"$file_base.$cf->{dlext}");my$lddlflags=$cf->{lddlflags};my$perl_src=$self->perl_src();$lddlflags =~ s{\Q$cf->{archlibexp}\E[\\/]CORE}{$perl_src`/lib/CORE} if$perl_src;my%spec=(srcdir=>$to,builddir=>$to,startup=>[],objects=>\@objects,libs=>[],output=>$output,ld=>$cf->{ld},libperl=>$cf->{libperl},perllibs=>[$self->split_like_shell($cf->{perllibs})],libpath=>[$self->split_like_shell($cf->{libpth})],lddlflags=>[$self->split_like_shell($lddlflags)],other_ldflags=>[$self->split_like_shell($args{extra_linker_flags}|| '')],use_scripts=>1,);unless ($spec{basename}){($spec{basename}=$args{module_name})=~ s/.*:://}$spec{srcdir}=File::Spec->canonpath($spec{srcdir});$spec{builddir}=File::Spec->canonpath($spec{builddir});$spec{output}||= File::Spec->catfile($spec{builddir},$spec{basename}.'.'.$cf->{dlext});$spec{manifest}||= $spec{output}.'.manifest';$spec{implib}||= File::Spec->catfile($spec{builddir},$spec{basename}.$cf->{lib_ext});$spec{explib}||= File::Spec->catfile($spec{builddir},$spec{basename}.'.exp');if ($cf->{cc}eq 'cl'){$spec{dbg_file}||= File::Spec->catfile($spec{builddir},$spec{basename}.'.pdb')}elsif ($cf->{cc}eq 'bcc32'){$spec{dbg_file}||= File::Spec->catfile($spec{builddir},$spec{basename}.'.tds')}$spec{def_file}||= File::Spec->catfile($spec{srcdir},$spec{basename}.'.def');$spec{base_file}||= File::Spec->catfile($spec{srcdir},$spec{basename}.'.base');$self->add_to_cleanup(grep defined,@{[@spec{qw(manifest implib explib dbg_file def_file base_file map_file)}]});for my$opt (qw(output manifest implib explib dbg_file def_file map_file base_file)){$self->normalize_filespecs(\$spec{$opt})}for my$opt (qw(libpath startup objects)){$self->normalize_filespecs($spec{$opt})}(my$def_base=$spec{def_file})=~ tr/'"//d;$def_base =~ s/\.def$//;$self->prelink(%args,dl_name=>$args{module_name},dl_file=>$def_base,dl_base=>$spec{basename});my@cmds=$self->format_linker_cmd(%spec);while (my$cmd=shift@cmds){$self->do_system(@$cmd)}$spec{output}=~ tr/'"//d;return wantarray ? grep defined,@spec{qw[output manifest implib explib dbg_file def_file map_file base_file]}: $spec{output}}sub normalize_filespecs {my ($self,@specs)=@_;for my$spec (grep defined,@specs){if (ref$spec eq 'ARRAY'){$self->normalize_filespecs(map {\$_}grep defined,@$spec)}elsif (ref$spec eq 'SCALAR'){$$spec =~ tr/"//d if $$spec;next unless $$spec;$$spec='"' .File::Spec->canonpath($$spec).'"'}elsif (ref$spec eq ''){$spec='"' .File::Spec->canonpath($spec).'"'}else {die "Don't know how to normalize " .(ref$spec || $spec)."\n"}}}sub perl_inc {my$self=shift;my$perl_src=$self->perl_src();if ($perl_src){File::Spec->catdir($perl_src,"lib","CORE")}else {File::Spec->catdir($self->{config}{archlibexp},"CORE")}}1;
EXTUTILS_CBUILDER_PLATFORM_WINDOWS
$fatpacked{"ExtUtils/CBuilder/Platform/Windows/BCC.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_CBUILDER_PLATFORM_WINDOWS_BCC';
package ExtUtils::CBuilder::Platform::Windows::BCC;$ExtUtils::CBuilder::Platform::Windows::BCC::VERSION='0.280226';use strict;use warnings;sub format_compiler_cmd {my ($self,%spec)=@_;for my$path (@{$spec{includes}|| []},@{$spec{perlinc}|| []}){$path='-I' .$path}%spec=$self->write_compiler_script(%spec)if$spec{use_scripts};return [grep {defined && length}($spec{cc},'-c',@{$spec{includes}},@{$spec{cflags}},@{$spec{optimize}},@{$spec{defines}},@{$spec{perlinc}},"-o$spec{output}",$spec{source},)]}sub write_compiler_script {my ($self,%spec)=@_;my$script=File::Spec->catfile($spec{srcdir},$spec{basename}.'.ccs');$self->add_to_cleanup($script);print "Generating script '$script'\n" if!$self->{quiet};my$SCRIPT=IO::File->new(">$script")or die("Could not create script '$script': $!");print$SCRIPT join("\n",map {ref $_ ? @{$_}: $_}grep defined,delete(@spec{qw(includes cflags optimize perlinc) }));push @{$spec{includes}},'@"' .$script .'"';return%spec}sub format_linker_cmd {my ($self,%spec)=@_;for my$path (@{$spec{libpath}}){$path="-L$path"}push(@{$spec{startup}},'c0d32.obj')unless ($spec{startup}&& @{$spec{startup}});%spec=$self->write_linker_script(%spec)if$spec{use_scripts};return [grep {defined && length}($spec{ld},@{$spec{lddlflags}},@{$spec{libpath}},@{$spec{other_ldflags}},@{$spec{startup}},@{$spec{objects}},',',$spec{output},',',$spec{map_file},',',$spec{libperl},@{$spec{perllibs}},',',$spec{def_file})]}sub write_linker_script {my ($self,%spec)=@_;my$ld_script=File::Spec->catfile($spec{srcdir},$spec{basename}.'.lds');my$ld_libs=File::Spec->catfile($spec{srcdir},$spec{basename}.'.lbs');$self->add_to_cleanup($ld_script,$ld_libs);print "Generating scripts '$ld_script' and '$ld_libs'.\n" if!$self->{quiet};my$LD_SCRIPT=IO::File->new(">$ld_script")or die("Could not create linker script '$ld_script': $!");print$LD_SCRIPT join(" +\n",map {@{$_}}grep defined,delete(@spec{qw(lddlflags libpath other_ldflags startup objects) }));my$LD_LIBS=IO::File->new(">$ld_libs")or die("Could not create linker script '$ld_libs': $!");print$LD_LIBS join(" +\n",(delete$spec{libperl}|| ''),@{delete$spec{perllibs}|| []},);push @{$spec{lddlflags}},'@"' .$ld_script .'"';push @{$spec{perllibs}},'@"' .$ld_libs .'"';return%spec}1;
EXTUTILS_CBUILDER_PLATFORM_WINDOWS_BCC
$fatpacked{"ExtUtils/CBuilder/Platform/Windows/GCC.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_CBUILDER_PLATFORM_WINDOWS_GCC';
package ExtUtils::CBuilder::Platform::Windows::GCC;$ExtUtils::CBuilder::Platform::Windows::GCC::VERSION='0.280226';use warnings;use strict;sub format_compiler_cmd {my ($self,%spec)=@_;for my$path (@{$spec{includes}|| []},@{$spec{perlinc}|| []}){$path='-I' .$path}my@cc=split / (?=-)/,$spec{cc};return [grep {defined && length}(@cc,'-c',@{$spec{includes}},@{$spec{cflags}},@{$spec{optimize}},@{$spec{defines}},@{$spec{perlinc}},'-o',$spec{output},$spec{source},)]}sub format_linker_cmd {my ($self,%spec)=@_;my$cf=$self->{config};$spec{libperl}=~ s/^(?:lib)?([^.]+).*$/-l$1/;unshift(@{$spec{other_ldflags}},'-nostartfiles')if ($spec{startup}&& @{$spec{startup}});File::Basename::basename($spec{output})=~ /(....)(.{0,4})/;$spec{image_base}=sprintf("0x%x0000",unpack('n',$1 ^ $2));%spec=$self->write_linker_script(%spec)if$spec{use_scripts};for my$path (@{$spec{libpath}}){$path="-L$path"}my@cmds;my$DLLTOOL=$cf->{dlltool}|| 'dlltool';push@cmds,[$DLLTOOL,'--def',$spec{def_file},'--output-exp',$spec{explib}];my@ld=split / (?=-)/,$spec{ld};push@cmds,[grep {defined && length}(@ld,'-o',$spec{output},"-Wl,--base-file,$spec{base_file}","-Wl,--image-base,$spec{image_base}",@{$spec{lddlflags}},@{$spec{libpath}},@{$spec{startup}},@{$spec{objects}},@{$spec{other_ldflags}},$spec{libperl},@{$spec{perllibs}},$spec{explib},$spec{map_file}? ('-Map',$spec{map_file}): '')];push@cmds,[$DLLTOOL,'--def',$spec{def_file},'--output-exp',$spec{explib},'--base-file',$spec{base_file}];push@cmds,[grep {defined && length}(@ld,'-o',$spec{output},"-Wl,--image-base,$spec{image_base}",@{$spec{lddlflags}},@{$spec{libpath}},@{$spec{startup}},@{$spec{objects}},@{$spec{other_ldflags}},$spec{libperl},@{$spec{perllibs}},$spec{explib},$spec{map_file}? ('-Map',$spec{map_file}): '')];return@cmds}sub write_linker_script {my ($self,%spec)=@_;my$script=File::Spec->catfile($spec{srcdir},$spec{basename}.'.lds');$self->add_to_cleanup($script);print "Generating script '$script'\n" if!$self->{quiet};my$SCRIPT=IO::File->new(">$script")or die("Could not create script '$script': $!");print$SCRIPT ('SEARCH_DIR(' .$_ .")\n")for @{delete$spec{libpath}|| []};if ($spec{startup}&& @{$spec{startup}}){print$SCRIPT 'STARTUP(' .shift(@{$spec{startup}}).")\n";unshift @{$spec{objects}},@{delete$spec{startup}|| []}}print$SCRIPT 'INPUT(' .join(',',@{delete$spec{objects}|| []}).")\n";print$SCRIPT 'INPUT(' .join(' ',(delete$spec{libperl}|| ''),@{delete$spec{perllibs}|| []},).")\n";unshift @{$spec{other_ldflags}},'"' .$script .'"';return%spec}1;
EXTUTILS_CBUILDER_PLATFORM_WINDOWS_GCC
$fatpacked{"ExtUtils/CBuilder/Platform/Windows/MSVC.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_CBUILDER_PLATFORM_WINDOWS_MSVC';
package ExtUtils::CBuilder::Platform::Windows::MSVC;$ExtUtils::CBuilder::Platform::Windows::MSVC::VERSION='0.280226';use warnings;use strict;sub arg_exec_file {my ($self,$file)=@_;return "/OUT:$file"}sub format_compiler_cmd {my ($self,%spec)=@_;for my$path (@{$spec{includes}|| []},@{$spec{perlinc}|| []}){$path='-I' .$path}%spec=$self->write_compiler_script(%spec)if$spec{use_scripts};return [grep {defined && length}($spec{cc},'-nologo','-c',@{$spec{includes}},@{$spec{cflags}},@{$spec{optimize}},@{$spec{defines}},@{$spec{perlinc}},"-Fo$spec{output}",$spec{source},)]}sub write_compiler_script {my ($self,%spec)=@_;my$script=File::Spec->catfile($spec{srcdir},$spec{basename}.'.ccs');$self->add_to_cleanup($script);print "Generating script '$script'\n" if!$self->{quiet};my$SCRIPT=IO::File->new(">$script")or die("Could not create script '$script': $!");print$SCRIPT join("\n",map {ref $_ ? @{$_}: $_}grep defined,delete(@spec{qw(includes cflags optimize defines perlinc) }));push @{$spec{includes}},'@"' .$script .'"';return%spec}sub format_linker_cmd {my ($self,%spec)=@_;my$cf=$self->{config};for my$path (@{$spec{libpath}}){$path="-libpath:$path"}my$output=$spec{output};my$manifest=$spec{manifest};$spec{def_file}&&= '-def:' .$spec{def_file};$spec{output}&&= '-out:' .$spec{output};$spec{manifest}&&= '-manifest ' .$spec{manifest};$spec{implib}&&= '-implib:' .$spec{implib};$spec{map_file}&&= '-map:' .$spec{map_file};%spec=$self->write_linker_script(%spec)if$spec{use_scripts};my@cmds;push@cmds,[grep {defined && length}($spec{ld},@{$spec{lddlflags}},@{$spec{libpath}},@{$spec{other_ldflags}},@{$spec{startup}},@{$spec{objects}},$spec{map_file},$spec{libperl},@{$spec{perllibs}},$spec{def_file},$spec{implib},$spec{output},)];push@cmds,['if','exist',$manifest,'mt','-nologo',$spec{manifest},'-outputresource:' ."$output;2" ];return@cmds}sub write_linker_script {my ($self,%spec)=@_;my$script=File::Spec->catfile($spec{srcdir},$spec{basename}.'.lds');$self->add_to_cleanup($script);print "Generating script '$script'\n" if!$self->{quiet};my$SCRIPT=IO::File->new(">$script")or die("Could not create script '$script': $!");print$SCRIPT join("\n",map {ref $_ ? @{$_}: $_}grep defined,delete(@spec{qw(lddlflags libpath other_ldflags startup objects libperl perllibs def_file implib map_file) }));push @{$spec{lddlflags}},'@"' .$script .'"';return%spec}1;
EXTUTILS_CBUILDER_PLATFORM_WINDOWS_MSVC
$fatpacked{"ExtUtils/CBuilder/Platform/aix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_CBUILDER_PLATFORM_AIX';
package ExtUtils::CBuilder::Platform::aix;$ExtUtils::CBuilder::Platform::aix::VERSION='0.280226';use warnings;use strict;use ExtUtils::CBuilder::Platform::Unix;use File::Spec;use vars qw(@ISA);@ISA=qw(ExtUtils::CBuilder::Platform::Unix);sub need_prelink {1}sub link {my ($self,%args)=@_;my$cf=$self->{config};(my$baseext=$args{module_name})=~ s/.*:://;my$perl_inc=$self->perl_inc();local$cf->{lddlflags}=$cf->{lddlflags};for ($cf->{lddlflags}){s/\Q$(BASEEXT)\E/$baseext/;s/\Q$(PERL_INC)\E/$perl_inc/}return$self->SUPER::link(%args)}1;
EXTUTILS_CBUILDER_PLATFORM_AIX
$fatpacked{"ExtUtils/CBuilder/Platform/android.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_CBUILDER_PLATFORM_ANDROID';
package ExtUtils::CBuilder::Platform::android;$ExtUtils::CBuilder::Platform::android::VERSION='0.280226';use warnings;use strict;use File::Spec;use ExtUtils::CBuilder::Platform::Unix;use Config;use vars qw(@ISA);@ISA=qw(ExtUtils::CBuilder::Platform::Unix);sub link {my ($self,%args)=@_;if ($self->{config}{useshrplib}eq 'true'){$args{extra_linker_flags}=[$self->split_like_shell($args{extra_linker_flags}),'-L' .$self->perl_inc(),'-lperl',$self->split_like_shell($Config{perllibs}),]}my($so_file,@so_tmps)=$self->SUPER::link(%args);$so_file=File::Spec->rel2abs($so_file);return wantarray ? ($so_file,@so_tmps): $so_file}1;
EXTUTILS_CBUILDER_PLATFORM_ANDROID
$fatpacked{"ExtUtils/CBuilder/Platform/cygwin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_CBUILDER_PLATFORM_CYGWIN';
package ExtUtils::CBuilder::Platform::cygwin;$ExtUtils::CBuilder::Platform::cygwin::VERSION='0.280226';use warnings;use strict;use File::Spec;use ExtUtils::CBuilder::Platform::Unix;use vars qw(@ISA);@ISA=qw(ExtUtils::CBuilder::Platform::Unix);sub link_executable {my$self=shift;return$self->SUPER::link_executable(@_)}sub link {my ($self,%args)=@_;my$lib=$self->{config}{useshrplib}? 'libperl.dll.a' : 'libperl.a';$args{extra_linker_flags}=[File::Spec->catfile($self->perl_inc(),$lib),$self->split_like_shell($args{extra_linker_flags})];return$self->SUPER::link(%args)}1;
EXTUTILS_CBUILDER_PLATFORM_CYGWIN
$fatpacked{"ExtUtils/CBuilder/Platform/darwin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_CBUILDER_PLATFORM_DARWIN';
package ExtUtils::CBuilder::Platform::darwin;$ExtUtils::CBuilder::Platform::darwin::VERSION='0.280226';use warnings;use strict;use ExtUtils::CBuilder::Platform::Unix;use vars qw(@ISA);@ISA=qw(ExtUtils::CBuilder::Platform::Unix);sub compile {my$self=shift;my$cf=$self->{config};local$cf->{ccflags}=$cf->{ccflags};$cf->{ccflags}=~ s/-flat_namespace//;$self->SUPER::compile(@_)}1;
EXTUTILS_CBUILDER_PLATFORM_DARWIN
$fatpacked{"ExtUtils/CBuilder/Platform/dec_osf.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_CBUILDER_PLATFORM_DEC_OSF';
package ExtUtils::CBuilder::Platform::dec_osf;$ExtUtils::CBuilder::Platform::dec_osf::VERSION='0.280226';use warnings;use strict;use ExtUtils::CBuilder::Platform::Unix;use File::Spec;use vars qw(@ISA);@ISA=qw(ExtUtils::CBuilder::Platform::Unix);sub link_executable {my$self=shift;local$self->{config}{ld}=$self->{config}{cc};return$self->SUPER::link_executable(@_)}1;
EXTUTILS_CBUILDER_PLATFORM_DEC_OSF
$fatpacked{"ExtUtils/CBuilder/Platform/os2.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_CBUILDER_PLATFORM_OS2';
package ExtUtils::CBuilder::Platform::os2;$ExtUtils::CBuilder::Platform::os2::VERSION='0.280226';use warnings;use strict;use ExtUtils::CBuilder::Platform::Unix;use vars qw(@ISA);@ISA=qw(ExtUtils::CBuilder::Platform::Unix);sub need_prelink {1}sub prelink {my$self=shift;my%args=@_;my@res=$self->SUPER::prelink(%args);die "Unexpected number of DEF files" unless@res==1;die "Can't find DEF file in the output" unless$res[0]=~ m,^(.*)\.def$,si;my$libname="$1$self->{config}{lib_ext}";$self->do_system('emximp','-o',$libname,$res[0])or die "emxexp: res=$?";return (@res,$libname)}sub _do_link {my$self=shift;my ($how,%args)=@_;if ($how eq 'lib_file' and (defined$args{module_name}and length$args{module_name})){my$objs=((ref$args{objects})? $args{objects}: [$args{objects}]);my$near_obj=$self->lib_file(@$objs);my$exp_dir=($near_obj =~ m,(.*)[/\\],s ? "$1/" : '');$args{dl_file}=$1 if$near_obj =~ m,(.*)\.,s;push @$objs,$self->perl_inc()."/libperl$self->{config}{lib_ext}";$args{objects}=$objs}local$self->{config}{shrpenv}='';return$self->SUPER::_do_link($how,%args)}sub extra_link_args_after_prelink {my ($self,%args)=@_;my@DEF=grep /\.def$/i,@{$args{prelink_res}};die "More than one .def files created by 'prelink' stage" if@DEF > 1;die "No .def file created by 'prelink' stage" unless@DEF or not @{$args{prelink_res}};my@after_libs=($OS2::is_aout ? (): $self->perl_inc()."/libperl_override$self->{config}{lib_ext}");(@after_libs,@DEF)}sub link_executable {my$self=shift;local$self->{config}{ldflags}=$self->{config}{ldflags};$self->{config}{ldflags}=~ s/(?<!\S)-Zexe(?!\S)//;return$self->SUPER::link_executable(@_)}1;
EXTUTILS_CBUILDER_PLATFORM_OS2
$fatpacked{"ExtUtils/Command.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_COMMAND';
package ExtUtils::Command;use 5.00503;use strict;require Exporter;use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);@ISA=qw(Exporter);@EXPORT=qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod dos2unix);$VERSION='7.30';$VERSION=eval$VERSION;my$Is_VMS=$^O eq 'VMS';my$Is_VMS_mode=$Is_VMS;my$Is_VMS_noefs=$Is_VMS;my$Is_Win32=$^O eq 'MSWin32';if($Is_VMS){my$vms_unix_rpt;my$vms_efs;my$vms_case;if (eval {local$SIG{__DIE__};local@INC=@INC;pop@INC if$INC[-1]eq '.';require VMS::Feature}){$vms_unix_rpt=VMS::Feature::current("filename_unix_report");$vms_efs=VMS::Feature::current("efs_charset");$vms_case=VMS::Feature::current("efs_case_preserve")}else {my$unix_rpt=$ENV{'DECC$FILENAME_UNIX_REPORT'}|| '';my$efs_charset=$ENV{'DECC$EFS_CHARSET'}|| '';my$efs_case=$ENV{'DECC$EFS_CASE_PRESERVE'}|| '';$vms_unix_rpt=$unix_rpt =~ /^[ET1]/i;$vms_efs=$efs_charset =~ /^[ET1]/i;$vms_case=$efs_case =~ /^[ET1]/i}$Is_VMS_mode=0 if$vms_unix_rpt;$Is_VMS_noefs=0 if ($vms_efs)}my$wild_regex=$Is_VMS ? '*%' : '*?';sub expand_wildcards {@ARGV=map(/[$wild_regex]/o ? glob($_): $_,@ARGV)}sub cat () {expand_wildcards();print while (<>)}sub eqtime {my ($src,$dst)=@ARGV;local@ARGV=($dst);touch();utime((stat($src))[8,9],$dst)}sub rm_rf {expand_wildcards();require File::Path;File::Path::rmtree([grep -e $_,@ARGV],0,0)}sub rm_f {expand_wildcards();for my$file (@ARGV){next unless -f $file;next if _unlink($file);chmod(0777,$file);next if _unlink($file);require Carp;Carp::carp("Cannot delete $file: $!")}}sub _unlink {my$files_unlinked=0;for my$file (@_){my$delete_count=0;$delete_count++ while unlink$file;$files_unlinked++ if$delete_count}return$files_unlinked}sub touch {my$t=time;expand_wildcards();for my$file (@ARGV){open(FILE,">>$file")|| die "Cannot write $file:$!";close(FILE);utime($t,$t,$file)}}sub mv {expand_wildcards();my@src=@ARGV;my$dst=pop@src;if (@src > 1 &&!-d $dst){require Carp;Carp::croak("Too many arguments")}require File::Copy;my$nok=0;for my$src (@src){$nok ||=!File::Copy::move($src,$dst)}return!$nok}sub cp {expand_wildcards();my@src=@ARGV;my$dst=pop@src;if (@src > 1 &&!-d $dst){require Carp;Carp::croak("Too many arguments")}require File::Copy;my$nok=0;for my$src (@src){$nok ||=!File::Copy::copy($src,$dst);utime(time,time,$dst)if$Is_Win32}return$nok}sub chmod {local@ARGV=@ARGV;my$mode=shift(@ARGV);expand_wildcards();if($Is_VMS_mode && $Is_VMS_noefs){require File::Spec;for my$idx (0..$#ARGV){my$path=$ARGV[$idx];next unless -d $path;my@dirs=File::Spec->splitdir($path);$dirs[-1].= '.dir';$path=File::Spec->catfile(@dirs);$ARGV[$idx]=$path}}chmod(oct$mode,@ARGV)|| die "Cannot chmod ".join(' ',$mode,@ARGV).":$!"}sub mkpath {expand_wildcards();require File::Path;File::Path::mkpath([@ARGV],0,0777)}sub test_f {exit(-f $ARGV[0]? 0 : 1)}sub test_d {exit(-d $ARGV[0]? 0 : 1)}sub dos2unix {require File::Find;File::Find::find(sub {return if -d;return unless -w _;return unless -r _;return if -B _;local $\;my$orig=$_;my$temp='.dos2unix_tmp';open ORIG,$_ or do {warn "dos2unix can't open $_: $!";return};open TEMP,">$temp" or do {warn "dos2unix can't create .dos2unix_tmp: $!";return};binmode ORIG;binmode TEMP;while (my$line=<ORIG>){$line =~ s/\015\012/\012/g;print TEMP$line}close ORIG;close TEMP;rename$temp,$orig},@ARGV)}
EXTUTILS_COMMAND
$fatpacked{"ExtUtils/Command/MM.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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 test_s cp_nonempty);our$VERSION='7.30';$VERSION=eval$VERSION;my$Is_VMS=$^O eq 'VMS';sub mtime {no warnings 'redefine';local $@;*mtime=(eval {require Time::HiRes}&& defined&Time::HiRes::stat)? sub {(Time::HiRes::stat($_[0]))[9]}: sub {(stat($_[0]))[9]};goto&mtime}sub test_harness {require Test::Harness;require File::Spec;$Test::Harness::verbose=shift;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)}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 0}}require Getopt::Long;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','utf8|u');delete$options{utf8}unless$Pod::Man::VERSION >= 2.17;return 0 unless@ARGV;if ($options{official}&&!defined$options{center}){$options{center}=q[Perl Programmer's Reference Guide]}delete$options{lax};my$count=scalar@ARGV / 2;my$plural=$count==1 ? 'document' : 'documents';print "Manifying $count pod $plural\n";do {{my ($pod,$man)=splice(@ARGV,0,2);next if ((-e $man)&& (mtime($man)> mtime($pod))&& (mtime($man)> mtime("Makefile")));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}sub warn_if_old_packlist {my$packlist=$ARGV[0];return unless -f $packlist;print <<"PACKLIST_WARNING"}sub perllocal_install {my($type,$name)=splice(@ARGV,0,2);my@mod_info=$Is_VMS ? split /\|/,<STDIN> : @ARGV;my$pod;my$time=gmtime($ENV{SOURCE_DATE_EPOCH}|| time);$pod=sprintf <<'POD',scalar($time),$type,$name,$name;do {my($key,$val)=splice(@mod_info,0,2);$pod .= <<POD}while(@mod_info);$pod .= "=back\n\n";$pod =~ s/^ //mg;print$pod;return 1}sub uninstall {my($packlist)=shift@ARGV;require ExtUtils::Install;print <<'WARNING';ExtUtils::Install::uninstall($packlist,1,1);print <<'WARNING'}sub test_s {exit(-s $ARGV[0]? 0 : 1)}sub cp_nonempty {my@args=@ARGV;return 0 unless -s $args[0];require ExtUtils::Command;{local@ARGV=@args[0,1];ExtUtils::Command::cp(@ARGV)}{local@ARGV=@args[2,1];ExtUtils::Command::chmod(@ARGV)}}1;
WARNING: I have found an old package in
$packlist.
Please make sure the two installations are not conflicting
PACKLIST_WARNING
=head2 %s: C<%s> L<%s|%s>
=over 4
POD
=item *
C<$key: $val>
POD
Uninstall is unsafe and deprecated, the uninstallation was not performed.
We will show what would have been done.
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
EXTUTILS_COMMAND_MM
$fatpacked{"ExtUtils/Install.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_INSTALL';
package ExtUtils::Install;use strict;use vars qw(@ISA @EXPORT $VERSION $MUST_REBOOT %Config);use AutoSplit;use Carp ();use Config qw(%Config);use Cwd qw(cwd);use Exporter;use ExtUtils::Packlist;use File::Basename qw(dirname);use File::Compare qw(compare);use File::Copy;use File::Find qw(find);use File::Path;use File::Spec;@ISA=('Exporter');@EXPORT=('install','uninstall','pm_to_blib','install_default');$VERSION='2.06';$VERSION=eval$VERSION;my$Is_VMS=$^O eq 'VMS';my$Is_MacPerl=$^O eq 'MacOS';my$Is_Win32=$^O eq 'MSWin32';my$Is_cygwin=$^O eq 'cygwin';my$CanMoveAtBoot=($Is_Win32 || $Is_cygwin);my$Inc_uninstall_warn_handler;my$INSTALL_ROOT=$ENV{PERL_INSTALL_ROOT};my$INSTALL_QUIET=$ENV{PERL_INSTALL_QUIET};my$Curdir=File::Spec->curdir;my$Updir=File::Spec->updir;sub _estr(@) {return join "\n",'!' x 72,@_,'!' x 72,''}{my%warned;sub _warnonce(@) {my$first=shift;my$msg=_estr "WARNING: $first",@_;warn$msg unless$warned{$msg}++}}sub _choke(@) {my$first=shift;my$msg=_estr "ERROR: $first",@_;Carp::croak($msg)}sub _chmod($$;$) {my ($mode,$item,$verbose)=@_;$verbose ||= 0;if (chmod$mode,$item){printf "chmod(0%o, %s)\n",$mode,$item if$verbose > 1}else {my$err="$!";_warnonce sprintf "WARNING: Failed chmod(0%o, %s): %s\n",$mode,$item,$err if -e $item}}{my$Has_Win32API_File;sub _move_file_at_boot {my ($file,$target,$moan)=@_;Carp::confess("Panic: Can't _move_file_at_boot on this platform!")unless$CanMoveAtBoot;my$descr=ref$target ? "'$file' for deletion" : "'$file' for installation as '$target'";$Has_Win32API_File=($Is_Win32 || $Is_cygwin)? (eval {require Win32API::File;1}|| 0): 0 unless defined$Has_Win32API_File;if (!$Has_Win32API_File){my@msg=("Cannot schedule $descr at reboot.","Try installing Win32API::File to allow operations on locked files","to be scheduled during reboot. Or try to perform the operation by","hand yourself. (You may need to close other perl processes first)");if ($moan){_warnonce(@msg)}else {_choke(@msg)}return 0}my$opts=Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT();$opts=$opts | Win32API::File::MOVEFILE_REPLACE_EXISTING()unless ref$target;_chmod(0666,$file);_chmod(0666,$target)unless ref$target;if (Win32API::File::MoveFileEx($file,$target,$opts)){$MUST_REBOOT ||= ref$target ? 0 : 1;return 1}else {my@msg=("MoveFileEx $descr at reboot failed: $^E","You may try to perform the operation by hand yourself. ","(You may need to close other perl processes first).",);if ($moan){_warnonce(@msg)}else {_choke(@msg)}}return 0}}sub _unlink_or_rename {my ($file,$tryhard,$installing)=@_;if ($^O =~ /^(dos|os2|MSWin32|VMS)$/){_chmod(0666,$file)}my$unlink_count=0;while (unlink$file){$unlink_count++}return$file if$unlink_count > 0;my$error="$!";_choke("Cannot unlink '$file': $!")unless$CanMoveAtBoot && $tryhard;my$tmp="AAA";++$tmp while -e "$file.$tmp";$tmp="$file.$tmp";warn "WARNING: Unable to unlink '$file': $error\n","Going to try to rename it to '$tmp'.\n";if (rename$file,$tmp){warn "Rename successful. Scheduling '$tmp'\nfor deletion at reboot.\n";_move_file_at_boot($tmp,[],$installing);return$file}elsif ($installing){_warnonce("Rename failed: $!. Scheduling '$tmp'\nfor"." installation as '$file' at reboot.\n");_move_file_at_boot($tmp,$file);return$tmp}else {_choke("Rename failed:$!","Cannot proceed.")}}sub _get_install_skip {my ($skip,$verbose)=@_;if ($ENV{EU_INSTALL_IGNORE_SKIP}){print "EU_INSTALL_IGNORE_SKIP is set, ignore skipfile settings\n" if$verbose>2;return []}if (!defined$skip){print "Looking for install skip list\n" if$verbose>2;for my$file ('INSTALL.SKIP',$ENV{EU_INSTALL_SITE_SKIPFILE}){next unless$file;print "\tChecking for $file\n" if$verbose>2;if (-e $file){$skip=$file;last}}}if ($skip &&!ref$skip){print "Reading skip patterns from '$skip'.\n" if$verbose;if (open my$fh,$skip){my@patterns;while (<$fh>){chomp;next if /^\s*(?:#|$)/;print "\tSkip pattern: $_\n" if$verbose>3;push@patterns,$_}$skip=\@patterns}else {warn "Can't read skip file:'$skip':$!\n";$skip=[]}}elsif (UNIVERSAL::isa($skip,'ARRAY')){print "Using array for skip list\n" if$verbose>2}elsif ($verbose){print "No skip list found.\n" if$verbose>1;$skip=[]}warn "Got @{[0+@$skip]} skip patterns.\n" if$verbose>3;return$skip}{my$has_posix;sub _have_write_access {my$dir=shift;unless (defined$has_posix){$has_posix=(!$Is_cygwin &&!$Is_Win32 && eval 'local $^W; require POSIX; 1')|| 0}if ($has_posix){return POSIX::access($dir,POSIX::W_OK())}else {return -w $dir}}}sub _can_write_dir {my$dir=shift;return unless defined$dir and length$dir;my ($vol,$dirs,$file)=File::Spec->splitpath($dir,1);my@dirs=File::Spec->splitdir($dirs);unshift@dirs,File::Spec->curdir unless File::Spec->file_name_is_absolute($dir);my$path='';my@make;while (@dirs){if ($Is_VMS){$dir=File::Spec->catdir($vol,@dirs)}else {$dir=File::Spec->catdir(@dirs);$dir=File::Spec->catpath($vol,$dir,'')if defined$vol and length$vol}next if ($dir eq $path);if (!-e $dir){unshift@make,$dir;next}if (_have_write_access($dir)){return 1,$dir,@make}else {return 0,$dir,@make}}continue {pop@dirs}return 0}sub _mkpath {my ($dir,$show,$mode,$verbose,$dry_run)=@_;if ($verbose && $verbose > 1 &&!-d $dir){$show=1;printf "mkpath(%s,%d,%#o)\n",$dir,$show,$mode}if (!$dry_run){if (!eval {File::Path::mkpath($dir,$show,$mode);1}){_choke("Can't create '$dir'","$@")}}my ($can,$root,@make)=_can_write_dir($dir);if (!$can){my@msg=("Can't create '$dir'",$root ? "Do not have write permissions on '$root'" : "Unknown Error");if ($dry_run){_warnonce@msg}else {_choke@msg}}elsif ($show and $dry_run){print "$_\n" for@make}}sub _copy {my ($from,$to,$verbose,$dry_run)=@_;if ($verbose && $verbose>1){printf "copy(%s,%s)\n",$from,$to}if (!$dry_run){File::Copy::copy($from,$to)or Carp::croak(_estr "ERROR: Cannot copy '$from' to '$to': $!")}}sub _chdir {my ($dir)=@_;my$ret;if (defined wantarray){$ret=cwd}chdir$dir or _choke("Couldn't chdir to '$dir': $!");return$ret}sub install {my($from_to,$verbose,$dry_run,$uninstall_shadows,$skip,$always_copy,$result)=@_;if (@_==1 and eval {1+@$from_to}){my%opts=@$from_to;$from_to=$opts{from_to}or Carp::confess("from_to is a mandatory parameter");$verbose=$opts{verbose};$dry_run=$opts{dry_run};$uninstall_shadows=$opts{uninstall_shadows};$skip=$opts{skip};$always_copy=$opts{always_copy};$result=$opts{result}}$result ||= {};$verbose ||= 0;$dry_run ||= 0;$skip=_get_install_skip($skip,$verbose);$always_copy=$ENV{EU_INSTALL_ALWAYS_COPY}|| $ENV{EU_ALWAYS_COPY}|| 0 unless defined$always_copy;my(%from_to)=%$from_to;my(%pack,$dir,%warned);my($packlist)=ExtUtils::Packlist->new();local(*DIR);for (qw/read write/){$pack{$_}=$from_to{$_};delete$from_to{$_}}my$tmpfile=install_rooted_file($pack{"read"});$packlist->read($tmpfile)if (-f $tmpfile);my$cwd=cwd();my@found_files;my%check_dirs;MOD_INSTALL: foreach my$source (sort keys%from_to){my$targetroot=install_rooted_dir($from_to{$source});my$blib_lib=File::Spec->catdir('blib','lib');my$blib_arch=File::Spec->catdir('blib','arch');if ($source eq $blib_lib and exists$from_to{$blib_arch}and directory_not_empty($blib_arch)){$targetroot=install_rooted_dir($from_to{$blib_arch});print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n"}next unless -d $source;_chdir($source);my$current_directory=$Is_MacPerl ? $Curdir : '.';find(sub {my ($mode,$size,$atime,$mtime)=(stat)[2,7,8,9];return if!-f _;my$origfile=$_;return if$origfile eq ".exists";my$targetdir=File::Spec->catdir($targetroot,$File::Find::dir);my$targetfile=File::Spec->catfile($targetdir,$origfile);my$sourcedir=File::Spec->catdir($source,$File::Find::dir);my$sourcefile=File::Spec->catfile($sourcedir,$origfile);for my$pat (@$skip){if ($sourcefile=~/$pat/){print "Skipping $targetfile (filtered)\n" if$verbose>1;$result->{install_filtered}{$sourcefile}=$pat;return}}my$save_cwd=_chdir($cwd);my$diff=0;if ($always_copy or!-f $targetfile or -s $targetfile!=$size){$diff++}else {$diff=compare($sourcefile,$targetfile)}$check_dirs{$targetdir}++ unless -w $targetfile;push@found_files,[$diff,$File::Find::dir,$origfile,$mode,$size,$atime,$mtime,$targetdir,$targetfile,$sourcedir,$sourcefile,];_chdir($save_cwd)},$current_directory);_chdir($cwd)}for my$targetdir (sort keys%check_dirs){_mkpath($targetdir,0,0755,$verbose,$dry_run)}for my$found (@found_files){my ($diff,$ffd,$origfile,$mode,$size,$atime,$mtime,$targetdir,$targetfile,$sourcedir,$sourcefile)=@$found;my$realtarget=$targetfile;if ($diff){eval {if (-f $targetfile){print "_unlink_or_rename($targetfile)\n" if$verbose>1;$targetfile=_unlink_or_rename($targetfile,'tryhard','install')unless$dry_run}elsif (!-d $targetdir){_mkpath($targetdir,0,0755,$verbose,$dry_run)}print "Installing $targetfile\n";_copy($sourcefile,$targetfile,$verbose,$dry_run,);print "utime($atime,$mtime,$targetfile)\n" if$verbose>1;utime($atime,$mtime + $Is_VMS,$targetfile)unless$dry_run>1;$mode=0444 | ($mode & 0111 ? 0111 : 0);$mode=$mode | 0222 if$realtarget ne $targetfile;_chmod($mode,$targetfile,$verbose);$result->{install}{$targetfile}=$sourcefile;1}or do {$result->{install_fail}{$targetfile}=$sourcefile;die $@}}else {$result->{install_unchanged}{$targetfile}=$sourcefile;print "Skipping $targetfile (unchanged)\n" if$verbose}if ($uninstall_shadows){inc_uninstall($sourcefile,$ffd,$verbose,$dry_run,$realtarget ne $targetfile ? $realtarget : "",$result)}$packlist->{$targetfile}++}if ($pack{'write'}){$dir=install_rooted_dir(dirname($pack{'write'}));_mkpath($dir,0,0755,$verbose,$dry_run);print "Writing $pack{'write'}\n" if$verbose;$packlist->write(install_rooted_file($pack{'write'}))unless$dry_run}_do_cleanup($verbose);return$result}sub _do_cleanup {my ($verbose)=@_;if ($MUST_REBOOT){die _estr "Operation not completed! ","You must reboot to complete the installation.","Sorry."}elsif (defined$MUST_REBOOT & $verbose){warn _estr "Installation will be completed at the next reboot.\n","However it is not necessary to reboot immediately.\n"}}sub install_rooted_file {if (defined$INSTALL_ROOT){File::Spec->catfile($INSTALL_ROOT,$_[0])}else {$_[0]}}sub install_rooted_dir {if (defined$INSTALL_ROOT){File::Spec->catdir($INSTALL_ROOT,$_[0])}else {$_[0]}}sub forceunlink {my ($file,$tryhard)=@_;_unlink_or_rename($file,$tryhard,not("installing"))}sub directory_not_empty ($) {my($dir)=@_;my$files=0;find(sub {return if $_ eq ".exists";if (-f){$File::Find::prune++;$files=1}},$dir);return$files}sub install_default {@_ < 2 or Carp::croak("install_default should be called with 0 or 1 argument");my$FULLEXT=@_ ? shift : $ARGV[0];defined$FULLEXT or die "Do not know to where to write install log";my$INST_LIB=File::Spec->catdir($Curdir,"blib","lib");my$INST_ARCHLIB=File::Spec->catdir($Curdir,"blib","arch");my$INST_BIN=File::Spec->catdir($Curdir,'blib','bin');my$INST_SCRIPT=File::Spec->catdir($Curdir,'blib','script');my$INST_MAN1DIR=File::Spec->catdir($Curdir,'blib','man1');my$INST_MAN3DIR=File::Spec->catdir($Curdir,'blib','man3');my@INST_HTML;if($Config{installhtmldir}){my$INST_HTMLDIR=File::Spec->catdir($Curdir,'blib','html');@INST_HTML=($INST_HTMLDIR=>$Config{installhtmldir})}install({read=>"$Config{sitearchexp}/auto/$FULLEXT/.packlist",write=>"$Config{installsitearch}/auto/$FULLEXT/.packlist",$INST_LIB=>(directory_not_empty($INST_ARCHLIB))? $Config{installsitearch}: $Config{installsitelib},$INST_ARCHLIB=>$Config{installsitearch},$INST_BIN=>$Config{installbin},$INST_SCRIPT=>$Config{installscript},$INST_MAN1DIR=>$Config{installman1dir},$INST_MAN3DIR=>$Config{installman3dir},@INST_HTML,},1,0,0)}sub uninstall {my($fil,$verbose,$dry_run)=@_;$verbose ||= 0;$dry_run ||= 0;die _estr "ERROR: no packlist file found: '$fil'" unless -f $fil;my ($packlist)=ExtUtils::Packlist->new($fil);for (sort(keys(%$packlist))){chomp;print "unlink $_\n" if$verbose;forceunlink($_,'tryhard')unless$dry_run}print "unlink $fil\n" if$verbose;forceunlink($fil,'tryhard')unless$dry_run;_do_cleanup($verbose)}sub inc_uninstall {my($filepath,$libdir,$verbose,$dry_run,$ignore,$results)=@_;my($dir);$ignore||="";my$file=(File::Spec->splitpath($filepath))[2];my%seen_dir=();my@PERL_ENV_LIB=split$Config{path_sep},defined$ENV{'PERL5LIB'}? $ENV{'PERL5LIB'}: $ENV{'PERLLIB'}|| '';my@dirs=(@PERL_ENV_LIB,@INC,@Config{qw(archlibexp privlibexp sitearchexp sitelibexp)});my$seen_ours;for$dir (@dirs){my$canonpath=$Is_VMS ? $dir : File::Spec->canonpath($dir);next if$canonpath eq $Curdir;next if$seen_dir{$canonpath}++;my$targetfile=File::Spec->catfile($canonpath,$libdir,$file);next unless -f $targetfile;my$diff=0;if (-f $targetfile && -s _==-s $filepath){$diff=compare($filepath,$targetfile)}else {$diff++}print "#$file and $targetfile differ\n" if$diff && $verbose > 1;if (!$diff or $targetfile eq $ignore){$seen_ours=1;next}if ($dry_run){$results->{uninstall}{$targetfile}=$filepath;if ($verbose){$Inc_uninstall_warn_handler ||= ExtUtils::Install::Warn->new();$libdir =~ s|^\./||s ;$Inc_uninstall_warn_handler->add(File::Spec->catfile($libdir,$file),$targetfile)}}else {print "Unlinking $targetfile (shadowing?)\n" if$verbose;eval {die "Fake die for testing" if$ExtUtils::Install::Testing and ucase(File::Spec->canonpath($ExtUtils::Install::Testing))eq ucase($targetfile);forceunlink($targetfile,'tryhard');$results->{uninstall}{$targetfile}=$filepath;1}or do {$results->{fail_uninstall}{$targetfile}=$filepath;if ($seen_ours){warn "Failed to remove probably harmless shadow file '$targetfile'\n"}else {die "$@\n"}}}}}sub run_filter {my ($cmd,$src,$dest)=@_;local(*CMD,*SRC);open(CMD,"|$cmd >$dest")|| die "Cannot fork: $!";open(SRC,$src)|| die "Cannot open $src: $!";my$buf;my$sz=1024;while (my$len=sysread(SRC,$buf,$sz)){syswrite(CMD,$buf,$len)}close SRC;close CMD or die "Filter command '$cmd' failed for $src"}sub pm_to_blib {my($fromto,$autodir,$pm_filter)=@_;_mkpath($autodir,0,0755)if defined$autodir;while(my($from,$to)=each %$fromto){if(-f $to && -s $from==-s $to && -M $to < -M $from){print "Skip $to (unchanged)\n" unless$INSTALL_QUIET;next}my$need_filtering=defined$pm_filter && length$pm_filter && $from =~ /\.pm$/;if (!$need_filtering && 0==compare($from,$to)){print "Skip $to (unchanged)\n" unless$INSTALL_QUIET;next}if (-f $to){forceunlink($to)}else {_mkpath(dirname($to),0,0755)}if ($need_filtering){run_filter($pm_filter,$from,$to);print "$pm_filter <$from >$to\n"}else {_copy($from,$to);print "cp $from $to\n" unless$INSTALL_QUIET}my($mode,$atime,$mtime)=(stat$from)[2,8,9];utime($atime,$mtime+$Is_VMS,$to);_chmod(0444 | ($mode & 0111 ? 0111 : 0),$to);next unless$from =~ /\.pm$/;_autosplit($to,$autodir)if defined$autodir}}sub _autosplit {my$retval=autosplit(@_);close*AutoSplit::IN if defined*AutoSplit::IN{IO};return$retval}package ExtUtils::Install::Warn;sub new {bless {},shift}sub add {my($self,$file,$targetfile)=@_;push @{$self->{$file}},$targetfile}sub DESTROY {unless(defined$INSTALL_ROOT){my$self=shift;my($file,$i,$plural);for$file (sort keys %$self){$plural=@{$self->{$file}}> 1 ? "s" : "";print "## Differing version$plural of $file found. You might like to\n";for (0..$#{$self->{$file}}){print "rm ",$self->{$file}[$_],"\n";$i++}}$plural=$i>1 ? "all those files" : "this file";my$inst=(_invokant()eq 'ExtUtils::MakeMaker')? ($Config::Config{make}|| 'make').' install' .($Is_VMS ? '/MACRO="UNINST"=1' : ' UNINST=1'): './Build install uninst=1';print "## Running '$inst' will unlink $plural for you.\n"}}sub _invokant {my@stack;my$frame=0;while (my$file=(caller($frame++))[1]){push@stack,(File::Spec->splitpath($file))[2]}my$builder;my$top=pop@stack;if ($top =~ /^Build/i || exists($INC{'Module/Build.pm'})){$builder='Module::Build'}else {$builder='ExtUtils::MakeMaker'}return$builder}1;
EXTUTILS_INSTALL
$fatpacked{"ExtUtils/Installed.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_INSTALLED';
package ExtUtils::Installed;use 5.00503;use strict;use Carp qw();use ExtUtils::Packlist;use ExtUtils::MakeMaker;use Config;use File::Find;use File::Basename;use File::Spec;my$Is_VMS=$^O eq 'VMS';my$DOSISH=($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);require VMS::Filespec if$Is_VMS;use vars qw($VERSION);$VERSION='2.06';$VERSION=eval$VERSION;sub _is_prefix {my ($self,$path,$prefix)=@_;return unless defined$prefix && defined$path;if($Is_VMS){$prefix=VMS::Filespec::unixify($prefix);$path=VMS::Filespec::unixify($path)}$prefix=File::Spec->canonpath($prefix);return 1 if substr($path,0,length($prefix))eq $prefix;if ($DOSISH){$path =~ s|\\|/|g;$prefix =~ s|\\|/|g;return 1 if$path =~ m{^\Q$prefix\E}i}return(0)}sub _is_doc {my ($self,$path)=@_;my$man1dir=$self->{':private:'}{Config}{man1direxp};my$man3dir=$self->{':private:'}{Config}{man3direxp};return(($man1dir && $self->_is_prefix($path,$man1dir))|| ($man3dir && $self->_is_prefix($path,$man3dir))? 1 : 0)}sub _is_type {my ($self,$path,$type)=@_;return 1 if$type eq "all";return($self->_is_doc($path))if$type eq "doc";my$conf=$self->{':private:'}{Config};if ($type eq "prog"){return($self->_is_prefix($path,$conf->{prefix}|| $conf->{prefixexp})&&!($self->_is_doc($path))? 1 : 0)}return(0)}sub _is_under {my ($self,$path,@under)=@_;$under[0]="" if (!@under);for my$dir (@under){return(1)if ($self->_is_prefix($path,$dir))}return(0)}sub _fix_dirs {my ($self,@dirs)=@_;if($Is_VMS){$_=VMS::Filespec::unixify($_)for@dirs}if ($DOSISH){s|\\|/|g for@dirs}return wantarray ? @dirs : $dirs[0]}sub _make_entry {my ($self,$module,$packlist_file,$modfile)=@_;my$data={module=>$module,packlist=>scalar(ExtUtils::Packlist->new($packlist_file)),packlist_file=>$packlist_file,};if (!$modfile){$data->{version}=$self->{':private:'}{Config}{version}}else {$data->{modfile}=$modfile;$data->{version}='';for my$dir (@{$self->{':private:'}{INC}}){my$p=File::Spec->catfile($dir,$modfile);if (-r $p){$module=_module_name($p,$module)if$Is_VMS;$data->{version}=MM->parse_version($p);$data->{version_from}=$p;$data->{packlist_valid}=exists$data->{packlist}{$p};last}}}$self->{$module}=$data}our$INSTALLED;sub new {my ($class)=shift(@_);$class=ref($class)|| $class;my%args=@_;return$INSTALLED if$INSTALLED and ($args{default_get}|| $args{default});my$self=bless {},$class;$INSTALLED=$self if$args{default_set}|| $args{default};if ($args{config_override}){eval {$self->{':private:'}{Config}={%{$args{config_override}}}}or Carp::croak("The 'config_override' parameter must be a hash reference.")}else {$self->{':private:'}{Config}=\%Config}for my$tuple ([inc_override=>INC=>[@INC ]],[extra_libs=>EXTRA=>[]]){my ($arg,$key,$val)=@$tuple;if ($args{$arg}){eval {$self->{':private:'}{$key}=[@{$args{$arg}}]}or Carp::croak("The '$arg' parameter must be an array reference.")}elsif ($val){$self->{':private:'}{$key}=$val}}{my%dupe;@{$self->{':private:'}{LIBDIRS}}=grep {$_ ne '.' ||!$args{skip_cwd}}grep {-e $_ &&!$dupe{$_}++}@{$self->{':private:'}{EXTRA}},@{$self->{':private:'}{INC}}}my@dirs=$self->_fix_dirs(@{$self->{':private:'}{LIBDIRS}});my$archlib=$self->_fix_dirs($self->{':private:'}{Config}{archlibexp});$self->_make_entry("Perl",File::Spec->catfile($archlib,'.packlist'));my$root;my$sub=sub {return if $_ ne ".packlist" || $File::Find::dir eq $archlib;my$module=$File::Find::name;my$found=$module =~ s!^.*?/auto/(.*)/.packlist!$1!s or do {return};my$modfile="$module.pm";$module =~ s!/!::!g;return if$self->{$module};$self->_make_entry($module,$File::Find::name,$modfile)};while (@dirs){$root=shift@dirs;next if!-d $root;find($sub,$root)}return$self}sub _module_name {my($file,$orig_module)=@_;my$module='';if (open PACKFH,$file){while (<PACKFH>){if (/package\s+(\S+)\s*;/){my$pack=$1;if (lc($pack)eq lc($orig_module)){$module=$pack;last}}}close PACKFH}print STDERR "Couldn't figure out the package name for $file\n" unless$module;return$module}sub modules {my ($self)=@_;$self=$self->new(default=>1)if!ref$self;return wantarray ? sort grep {not /^:private:$/}keys %$self : grep {not /^:private:$/}keys %$self}sub files {my ($self,$module,$type,@under)=@_;$self=$self->new(default=>1)if!ref$self;Carp::croak("$module is not installed")if (!exists($self->{$module}));$type="all" if (!defined($type));Carp::croak('type must be "all", "prog" or "doc"')if ($type ne "all" && $type ne "prog" && $type ne "doc");my (@files);for my$file (keys(%{$self->{$module}{packlist}})){push(@files,$file)if ($self->_is_type($file,$type)&& $self->_is_under($file,@under))}return(@files)}sub directories {my ($self,$module,$type,@under)=@_;$self=$self->new(default=>1)if!ref$self;my (%dirs);for my$file ($self->files($module,$type,@under)){$dirs{dirname($file)}++}return sort keys%dirs}sub directory_tree {my ($self,$module,$type,@under)=@_;$self=$self->new(default=>1)if!ref$self;my (%dirs);for my$dir ($self->directories($module,$type,@under)){$dirs{$dir}++;my ($last)=("");while ($last ne $dir){$last=$dir;$dir=dirname($dir);last if!$self->_is_under($dir,@under);$dirs{$dir}++}}return(sort(keys(%dirs)))}sub validate {my ($self,$module,$remove)=@_;$self=$self->new(default=>1)if!ref$self;Carp::croak("$module is not installed")if (!exists($self->{$module}));return($self->{$module}{packlist}->validate($remove))}sub packlist {my ($self,$module)=@_;$self=$self->new(default=>1)if!ref$self;Carp::croak("$module is not installed")if (!exists($self->{$module}));return($self->{$module}{packlist})}sub version {my ($self,$module)=@_;$self=$self->new(default=>1)if!ref$self;Carp::croak("$module is not installed")if (!exists($self->{$module}));return($self->{$module}{version})}sub debug_dump {my ($self,$module)=@_;$self=$self->new(default=>1)if!ref$self;local$self->{":private:"}{Config};require Data::Dumper;print Data::Dumper->new([$self])->Sortkeys(1)->Indent(1)->Dump()}1;
EXTUTILS_INSTALLED
$fatpacked{"ExtUtils/Liblist.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_LIBLIST';
package ExtUtils::Liblist;use strict;our$VERSION='7.30';$VERSION=eval$VERSION;use File::Spec;require ExtUtils::Liblist::Kid;our@ISA=qw(ExtUtils::Liblist::Kid File::Spec);sub ext {goto&ExtUtils::Liblist::Kid::ext}sub lsdir {shift;my$rex=qr/$_[1]/;opendir my$dir_fh,$_[0];my@out=grep /$rex/,readdir$dir_fh;closedir$dir_fh;return@out}
EXTUTILS_LIBLIST
$fatpacked{"ExtUtils/Liblist/Kid.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_LIBLIST_KID';
package ExtUtils::Liblist::Kid;use 5.006;use strict;use warnings;our$VERSION='7.30';$VERSION=eval$VERSION;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|android/ and $Config{perllibs}){$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};my (@searchpath);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();my ($found)=0;for my$thislib (split ' ',$potential_libs){my ($custom_name)='';if ($thislib =~ s/^(-[LR]|-Wl,-R|-Wl,-rpath,)//){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 =~ m!^-Wl,-[Rr]!)){if ($Config{'lddlflags'}=~ /-Wl,-[Rr]/){$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}if ($thislib =~ m!^-Wl,!){push(@extralibs,$thislib);push(@ldloadlibs,$thislib);next}if ($thislib =~ s/^-l(:)?//){$custom_name=$1 || ''}else {warn "Unrecognized argument in LIBS ignored: '$thislib'\n";next}my ($found_lib)=0;for my$thispth (@searchpath,@libpath){if ((@fullname=$self->lsdir($thispth,"^\Qlib$thislib.$so.\E[0-9]+"))|| (@fullname=$self->lsdir($thispth,"^\Qlib$thislib.\E[0-9]+\Q\.$so"))){$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"}$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")){}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 ($^O eq 'cygwin' && -f ($fullname="$thispth/$thislib.dll")){}elsif (-f ($fullname="$thispth/Slib$thislib$Config_libext")){}elsif ($^O eq 'dgux' && -l ($fullname="$thispth/lib$thislib$Config_libext")&& readlink($fullname)=~ /^elink:/s){}elsif ($custom_name && -f ($fullname="$thispth/$thislib")){}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++;my$is_dyna=($fullname !~ /\Q$Config_libext\E\z/);my$in_perl=($libs =~ /\B-l:?\Q${thislib}\E\b/s);my ($fullnamedir)=dirname($fullname);push@ld_run_path,$fullnamedir if$is_dyna &&!$in_perl &&!$ld_run_path_seen{$fullnamedir}++;unless ($in_perl || ($Config{'osname'}eq 'next' && ($thislib eq 'm' || $thislib eq 'ndbm'))){push(@extralibs,"-l$custom_name$thislib")}if (($Config{'dlsrc'}=~ /dl_next/ && $Config{'osvers'}lt '4_0')|| ($Config{'dlsrc'}=~ /dl_dld/)){push(@bsloadlibs,"$fullname")}else {if ($is_dyna){push(@ldloadlibs,"-l$custom_name$thislib")unless ($in_perl and $^O eq 'sunos')}else {push(@ldloadlibs,"-l$custom_name$thislib")}}last}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;return ("","","","",($give_libs ? []: ()))unless$potential_libs;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=('');my@libpath=_win32_default_search_paths($VC,$GC);my$pwd=cwd();my$search=1;my@lib_search_list=_win32_make_lib_search_list($potential_libs,$verbose);for (@lib_search_list){my$thislib=$_;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}unless ($search){s/^-l(.+)$/$1.lib/ unless$GC;s/^-L/-libpath:/ if$VC;push(@extralibs,$_);next}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}my@libs=sort keys%libs_seen;return ('','','','',($give_libs ? \@libs : ()))unless@extralibs;@extralibs=map {qq["$_"]}@extralibs;@libs=map {qq["$_"]}@libs;my$lib=join(' ',@extralibs);$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)=@_;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;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;my@libpath=Text::ParseWords::quotewords('\s+',0,$libpth);push@libpath,"$Config{installarchlib}/CORE";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;push@extensions,$Config{'lib_ext'}if$Config{'lib_ext'};push@extensions,'.dll.a' if grep {m!^\.a$!}@extensions;push@extensions,'.lib' unless grep {m!^\.lib$!}@extensions;return \@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'});if ($self->{PERL_SRC}){my ($locspec,$type);for 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' };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');warn "Potential libraries are '$potential_libs'\n" if$verbose;my (@dirs,@libs);for 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'}));for 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=VMS::Filespec::vmspath($dir)}else {$dir=$self->catdir($cwd,$dir)}}@dirs=grep {length($_)}@dirs;unshift(@dirs,'');LIB: foreach my$lib (@libs){if (exists$libmap{$lib}){next unless length$libmap{$lib};$lib=$libmap{$lib}}my (@variants,$cand);my ($ctype)='';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;for my$variant (@variants){my ($fullname,$name);for 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){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 (-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 (-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){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;$ldlib =~ s/^\s+|\s+$//g;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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM';
package ExtUtils::MM;use strict;use ExtUtils::MakeMaker::Config;our$VERSION='7.30';$VERSION=eval$VERSION;require ExtUtils::Liblist;require ExtUtils::MakeMaker;our@ISA=qw(ExtUtils::Liblist ExtUtils::MakeMaker);{package MM;our@ISA=qw(ExtUtils::MM);sub DESTROY {}}sub _is_win95 {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';$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"};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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_AIX';
package ExtUtils::MM_AIX;use strict;our$VERSION='7.30';$VERSION=eval$VERSION;use ExtUtils::MakeMaker::Config;require ExtUtils::MM_Unix;our@ISA=qw(ExtUtils::MM_Unix);sub dlsyms {my($self,%attribs)=@_;return '' unless$self->needs_linking;join "\n",$self->xs_dlsyms_iterator(\%attribs)}sub xs_dlsyms_ext {'.exp'}sub xs_dlsyms_arg {my($self,$file)=@_;return qq{-bE:${file}}}sub init_others {my$self=shift;$self->SUPER::init_others;$self->{LDDLFLAGS}||= $Config{lddlflags};$self->{LDDLFLAGS}=~ s#(\s*)\S*\Q$(BASEEXT)\E\S*(\s*)#$1$2#;return}1;
EXTUTILS_MM_AIX
$fatpacked{"ExtUtils/MM_Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_ANY';
package ExtUtils::MM_Any;use strict;our$VERSION='7.30';$VERSION=eval$VERSION;use Carp;use File::Spec;use File::Basename;BEGIN {our@ISA=qw(File::Spec)}use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562);use ExtUtils::MakeMaker::Config;my$Curdir=__PACKAGE__->curdir;my$METASPEC_URL='https://metacpan.org/pod/CPAN::Meta::Spec';my$METASPEC_V=2;sub os_flavor_is {my$self=shift;my%flavors=map {($_=>1)}$self->os_flavor;return (grep {$flavors{$_}}@_)? 1 : 0}sub can_load_xs {return defined&DynaLoader::boot_DynaLoader ? 1 : 0}sub can_run {my ($self,$command)=@_;if ($^O eq 'VMS'){require VMS::DCLsym;my$syms=VMS::DCLsym->new;return$command if scalar$syms->getsym(uc$command)}my@possibles;if(File::Spec->file_name_is_absolute($command)){return$self->maybe_command($command)}else {for my$dir (File::Spec->path,File::Spec->curdir){next if!$dir ||!-d $dir;my$abs=File::Spec->catfile($self->os_flavor_is('Win32')? Win32::GetShortPathName($dir): $dir,$command);push@possibles,$abs if$abs=$self->maybe_command($abs)}}return@possibles if wantarray;return shift@possibles}sub can_redirect_error {my$self=shift;$self->os_flavor_is('Unix')or ($self->os_flavor_is('Win32')and!$self->os_flavor_is('Win9x'))or $self->os_flavor_is('OS/2')}my%maketype2true;sub _clear_maketype_cache {%maketype2true=()}sub is_make_type {my($self,$type)=@_;return$maketype2true{$type}if defined$maketype2true{$type};(undef,undef,my$make_basename)=$self->splitpath($self->make);return$maketype2true{$type}=1 if$make_basename =~ /\b$type\b/i;return$maketype2true{$type}=0 if$make_basename =~ /\b[gdn]make\b/i;my$redirect=$self->can_redirect_error ? '2>&1' : '';my$make=$self->make || $self->{MAKE};my$minus_v=`"$make" -v $redirect`;return$maketype2true{$type}=1 if$type eq 'gmake' and $minus_v =~ /GNU make/i;return$maketype2true{$type}=1 if$type eq 'bsdmake' and $minus_v =~ /^usage: make \[-BeikNnqrstWwX\]/im;$maketype2true{$type}=0}my$cached_dep_space;sub can_dep_space {my$self=shift;return$cached_dep_space if defined$cached_dep_space;return$cached_dep_space=1 if$self->is_make_type('gmake');return$cached_dep_space=0 if$self->is_make_type('dmake');return$cached_dep_space=0 if$self->is_make_type('bsdmake');return$cached_dep_space=0}sub quote_dep {my ($self,$arg)=@_;die <<EOF if$arg =~ / / and not $self->can_dep_space;$arg =~ s/( )/\\$1/g;return$arg}sub split_command {my($self,$cmd,@args)=@_;my@cmds=();return(@cmds)unless@args;chomp$cmd;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)){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+)\)}{
Tried to use make dependency with space for make that can't:
'$arg'
EOF
defined $self->{$1} ? $self->{$1} : "\$($1)"
}e;return$cmd}sub make_type {return 'Unix-style'}sub stashmeta {my($self,$text,$file)=@_;$self->echo($text,$file,{allow_variables=>0,append=>0 })}sub echo {my($self,$text,$file,$opts)=@_;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}sub wraplist {my$self=shift;return join " \\\n\t",@_}sub maketext_filter {return $_[1]}sub escape_dollarsigns {my($self,$text)=@_;$text =~ s{\$ (?!\() }{\$\$}gx;return$text}sub escape_all_dollarsigns {my($self,$text)=@_;$text =~ s{\$}{\$\$}gx;return$text}sub make {my$self=shift;my$make=lc$self->{MAKE};$make =~ s/^(\w+make).*/$1/;$make =~ s/^gnu/g/;return$make}sub all_target {my$self=shift;return <<'MAKE_EXT'}sub _xs_list_basenames {my ($self)=@_;map {(my$b=$_)=~ s/\.xs$//;$b}sort keys %{$self->{XS}}}sub blibdirs_target {my$self=shift;my@dirs=map {uc "\$(INST_$_)"}qw(libdir archlib autodir archautodir bin script man1dir man3dir);if ($self->{XSMULTI}){for my$ext ($self->_xs_list_basenames){my ($v,$d,$f)=File::Spec->splitpath($ext);my@d=File::Spec->splitdir($d);shift@d if$d[0]eq 'lib';push@dirs,$self->catdir('$(INST_ARCHLIB)','auto',@d,$f)}}my@exists=map {$_.'$(DFSEP).exists'}@dirs;my$make=sprintf <<'MAKE',join(' ',@exists);$make .= $self->dir_target(@dirs);return$make}sub clean {my($self,%attribs)=@_;my@m;push(@m,'
all :: pure_all
$(NOECHO) $(NOOP)
MAKE_EXT
blibdirs : %s
$(NOECHO) $(NOOP)
# Backwards compat with 6.18 through 6.25
blibdirs.ts : blibdirs
$(NOECHO) $(NOOP)
MAKE
# 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=sort values %{$self->{XS}};push@files,map {my$file=$_;map {$file.$_}$self->{OBJ_EXT},qw(.def _def.old .bs .bso .exp .base)}$self->_xs_list_basenames;my@dirs=qw(blib);if($attribs{FILES}){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'));if ($^O eq 'vos'){push(@files,qw[perl*.kp])}else {push(@files,qw[core core.*perl.*.? *perl.core])}push(@files,map {"core." ."[0-9]"x$_}(1..5));push@dirs,$self->extra_clean_files;{my(%f)=map {($_=>1)}@files;@files=sort keys%f}{my(%d)=map {($_=>1)}@dirs;@dirs=sort keys%d}push@m,map "\t$_\n",$self->split_command('- $(RM_F)',@files);push@m,map "\t$_\n",$self->split_command('- $(RM_RF)',@dirs);push@m,<<'MAKE';push(@m,"\t$attribs{POSTOP}\n")if$attribs{POSTOP};join("",@m)}sub clean_subdirs_target {my($self)=shift;return <<'NOOP_FRAG' unless @{$self->{DIR}};my$clean="clean_subdirs :\n";for my$dir (@{$self->{DIR}}){my$subclean=$self->oneliner(sprintf <<'CODE',$dir);$clean .= "\t$subclean\n"}return$clean}sub dir_target {my($self,@dirs)=@_;my$make='';for my$dir (@dirs){$make .= sprintf <<'MAKE',($dir)x 4}return$make}*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}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}sub xs_dlsyms_arg {return ''}sub xs_dlsyms_ext {die "Pure virtual method"}sub xs_dlsyms_extra {''}sub xs_dlsyms_iterator {my ($self,$attribs)=@_;if ($self->{XSMULTI}){my@m;for my$ext ($self->_xs_list_basenames){my@parts=File::Spec->splitdir($ext);shift@parts if$parts[0]eq 'lib';my$name=join '::',@parts;push@m,$self->xs_make_dlsyms($attribs,$ext .$self->xs_dlsyms_ext,"$ext.xs",$name,$parts[-1],{},[],{},[],$self->xs_dlsyms_extra .q!, 'FILE' => ! .neatvalue($ext),)}return join "\n",@m}else {return$self->xs_make_dlsyms($attribs,$self->{BASEEXT}.$self->xs_dlsyms_ext,'Makefile.PL',$self->{NAME},$self->{DLBASE},$attribs->{DL_FUNCS}|| $self->{DL_FUNCS}|| {},$attribs->{FUNCLIST}|| $self->{FUNCLIST}|| [],$attribs->{IMPORTS}|| $self->{IMPORTS}|| {},$attribs->{DL_VARS}|| $self->{DL_VARS}|| [],$self->xs_dlsyms_extra,)}}sub xs_make_dlsyms {my ($self,$attribs,$target,$dep,$name,$dlbase,$funcs,$funclist,$imports,$vars,$extra)=@_;my@m=("\n$target: $dep\n",q! $(PERLRUN) -MExtUtils::Mksymlists \\
$(NOECHO) $(RM_F) $(MAKEFILE_OLD)
- $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) $(DEV_NULL)
MAKE
clean_subdirs :
$(NOECHO) $(NOOP)
NOOP_FRAG
exit 0 unless chdir '%s'; system '$(MAKE) clean' if -f '$(FIRST_MAKEFILE)';
CODE
%s$(DFSEP).exists :: Makefile.PL
$(NOECHO) $(MKPATH) %s
$(NOECHO) $(CHMOD) $(PERM_DIR) %s
$(NOECHO) $(TOUCH) %s$(DFSEP).exists
MAKE
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
disttest : distdir
%s
MAKE_FRAG
-e "Mksymlists('NAME'=>\"!,$name,q!\", 'DLBASE' => '!,$dlbase,q!', 'DL_FUNCS' => !,neatvalue($funcs),q!, 'FUNCLIST' => !,neatvalue($funclist),q!, 'IMPORTS' => !,neatvalue($imports),q!, 'DL_VARS' => !,neatvalue($vars));push@m,$extra if defined$extra;push@m,qq!);"\n!;join '',@m}sub dynamic {my($self)=shift;'
dynamic :: $(FIRST_MAKEFILE) config $(INST_BOOT) $(INST_DYNAMIC)
$(NOECHO) $(NOOP)
'}sub makemakerdflt_target {return <<'MAKE_FRAG'}sub manifypods_target {my($self)=shift;my$man1pods='';my$man3pods='';my$dependencies='';for my$name (sort keys %{$self->{MAN1PODS}},sort keys %{$self->{MAN3PODS}}){$dependencies .= " \\\n\t$name"}my$manify=<<END;my@man_cmds;for my$section (qw(1 3)){my$pods=$self->{"MAN${section}PODS"};my$p2m=sprintf <<'CMD',$section,$] > 5.008 ? " -u" : "";push@man_cmds,$self->split_command($p2m,map {($_,$pods->{$_})}sort keys %$pods)}$manify .= "\t\$(NOECHO) \$(NOOP)\n" unless@man_cmds;$manify .= join '',map {"$_\n"}@man_cmds;return$manify}{my$has_cpan_meta;sub _has_cpan_meta {return$has_cpan_meta if defined$has_cpan_meta;return$has_cpan_meta=!!eval {require CPAN::Meta;CPAN::Meta->VERSION(2.112150);1}}}sub metafile_target {my$self=shift;return <<'MAKE_FRAG' if$self->{NO_META}or!_has_cpan_meta();my$metadata=$self->metafile_data($self->{META_ADD}|| {},$self->{META_MERGE}|| {},);my$meta=$self->_fix_metadata_before_conversion($metadata);my@write_metayml=$self->stashmeta($meta->as_string({version=>"1.4"}),'META_new.yml');my@write_metajson=$self->stashmeta($meta->as_string({version=>"2.0"}),'META_new.json');my$metayml=join("\n\t",@write_metayml);my$metajson=join("\n\t",@write_metajson);return sprintf <<'MAKE_FRAG',$metayml,$metajson}sub _fix_metadata_before_conversion {my ($self,$metadata)=@_;return unless _has_cpan_meta;my$bad_version=$metadata->{version}&& !CPAN::Meta::Validator->new->version('version',$metadata->{version});if($bad_version){warn "Can't parse version '$metadata->{version}'\n";$metadata->{version}=''}my$validator2=CPAN::Meta::Validator->new($metadata);my@errors;push@errors,$validator2->errors if!$validator2->is_valid;my$validator14=CPAN::Meta::Validator->new({%$metadata,'meta-spec'=>{version=>1.4 },});push@errors,$validator14->errors if!$validator14->is_valid;for my$error (@errors){my ($key)=($error =~ /Custom resource '(.*)' must be in CamelCase./);next if!$key;(my$new_key=$key)=~ s/[^_a-zA-Z]//g;$new_key=ucfirst$new_key if!$validator14->custom_1($new_key);$metadata->{resources}{$new_key}=$metadata->{resources}{$key}if$validator14->custom_1($new_key);delete$metadata->{resources}{$key}}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/;if(!$meta || !eval {$meta->as_string({version=>$METASPEC_V })}|| !eval {$meta->as_string}){$meta=bless$metadata,'CPAN::Meta'}my$now_license=$meta->as_struct({version=>2 })->{license};if ($self->{LICENSE}and $self->{LICENSE}ne 'unknown' and @{$now_license}==1 and $now_license->[0]eq 'unknown'){warn "Invalid LICENSE value '$self->{LICENSE}' ignored\n"}$meta}sub _sort_pairs {my$sort=shift;my$pairs=shift;return map {$_=>$pairs->{$_}}sort$sort keys %$pairs}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}}sub metafile_data {my$self=shift;my($meta_add,$meta_merge)=@_;$meta_add ||= {};$meta_merge ||= {};my$version=_normalize_version($self->{VERSION});my$release_status=($version =~ /_/)? 'unstable' : 'stable';my%meta=(abstract=>$self->{ABSTRACT}|| 'unknown',author=>defined($self->{AUTHOR})? $self->{AUTHOR}: ['unknown'],dynamic_config=>1,generated_by=>"ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",license=>[$self->{LICENSE}|| 'unknown' ],'meta-spec'=>{url=>$METASPEC_URL,version=>$METASPEC_V,},name=>$self->{DISTNAME},release_status=>$release_status,version=>$version,no_index=>{directory=>[qw(t inc)]},);$self->_add_requirements_to_meta(\%meta);if (!eval {require JSON::PP;require CPAN::Meta::Converter;CPAN::Meta::Converter->VERSION(2.141170)}){return \%meta}my$v1_add=_metaspec_version($meta_add)!~ /^2/;my ($add_v,$merge_v)=map _metaspec_version($_),$meta_add,$meta_merge;for my$frag ($meta_add,$meta_merge){my$def_v=$frag==$meta_add ? $merge_v : $add_v;$frag=CPAN::Meta::Converter->new($frag,default_version=>$def_v)->upgrade_fragment}while(my($key,$val)=each %$meta_add){if ($v1_add and $key eq 'prereqs'){$meta{$key}{$_}=$val->{$_}for keys %$val}elsif ($key ne 'meta-spec'){$meta{$key}=$val}}while(my($key,$val)=each %$meta_merge){next if$key eq 'meta-spec';$self->_hash_merge(\%meta,$key,$val)}return \%meta}sub _add_requirements_to_meta {my ($self,$meta)=@_;$meta->{prereqs}{configure}{requires}=$self->{ARGS}{CONFIGURE_REQUIRES}? $self->{CONFIGURE_REQUIRES}: {'ExtUtils::MakeMaker'=>0,};$meta->{prereqs}{build}{requires}=$self->{ARGS}{BUILD_REQUIRES}? $self->{BUILD_REQUIRES}: {'ExtUtils::MakeMaker'=>0,};$meta->{prereqs}{test}{requires}=$self->{TEST_REQUIRES}if$self->{ARGS}{TEST_REQUIRES};$meta->{prereqs}{runtime}{requires}=$self->{PREREQ_PM}if$self->{ARGS}{PREREQ_PM};$meta->{prereqs}{runtime}{requires}{perl}=_normalize_version($self->{MIN_PERL_VERSION})if$self->{MIN_PERL_VERSION}}sub _metaspec_version {my ($meta)=@_;return$meta->{'meta-spec'}->{version}if defined$meta->{'meta-spec'}and defined$meta->{'meta-spec'}->{version};return '1.4'}sub _add_requirements_to_meta_v1_4 {my ($self,$meta)=@_;if($self->{ARGS}{CONFIGURE_REQUIRES}){$meta->{configure_requires}=$self->{CONFIGURE_REQUIRES}}else {$meta->{configure_requires}={'ExtUtils::MakeMaker'=>0,}}if($self->{ARGS}{BUILD_REQUIRES}){$meta->{build_requires}=$self->{BUILD_REQUIRES}}else {$meta->{build_requires}={'ExtUtils::MakeMaker'=>0,}}if($self->{ARGS}{TEST_REQUIRES}){$meta->{build_requires}={%{$meta->{build_requires}},%{$self->{TEST_REQUIRES}},}}$meta->{requires}=$self->{PREREQ_PM}if defined$self->{PREREQ_PM};$meta->{requires}{perl}=_normalize_version($self->{MIN_PERL_VERSION})if$self->{MIN_PERL_VERSION}}sub _normalize_version {my ($version)=@_;$version=0 unless defined$version;if (ref$version eq 'version'){$version=$version->stringify}elsif ($version =~ /^[^v][^.]*\.[^.]+\./){$version="v$version"}else {}return$version}sub _dump_hash {croak "first argument should be a hash ref" unless ref $_[0]eq 'HASH';my$options=shift;my%hash=@_;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 {@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}|| {};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=(delta=>$options->{delta},use_header=>0,indent=>$indent .$options->{delta},);if (exists$customs->{$key}){my%k_custom=%{$customs->{$key}};for 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 {$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]}sub metafile_file {my$self=shift;my%dump_options=(use_header=>1,delta=>' ' x 4,key_sort=>undef,);return _dump_hash(\%dump_options,@_)}sub distmeta_target {my$self=shift;my@add_meta=($self->oneliner(<<'CODE',['-MExtUtils::Manifest=maniadd']),$self->oneliner(<<'CODE',['-MExtUtils::Manifest=maniadd']));my@add_meta_to_distdir=map {$self->cd('$(DISTVNAME)',$_)}@add_meta;return sprintf <<'MAKE',@add_meta_to_distdir}sub mymeta {my$self=shift;my$file=shift || '';my$mymeta=$self->_mymeta_from_meta($file);my$v2=1;unless ($mymeta){$mymeta=$self->metafile_data($self->{META_ADD}|| {},$self->{META_MERGE}|| {},);$v2=0}$self->_add_requirements_to_meta($mymeta);$mymeta->{dynamic_config}=0;return$mymeta}sub _mymeta_from_meta {my$self=shift;my$metafile=shift || '';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 unless$meta;if ($meta->{generated_by}&& $meta->{generated_by}=~ /ExtUtils::MakeMaker version ([\d\._]+)/){my$eummv=do {local $^W=0;$1+0};if ($eummv < 6.2501){return}}return$meta}sub write_mymeta {my$self=shift;my$mymeta=shift;return unless _has_cpan_meta();my$meta_obj=$self->_fix_metadata_before_conversion($mymeta);$meta_obj->save('MYMETA.json',{version=>"2.0" });$meta_obj->save('MYMETA.yml',{version=>"1.4" });return 1}sub realclean {my($self,%attribs)=@_;my@dirs=qw($(DISTVNAME));my@files=qw($(FIRST_MAKEFILE) $(MAKEFILE_OLD));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}}}{my(%f)=map {($_=>1)}@files;@files=sort keys%f}{my(%d)=map {($_=>1)}@dirs;@dirs=sort 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;$m .= "\t$attribs{POSTOP}\n" if$attribs{POSTOP};return$m}sub realclean_subdirs_target {my$self=shift;my@m=<<'EOF';return join '',@m,"\t\$(NOECHO) \$(NOOP)\n" unless @{$self->{DIR}};for my$dir (@{$self->{DIR}}){for my$makefile ('$(MAKEFILE_OLD)','$(FIRST_MAKEFILE)'){my$subrclean .= $self->oneliner(_sprintf562 <<'CODE',$dir,$makefile);push@m,"\t- $subrclean\n"}}return join '',@m}sub signature_target {my$self=shift;return <<'MAKE_FRAG'}sub distsignature_target {my$self=shift;my$add_sign=$self->oneliner(<<'CODE',['-MExtUtils::Manifest=maniadd']);my$sign_dist=$self->cd('$(DISTVNAME)'=>'cpansign -s');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}sub special_targets {my$make_frag=<<'MAKE_FRAG';$make_frag .= <<'MAKE_FRAG' if$ENV{CLEARCASE_ROOT};return$make_frag}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"}if ($self->{ABSTRACT}&& $self->{ABSTRACT}=~ m![[:cntrl:]]+!){warn "WARNING: ABSTRACT contains control character(s),"." they will be removed\n";$self->{ABSTRACT}=~ s![[:cntrl:]]+!!g;return}}sub init_INST {my($self)=shift;$self->{INST_ARCHLIB}||= $self->catdir($Curdir,"blib","arch");$self->{INST_BIN}||= $self->catdir($Curdir,'blib','bin');unless ($self->{INST_LIB}){if ($self->{PERL_CORE}){$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}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}}sub init_INSTALL_from_PREFIX {my$self=shift;$self->init_lib2arch;for my$num (1,3){my$k='installsiteman'.$num.'dir';$self->{uc$k}||= uc "\$(installman${num}dir)" unless$Config{$k}}for 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}|| '';$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;$self->{PREFIX}='$('.uc$self->{INSTALLDIRS}.'PREFIX)'}my$arch=$Config{archname};my$version=$Config{version};my$libstyle=$Config{installstyle}|| 'lib/perl5';my$manstyle='';if($self->{LIBSTYLE}){$libstyle=$self->{LIBSTYLE};$manstyle=$self->{LIBSTYLE}eq 'lib/perl5' ? 'lib/perl5' : ''}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 },);if($self->{LIB}){for 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}$self->{VENDORARCHEXP}||= $self->{INSTALLVENDORARCH};$self->{VENDORLIBEXP}||= $self->{INSTALLVENDORLIB};return 1}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;for my$thing (keys%map){for my$dir (('','SITE','VENDOR')){my$uc_thing=uc$thing;my$key="INSTALL".$dir.$uc_thing;$install{$key}||= $self->catdir('$(INSTALL_BASE)',@{$map{$thing}})}}$install{INSTALLARCHLIB}||= delete$install{INSTALLARCH};$install{INSTALLPRIVLIB}||= delete$install{INSTALLLIB};for my$key (keys%install){$self->{$key}||= $install{$key}}return 1}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")}}if (defined$self->{VERSION}){if ($self->{VERSION}!~ /^\s*v?[\d_\.]+\s*$/){require version;my$normal=eval {version->new($self->{VERSION})};$self->{VERSION}=$normal if defined$normal}$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)\"';$self->{XS_VERSION}||= $self->{VERSION};$self->{XS_VERSION_MACRO}='XS_VERSION';$self->{XS_DEFINE_VERSION}='-D$(XS_VERSION_MACRO)=\"$(XS_VERSION)\"'}sub init_tools {my$self=shift;$self->{ECHO}||= $self->oneliner('binmode STDOUT, qq{:raw}; 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->{TEST_S}||= $self->oneliner('test_s',["-MExtUtils::Command::MM"]);$self->{CP_NONEMPTY}||= $self->oneliner('cp_nonempty',["-MExtUtils::Command::MM"]);$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']);$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};$self->{UMASK_NULL}||= "umask 0";$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';$self->{USEMAKEFILE}||= '-f';$self->{MACROSTART}||= '';$self->{MACROEND}||= '';return}sub init_others {my$self=shift;$self->{LD_RUN_PATH}="";$self->{LIBS}=$self->_fix_libs($self->{LIBS});for my$libs (@{$self->{LIBS}}){$libs =~ s/^\s*(.*\S)\s*$/$1/;my(@libs)=$self->extliblist($libs);if ($libs[0]or $libs[1]or $libs[2]){($self->{EXTRALIBS},$self->{BSLOADLIBS},$self->{LDLOADLIBS},$self->{LD_RUN_PATH})=@libs;last}}if ($self->{OBJECT}){$self->{OBJECT}=join(" ",@{$self->{OBJECT}})if ref$self->{OBJECT};$self->{OBJECT}=~ s!\.o(bj)?\b!\$(OBJ_EXT)!g}elsif (($self->{MAGICXS}|| $self->{XSMULTI})&& @{$self->{O_FILES}||[]}){$self->{OBJECT}=join(" ",@{$self->{O_FILES}});$self->{OBJECT}=~ s!\.o(bj)?\b!\$(OBJ_EXT)!g}else {$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};if (!$self->{LINKTYPE}){$self->{LINKTYPE}=$self->{SKIPHASH}{'dynamic'}? 'static' : ($Config{usedl}? 'dynamic' : 'static')}return}sub _fix_libs {my($self,$libs)=@_;return!defined$libs ? ['']: !ref$libs ? [$libs]: !defined$libs->[0]? ['']: $libs }sub tools_other {my($self)=shift;my@m;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 CP_NONEMPTY}){next unless defined$self->{$tool};push@m,"$tool = $self->{$tool}\n"}return join "",@m}sub init_platform {return ''}sub init_MAKE {my$self=shift;$self->{MAKE}||= $ENV{MAKE}|| $Config{make}}sub manifypods {my$self=shift;my$POD2MAN_macro=$self->POD2MAN_macro();my$manifypods_target=$self->manifypods_target();return <<END_OF_TARGET}sub POD2MAN_macro {my$self=shift;return <<'END_OF_DEF'}sub test_via_harness {my($self,$perl,$tests)=@_;return qq{\t$perl "-MExtUtils::Command::MM" "-MTest::Harness" }.qq{"-e" "undef *Test::Harness::Switches; test_harness(\$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n}}sub test_via_script {my($self,$perl,$script)=@_;return qq{\t$perl "-I\$(INST_LIB)" "-I\$(INST_ARCHLIB)" $script\n}}sub tool_autosplit {my($self,%attribs)=@_;my$maxlen=$attribs{MAXLEN}? '$$AutoSplit::Maxlen=$attribs{MAXLEN};' : '';my$asplit=$self->oneliner(sprintf <<'PERL_CODE',$maxlen);return sprintf <<'MAKE_FRAG',$asplit}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}}return$ret}sub catfile {my$self=shift;return$self->canonpath($self->SUPER::catfile(@_))}sub find_tests {my($self)=shift;return -d 't' ? 't/*.t' : ''}sub find_tests_recursive {my$self=shift;return$self->find_tests_recursive_in('t')}sub find_tests_recursive_in {my($self,$dir)=@_;return '' unless -d $dir;require File::Find;my$base_depth=grep {$_ ne ''}File::Spec->splitdir((File::Spec->splitpath($dir))[1]);my%depths;my$wanted=sub {return unless m!\.t$!;my ($volume,$directories,$file)=File::Spec->splitpath($File::Find::name);my$depth=grep {$_ ne ''}File::Spec->splitdir($directories);$depth -= $base_depth;$depths{$depth }=1};File::Find::find($wanted,$dir);return join ' ',map {$dir .'/*' x $_ .'.t'}sort {$a <=> $b}keys%depths}sub extra_clean_files {return}sub installvars {return qw(PRIVLIB SITELIB VENDORLIB ARCHLIB SITEARCH VENDORARCH BIN SITEBIN VENDORBIN SCRIPT SITESCRIPT VENDORSCRIPT MAN1DIR SITEMAN1DIR VENDORMAN1DIR MAN3DIR SITEMAN3DIR VENDORMAN3DIR)}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}sub platform_constants {return ''}sub post_constants {""}sub post_initialize {""}sub postamble {""}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}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}sub _perl_header_files {my$self=shift;my$header_dir=$self->{PERL_SRC}|| $ENV{PERL_SRC}|| $self->catdir($Config{archlibexp},'CORE');opendir my$dh,$header_dir or die "Failed to opendir '$header_dir' to find header files: $!";my@perl_headers=sort grep {/\.h\z/}readdir($dh);closedir$dh;return@perl_headers}sub _perl_header_files_fragment {my ($self,$separator)=@_;$separator ||= "";return join("\\\n","PERL_HDRS = ",map {sprintf(" \$(PERL_INCDEP)%s%s ",$separator,$_)}$self->_perl_header_files())."\n\n" ."\$(OBJECT) : \$(PERL_HDRS)\n"}1;
makemakerdflt : all
$(NOECHO) $(NOOP)
MAKE_FRAG
manifypods : pure_all config $dependencies
END
$(NOECHO) $(POD2MAN) --section=%s --perm_rw=$(PERM_RW)%s
CMD
metafile :
$(NOECHO) $(NOOP)
MAKE_FRAG
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
exit unless -e q{META.yml};
eval { maniadd({q{META.yml} => q{Module YAML meta-data (added by MakeMaker)}}) }
or die "Could not add META.yml to MANIFEST: ${'@'}"
CODE
exit unless -f q{META.json};
eval { maniadd({q{META.json} => q{Module JSON meta-data (added by MakeMaker)}}) }
or die "Could not add META.json to MANIFEST: ${'@'}"
CODE
distmeta : create_distdir metafile
$(NOECHO) %s
$(NOECHO) %s
MAKE
# Delete temporary files (via clean) and also delete dist files
realclean purge :: realclean_subdirs
%s
%s
MAKE
# so clean is forced to complete before realclean_subdirs runs
realclean_subdirs : clean
EOF
chdir '%1$s'; system '$(MAKE) $(USEMAKEFILE) %2$s realclean' if -f '%2$s';
CODE
signature :
cpansign -s
MAKE_FRAG
eval { maniadd({q{SIGNATURE} => q{Public-key signature (added by MakeMaker)}}) }
or die "Could not add SIGNATURE to MANIFEST: ${'@'}"
CODE
distsignature : distmeta
$(NOECHO) %s
$(NOECHO) %s
%s
MAKE
.SUFFIXES : .xs .c .C .cpp .i .s .cxx .cc $(OBJ_EXT)
.PHONY: all config static dynamic test linkext manifest blibdirs clean realclean disttest distdir pure_all subdirs clean_subdirs makemakerdflt manifypods realclean_subdirs subdirs_dynamic subdirs_pure_nolink subdirs_static subdirs-test_dynamic subdirs-test_static test_dynamic test_static
MAKE_FRAG
.NO_CONFIG_REC: Makefile
MAKE_FRAG
install([ from_to => {@ARGV}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]);
CODE
$POD2MAN_macro
$manifypods_target
END_OF_TARGET
POD2MAN_EXE = $(PERLRUN) "-MExtUtils::Command::MM" -e pod2man "--"
POD2MAN = $(POD2MAN_EXE)
END_OF_DEF
use AutoSplit; %s autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1)
PERL_CODE
# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto
AUTOSPLITFILE = %s
MAKE_FRAG
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
EXTUTILS_MM_ANY
$fatpacked{"ExtUtils/MM_BeOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_BEOS';
package ExtUtils::MM_BeOS;use strict;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='7.30';$VERSION=eval$VERSION;sub os_flavor {return('BeOS')}sub init_linker {my($self)=shift;$self->{PERL_ARCHIVE}||= File::Spec->catdir('$(PERL_INC)',$Config{libperl});$self->{PERL_ARCHIVEDEP}||= '';$self->{PERL_ARCHIVE_AFTER}||= '';$self->{EXPORT_LIST}||= ''}
EXTUTILS_MM_BEOS
$fatpacked{"ExtUtils/MM_Cygwin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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='7.30';$VERSION=eval$VERSION;sub os_flavor {return('Unix','Cygwin')}sub cflags {my($self,$libperl)=@_;return$self->{CFLAGS}if$self->{CFLAGS};return '' unless$self->needs_linking();my$base=$self->SUPER::cflags($libperl);for (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}
}}sub replace_manpage_separator {my($self,$man)=@_;$man =~ s{/+}{.}g;return$man}sub init_linker {my$self=shift;if ($Config{useshrplib}eq 'true'){my$libperl='$(PERL_INC)' .'/'."$Config{libperl}";if($] >= 5.006002){$libperl =~ s/(dll\.)?a$/dll.a/}$self->{PERL_ARCHIVE}=$libperl}else {$self->{PERL_ARCHIVE}='$(PERL_INC)' .'/'.("$Config{libperl}" or "libperl.a")}$self->{PERL_ARCHIVEDEP}||= '';$self->{PERL_ARCHIVE_AFTER}||= '';$self->{EXPORT_LIST}||= ''}sub maybe_command {my ($self,$file)=@_;my$cygpath=Cygwin::posix_to_win_path('/',1);my$filepath=Cygwin::posix_to_win_path($file,1);return (substr($filepath,0,length($cygpath))eq $cygpath)? $self->SUPER::maybe_command($file): ExtUtils::MM_Win32->maybe_command($file)}sub dynamic_lib {my($self,%attribs)=@_;my$s=ExtUtils::MM_Unix::dynamic_lib($self,%attribs);return '' unless$s;return$s unless %{$self->{XS}};$s .= "\t/bin/find \$\(INST_ARCHLIB\)/auto -xdev -name \\*.$self->{DLEXT} | /bin/rebase -sOT -" if (($Config{myarchname}eq 'i686-cygwin')and not (exists$ENV{CYGPORT_PACKAGE_VERSION}));$s}sub install {my($self,%attribs)=@_;my$s=ExtUtils::MM_Unix::install($self,%attribs);return '' unless$s;return$s unless %{$self->{XS}};my$INSTALLDIRS=$self->{INSTALLDIRS};my$INSTALLLIB=$self->{"INSTALL".($INSTALLDIRS eq 'perl' ? 'ARCHLIB' : uc($INSTALLDIRS)."ARCH")};my$dop="\$\(DESTDIR\)$INSTALLLIB/auto/";my$dll="$dop/$self->{FULLEXT}/$self->{BASEEXT}.$self->{DLEXT}";$s =~ s|^(pure_install :: pure_\$\(INSTALLDIRS\)_install\n\t)\$\(NOECHO\) \$\(NOOP\)\n|$1\$(CHMOD) \$(PERM_RWX) $dll\n\t/bin/find $dop -xdev -name \\*.$self->{DLEXT} \| /bin/rebase -sOT -\n|m if (($Config{myarchname}eq 'i686-cygwin')and not (exists$ENV{CYGPORT_PACKAGE_VERSION}));$s}sub all_target {ExtUtils::MM_Unix::all_target(shift)}1;
EXTUTILS_MM_CYGWIN
$fatpacked{"ExtUtils/MM_DOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_DOS';
package ExtUtils::MM_DOS;use strict;our$VERSION='7.30';$VERSION=eval$VERSION;require ExtUtils::MM_Any;require ExtUtils::MM_Unix;our@ISA=qw(ExtUtils::MM_Any ExtUtils::MM_Unix);sub os_flavor {return('DOS')}sub replace_manpage_separator {my($self,$man)=@_;$man =~ s,/+,__,g;return$man}1;
EXTUTILS_MM_DOS
$fatpacked{"ExtUtils/MM_Darwin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_DARWIN';
package ExtUtils::MM_Darwin;use strict;BEGIN {require ExtUtils::MM_Unix;our@ISA=qw(ExtUtils::MM_Unix)}our$VERSION='7.30';$VERSION=eval$VERSION;sub init_dist {my$self=shift;$self->{TAR}||= 'COPY_EXTENDED_ATTRIBUTES_DISABLE=1 COPYFILE_DISABLE=1 tar';$self->SUPER::init_dist(@_)}1;
EXTUTILS_MM_DARWIN
$fatpacked{"ExtUtils/MM_MacOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_MACOS';
package ExtUtils::MM_MacOS;use strict;our$VERSION='7.30';$VERSION=eval$VERSION;sub new {die 'MacOS Classic (MacPerl) is no longer supported by MakeMaker'}1;
EXTUTILS_MM_MACOS
$fatpacked{"ExtUtils/MM_NW5.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_NW5';
package ExtUtils::MM_NW5;use strict;use ExtUtils::MakeMaker::Config;use File::Basename;our$VERSION='7.30';$VERSION=eval$VERSION;require ExtUtils::MM_Win32;our@ISA=qw(ExtUtils::MM_Win32);use ExtUtils::MakeMaker qw(&neatvalue &_sprintf562);$ENV{EMXSHELL}='sh';my$BORLAND=$Config{'cc'}=~ /\bbcc/i;my$GCC=$Config{'cc'}=~ /\bgcc/i;sub os_flavor {my$self=shift;return ($self->SUPER::os_flavor,'Netware')}sub init_platform {my($self)=shift;$self->SUPER::init_platform;my$libpth=$Config{'libpth'};$libpth =~ s( )(;);$self->{'LIBPTH'}=$libpth;$self->{'BASE_IMPORT'}=$Config{'base_import'};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(length($self->{'BASEEXT'})> 8){$self->{'NLM_SHORT_NAME'}=substr($self->{'BASEEXT'},0,8)}($self->{INCLUDE}=$Config{'incpath'})=~ s/([ ]*)-I/;/g;$self->{PATH}='$(PATH);$(TOOLPATH)';$self->{MM_NW5_VERSION}=$VERSION}sub platform_constants {my($self)=shift;my$make_frag='';$make_frag .= $self->SUPER::platform_constants;for 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}sub static_lib_pure_cmd {my ($self,$src)=@_;$src =~ s/(\$\(\w+)(\))/$1:^"+"$2/g if$BORLAND;sprintf qq{\t\$(AR) %s\n},($BORLAND ? '$@ ' .$src : ($GCC ? '-ru $@ ' .$src : '-type library -o $@ ' .$src))}sub xs_make_dynamic_lib {my ($self,$attribs,$from,$to,$todir,$ldfrom,$exportlist)=@_;my@m;if ($to =~ /^\$/){if ($self->{NLM_SHORT_NAME}){my$newto=q{$(INST_AUTODIR)\\$(NLM_SHORT_NAME).$(DLEXT)};push@m,"$to: $newto\n\n";$to=$newto}}else {my ($v,$d,$f)=File::Spec->splitpath($to);if ($f =~ /[^\.]{9}\./){$f=substr$f,0,8}my$newto=File::Spec->catpath($v,$d,$f);push@m,"$to: $newto\n\n";$to=$newto}push@m,_sprintf562 <<'MAKE_FRAG',$to,$from,$todir,$exportlist;if ($self->{CCFLAGS}=~ m/ -DMPK_ON /){(my$xdc=$exportlist)=~ s#def\z#xdc#;$xdc='$(BASEEXT).xdc';push@m,sprintf <<'MAKE_FRAG',$xdc,$exportlist}my$version=join '.',map {sprintf "%d",$_}$] =~ /(\d)\.(\d{3})(\d{2})/;push@m,sprintf <<'EOF',$from,$version,$to,$exportlist;join '',@m}1;
# Create xdc data for an MT safe NLM in case of mpk build
%1$s: %2$s $(MYEXTLIB) $(BOOTSTRAP) %3$s$(DFSEP).exists
$(NOECHO) $(ECHO) Export boot_$(BOOT_SYMBOL) > %4$s
$(NOECHO) $(ECHO) $(BASE_IMPORT) >> %4$s
$(NOECHO) $(ECHO) Import @$(PERL_INC)\perl.imp >> %4$s
MAKE_FRAG
$(MPKTOOL) $(XDCFLAGS) %s
$(NOECHO) $(ECHO) xdcdata $(BASEEXT).xdc >> %s
MAKE_FRAG
$(LD) $(LDFLAGS) %s -desc "Perl %s Extension ($(BASEEXT)) XS_VERSION: $(XS_VERSION)" -nlmversion $(NLM_VERSION) -o %s $(MYEXTLIB) $(PERL_INC)\Main.lib -commandfile %s
$(CHMOD) 755 $@
EOF
EXTUTILS_MM_NW5
$fatpacked{"ExtUtils/MM_OS2.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_OS2';
package ExtUtils::MM_OS2;use strict;use ExtUtils::MakeMaker qw(neatvalue);use File::Spec;our$VERSION='7.30';$VERSION=eval$VERSION;require ExtUtils::MM_Any;require ExtUtils::MM_Unix;our@ISA=qw(ExtUtils::MM_Any ExtUtils::MM_Unix);sub init_dist {my($self)=@_;$self->{TO_UNIX}||= <<'MAKE_TEXT';$self->SUPER::init_dist}sub dlsyms {my($self,%attribs)=@_;if ($self->{IMPORTS}&& %{$self->{IMPORTS}}){-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";for my$name (sort keys %{$self->{IMPORTS}}){my$exp=$self->{IMPORTS}->{$name};my ($lib,$id)=($exp =~ /(.*)\.(.*)/)or die "Malformed IMPORT `$exp'";print$imp "$name $lib $id ?\n"}close$imp or die "Can't close tmpimp.imp";system "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp" and die "Cannot make import library: $!, \$?=$?";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: $!, \$?=$?"}return '' if$self->{SKIPHASH}{'dynamic'};$self->xs_dlsyms_iterator(\%attribs)}sub xs_dlsyms_ext {'.def'}sub xs_dlsyms_extra {join '',map {qq{, "$_" => "\$($_)"}}qw(VERSION DISTNAME INSTALLDIRS)}sub static_lib_pure_cmd {my($self)=@_;my$old=$self->SUPER::static_lib_pure_cmd;return$old unless$self->{IMPORTS}&& %{$self->{IMPORTS}};$old .<<'EOC'}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}sub init_linker {my$self=shift;$self->{PERL_ARCHIVE}="\$(PERL_INC)/libperl\$(LIB_EXT)";$self->{PERL_ARCHIVEDEP}||= '';$self->{PERL_ARCHIVE_AFTER}=$OS2::is_aout ? '' : '$(PERL_INC)/libperl_override$(LIB_EXT)';$self->{EXPORT_LIST}='$(BASEEXT).def'}sub os_flavor {return('OS/2')}1;
$(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
$(AR) $(AR_STATIC_ARGS) "$@" tmp_imp/*
$(RANLIB) "$@"
EOC
EXTUTILS_MM_OS2
$fatpacked{"ExtUtils/MM_QNX.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_QNX';
package ExtUtils::MM_QNX;use strict;our$VERSION='7.30';$VERSION=eval$VERSION;require ExtUtils::MM_Unix;our@ISA=qw(ExtUtils::MM_Unix);sub extra_clean_files {my$self=shift;my@errfiles=@{$self->{C}};for (@errfiles){s/.c$/.err/}return(@errfiles,'perlmain.err')}1;
EXTUTILS_MM_QNX
$fatpacked{"ExtUtils/MM_UWIN.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_UWIN';
package ExtUtils::MM_UWIN;use strict;our$VERSION='7.30';$VERSION=eval$VERSION;require ExtUtils::MM_Unix;our@ISA=qw(ExtUtils::MM_Unix);sub os_flavor {return('Unix','U/WIN')}sub replace_manpage_separator {my($self,$man)=@_;$man =~ s,/+,.,g;return$man}1;
EXTUTILS_MM_UWIN
$fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_UNIX';
package ExtUtils::MM_Unix;require 5.006;use strict;use Carp;use ExtUtils::MakeMaker::Config;use File::Basename qw(basename dirname);our%Config_Override;use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562);use vars qw($VERSION);$VERSION='7.30';$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)));$Is{Android}=$^O =~ /android/}BEGIN {if($Is{VMS}){require VMS::Filespec;VMS::Filespec->import}}my$Curdir=__PACKAGE__->curdir;my$Updir=__PACKAGE__->updir;sub os_flavor {return('Unix')}sub c_o {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
}}my$m_o=$self->{XSMULTI}? $self->xs_obj_opt('$*.s'): '';push@m,sprintf <<'EOF',$command,$flags,$m_o;my@exts=qw(c cpp cxx cc);push@exts,'C' if!$Is{OS2}and!$Is{Win32}and!$Is{Dos};$m_o=$self->{XSMULTI}? $self->xs_obj_opt('$*$(OBJ_EXT)'): '';for my$ext (@exts){push@m,"\n.$ext\$(OBJ_EXT) :\n\t$command $flags \$*.$ext" .($m_o ? " $m_o" : '')."\n"}return join "",@m}sub xs_obj_opt {my ($self,$output_file)=@_;"-o $output_file"}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@ccextraflags=qw(ccwarnflags);if ($ENV{PERL_CORE}){for my$x (@ccextraflags){if (exists$Config{$x}){$cflags{$x}=$Config{$x}}}}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=""}$perltype=$map{$uc}? $map{$uc}: "";if ($uc =~ /^D/){$optdebug="-g"}my($name);($name=$self->{NAME}."_cflags")=~ s/:/_/g ;if ($prog=$Config{$name}){print "Processing $name hint:\n" if$Verbose;my(@o)=`cc=\"$cflags{cc}\"
.c.s :
%s -S %s $*.c %s
EOF
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
`;for 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 '}for my$x (@ccextraflags){next unless exists$cflags{$x};$self->{CCFLAGS}.= $cflags{$x}=~ m!^\s! ? $cflags{$x}: ' ' .$cflags{$x}}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)'}return$self->{CFLAGS}=qq{
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
PERLTYPE = $self->{PERLTYPE}
MPOLLUTE = $pollute
}}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)}}sub const_config {my($self)=shift;my@m=$self->specify_shell();push@m,<<"END";my(%once_only);for my$key (@{$self->{CONFIG}}){next if$once_only{$key};push@m,uc($key),' = ',$self->{uc$key},"\n";$once_only{$key}=1}join('',@m)}sub const_loadlibs {my($self)=shift;return "" unless$self->needs_linking;my@m;push@m,qq{
# These definitions are from config.sh (via $INC{'Config.pm'}).
# They may have been overridden via Makefile.PL or on the command line.
END
# $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"}for my$tmp (qw/LD_RUN_PATH/){next unless$self->{$tmp};push@m,"$tmp = $self->{$tmp}\n"}return join "",@m}sub constants {my($self)=@_;my@m=();$self->{DFSEP}='$(DIRFILESEP)';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 PERL_ARCHLIBDEP LIBPERL_A MYEXTLIB FIRST_MAKEFILE MAKEFILE_OLD MAKE_APERL_FILE PERLMAINCC PERL_SRC PERL_INC PERL_INCDEP PERL FULLPERL ABSPERL PERLRUN FULLPERLRUN ABSPERLRUN PERLRUNINST FULLPERLRUNINST ABSPERLRUNINST PERL_CORE PERM_DIR PERM_RW PERM_RWX)){next unless defined$self->{$macro};$self->{$macro}=~ s/#/\\#/g;$self->{$macro}=$self->quote_dep($self->{$macro})if$ExtUtils::MakeMaker::macro_dep{$macro};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(sort @{$self->{C}})."
O_FILES = ".$self->wraplist(sort @{$self->{O_FILES}})."
H_FILES = ".$self->wraplist(sort @{$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_ARCHLIBDEP)$(DFSEP)Config.pm $(PERL_INCDEP)$(DFSEP)config.h
} if -e $self->catfile($self->{PERL_INC},'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_ARCHIVEDEP = $self->{PERL_ARCHIVEDEP}
PERL_ARCHIVE_AFTER = $self->{PERL_ARCHIVE_AFTER}
};push@m,"
TO_INST_PM = ".$self->wraplist(map$self->quote_dep($_),sort keys %{$self->{PM}})."\n";join('',@m)}sub depend {my($self,%attribs)=@_;my(@m,$key,$val);for my$key (sort keys%attribs){my$val=$attribs{$key};next unless defined$key and defined$val;push@m,"$key : $val\n"}join "",@m}sub init_DEST {my$self=shift;$self->{DESTDIR}||= '';for my$var ($self->installvars){my$destvar='DESTINSTALL'.$var;$self->{$destvar}||= '$(DESTDIR)$(INSTALL'.$var.')'}}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)';$self->{POSTOP}||= '$(NOECHO) $(NOOP)';$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}}sub dist {my($self,%attribs)=@_;my$make='';if ($attribs{SUFFIX}&& $attribs{SUFFIX}!~ m!^\.!){$attribs{SUFFIX}='.' .$attribs{SUFFIX}}for 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}sub dist_basics {my($self)=shift;return <<'MAKE_FRAG'}sub dist_ci {my($self)=shift;return sprintf "ci :\n\t%s\n",$self->oneliner(<<'EOF',[qw(-MExtUtils::Manifest=maniread)])}sub dist_core {my($self)=shift;my$make_frag='';for my$target (qw(dist tardist uutardist tarfile zipdist zipfile shdist)){my$method=$target.'_target';$make_frag .= "\n";$make_frag .= $self->$method()}return$make_frag}sub dist_target {my($self)=shift;my$date_check=$self->oneliner(<<'CODE',['-l']);return sprintf <<'MAKE_FRAG',$date_check}sub tardist_target {my($self)=shift;return <<'MAKE_FRAG'}sub zipdist_target {my($self)=shift;return <<'MAKE_FRAG'}sub tarfile_target {my($self)=shift;return <<'MAKE_FRAG'}sub zipfile_target {my($self)=shift;return <<'MAKE_FRAG'}sub uutardist_target {my($self)=shift;return <<'MAKE_FRAG'}sub shdist_target {my($self)=shift;return <<'MAKE_FRAG'}sub dlsyms {return ''}sub dynamic_bs {my($self,%attribs)=@_;return "\nBOOTSTRAP =\n" unless$self->has_link_code();my@exts;if ($self->{XSMULTI}){@exts=$self->_xs_list_basenames}else {@exts='$(BASEEXT)'}return join "\n","BOOTSTRAP = @{[map { qq{$_.bs} } @exts]}\n",map {$self->_xs_make_bs($_)}@exts}sub _xs_make_bs {my ($self,$basename)=@_;my ($v,$d,$f)=File::Spec->splitpath($basename);my@d=File::Spec->splitdir($d);shift@d if$self->{XSMULTI}and $d[0]eq 'lib';my$instdir=$self->catdir('$(INST_ARCHLIB)','auto',@d,$f);$instdir='$(INST_ARCHAUTODIR)' if$basename eq '$(BASEEXT)';my$instfile=$self->catfile($instdir,"$f.bs");my$exists="$instdir\$(DFSEP).exists";return _sprintf562 <<'MAKE_FRAG',$basename,$instfile,$exists}sub dynamic_lib {my($self,%attribs)=@_;return '' unless$self->needs_linking();return '' unless$self->has_link_code;my@m=$self->xs_dynamic_lib_macros(\%attribs);my@libs;my$dlsyms_ext=eval {$self->xs_dlsyms_ext};if ($self->{XSMULTI}){my@exts=$self->_xs_list_basenames;for my$ext (@exts){my ($v,$d,$f)=File::Spec->splitpath($ext);my@d=File::Spec->splitdir($d);shift@d if$d[0]eq 'lib';my$instdir=$self->catdir('$(INST_ARCHLIB)','auto',@d,$f);eval {require DynaLoader};if (defined&DynaLoader::mod2fname){$f=&DynaLoader::mod2fname([@d,$f])}my$instfile=$self->catfile($instdir,"$f.\$(DLEXT)");my$objfile=$self->_xsbuild_value('xs',$ext,'OBJECT');$objfile="$ext\$(OBJ_EXT)" unless defined$objfile;my$ldfrom=$self->_xsbuild_value('xs',$ext,'LDFROM');$ldfrom=$objfile unless defined$ldfrom;my$exportlist="$ext.def";my@libchunk=($objfile,$instfile,$instdir,$ldfrom,$exportlist);push@libchunk,$dlsyms_ext ? $ext.$dlsyms_ext : undef;push@libs,\@libchunk}}else {my@libchunk=qw($(OBJECT) $(INST_DYNAMIC) $(INST_ARCHAUTODIR) $(LDFROM) $(EXPORT_LIST));push@libchunk,$dlsyms_ext ? '$(BASEEXT)'.$dlsyms_ext : undef;@libs=(\@libchunk)}push@m,map {$self->xs_make_dynamic_lib(\%attribs,@$_)}@libs;return join("\n",@m)}sub xs_dynamic_lib_macros {my ($self,$attribs)=@_;my$otherldflags=$attribs->{OTHERLDFLAGS}|| "";my$inst_dynamic_dep=$attribs->{INST_DYNAMIC_DEP}|| "";my$armaybe=$self->_xs_armaybe($attribs);my$ld_opt=$Is{OS2}? '$(OPTIMIZE) ' : '';my$ld_fix=$Is{OS2}? '|| ( $(RM_F) $@ && sh -c false )' : '';sprintf <<'EOF',$armaybe,$ld_opt.$otherldflags,$inst_dynamic_dep,$ld_fix}sub _xs_armaybe {my ($self,$attribs)=@_;my$armaybe=$attribs->{ARMAYBE}|| $self->{ARMAYBE}|| ":";$armaybe='ar' if ($Is{OSF}and $armaybe eq ':');$armaybe}sub xs_make_dynamic_lib {my ($self,$attribs,$object,$to,$todir,$ldfrom,$exportlist,$dlsyms)=@_;$exportlist='' if$exportlist ne '$(EXPORT_LIST)';my$armaybe=$self->_xs_armaybe($attribs);my@m=sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP) %s'."\n",$to,$object,$todir,$exportlist,($dlsyms || '');my$dlsyms_arg=$self->xs_dlsyms_arg($dlsyms);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};my$ldrun=$Is{IRIX}&& $self->{LD_RUN_PATH}? qq{-rpath "$self->{LD_RUN_PATH}"} : '';push(@m," \$(RM_F) \$\@\n");my$libs='$(LDLOADLIBS)';if (($Is{NetBSD}|| $Is{Interix}|| $Is{Android})&& $Config{'useshrplib'}eq 'true'){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'}elsif ($Is{Android}){$libs .= ' "-L$(PERL_INC)" -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,$dlsyms_arg,$ldfrom,$self->xs_obj_opt('$@'),$libs,$exportlist;join '',@m}sub exescan {my($self,$path)=@_;$path}sub extliblist {my($self,$libs)=@_;require ExtUtils::Liblist;$self->ext($libs,$Verbose)}sub find_perl {my($self,$ver,$names,$dirs,$trace)=@_;if ($trace >= 2){print "Looking for perl $ver by these names:
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
@all = sort keys %{ maniread() };
print(qq{Executing $(CI) @all\n});
system(qq{$(CI) @all}) == 0 or die $!;
print(qq{Executing $(RCS_LABEL) ...\n});
system(qq{$(RCS_LABEL) @all}) == 0 or die $!;
EOF
print 'Warning: Makefile possibly out of date with $(VERSION_FROM)'
if -e '$(VERSION_FROM)' and -M '$(VERSION_FROM)' < -M '$(FIRST_MAKEFILE)';
CODE
dist : $(DIST_DEFAULT) $(FIRST_MAKEFILE)
$(NOECHO) %s
MAKE_FRAG
tardist : $(DISTVNAME).tar$(SUFFIX)
$(NOECHO) $(NOOP)
MAKE_FRAG
zipdist : $(DISTVNAME).zip
$(NOECHO) $(NOOP)
MAKE_FRAG
$(DISTVNAME).tar$(SUFFIX) : distdir
$(PREOP)
$(TO_UNIX)
$(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME)
$(RM_RF) $(DISTVNAME)
$(COMPRESS) $(DISTVNAME).tar
$(NOECHO) $(ECHO) 'Created $(DISTVNAME).tar$(SUFFIX)'
$(POSTOP)
MAKE_FRAG
$(DISTVNAME).zip : distdir
$(PREOP)
$(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME)
$(RM_RF) $(DISTVNAME)
$(NOECHO) $(ECHO) 'Created $(DISTVNAME).zip'
$(POSTOP)
MAKE_FRAG
uutardist : $(DISTVNAME).tar$(SUFFIX)
uuencode $(DISTVNAME).tar$(SUFFIX) $(DISTVNAME).tar$(SUFFIX) > $(DISTVNAME).tar$(SUFFIX)_uu
$(NOECHO) $(ECHO) 'Created $(DISTVNAME).tar$(SUFFIX)_uu'
MAKE_FRAG
shdist : distdir
$(PREOP)
$(SHAR) $(DISTVNAME) > $(DISTVNAME).shar
$(RM_RF) $(DISTVNAME)
$(NOECHO) $(ECHO) 'Created $(DISTVNAME).shar'
$(POSTOP)
MAKE_FRAG
# 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.
%1$s.bs : $(FIRST_MAKEFILE) $(BOOTDEP)
$(NOECHO) $(ECHO) "Running Mkbootstrap for %1$s ($(BSLOADLIBS))"
$(NOECHO) $(PERLRUN) \
"-MExtUtils::Mkbootstrap" \
-e "Mkbootstrap('%1$s','$(BSLOADLIBS)');"
$(NOECHO) $(TOUCH) "%1$s.bs"
$(CHMOD) $(PERM_RW) "%1$s.bs"
%2$s : %1$s.bs %3$s
$(NOECHO) $(RM_RF) %2$s
- $(CP_NONEMPTY) %1$s.bs %2$s $(PERM_RW)
MAKE_FRAG
# This section creates the dynamically loadable objects from relevant
# objects and possibly $(MYEXTLIB).
ARMAYBE = %s
OTHERLDFLAGS = %s
INST_DYNAMIC_DEP = %s
INST_DYNAMIC_FIX = %s
EOF
%s$(LD) %s $(LDDLFLAGS) %s %s $(OTHERLDFLAGS) %s $(MYEXTLIB) \
$(PERL_ARCHIVE) %s $(PERL_ARCHIVE_AFTER) %s \
$(INST_DYNAMIC_FIX)
$(CHMOD) $(PERM_RWX) $@
MAKE
@$names
in these dirs:
@$dirs
"}my$stderr_duped=0;local*STDERR_COPY;unless ($Is{BSD}){if(open(STDERR_COPY,'>&STDERR')){$stderr_duped=1}else {warn <<WARNING}}for my$name (@$names){my ($abs,$use_dir);if ($self->file_name_is_absolute($name)){$abs=$name}elsif ($self->canonpath($name)eq $self->canonpath(basename($name))){$use_dir=1}else {$abs=$self->catfile($Curdir,$name)}for my$dir ($use_dir ? @$dirs : 1){next unless defined$dir;$abs=$self->catfile($dir,$name)if$use_dir;print "Checking $abs\n" if ($trace >= 2);next unless$self->maybe_command($abs);print "Executing $abs\n" if ($trace >= 2);my$val;my$version_check=qq{"$abs" -le "require $ver; print qq{VER_OK}"};if ($Is{BSD}){$val=`$version_check 2>&1`}else {close STDERR if$stderr_duped;$val=`$version_check`;open STDERR,">&STDERR_COPY" 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}sub fixin {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*//;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};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)=@_;for my$file ($old,$new){if($Is{VMS}and basename($file)!~ /\./){$file="$file."}}return rename($old,$new)}sub _fixin_replace_shebang {my ($self,$file,$line)=@_;my ($cmd,$arg)=split ' ',$line,2;$cmd =~ s!^.*/!!;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='';for my$dir (@absdirs){my$maybefile=$self->catfile($dir,$cmd);if ($self->maybe_command($maybefile)){warn "Ignoring $interpreter in $file\n" if$Verbose && $interpreter;$interpreter=$maybefile}}}my ($does_shbang)=$Config{'sharpbang'}=~ /^\s*\#\!/;my ($shb)="";if ($interpreter){print "Changing sharpbang in $file to $interpreter" if$Verbose;if ($does_shbang){$shb .= "$Config{'sharpbang'}$interpreter";$shb .= ' ' .$arg if defined$arg;$shb .= "\n"}}else {warn "Can't find $cmd in PATH, $file unchanged" if$Verbose;return}return$shb}sub force {my($self)=shift;'# Phony target to force checking subdirectories.
find_perl() can't dup STDERR: $!
You might see some garbage while we search for Perl
WARNING
FORCE :
$(NOECHO) $(NOOP)
'}sub guess_name {my($self)=@_;use Cwd 'cwd';my$name=basename(cwd());$name =~ s|[\-_][\d\.\-]+\z||;print "Warning: Guessing NAME [$name] from current directory name.\n";$name}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}sub init_dirscan {my($self)=@_;my(%dir,%xs,%c,%o,%h,%pl_files,%pm);my%ignore=map {($_=>1)}qw(Makefile.PL Build.PL test.pl t);$Is{VMS}? $ignore{"$self->{DISTVNAME}.dir"}=1 : $ignore{$self->{DISTVNAME}}=1;my$distprefix=$Is{VMS}? qr/^\Q$self->{DISTNAME}\E-v?[\d\.]+\.dir$/i : qr/^\Q$self->{DISTNAME}\E-v?[\d\.]+$/;@ignore{map lc,keys%ignore}=values%ignore if$Is{VMS};if (defined$self->{XS}and!defined$self->{C}){my@c_files=grep {m/\.c(pp|xx)?\z/i}values %{$self->{XS}};my@o_files=grep {m/(?:.(?:o(?:bj)?)|\$\(OBJ_EXT\))\z/i}values %{$self->{XS}};%c=map {$_=>1}@c_files;%o=map {$_=>1}@o_files}for my$name ($self->lsdir($Curdir)){next if$name =~ /\#/;next if$name =~ $distprefix && -d $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;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{$name}=1 unless$name =~ m/perlmain\.c/}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){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}};%o=(%o,map {$_=>1}grep s/\.c(pp|xx|c)?\z/$self->{OBJ_EXT}/i,@o_files);$self->{O_FILES}=[sort keys%o]}sub init_MANPODS {my$self=shift;for 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 {$ispod=1}return$ispod}sub init_MAN1PODS {my($self)=@_;if (exists$self->{EXE_FILES}){for my$name (@{$self->{EXE_FILES}}){next unless$self->_has_pod($name);$self->{MAN1PODS}->{$name}=$self->catfile("\$(INST_MAN1DIR)",basename($name).".\$(MAN1EXT)")}}}sub init_MAN3PODS {my$self=shift;my%manifypods=();for 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}};for my$name (keys%manifypods){if (($self->{PERL_CORE}and $name =~ /(config|setup).*\.pm/is)or ($name =~ m/^README\.pod$/i)){delete$manifypods{$name};next}my($manpagename)=$name;$manpagename =~ s/\.p(od|m|l)\z//;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)")}}sub init_PM {my$self=shift;unless($self->{PMLIBDIRS}){if($Is{VMS}){$self->{PMLIBDIRS}=['./lib',"./$self->{BASEEXT}"]}else {$self->{PMLIBDIRS}=['lib',$self->{BASEEXT}]}}my (@pmlibdirs)=@{$self->{PMLIBDIRS}};@{$self->{PMLIBDIRS}}=();my%dir=map {($_=>$_)}@{$self->{DIR}};for 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 /~$/;return if /,v$/;return if m{\.swp$};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;$inst=$self->libscan($inst);print "libscan($path) => '$inst'\n" if ($Verbose >= 2);return unless$inst;if ($self->{XSMULTI}and $inst =~ /\.xs\z/){my($base);($base=$path)=~ s/\.xs\z//;$self->{XS}{$path}="$base.c";push @{$self->{C}},"$base.c";push @{$self->{O_FILES}},"$base$self->{OBJ_EXT}"}else {$self->{PM}{$path}=$inst}},@{$self->{PMLIBDIRS}})}}sub init_DIRFILESEP {my($self)=shift;$self->{DIRFILESEP}='/'}sub init_main {my($self)=@_;$self->{FULLEXT}=$self->catdir(split /::/,$self->{NAME});my(@modparts)=split(/::/,$self->{NAME});my($modfname)=$modparts[-1];eval {require DynaLoader};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){$self->{DLBASE}=$modfname}else {$self->{DLBASE}='$(BASEEXT)'}my$inc_config_dir=dirname($INC{'Config.pm'});my$inc_carp_dir=dirname($INC{'Carp.pm'});unless ($self->{PERL_SRC}){for my$dir_count (1..8){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");$self->{PERL_ARCHLIB}=$self->{PERL_LIB};$self->{PERL_INC}=($Is{Win32})? $self->catdir($self->{PERL_LIB},"CORE"): $self->{PERL_SRC};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 {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");my$perl_h;if (not -f ($perl_h=$self->catfile($self->{PERL_INC},"perl.h"))and not $old){my$lib;for my$dir (@INC){$lib=$dir,last if -e $self->catfile($dir,"Config.pm")}if ($lib){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}}}}if ($Is{Android}){$self->{PERL_LIB}=File::Spec->rel2abs($self->{PERL_LIB});$self->{PERL_ARCHLIB}=File::Spec->rel2abs($self->{PERL_ARCHLIB})}$self->{PERL_INCDEP}=$self->{PERL_INC};$self->{PERL_ARCHLIBDEP}=$self->{PERL_ARCHLIB};$self->{INSTALLDIRS}||= "site";$self->{MAN1EXT}||= $Config{man1ext};$self->{MAN3EXT}||= $Config{man3ext};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);for 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}$self->{AR_STATIC_ARGS}||= "cr";$self->{OBJ_EXT}||= '.o';$self->{LIB_EXT}||= '.a';$self->{MAP_TARGET}||= "perl";$self->{LIBPERL_A}||= "libperl$self->{LIB_EXT}";warn "Warning: PERL_LIB ($self->{PERL_LIB}) seems not to be a perl library directory
... Detected uninstalled Perl. Trying to continue.
EOP
(strict.pm not found)" unless -f $self->catfile("$self->{PERL_LIB}","strict.pm")|| $self->{NAME}eq "ExtUtils::MakeMaker"}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->{TEST_S}||= "test -s";$self->{CP}||= "cp";$self->{MV}||= "mv";$self->{CHMOD}||= "chmod";$self->{FALSE}||= 'false';$self->{TRUE}||= 'true';$self->{LD}||= 'ld';return$self->SUPER::init_tools(@_);$self->{SHELL}||= '/bin/sh';return}sub init_linker {my($self)=shift;$self->{PERL_ARCHIVE}||= '';$self->{PERL_ARCHIVEDEP}||= '';$self->{PERL_ARCHIVE_AFTER}||= '';$self->{EXPORT_LIST}||= ''}sub init_lib2arch {my($self)=shift;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}}}sub init_PERL {my($self)=shift;my@defpath=();for my$component ($self->{PERL_SRC},$self->path(),$Config{binexp}){push@defpath,$component if defined$component}my$thisperl=$self->canonpath($^X);$thisperl .= $Config{exe_ext}unless $Is{VMS}? $thisperl =~ m/$Config{exe_ext}(;\d+)?$/i : $thisperl =~ m/$Config{exe_ext}$/i;$thisperl=$self->abs2rel($thisperl)if$self->{PERL_CORE};my@perls=($thisperl);push@perls,map {"$_$Config{exe_ext}"}("perl$Config{version}",'perl5','perl');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);my$perl=$self->{PERL};$perl =~ s/^"//;my$has_mcr=$perl =~ s/^MCR\s*//;my$perlflags='';my$stripped_perl;while ($perl){($stripped_perl=$perl)=~ s/"$//;last if -x $stripped_perl;last unless$perl =~ s/(\s+\S+)$//;$perlflags=$1.$perlflags}$self->{PERL}=$stripped_perl;$self->{PERL}='MCR '.$self->{PERL}if$has_mcr || $Is{VMS};my$perl_name='perl';$perl_name='ndbgperl' if$Is{VMS}&& defined$Config{usevmsdebug}&& $Config{usevmsdebug}eq 'define';unless ($self->{FULLPERL}){($self->{FULLPERL}=$self->{PERL})=~ s/\Q$miniperl\E$/$perl_name$Config{exe_ext}/i;$self->{FULLPERL}=qq{"$self->{FULLPERL}"}.$perlflags}$self->{FULLPERL}=~ tr/"//d if$Is{VMS};$self->{ABSPERL}=$self->{PERL};$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});$self->{ABSPERL}=$self->quote_literal($self->{ABSPERL})if$self->{ABSPERL}=~ /\s/;$self->{ABSPERL}='MCR '.$self->{ABSPERL}if$has_mcr}$self->{PERL}=qq{"$self->{PERL}"}.$perlflags;$self->{PERL}=~ tr/"//d if$Is{VMS};$self->{PERL_CORE}=$ENV{PERL_CORE}unless exists$self->{PERL_CORE};$self->{PERL_CORE}=0 unless defined$self->{PERL_CORE};my$lib_paths=$self->{UNINSTALLED_PERL}|| $self->{PERL_CORE}? ($self->{PERL_ARCHLIB}&& $self->{PERL_LIB}&& $self->{PERL_ARCHLIB}ne $self->{PERL_LIB})? q{ "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)"} : q{ "-I$(PERL_LIB)"} : undef;my$inst_lib_paths=$self->{INST_ARCHLIB}ne $self->{INST_LIB}? 'RUN)'.$perlflags.' "-I$(INST_ARCHLIB)" "-I$(INST_LIB)"' : 'RUN)'.$perlflags.' "-I$(INST_LIB)"';for my$perl (qw(PERL FULLPERL ABSPERL)){my$run=$perl.'RUN';$self->{$run}=qq{\$($perl)};$self->{$run}.= $lib_paths if$lib_paths;$self->{$perl.'RUNINST'}='$('.$perl.$inst_lib_paths}return 1}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='';for my$macro (qw(MM_Unix_VERSION PERL_MALLOC_DEF)){next unless defined$self->{$macro};$make_frag .= "$macro = $self->{$macro}\n"}return$make_frag}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}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');if ($self->{XSMULTI}){my@exts=$self->_xs_list_basenames;my (@statics,@dynamics,@boots);for my$ext (@exts){my ($v,$d,$f)=File::Spec->splitpath($ext);my@d=File::Spec->splitdir($d);shift@d if defined$d[0]and $d[0]eq 'lib';my$instdir=$self->catdir('$(INST_ARCHLIB)','auto',@d,$f);my$instfile=$self->catfile($instdir,$f);push@statics,"$instfile\$(LIB_EXT)";my$dynfile=$instfile;eval {require DynaLoader};if (defined&DynaLoader::mod2fname){$dynfile=$self->catfile($instdir,&DynaLoader::mod2fname([@d,$f]))}push@dynamics,"$dynfile.\$(DLEXT)";push@boots,"$instfile.bs"}$self->{INST_STATIC}=join ' ',@statics;$self->{INST_DYNAMIC}=join ' ',@dynamics;$self->{INST_BOOT}=join ' ',@boots}}else {$self->{INST_STATIC}='';$self->{INST_DYNAMIC}='';$self->{INST_BOOT}=''}}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) \
};push@m,q{ read "}.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{" \
write "}.$self->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q{" \
} unless$self->{NO_PACKLIST};push@m,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) \
};push@m,q{ read "}.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \
write "}.$self->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{" \
} unless$self->{NO_PACKLIST};push@m,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) \
};push@m,q{ read "}.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \
write "}.$self->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').q{" \
} unless$self->{NO_PACKLIST};push@m,q{ "$(INST_LIB)" "$(DESTINSTALLVENDORLIB)" \
"$(INST_ARCHLIB)" "$(DESTINSTALLVENDORARCH)" \
"$(INST_BIN)" "$(DESTINSTALLVENDORBIN)" \
"$(INST_SCRIPT)" "$(DESTINSTALLVENDORSCRIPT)" \
"$(INST_MAN1DIR)" "$(DESTINSTALLVENDORMAN1DIR)" \
"$(INST_MAN3DIR)" "$(DESTINSTALLVENDORMAN3DIR)"
};push@m,q{
doc_perl_install :: all
$(NOECHO) $(NOOP)
doc_site_install :: all
$(NOECHO) $(NOOP)
doc_vendor_install :: all
$(NOECHO) $(NOOP)
} if$self->{NO_PERLLOCAL};push@m,q{
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{"
} unless$self->{NO_PERLLOCAL};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)}sub installbin {my($self)=shift;return "" unless$self->{EXE_FILES}&& ref$self->{EXE_FILES}eq "ARRAY";my@exefiles=sort @{$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;my$to=$self->libscan($path);print "libscan($from) => '$to'\n" if ($Verbose >=2);$to=vmsify($to)if$Is{VMS};$fromto{$from}=$to}my@to=sort values%fromto;my@m;push(@m,qq{
EXE_FILES = @exefiles
pure_all :: @to
\$(NOECHO) \$(NOOP)
realclean ::
});push@m,map "\t$_\n",$self->split_command('$(RM_F)',@to);push@m,"\n";my@froms=sort keys%fromto;for my$from (@froms){push@m,_sprintf562 <<'MAKE',$from,$fromto{$from}}join "",@m}sub linkext {my($self,%attribs)=@_;my$linktype=$attribs{LINKTYPE};$linktype=$self->{LINKTYPE}unless defined$linktype;if (defined$linktype and $linktype eq ''){warn "Warning: LINKTYPE set to '', no longer necessary\n"}$linktype='$(LINKTYPE)' unless defined$linktype;"
%2$s : %1$s $(FIRST_MAKEFILE) $(INST_SCRIPT)$(DFSEP).exists $(INST_BIN)$(DFSEP).exists
$(NOECHO) $(RM_F) %2$s
$(CP) %1$s %2$s
$(FIXIN) %2$s
-$(NOECHO) $(CHMOD) $(PERM_RWX) %2$s
MAKE
linkext :: $linktype
\$(NOECHO) \$(NOOP)
"}sub lsdir {my(undef,$dir,$regex)=@_;opendir(my$dh,defined($dir)? $dir : ".")or return;my@ls=readdir$dh;closedir$dh;@ls=grep(/$regex/,@ls)if defined$regex;@ls}sub macro {my($self,%attribs)=@_;my@m;for my$key (sort keys%attribs){my$val=$attribs{$key};push@m,"$key = $val\n"}join "",@m}sub makeaperl {my($self,%attribs)=@_;my($makefilename,$searchdirs,$static,$extra,$perlinc,$target,$tmp,$libperl)=@attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};s/^(.*)/"-I$1"/ for @{$perlinc || []};my(@m);push@m,"
# --- MakeMaker makeaperl section ---
MAP_TARGET = $target
FULLPERL = $self->{FULLPERL}
MAP_PERLINC = @{$perlinc || []}
";return join '',@m if$self->{PARENT};my($dir)=join ":",@{$self->{DIR}};unless ($self->{MAKEAPERL}){push@m,q{
$(MAP_TARGET) :: $(MAKE_APERL_FILE)
$(MAKE) $(USEMAKEFILE) $(MAKE_APERL_FILE) $@
$(MAKE_APERL_FILE) : static $(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=};for (@ARGV){my$arg=$_;if ($arg =~ /(^.*?=)(.*['\s].*)/){$arg=$1 .$self->quote_literal($2)}push@m," \\\n\t\t$arg"}push@m,"\n";return join '',@m}my$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\)/;my$linkcmd=join ' ',"\$(CC)",grep($_,@Config{qw(ldflags ccdlflags)});$linkcmd =~ s/\s+/ /g;$linkcmd =~ s,(perl\.exp),\$(PERL_INC)/$1,;my%static;require File::Find;my$installed_version=join('/','auto',$self->{FULLEXT},"$self->{BASEEXT}$self->{LIB_EXT}");File::Find::find(sub {if ($File::Find::name =~ m{/auto/share\z}){$File::Find::prune=1;return}return unless m/\Q$self->{LIB_EXT}\E$/;return unless -f 'extralibs.ld';return if m/^libperl/ or m/^perl\Q$self->{LIB_EXT}\E$/;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;for 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;for my$excl (@{$self->{EXCLUDE_EXT}}){return if($xx eq $excl)}}return if$File::Find::name =~ m:\Q$installed_version\E\z:;use Cwd 'cwd';$static{cwd()."/" .$_}++},grep(-d $_,map {$self->catdir($_,'auto')}@{$searchdirs || []}));$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 ||= ".";my@map_static=reverse sort keys%static;push@m,"
MAP_LINKCMD = $linkcmd
MAP_STATIC = ",join(" \\\n\t",map {qq{"$_"}}@map_static),"
MAP_STATICDEP = ",join(' ',map {$self->quote_dep($_)}@map_static),"
MAP_PRELIBS = $Config{perllibs} $Config{cryptlib}
";my$lperl;if (defined$libperl){($lperl=$libperl)=~ s/\$\(A\)/$self->{LIB_EXT}/}unless ($libperl && -f $lperl){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){if ($Is{SunOS}){$lperl=$libperl="$dir/$Config{libperl}";$libperl='' if$Is{SunOS4}}}print <<EOF unless -f $lperl || defined($self->{PERL_SRC})}my$llibperl=$libperl ? '$(MAP_LIBPERL)' : '-lperl';my$libperl_dep=$self->quote_dep($libperl);push@m,"
Warning: $libperl not found
If you're going to build a static perl binary, make sure perl is installed
otherwise ignore this warning
EOF
MAP_LIBPERL = $libperl
MAP_LIBPERLDEP = $libperl_dep
LLIBPERL = $llibperl
";push@m,'
$(INST_ARCHAUTODIR)/extralibs.all : $(INST_ARCHAUTODIR)$(DFSEP).exists '.join(" \\\n\t",@$extra).'
$(NOECHO) $(RM_F) $@
$(NOECHO) $(TOUCH) $@
';for my$catfile (@$extra){push@m,"\tcat $catfile >> \$\@\n"}my$ldfrom=$self->{XSMULTI}? '' : '$(LDFROM)';push@m,_sprintf562 <<'EOF',$tmp,$ldfrom,$self->xs_obj_opt('$@'),$makefilename;push@m,"\t".$self->cd($tmp,qq[$cccmd "-I\$(PERL_INC)" perlmain.c])."\n";my$maybe_DynaLoader=$Config{usedl}? 'q(DynaLoader)' : '';push@m,_sprintf562 <<'EOF',$tmp,$makefilename,$maybe_DynaLoader;push@m,"\t",q{$(NOECHO) $(PERL) "$(INSTALLSCRIPT)/fixpmain"
$(MAP_TARGET) :: %1$s/perlmain$(OBJ_EXT) $(MAP_LIBPERLDEP) $(MAP_STATICDEP) $(INST_ARCHAUTODIR)/extralibs.all
$(MAP_LINKCMD) %2$s $(OPTIMIZE) %1$s/perlmain$(OBJ_EXT) %3$s $(MAP_STATIC) "$(LLIBPERL)" `cat $(INST_ARCHAUTODIR)/extralibs.all` $(MAP_PRELIBS)
$(NOECHO) $(ECHO) "To install the new '$(MAP_TARGET)' binary, call"
$(NOECHO) $(ECHO) " $(MAKE) $(USEMAKEFILE) %4$s inst_perl MAP_TARGET=$(MAP_TARGET)"
$(NOECHO) $(ECHO) " $(MAKE) $(USEMAKEFILE) %4$s map_clean"
%1$s/perlmain\$(OBJ_EXT): %1$s/perlmain.c
EOF
%1$s/perlmain.c: %2$s
$(NOECHO) $(ECHO) Writing $@
$(NOECHO) $(PERL) $(MAP_PERLINC) "-MExtUtils::Miniperl" \
-e "writemain(grep(s#.*/auto/##s, @ARGV), %3$s)" $(MAP_STATIC) > $@t
$(MV) $@t $@
EOF
} 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}sub makefile {my($self)=shift;my$m;$m='
$(OBJECT) : $(FIRST_MAKEFILE)
' if$self->{OBJECT};my$newer_than_target=$Is{VMS}? '$(MMS$SOURCE_LIST)' : '$?';my$mpl_args=join " ",map qq["$_"],@ARGV;my$cross='';if (defined$::Cross::platform){$cross="-MCross=$::Cross::platform "}$m .= sprintf <<'MAKE_FRAG',$newer_than_target,$cross,$mpl_args;return$m}sub maybe_command {my($self,$file)=@_;return$file if -x $file &&!-d $file;return}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}for my$child (keys %{$self->{CHILDREN}}){if ($self->{CHILDREN}->{$child}->needs_linking){$self->{NEEDS_LINKING}=1;return 1}}return$self->{NEEDS_LINKING}=0}sub parse_abstract {my($self,$parsefile)=@_;my$result;local $/="\n";open(my$fh,'<',$parsefile)or die "Could not open '$parsefile': $!";binmode$fh;my$inpod=0;my$pod_encoding;my$package=$self->{DISTNAME};$package =~ s/-/::/g;while (<$fh>){$inpod=/^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;next if!$inpod;s#\r*\n\z##;if (/^=encoding\s*(.*)$/i){$pod_encoding=$1}if (/^($package(?:\.pm)? \s+ -+ \s+)(.*)/x){$result=$2;next}next unless$result;if ($result && (/^\s*$/ || /^\=/)){last}$result=join ' ',$result,$_}close$fh;if ($pod_encoding and!($] < 5.008 or!$Config{useperlio})){eval {require Encode;$result=Encode::decode($pod_encoding,$result)}}return$result}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){$result=$self->get_version($parsefile,$1,$2)}else {next}last if defined$result}close$fh;if (defined$result && $result !~ /^v?[\d_\.]+$/){require version;my$normal=eval {version->new($result)};$result=$normal if defined$normal}$result="undef" unless defined$result;return$result}sub get_version {my ($self,$parsefile,$sigil,$name)=@_;my$line=$_;{package ExtUtils::MakeMaker::_version;undef*version;eval {require version;version::->import};no strict;local *{$name};local $^W=0;$line=$1 if$line =~ m{^(.+)}s;eval($line);return ${$name}}}sub pasthru {my($self)=shift;my(@m);my(@pasthru);my($sep)=$Is{VMS}? ',' : '';$sep .= "\\\n\t";for my$key (qw(LIB LIBPERL_A LINKTYPE OPTIMIZE PREFIX INSTALL_BASE)){next unless defined$self->{$key};push@pasthru,"$key=\"\$($key)\""}for my$key (qw(DEFINE INC)){my$val=qq{\$($key)};chomp($val=$self->{$key})if defined$self->{$key};$val .= " \$(PASTHRU_$key)";my$quoted=$self->quote_literal($val);push@pasthru,qq{PASTHRU_$key=$quoted}}push@m,"\nPASTHRU = ",join ($sep,@pasthru),"\n";join "",@m}sub perl_script {my($self,$file)=@_;return$file if -r $file && -f _;return}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};return join "",@m unless$self->needs_linking;if ($self->{OBJECT}){push@m,$self->_perl_header_files_fragment("/")}push@m,join(" ",sort values %{$self->{XS}})." : \$(XSUBPPDEPS)\n" if %{$self->{XS}};return join "\n",@m}sub pm_to_blib {my$self=shift;my($autodir)=$self->catdir('$(INST_LIB)','auto');my$r=q{
# 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) %sMakefile.PL %s
$(NOECHO) $(ECHO) "==> Your Makefile has been rebuilt. <=="
$(NOECHO) $(ECHO) "==> Please rerun the $(MAKE) command. <=="
$(FALSE)
MAKE_FRAG
# 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_INCDEP)/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
pm_to_blib : $(FIRST_MAKEFILE) $(TO_INST_PM)
};my$pm_to_blib=$self->oneliner(<<CODE,['-MExtUtils::Install']);my@cmds=$self->split_command($pm_to_blib,map {($self->quote_literal($_)=>$self->quote_literal($self->{PM}->{$_}))}sort keys %{$self->{PM}});$r .= join '',map {"\t\$(NOECHO) $_\n"}@cmds;$r .= qq{\t\$(NOECHO) \$(TOUCH) pm_to_blib\n};return$r}sub _ppd_version {my ($self,$string)=@_;return join ',',((split /\./,$string),(0)x 4)[0..3]}sub ppd {my($self)=@_;my$abstract=$self->{ABSTRACT}|| '';$abstract =~ s/\n/\\n/sg;$abstract =~ s/</</g;$abstract =~ s/>/>/g;my$author=join(', ',@{ref$self->{AUTHOR}eq 'ARRAY' ? $self->{AUTHOR}: [$self->{AUTHOR}|| '']});$author =~ s/</</g;$author =~ s/>/>/g;my$ppd_file="$self->{DISTNAME}.ppd";my@ppd_chunks=qq(<SOFTPKG NAME="$self->{DISTNAME}" VERSION="$self->{VERSION}">\n);push@ppd_chunks,sprintf <<'PPD_HTML',$abstract,$author;push@ppd_chunks," <IMPLEMENTATION>\n";if ($self->{MIN_PERL_VERSION}){my$min_perl_version=$self->_ppd_version($self->{MIN_PERL_VERSION});push@ppd_chunks,sprintf <<'PPD_PERLVERS',$min_perl_version}my%prereqs=%{$self->{PREREQ_PM}};delete$prereqs{perl};for my$prereq (sort keys%prereqs){my$name=$prereq;$name .= '::' unless$name =~ /::/;my$version=$prereqs{$prereq};my%attrs=(NAME=>$name);$attrs{VERSION}=$version if$version;my$attrs=join " ",map {qq[$_="$attrs{$_}"]}sort keys%attrs;push@ppd_chunks,qq( <REQUIRE $attrs />\n)}my$archname=$Config{archname};if ($] >= 5.008){$archname .= "-$Config{PERL_REVISION}.$Config{PERL_VERSION}"}push@ppd_chunks,sprintf <<'PPD_OUT',$archname;if ($self->{PPM_INSTALL_SCRIPT}){if ($self->{PPM_INSTALL_EXEC}){push@ppd_chunks,sprintf qq{ <INSTALL EXEC="%s">%s</INSTALL>\n},$self->{PPM_INSTALL_EXEC},$self->{PPM_INSTALL_SCRIPT}}else {push@ppd_chunks,sprintf qq{ <INSTALL>%s</INSTALL>\n},$self->{PPM_INSTALL_SCRIPT}}}if ($self->{PPM_UNINSTALL_SCRIPT}){if ($self->{PPM_UNINSTALL_EXEC}){push@ppd_chunks,sprintf qq{ <UNINSTALL EXEC="%s">%s</UNINSTALL>\n},$self->{PPM_UNINSTALL_EXEC},$self->{PPM_UNINSTALL_SCRIPT}}else {push@ppd_chunks,sprintf qq{ <UNINSTALL>%s</UNINSTALL>\n},$self->{PPM_UNINSTALL_SCRIPT}}}my ($bin_location)=$self->{BINARY_LOCATION}|| '';$bin_location =~ s/\\/\\\\/g;push@ppd_chunks,sprintf <<'PPD_XML',$bin_location;my@ppd_cmds=$self->stashmeta(join('',@ppd_chunks),$ppd_file);return sprintf <<'PPD_OUT',join "\n\t",@ppd_cmds}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}sub processPL {my$self=shift;my$pl_files=$self->{PL_FILES};return "" unless$pl_files;my$m='';for my$plfile (sort keys %$pl_files){my$list=ref($pl_files->{$plfile})? $pl_files->{$plfile}: [$pl_files->{$plfile}];for my$target (@$list){if($Is{VMS}){$plfile=vmsify($self->eliminate_macros($plfile));$target=vmsify($self->eliminate_macros($target))}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}}return$m}sub specify_shell {return ''}sub quote_paren {my$arg=shift;$arg =~ s{\$\((.+?)\)}{\$\\\\($1\\\\)}g;$arg =~ s{(?<!\\)([()])}{\\$1}g;$arg =~ s{\$\\\\\((.+?)\\\\\)}{\$($1)}g;return$arg}sub replace_manpage_separator {my($self,$man)=@_;$man =~ s,/+,::,g;return$man}sub cd {my($self,$dir,@cmds)=@_;my$make_frag=join "\n\t",map {"cd $dir && $_"}@cmds;return$make_frag}sub oneliner {my($self,$cmd,$switches)=@_;$switches=[]unless defined$switches;$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 --}}sub quote_literal {my($self,$text,$opts)=@_;$opts->{allow_variables}=1 unless defined$opts->{allow_variables};$text =~ s{'}{'\\''}g;$text=$opts->{allow_variables}? $self->escape_dollarsigns($text): $self->escape_all_dollarsigns($text);return "'$text'"}sub escape_newlines {my($self,$text)=@_;$text =~ s{\n}{\\\n}g;return$text}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 {$self->{_MAX_EXEC_LEN}=4096}}return$self->{_MAX_EXEC_LEN}}sub static {my($self)=shift;'
pm_to_blib({\@ARGV}, '$autodir', q[\$(PM_FILTER)], '\$(PERM_DIR)')
CODE
<ABSTRACT>%s</ABSTRACT>
<AUTHOR>%s</AUTHOR>
PPD_HTML
<PERLCORE VERSION="%s" />
PPD_PERLVERS
<ARCHITECTURE NAME="%s" />
PPD_OUT
<CODEBASE HREF="%s" />
</IMPLEMENTATION>
</SOFTPKG>
PPD_XML
# Creates a PPD (Perl Package Description) for a binary distribution.
ppd :
%s
PPD_OUT
pure_all :: $target
\$(NOECHO) \$(NOOP)
$target :: $plfile $pm_dep
\$($perlrun) $plfile $target
MAKE_FRAG
## $(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)
'}sub static_lib {my($self)=@_;return '' unless$self->has_link_code;my(@m);my@libs;if ($self->{XSMULTI}){for my$ext ($self->_xs_list_basenames){my ($v,$d,$f)=File::Spec->splitpath($ext);my@d=File::Spec->splitdir($d);shift@d if$d[0]eq 'lib';my$instdir=$self->catdir('$(INST_ARCHLIB)','auto',@d,$f);my$instfile=$self->catfile($instdir,"$f\$(LIB_EXT)");my$objfile="$ext\$(OBJ_EXT)";push@libs,[$objfile,$instfile,$instdir ]}}else {@libs=([qw($(OBJECT) $(INST_STATIC) $(INST_ARCHAUTODIR)) ])}push@m,map {$self->xs_make_static_lib(@$_)}@libs;join "\n",@m}sub xs_make_static_lib {my ($self,$from,$to,$todir)=@_;my@m=sprintf '%s: %s $(MYEXTLIB) %s$(DFSEP).exists'."\n",$to,$from,$todir;push@m,"\t\$(RM_F) \"\$\@\"\n";push@m,$self->static_lib_fixtures;push@m,$self->static_lib_pure_cmd($from);push@m,"\t\$(CHMOD) \$(PERM_RWX) \$\@\n";push@m,$self->static_lib_closures($todir);join '',@m}sub static_lib_closures {my ($self,$todir)=@_;my@m=sprintf <<'MAKE_FRAG',$todir;push@m,<<'MAKE_FRAG' if$self->{PERL_SRC}&& $self->{EXTRALIBS};@m}sub static_lib_fixtures {my ($self)=@_;return unless$self->{MYEXTLIB};"\t\$(CP) \$(MYEXTLIB) \"\$\@\"\n"}sub static_lib_pure_cmd {my ($self,$from)=@_;my$ar;if (exists$self->{FULL_AR}&& -x $self->{FULL_AR}){$ar='FULL_AR'}else {$ar='AR'}sprintf <<'MAKE_FRAG',$ar,$from}sub staticmake {my($self,%attribs)=@_;my(@static);my(@searchdirs)=($self->{PERL_ARCHLIB},$self->{SITEARCHEXP},$self->{INST_ARCHLIB});if (@{$self->{C}}){@static=$self->catfile($self->{INST_ARCHLIB},"auto",$self->{FULLEXT},"$self->{BASEEXT}$self->{LIB_EXT}")}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})}sub subdir_x {my($self,$subdir)=@_;my$subdir_cmd=$self->cd($subdir,'$(MAKE) $(USEMAKEFILE) $(FIRST_MAKEFILE) all $(PASTHRU)');return sprintf <<'EOT',$subdir_cmd}sub subdirs {my($self)=shift;my(@m);for my$dir (@{$self->{DIR}}){push@m,$self->subdir_x($dir)}if (@m){unshift@m,<<'EOF'}else {push(@m,"\n# none")}join('',@m)}sub test {my($self,%attribs)=@_;my$tests=$attribs{TESTS}|| '';if (!$tests && -d 't' && defined$attribs{RECURSIVE_TEST_FILES}){$tests=$self->find_tests_recursive}elsif (!$tests && -d 't'){$tests=$self->find_tests}$tests =~ s!/!\\!g if$self->is_make_type('nmake');my@m;my$default_testtype=$Config{usedl}? 'dynamic' : 'static';push@m,<<EOF;for my$linktype (qw(dynamic static)){my$directdeps=join ' ',grep!$self->{SKIPHASH}{$_},$linktype,"pure_all";push@m,"subdirs-test_$linktype :: $directdeps\n";for my$dir (@{$self->{DIR}}){my$test=$self->cd($dir,"\$(MAKE) test_$linktype \$(PASTHRU)");push@m,"\t\$(NOECHO) $test\n"}push@m,"\n";if ($tests or -f "test.pl"){for my$testspec (['','' ],['db',' $(TESTDB_SW)' ]){my ($db,$switch)=@$testspec;my ($command,$deps);$deps=$db eq 'db' ? $directdeps : "subdirs-test_$linktype";if ($linktype eq 'static' and $self->needs_linking){my$target=File::Spec->rel2abs('$(MAP_TARGET)');$command=qq{"$target" \$(MAP_PERLINC)};$deps .= ' $(MAP_TARGET)'}else {$command='$(FULLPERLRUN)' .$switch}push@m,"test${db}_$linktype :: $deps\n";if ($db eq 'db'){push@m,$self->test_via_script($command,'$(TEST_FILE)')}else {push@m,$self->test_via_script($command,'$(TEST_FILE)')if -f "test.pl";push@m,$self->test_via_harness($command,'$(TEST_FILES)')if$tests}push@m,"\n"}}else {push@m,_sprintf562 <<'EOF',$linktype}}join "",@m}sub test_via_harness {my($self,$perl,$tests)=@_;return$self->SUPER::test_via_harness("PERL_DL_NONLAZY=1 $perl",$tests)}sub test_via_script {my($self,$perl,$script)=@_;return$self->SUPER::test_via_script("PERL_DL_NONLAZY=1 $perl",$script)}sub tool_xsubpp {my($self)=shift;return "" unless$self->needs_linking;my$xsdir;my@xsubpp_dirs=@INC;unshift@xsubpp_dirs,$self->{PERL_LIB}if$self->{PERL_CORE};my$foundxsubpp=0;for my$dir (@xsubpp_dirs){$xsdir=$self->catdir($dir,'ExtUtils');if(-r $self->catfile($xsdir,"xsubpp")){$foundxsubpp=1;last}}die "ExtUtils::MM_Unix::tool_xsubpp : Can't find xsubpp" if!$foundxsubpp;my$tmdir=$self->catdir($self->{PERL_LIB},"ExtUtils");my(@tmdeps)=$self->catfile($tmdir,'typemap');if($self->{TYPEMAPS}){for my$typemap (@{$self->{TYPEMAPS}}){if(!-f $typemap){warn "Typemap $typemap not found.\n"}else {$typemap=vmsify($typemap)if$Is{VMS};push(@tmdeps,$typemap)}}}push(@tmdeps,"typemap")if -f "typemap";my@tmargs=map {'-typemap '.$self->quote_literal(File::Spec->rel2abs($_))}@tmdeps;$_=$self->quote_dep($_)for@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};my$xsdirdep=$self->quote_dep($xsdir);return qq{
$(NOECHO) $(ECHO) "$(EXTRALIBS)" > %s$(DFSEP)extralibs.ld
MAKE_FRAG
$(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)$(DFSEP)ext.libs
MAKE_FRAG
$(%s) $(AR_STATIC_ARGS) "$@" %s
$(RANLIB) "$@"
MAKE_FRAG
subdirs ::
$(NOECHO) %s
EOT
# The default clean, realclean and test targets in this Makefile
# have automatically been given entries for each subdir.
EOF
TEST_VERBOSE=0
TEST_TYPE=test_\$(LINKTYPE)
TEST_FILE = test.pl
TEST_FILES = $tests
TESTDB_SW = -d
testdb :: testdb_\$(LINKTYPE)
\$(NOECHO) \$(NOOP)
test :: \$(TEST_TYPE)
\$(NOECHO) \$(NOOP)
# Occasionally we may face this degenerate target:
test_ : test_$default_testtype
\$(NOECHO) \$(NOOP)
EOF
testdb_%1$s test_%1$s :: subdirs-test_%1$s
$(NOECHO) $(ECHO) 'No tests defined for $(NAME) extension.'
EOF
XSUBPPDIR = $xsdir
XSUBPP = "\$(XSUBPPDIR)\$(DFSEP)xsubpp"
XSUBPPRUN = \$(PERLRUN) \$(XSUBPP)
XSPROTOARG = $self->{XSPROTOARG}
XSUBPPDEPS = @tmdeps $xsdirdep\$(DFSEP)xsubpp
XSUBPPARGS = @tmargs
XSUBPP_EXTRA_ARGS =
}}sub all_target {my$self=shift;return <<'MAKE_EXT'}sub top_targets {my($self)=shift;my(@m);push@m,$self->all_target,"\n" unless$self->{SKIPHASH}{'all'};push@m,sprintf <<'EOF';push@m,'
all :: pure_all manifypods
$(NOECHO) $(NOOP)
MAKE_EXT
pure_all :: config pm_to_blib subdirs linkext
$(NOECHO) $(NOOP)
$(NOECHO) $(NOOP)
subdirs :: $(MYEXTLIB)
$(NOECHO) $(NOOP)
config :: $(FIRST_MAKEFILE) blibdirs
$(NOECHO) $(NOOP)
EOF
$(O_FILES) : $(H_FILES)
' if @{$self->{O_FILES}|| []}&& @{$self->{H}|| []};push@m,q{
help :
perldoc ExtUtils::MakeMaker
};join('',@m)}sub writedoc {my($self,$what,$name,@attribs)=@_;my$time=gmtime($ENV{SOURCE_DATE_EPOCH}|| time);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"}sub xs_c {my($self)=shift;return '' unless$self->needs_linking();'
.xs.c:
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(XSUBPP_EXTRA_ARGS) $*.xs > $*.xsc
$(MV) $*.xsc $*.c
'}sub xs_cpp {my($self)=shift;return '' unless$self->needs_linking();'
.xs.cpp:
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc
$(MV) $*.xsc $*.cpp
'}sub xs_o {my ($self)=@_;return '' unless$self->needs_linking();my$m_o=$self->{XSMULTI}? $self->xs_obj_opt('$*$(OBJ_EXT)'): '';my$frag='';$frag .= sprintf <<'EOF',$m_o unless$self->is_make_type('dmake');if ($self->{XSMULTI}){for my$ext ($self->_xs_list_basenames){my$pmfile="$ext.pm";croak "$ext.xs has no matching $pmfile: $!" unless -f $pmfile;my$version=$self->parse_version($pmfile);my$cccmd=$self->{CONST_CCCMD};$cccmd =~ s/^\s*CCCMD\s*=\s*//;$cccmd =~ s/\$\(DEFINE_VERSION\)/-DVERSION=\\"$version\\"/;$cccmd =~ s/\$\(XS_DEFINE_VERSION\)/-DXS_VERSION=\\"$version\\"/;$self->_xsbuild_replace_macro($cccmd,'xs',$ext,'INC');my$define='$(DEFINE)';$self->_xsbuild_replace_macro($define,'xs',$ext,'DEFINE');$frag .= _sprintf562 <<'EOF',$ext,$cccmd,$m_o,$define}}$frag}sub _xsbuild_replace_macro {my ($self,undef,$xstype,$ext,$varname)=@_;my$value=$self->_xsbuild_value($xstype,$ext,$varname);return unless defined$value;$_[1]=~ s/\$\($varname\)/$value/}sub _xsbuild_value {my ($self,$xstype,$ext,$varname)=@_;return$self->{XSBUILD}{$xstype}{$ext}{$varname}if$self->{XSBUILD}{$xstype}{$ext}{$varname};return$self->{XSBUILD}{$xstype}{all}{$varname}if$self->{XSBUILD}{$xstype}{all}{$varname};()}1;
.xs$(OBJ_EXT) :
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc
$(MV) $*.xsc $*.c
$(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) $*.c %s
EOF
%1$s$(OBJ_EXT): %1$s.xs
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc
$(MV) $*.xsc $*.c
%2$s $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) %4$s $*.c %3$s
EOF
EXTUTILS_MM_UNIX
$fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_VMS';
package ExtUtils::MM_VMS;use strict;use ExtUtils::MakeMaker::Config;require Exporter;BEGIN {if($^O eq 'VMS'){require VMS::Filespec;VMS::Filespec->import}}use File::Basename;our$VERSION='7.30';$VERSION=eval$VERSION;require ExtUtils::MM_Any;require ExtUtils::MM_Unix;our@ISA=qw(ExtUtils::MM_Any ExtUtils::MM_Unix);use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562);our$Revision=$ExtUtils::MakeMaker::Revision;sub wraplist {my($self)=shift;my($line,$hlen)=('',0);for my$word (@_){next unless$word =~ /\w/;$line .= ' ' if length($line);if ($hlen > 80){$line .= "\\\n\t";$hlen=0}$line .= $word;$hlen += length($word)+ 2}$line}sub ext {require ExtUtils::Liblist::Kid;goto&ExtUtils::Liblist::Kid::ext}sub guess_name {my($self)=@_;my($defname,$defpm,@pm,%xs);local*PM;$defname=basename(fileify($ENV{'DEFAULT'}));$defname =~ s![\d\-_]*\.dir.*$!!;$defpm=$defname;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');if (keys%xs){for 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}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}){@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;@snames=sort {my($ba)=$a =~ m!([^:>\]/]+)$!;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}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"}for my$dir (@sdirs){next unless defined$dir;$inabs++ if$self->file_name_is_absolute($dir);if ($inabs==1){for my$name (@snames){push(@cand,$name)if$name =~ /^[\w\-\$]+$/}$inabs++}for my$name (@snames){push@cand,($name !~ m![/:>\]]!)? $self->catfile($dir,$name): $self->fixpath($name,0)}}for my$name (@cand){print "Checking $name\n" if$trace >= 2;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\-]*$//;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}sub _fixin_replace_shebang {my ($self,$file,$line)=@_;my (undef,$arg)=split ' ',$line,2;return$Config{startperl}."\n" .$Config{sharpbang}."perl $arg\n"}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:');for my$dir (@dirs){my$sysfile="$dir$file";for my$ext (@exts){return$file if -x "$sysfile$ext" &&!-d _}}}return 0}sub pasthru {my($self)=shift;my$pasthru=$self->SUPER::pasthru;$pasthru =~ s|(PASTHRU\s*=\s*)|$1/MACRO=(|;$pasthru =~ s|\n\z|)\n|m;$pasthru =~ s|/defi?n?e?=\(?([^\),]+)\)?|,$1|ig;return$pasthru}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;return$make}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 ''}sub replace_manpage_separator {my($self,$man)=@_;$man=unixify($man);$man =~ s#/+#__#g;$man}sub init_DEST {my$self=shift;$self->SUPER::init_DEST;for my$var ($self->installvars){my$destvar='DESTINSTALL'.$var;$self->{$destvar}=$self->eliminate_macros($self->{$destvar})}}sub init_DIRFILESEP {my($self)=shift;$self->{DIRFILESEP}='';return 1}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);for my$def (@terms){next unless$def;my$targ=\@defs;if ($def =~ s/^-([DU])//){$targ=\@udefs if $1 eq 'U';$def =~ s/='(.*)'$/=$1/;$def =~ s/^'(.*)'$/$1/}if ($def =~ /=/){$def =~ s/"/""/g;$def=qq["$def"]}push @$targ,$def}$self->{DEFINE}='';if (@defs){$self->{DEFINE}='/Define=(' .join(',',@defs).')'}if (@udefs){$self->{DEFINE}.= '/Undef=(' .join(',',@udefs).')'}}}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');$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']);$self->{UMASK_NULL}='! ';$self->SUPER::init_tools;$self->{SHELL}||= 'Posix';$self->{DEV_NULL}='';return}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}}sub platform_constants {my($self)=shift;my$make_frag='';for 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}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'})}sub constants {my($self)=@_;for (@ARGV){$_=uc($_)if /POLLUTE/i}for 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)}for 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)}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};$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/){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}$self->{MAKE}='$(MMS)$(MMSQUALIFIERS)';return$self->SUPER::constants}sub special_targets {my$self=shift;my$make_frag .= <<'MAKE_FRAG';return$make_frag}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)"}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).($type eq 'Def' ? '$(PASTHRU_DEFINE)' : '').')'}}$libperl or $libperl=$self->{LIBPERL_A}|| "libperl.olb";if ($self->{'INC'}){my(@includes)=split(/\s+/,$self->{INC});for (@includes){s/^-I//;$incstr .= ','.$self->fixpath($_,1)}}$quals .= "$incstr)";$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{
# 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
install([ from_to => {split('\|', <STDIN>)}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]);
CODE
.SUFFIXES :
.SUFFIXES : $(OBJ_EXT) .c .cpp .cxx .xs
MAKE_FRAG
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
PERLTYPE = $self->{PERLTYPE}
}}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)}sub tools_other {my($self)=@_;my$extra_tools=<<'EXTRA_TOOLS';return$self->SUPER::tools_other .$extra_tools}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}sub c_o {my($self)=@_;return '' unless$self->needs_linking();'
# Just in case anyone is using the old macro.
USEMACROS = $(MACROSTART)
SAY = $(ECHO)
EXTRA_TOOLS
.c$(OBJ_EXT) :
$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
.cpp$(OBJ_EXT) :
$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cpp /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
.cxx$(OBJ_EXT) :
$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cxx /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
'}sub xs_c {my($self)=@_;return '' unless$self->needs_linking();'
.xs.c :
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).xsc
$(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c
'}sub xs_o {my ($self)=@_;return '' unless$self->needs_linking();my$frag='
.xs$(OBJ_EXT) :
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).xsc
$(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c
$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
';if ($self->{XSMULTI}){for my$ext ($self->_xs_list_basenames){my$version=$self->parse_version("$ext.pm");my$ccflags=$self->{CCFLAGS};$ccflags =~ s/\$\(DEFINE_VERSION\)/\"VERSION_MACRO=\\"\"$version\\"\"/;$ccflags =~ s/\$\(XS_DEFINE_VERSION\)/\"XS_VERSION_MACRO=\\"\"$version\\"\"/;$self->_xsbuild_replace_macro($ccflags,'xs',$ext,'INC');$self->_xsbuild_replace_macro($ccflags,'xs',$ext,'DEFINE');$frag .= _sprintf562 <<'EOF',$ext,$ccflags}}$frag}sub _xsbuild_replace_macro {my ($self,undef,$xstype,$ext,$varname)=@_;my$value=$self->_xsbuild_value($xstype,$ext,$varname);return unless defined$value;$_[1]=_vms_replace_qualifier($self,$_[1],$value,$varname)}sub _xsbuild_value {my ($self,$xstype,$ext,$varname)=@_;$ext=unixify($ext);return$self->SUPER::_xsbuild_value($xstype,$ext,$varname)}sub _vms_replace_qualifier {my ($self,$flags,$newflag,$macro)=@_;my$qual_type;my$type_suffix;my$quote_subquals=0;my@subquals_new=split /\s+/,$newflag;if ($macro eq 'DEFINE'){$qual_type='Def';$type_suffix='ine';map {$_ =~ s/^-D//}@subquals_new;$quote_subquals=1}elsif ($macro eq 'INC'){$qual_type='Inc';$type_suffix='lude';map {$_ =~ s/^-I//;$_=$self->fixpath($_)}@subquals_new}my@subquals=();while ($flags =~ m:/${qual_type}\S{0,4}=([^/]+):ig){my$term=$1;$term =~ s/\"//g;$term =~ s:^\((.+)\)$:$1:;push@subquals,split /,/,$term}for my$new (@subquals_new){my ($sq_new,$sqval_new)=split /=/,$new;my$replaced_old=0;for my$old (@subquals){my ($sq,$sqval)=split /=/,$old;if ($sq_new eq $sq){$old=$sq_new;$old .= '=' .$sqval_new if defined($sqval_new)and length($sqval_new);$replaced_old=1;last}}push@subquals,$new unless$replaced_old}if (@subquals){$flags =~ s:/${qual_type}\S{0,4}=[^/]+::ig;map {$_=qq/"$_"/ if $_ !~ m/^\$\(/}@subquals if$quote_subquals;$flags .= "/${qual_type}$type_suffix=(" .join(',',@subquals).')'}return$flags}sub xs_dlsyms_ext {'.opt'}sub dlsyms {my ($self,%attribs)=@_;return '' unless$self->needs_linking;$self->xs_dlsyms_iterator}sub xs_make_dlsyms {my ($self,$attribs,$target,$dep,$name,$dlbase,$funcs,$funclist,$imports,$vars,$extra)=@_;my@m;my$instloc;if ($self->{XSMULTI}){my ($v,$d,$f)=File::Spec->splitpath($target);my@d=File::Spec->splitdir($d);shift@d if$d[0]eq 'lib';$instloc=$self->catfile('$(INST_ARCHLIB)','auto',@d,$f);push@m,"\ndynamic :: $instloc\n\t\$(NOECHO) \$(NOOP)\n" unless$self->{SKIPHASH}{'dynamic'};push@m,"\nstatic :: $instloc\n\t\$(NOECHO) \$(NOOP)\n" unless$self->{SKIPHASH}{'static'};push@m,"\n",sprintf <<'EOF',$instloc,$target}else {push@m,"\ndynamic :: \$(INST_ARCHAUTODIR)$self->{BASEEXT}.opt\n\t\$(NOECHO) \$(NOOP)\n" unless$self->{SKIPHASH}{'dynamic'};push@m,"\nstatic :: \$(INST_ARCHAUTODIR)$self->{BASEEXT}.opt\n\t\$(NOECHO) \$(NOOP)\n" unless$self->{SKIPHASH}{'static'};push@m,"\n",sprintf <<'EOF',$target}push@m,"\n$target : $dep\n\t",q!$(PERLRUN) -MExtUtils::Mksymlists -e "Mksymlists('NAME'=>'!,$name,q!', 'DLBASE' => '!,$dlbase,q!', 'DL_FUNCS' => !,neatvalue($funcs),q!, 'FUNCLIST' => !,neatvalue($funclist),q!, 'IMPORTS' => !,neatvalue($imports),q!, 'DL_VARS' => !,neatvalue($vars);push@m,$extra if defined$extra;push@m,qq!);"\n\t!;my$olb_base=basename($target,'.opt');if ($self->{XSMULTI}){my$olb_dir=$self->catdir(dirname($instloc),$olb_base);push@m,qq!\$(PERL) -e "print ""${olb_dir}${olb_base}\$(LIB_EXT)/Include=!;push@m,($Config{d_vms_case_sensitive_symbols}? uc($olb_base): $olb_base);push@m,'\n' .$olb_dir .$olb_base .'$(LIB_EXT)/Library\n"";" >>$(MMS$TARGET)',"\n"}else {push@m,qq!\$(PERL) -e "print ""\$(INST_ARCHAUTODIR)${olb_base}\$(LIB_EXT)/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 {my($upcase)=$Config{d_vms_case_sensitive_symbols};my(@omods)=split ' ',$self->eliminate_macros($self->{OBJECT});for (@omods){s/\.[^.]*$//;s[\$\(\w+_EXT\)][];s/.*[:>\/\]]//;$_=uc if$upcase};my(@lines);my$tmp=shift@omods;for 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_ARCHAUTODIR)' .$olb_base .'$(LIB_EXT)/Library\n"";" >>$(MMS$TARGET)',"\n"}if (length$self->{LDLOADLIBS}){my($line)='';for my$lib (split ' ',$self->{LDLOADLIBS}){$lib =~ s%\$%\\\$%g;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}sub xs_obj_opt {my ($self,$output_file)=@_;"/OBJECT=$output_file"}sub xs_dynamic_lib_macros {my ($self,$attribs)=@_;my$otherldflags=$attribs->{OTHERLDFLAGS}|| "";my$inst_dynamic_dep=$attribs->{INST_DYNAMIC_DEP}|| "";sprintf <<'EOF',$otherldflags,$inst_dynamic_dep}sub xs_make_dynamic_lib {my ($self,$attribs,$from,$to,$todir,$ldfrom,$exportlist)=@_;my$shr=$Config{'dbgprefix'}.'PerlShr';$exportlist =~ s/.def$/.opt/;_sprintf562 <<'EOF',$to,$todir,$exportlist,$shr,"$shr Sys\$Share:$shr.$Config{'dlext'}"}sub xs_make_static_lib {my ($self,$object,$to,$todir)=@_;my@objects;if ($self->{XSMULTI}){my$lib=$object;$lib =~ s/\$\(OBJ_EXT\)\z//;my$override=$self->_xsbuild_value('xs',$lib,'OBJECT');$object=$override if defined$override;@objects=map {$self->fixpath($_,0)}split /(?<!\^)\s+/,$object}else {push@objects,$object}my@m;for my$obj (@objects){push(@m,sprintf "\n%s : %s\$(DFSEP).exists",$obj,$todir)}push(@m,sprintf "\n\n%s : %s \$(MYEXTLIB)\n",$to,(join ' ',@objects));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 ($self->{MYEXTLIB}){for my$obj (@objects){push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) ' .$obj,"\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";for my$lib (split ' ',$self->{EXTRALIBS}){push(@m,"\t",'$(NOECHO) $(PERL) -e "print qq{',$lib,'\n}" >>$(INST_ARCHAUTODIR)extralibs.ld',"\n")}join('',@m)}sub extra_clean_files {return qw(*.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *.Opt $(BASEEXT).bso .MM_Tmp cxx_repository)}sub zipfile_target {my($self)=shift;return <<'MAKE_FRAG'}sub tarfile_target {my($self)=shift;return <<'MAKE_FRAG'}sub shdist_target {my($self)=shift;return <<'MAKE_FRAG'}sub install {my($self,%attribs)=@_;my(@m);push@m,q[
%1$s$(OBJ_EXT) : %1$s.xs
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs > $(MMS$TARGET_NAME).xsc
$(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c
$(CC)%2$s$(OPTIMIZE) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
EOF
%s : %s
$(CP) $(MMS$SOURCE) $(MMS$TARGET)
EOF
$(INST_ARCHAUTODIR)$(BASEEXT).opt : %s
$(CP) $(MMS$SOURCE) $(MMS$TARGET)
EOF
# This section creates the dynamically loadable objects from relevant
# objects and possibly $(MYEXTLIB).
OTHERLDFLAGS = %s
INST_DYNAMIC_DEP = %s
EOF
%1$s : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt %2$s$(DFSEP).exists %3$s $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
If F$TrnLNm("%4$s").eqs."" Then Define/NoLog/User %5$s
Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) %3$s/Option,$(PERL_INC)perlshr_attr.opt/Option
EOF
$(DISTVNAME).zip : distdir
$(PREOP)
$(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) [.$(DISTVNAME)...]*.*;
$(RM_RF) $(DISTVNAME)
$(POSTOP)
MAKE_FRAG
$(DISTVNAME).tar$(SUFFIX) : distdir
$(PREOP)
$(TO_UNIX)
$(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)...]
$(RM_RF) $(DISTVNAME)
$(COMPRESS) $(DISTVNAME).tar
$(POSTOP)
MAKE_FRAG
shdist : distdir
$(PREOP)
$(SHAR) [.$(DISTVNAME)...]*.*; $(DISTVNAME).share
$(RM_RF) $(DISTVNAME)
$(POSTOP)
MAKE_FRAG
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)
install_vendor :: all 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"
# This hack brought to you by DCL's 255-character command line limit
pure_perl_install ::
];push@m,q[ $(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
] unless$self->{NO_PACKLIST};push@m,q[ $(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 ::
];push@m,q[ $(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
] unless$self->{NO_PACKLIST};push@m,q[ $(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 ::
];push@m,q[ $(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
] unless$self->{NO_PACKLIST};push@m,q[ $(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
];push@m,q[
# Ditto
doc_perl_install ::
$(NOECHO) $(NOOP)
# And again
doc_site_install ::
$(NOECHO) $(NOOP)
doc_vendor_install ::
$(NOECHO) $(NOOP)
] if$self->{NO_PERLLOCAL};push@m,q[
# 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
] unless$self->{NO_PERLLOCAL};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[
uninstall_from_sitedirs ::
$(NOECHO) $(UNINSTALL) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[
uninstall_from_vendordirs ::
$(NOECHO) $(UNINSTALL) ].$self->catfile($self->{VENDORARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[
];join('',@m)}sub perldepend {my($self)=@_;my(@m);if ($self->{OBJECT}){push@m,$self->_perl_header_files_fragment("")}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),sort values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n")if %{$self->{XS}};join('',@m)}our%olbs;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($_);$linkcmd=join ' ',$Config{'ld'},grep($_,@Config{qw(large split ldflags ccdlflags)});$linkcmd =~ s/\s+/ /g;local(%olbs);$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;for 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;for my$excl (@{$self->{EXCLUDE_EXT}}){return if($xx eq $excl)}}$olbs{$ENV{DEFAULT}}=$_},grep(-d $_,@{$searchdirs || []}));$static=[]unless$static;@olbs{@{$static}}=(1)x @{$static};$extra=[]unless$extra && ref$extra eq 'ARRAY';for (sort {length($a)<=> length($b)|| $a cmp $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{$_}";if (-f $extralibs){my%seenthis;open my$list,"<",$extralibs or warn $!,next;while (<$list>){chomp;my$skip=exists($libseen{$_})&&!exists($seenthis{$_});$libseen{$_}++;$seenthis{$_}++;next if$skip;push @$extra,$_}}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}}}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=''}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";for (@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";for (@staticpkgs){push@m,' $(NOECHO) $(PERL) -e "print q{',$_,qq[}" >>${tmpdir}Writemain.tmp\n]}push@m,sprintf <<'MAKE_FRAG',$tmpdir,$tmpdir;push@m,q[
$(NOECHO) $(PERL) $(MAP_PERLINC) -ane "use ExtUtils::Miniperl; writemain(@F)" %sWritemain.tmp >$(MMS$TARGET)
$(NOECHO) $(RM_F) %sWritemain.tmp
MAKE_FRAG
# 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}sub maketext_filter {my($self,$text)=@_;$text =~ s/^([^\s:=]+)(:+\s)/$1 $2/mg;return$text}sub prefixify {my($self,$var,$sprefix,$rprefix,$default)=@_;$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)){}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)}}sub cd {my($self,$dir,@cmds)=@_;$dir=vmspath($dir);my$cmd=join "\n\t",map "$_",@cmds;my$make_frag=sprintf <<'MAKE_FRAG',$dir,$cmd;chomp$make_frag;return$make_frag}sub oneliner {my($self,$cmd,$switches)=@_;$switches=[]unless defined$switches;$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 ' ',map {qq{"$_"}}@$switches;return qq{\$(ABSPERLRUN) $switches -e $cmd "--"}}sub echo {my($self,$text,$file,$opts)=@_;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}sub quote_literal {my($self,$text,$opts)=@_;$opts->{allow_variables}=1 unless defined$opts->{allow_variables};$text =~ s{"}{""}g;$text=$opts->{allow_variables}? $self->escape_dollarsigns($text): $self->escape_all_dollarsigns($text);return qq{"$text"}}sub escape_dollarsigns {my($self,$text)=@_;$text =~ s{\$ (?!\() }{"\$"}gx;return$text}sub escape_all_dollarsigns {my($self,$text)=@_;$text =~ s{\$}{"\$\"}gx;return$text}sub escape_newlines {my($self,$text)=@_;$text =~ s{\n}{-\n}g;return$text}sub max_exec_len {my$self=shift;return$self->{_MAX_EXEC_LEN}||= 256}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_ARCHIVEDEP}||= '';$self->{PERL_ARCHIVE_AFTER}||= ''}sub catdir {my$self=shift;my@args=map {m{\$\(} ? $self->eliminate_macros($_): $_}@_;my$dir=$self->SUPER::catdir(@args);$dir=$self->fixpath($dir,1);return$dir}sub catfile {my$self=shift;my@args=map {m{\$\(} ? $self->eliminate_macros($_): $_}@_;my$file=$self->SUPER::catfile(@args);$file=vmsify($file);return$file}sub eliminate_macros {my($self,$path)=@_;return '' unless$path;$self={}unless ref$self;my($npath)=unixify($path);$npath =~ s{\0$}{};my($complex)=0;my($head,$macro,$tail);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=$self->{$macro};$macro=unixify($macro)unless ($macro =~ /(?<!\^)\s/);$macro =~ s#/\Z(?!\n)##}$npath="$head$macro$tail"}}if ($complex){$npath =~ s#\cB(.*?)\cB#\${$1}#gs}$npath}sub fixpath {my($self,$path,$force_path)=@_;return '' unless$path;$self=bless {},$self unless ref$self;my($fixedpath,$prefix,$name);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)");$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}if (!defined($force_path)and $fixedpath !~ /[:>(.\]]/){$fixedpath=vmspath($fixedpath)if -d $fixedpath}$fixedpath =~ s/\.000000([\]>])/$1/;if ($path =~ /^[\[>][^.\-]/){$fixedpath =~ s/^[^\[<]+//}return$fixedpath}sub os_flavor {return('VMS')}sub is_make_type {my($self,$type)=@_;return 0}sub make_type {"$Config{make}-style"}1;
startdir = F$Environment("Default")
Set Default %s
%s
Set Default 'startdir'
MAKE_FRAG
EXTUTILS_MM_VMS
$fatpacked{"ExtUtils/MM_VOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_VOS';
package ExtUtils::MM_VOS;use strict;our$VERSION='7.30';$VERSION=eval$VERSION;require ExtUtils::MM_Unix;our@ISA=qw(ExtUtils::MM_Unix);sub extra_clean_files {return qw(*.kp)}1;
EXTUTILS_MM_VOS
$fatpacked{"ExtUtils/MM_Win32.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_WIN32';
package ExtUtils::MM_Win32;use strict;use ExtUtils::MakeMaker::Config;use File::Basename;use File::Spec;use ExtUtils::MakeMaker qw(neatvalue _sprintf562);require ExtUtils::MM_Any;require ExtUtils::MM_Unix;our@ISA=qw(ExtUtils::MM_Any ExtUtils::MM_Unix);our$VERSION='7.30';$VERSION=eval$VERSION;$ENV{EMXSHELL}='sh';my ($BORLAND,$GCC,$MSVC)=_identify_compiler_environment(\%Config);sub _identify_compiler_environment {my ($config)=@_;my$BORLAND=$config->{cc}=~ /\bbcc/i ? 1 : 0;my$GCC=$config->{cc}=~ /\bgcc\b/i ? 1 : 0;my$MSVC=$config->{cc}=~ /\b(?:cl|icl)/i ? 1 : 0;return ($BORLAND,$GCC,$MSVC)}sub dlsyms {my($self,%attribs)=@_;return '' if$self->{SKIPHASH}{'dynamic'};$self->xs_dlsyms_iterator(\%attribs)}sub xs_dlsyms_ext {'.def'}sub replace_manpage_separator {my($self,$man)=@_;$man =~ s,/+,.,g;$man}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;if ($file =~ /($e)$/i){return$file if -e $file}else {for (@e){return "$file$_" if -e "$file$_"}}return}sub init_DIRFILESEP {my($self)=shift;$self->{DIRFILESEP}=$self->is_make_type('nmake')? '^\\' : $self->is_make_type('dmake')? '\\\\' : $self->is_make_type('gmake')? '/' : '\\'}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;delete$self->{SHELL};return}sub init_others {my$self=shift;$self->{LD}||= 'link';$self->{AR}||= 'lib';$self->SUPER::init_others;$self->{LDLOADLIBS}||= $Config{libs};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}sub init_platform {my($self)=shift;$self->{MM_Win32_VERSION}=$VERSION;return}sub platform_constants {my($self)=shift;my$make_frag='';for my$macro (qw(MM_Win32_VERSION)){next unless defined$self->{$macro};$make_frag .= "$macro = $self->{$macro}\n"}return$make_frag}sub specify_shell {my$self=shift;return '' unless$self->is_make_type('gmake');"\nSHELL = $ENV{COMSPEC}\n"}sub constants {my$self=shift;my$make_text=$self->SUPER::constants;return$make_text unless$self->is_make_type('dmake');my$size=$self->{MAXLINELENGTH}|| 800000;my$prefix=qq{
# Get dmake to read long commands like PM_TO_BLIB
MAXLINELENGTH = $size
};return$prefix .$make_text}sub special_targets {my($self)=@_;my$make_frag=$self->SUPER::special_targets;$make_frag .= <<'MAKE_FRAG' if$self->is_make_type('dmake');return$make_frag}sub static_lib_pure_cmd {my ($self,$from)=@_;$from =~ s/(\$\(\w+)(\))/$1:^"+"$2/g if$BORLAND;sprintf qq{\t\$(AR) %s\n},($BORLAND ? '$@ ' .$from : ($GCC ? '-ru $@ ' .$from : '-out:$@ ' .$from))}sub xs_make_dynamic_lib {my ($self,$attribs,$from,$to,$todir,$ldfrom,$exportlist)=@_;my@m=sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(INST_DYNAMIC_DEP)'."\n",$to,$from,$todir,$exportlist;if ($GCC){push@m,_sprintf562 <<'EOF',$exportlist,$ldfrom}elsif ($BORLAND){my$ldargs=$self->is_make_type('dmake')? q{"$(PERL_ARCHIVE:s,/,\,)" $(LDLOADLIBS:s,/,\,) $(MYEXTLIB:s,/,\,),} : q{"$(subst /,\,$(PERL_ARCHIVE))" $(subst /,\,$(LDLOADLIBS)) $(subst /,\,$(MYEXTLIB)),};my$subbed;if ($exportlist eq '$(EXPORT_LIST)'){$subbed=$self->is_make_type('dmake')? q{$(EXPORT_LIST:s,/,\,)} : q{$(subst /,\,$(EXPORT_LIST))}}else {($subbed=$exportlist)=~ s#/#\\#g}push@m,sprintf <<'EOF',$ldfrom,$ldargs .$subbed}else {push@m,sprintf <<'EOF',$ldfrom,$exportlist;push(@m,q{ if exist [email protected] mt -nologo -manifest [email protected] -outputresource:$@;2
.USESHELL :
MAKE_FRAG
$(LD) %1$s -o $@ $(LDDLFLAGS) %2$s $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) -Wl,--enable-auto-image-base
EOF
$(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) %s,$@,,%s,$(RESFILES)
EOF
$(LD) -out:$@ $(LDDLFLAGS) %s $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) -def:%s
EOF
if exist [email protected] del [email protected]})}push@m,"\n\t\$(CHMOD) \$(PERM_RWX) \$\@\n";join '',@m}sub xs_dynamic_lib_macros {my ($self,$attribs)=@_;my$otherldflags=$attribs->{OTHERLDFLAGS}|| ($BORLAND ? 'c0d32.obj': '');my$inst_dynamic_dep=$attribs->{INST_DYNAMIC_DEP}|| "";sprintf <<'EOF',$otherldflags,$inst_dynamic_dep}sub extra_clean_files {my$self=shift;return$GCC ? (qw(dll.base dll.exp)): ('*.pdb')}sub init_linker {my$self=shift;$self->{PERL_ARCHIVE}="\$(PERL_INC)\\$Config{libperl}";$self->{PERL_ARCHIVEDEP}="\$(PERL_INCDEP)\\$Config{libperl}";$self->{PERL_ARCHIVE_AFTER}='';$self->{EXPORT_LIST}='$(BASEEXT).def'}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}sub can_dep_space {my$self=shift;1}sub quote_dep {my ($self,$arg)=@_;if ($arg =~ / / and not $self->is_make_type('gmake')){require Win32;$arg=Win32::GetShortPathName($arg);die <<EOF if not defined$arg or $arg =~ / /;return$arg}return$self->SUPER::quote_dep($arg)}sub xs_obj_opt {my ($self,$output_file)=@_;($MSVC ? "/Fo" : "-o ").$output_file}sub pasthru {my($self)=shift;my$old=$self->SUPER::pasthru;return$old unless$self->is_make_type('nmake');$old =~ s/(PASTHRU\s*=\s*)/$1 -nologo /;$old}sub arch_check {my$self=shift;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}sub oneliner {my($self,$cmd,$switches)=@_;$switches=[]unless defined$switches;$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};$text =~ s{\\\\"}{\\\\\\\\\\"}g;$text =~ s{(?<!\\)\\"}{\\\\\\"}g;$text =~ s{(?<!\\)"}{\\"}g;$text=qq{"$text"} if$text =~ /[ \t]/;my@text=split /("[^"]*")/,$text;s{([<>|&^@!])}{^$1}g foreach grep {!/^"[^"]*"$/}@text;$text=join('',@text);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)=@_;$text =~ s{\n}{\\\n}g;return$text}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));my$make_frag=sprintf <<'MAKE_FRAG',$dir,$cmd,$updirs;chomp$make_frag;return$make_frag}sub max_exec_len {my$self=shift;return$self->{_MAX_EXEC_LEN}||= 2 * 1024}sub os_flavor {return('Win32')}sub cflags {my($self,$libperl)=@_;return$self->{CFLAGS}if$self->{CFLAGS};return '' unless$self->needs_linking();my$base=$self->SUPER::cflags($libperl);for (split /\n/,$base){/^(\S*)\s*=\s*(\S*)$/ and $self->{$1}=$2};$self->{CCFLAGS}.= " -DPERLDLL" if ($self->{LINKTYPE}eq 'static');return$self->{CFLAGS}=qq{
# This section creates the dynamically loadable objects from relevant
# objects and possibly $(MYEXTLIB).
OTHERLDFLAGS = %s
INST_DYNAMIC_DEP = %s
EOF
Tried to use make dependency with space for non-GNU make:
'$arg'
Fallback to short pathname failed.
EOF
cd %s
%s
cd %s
MAKE_FRAG
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
PERLTYPE = $self->{PERLTYPE}
}}sub make_type {my ($self)=@_;my$make=$self->make;$make=+(File::Spec->splitpath($make))[-1];$make =~ s!\.exe$!!i;if ($make =~ m![^A-Z0-9]!i){($make)=grep {m!make!i}split m![^A-Z0-9]!i,$make}return "$make-style"}1;
EXTUTILS_MM_WIN32
$fatpacked{"ExtUtils/MM_Win95.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_WIN95';
package ExtUtils::MM_Win95;use strict;our$VERSION='7.30';$VERSION=eval$VERSION;require ExtUtils::MM_Win32;our@ISA=qw(ExtUtils::MM_Win32);use ExtUtils::MakeMaker::Config;sub max_exec_len {my$self=shift;return$self->{_MAX_EXEC_LEN}||= 1024}sub os_flavor {my$self=shift;return ($self->SUPER::os_flavor,'Win9x')}1;
EXTUTILS_MM_WIN95
$fatpacked{"ExtUtils/MY.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MY';
package ExtUtils::MY;use strict;require ExtUtils::MM;our$VERSION='7.30';$VERSION=eval$VERSION;our@ISA=qw(ExtUtils::MM);{package MY;our@ISA=qw(ExtUtils::MY)}sub DESTROY {}
EXTUTILS_MY
$fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MAKEMAKER';
package ExtUtils::MakeMaker;use strict;BEGIN {require 5.006}require Exporter;use ExtUtils::MakeMaker::Config;use ExtUtils::MakeMaker::version;use Carp;use File::Path;my$CAN_DECODE=eval {require ExtUtils::MakeMaker::Locale};eval {ExtUtils::MakeMaker::Locale::reinit('UTF-8')}if$CAN_DECODE and Encode::find_encoding('locale')->name eq 'ascii';our$Verbose=0;our@Parent;our@Get_from_Config;our@MM_Sections;our@Overridable;my@Prepend_parent;my%Recognized_Att_Keys;our%macro_fsentity;our%macro_dep;our$VERSION='7.30';$VERSION=eval$VERSION;(our$Revision=$VERSION)=~ s{_}{};$Revision=int$Revision * 10000;our$Filename=__FILE__;our@ISA=qw(Exporter);our@EXPORT=qw(&WriteMakefile $Verbose &prompt &os_unsupported);our@EXPORT_OK=qw($VERSION &neatvalue &mkbootstrap &mksymlists &WriteEmptyMakefile &open_for_writing &write_file_via_tmp &_sprintf562);my$Is_VMS=$^O eq 'VMS';my$Is_Win32=$^O eq 'MSWin32';our$UNDER_CORE=$ENV{PERL_CORE};full_setup();require ExtUtils::MM;require ExtUtils::MY;sub _sprintf562 {my ($format,@args)=@_;for (my$i=1;$i <= @args;$i++){$format =~ s#%$i\$s#$args[$i-1]#g}$format}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}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',OBJECT=>['ARRAY',''],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',XSBUILD=>'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 {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)=@_;for my$key (sort keys %$att){my$val=$att->{$key};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"}}}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 ($;$) {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){$ans =~ s{\015?\012$}{}}else {print "\n"}}return (!defined$ans || $ans eq '')? $def : $ans}sub os_unsupported {die "OS unsupported\n"}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,'.';for 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 ($@){die "ERROR from evaluation of $dir/Makefile.PL: $@"}}my$PACKNAME='PACK000';sub full_setup {$Verbose ||= 0;my@dep_macros=qw/PERL_INCDEP PERL_ARCHLIBDEP PERL_ARCHIVEDEP/;my@fs_macros=qw/FULLPERL XSUBPPDIR 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 MAKE LIBPERL_A LIB PERL_SRC PERL_INC PPM_INSTALL_EXEC PPM_UNINSTALL_EXEC PPM_INSTALL_SCRIPT PPM_UNINSTALL_SCRIPT/;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 FULLPERLRUN FULLPERLRUNINST FUNCLIST H IMPORTS INC INCLUDE_EXT LDFROM LIBS LICENSE LINKTYPE 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 NO_PACKLIST NO_PERLLOCAL NORECURS NO_VC OBJECT OPTIMIZE PERL_MALLOC_OK PERL PERLMAINCC PERLRUN PERLRUNINST PERL_CORE PERM_DIR PERM_RW PERM_RWX MAGICXS PL_FILES PM PM_FILTER PMLIBDIRS PMLIBPARENTDIRS POLLUTE PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST VERSION VERSION_FROM XS XSBUILD XSMULTI XSOPT XSPROTOARG XS_VERSION clean depend dist dynamic_lib linkext macro realclean tool_autosplit MAN1EXT MAN3EXT MACPERL_SRC MACPERL_LIB MACLIBS_68K MACLIBS_PPC MACLIBS_SC MACLIBS_MRC MACLIBS_ALL_68K MACLIBS_ALL_PPC MACLIBS_SHARED/;push@attrib_help,@fs_macros;@macro_fsentity{@fs_macros,@dep_macros}=(1)x (@fs_macros+@dep_macros);@macro_dep{@dep_macros}=(1)x @dep_macros;@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_bs dynamic 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);@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];push@MM_Sections,"postamble";push@Overridable,"postamble";@Recognized_Att_Keys{@MM_Sections}=(1)x @MM_Sections;@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);push@Get_from_Config,qw(vendorarchexp vendorlibexp) if $] >= 5.006;for my$item (@attrib_help){$Recognized_Att_Keys{$item}=1}for my$item (@Get_from_Config){$Recognized_Att_Keys{uc$item}=$Config{$item};print "Attribute '\U$item\E' => '$Config{$item}'\n" if ($Verbose >= 2)}@Prepend_parent=qw(INST_BIN INST_LIB INST_ARCHLIB INST_SCRIPT MAP_TARGET INST_MAN1DIR INST_MAN3DIR PERL_SRC PERL FULLPERL)}sub _has_cpan_meta_requirements {return eval {require CPAN::Meta::Requirements;CPAN::Meta::Requirements->VERSION(2.130);require B}}sub new {my($class,$self)=@_;my($key);_convert_compat_attrs($self)if defined$self && $self;for my$k (keys %$self){$self->{ARGS}{$k}=$self->{$k}}$self={}unless defined$self;bless$self,"MM";my%key2cmr;for my$key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)){$self->{$key}||= {};if (_has_cpan_meta_requirements){my$cmr=CPAN::Meta::Requirements->from_string_hash($self->{$key},{bad_version_hook=>sub {my$fallback;if ($_[0]=~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$!){$fallback=sprintf "%f",$_[0]}else {($fallback)=$_[0]? ($_[0]=~ /^([0-9.]+)/): 0;$fallback += 0;carp "Unparsable version '$_[0]' for prerequisite $_[1] treated as $fallback"}version->new($fallback)},},);$self->{$key}=$cmr->as_string_hash;$key2cmr{$key}=$cmr}else {for my$module (sort keys %{$self->{$key}}){my$version=$self->{$key}->{$module};my$fallback=0;if (!defined($version)or!length($version)){carp "Undefined requirement for $module treated as '0' (CPAN::Meta::Requirements not available)"}elsif ($version =~ /^\d+(?:\.\d+(?:_\d+)*)?$/){next}else {if ($version =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$!){$fallback=sprintf "%f",$version}else {($fallback)=$version ? ($version =~ /^([0-9.]+)/): 0;$fallback += 0;carp "Unparsable version '$version' for prerequisite $module treated as $fallback (CPAN::Meta::Requirements not available)"}}$self->{$key}->{$module}=$fallback}}}if ("@ARGV" =~ /\bPREREQ_PRINT\b/){$self->_PREREQ_PRINT}if ("@ARGV" =~ /\bPRINT_PREREQ\b/){$self->_PRINT_PREREQ}print "MakeMaker (v$VERSION)\n" if$Verbose;if (-f "MANIFEST" &&!-f "Makefile" &&!$UNDER_CORE){check_manifest()}check_hints($self);if (defined$self->{MIN_PERL_VERSION}&& $self->{MIN_PERL_VERSION}!~ /^v?[\d_\.]+$/){require version;my$normal=eval {local$SIG{__WARN__}=sub {die @_};version->new($self->{MIN_PERL_VERSION})};$self->{MIN_PERL_VERSION}=$normal if defined$normal &&!$@}if(defined$self->{MIN_PERL_VERSION}){$self->{MIN_PERL_VERSION}=~ s{ ^v? (\d+) \. (\d+) \. (\d+) $ }
{sprintf "%d.%03d%03d", $1, $2, $3}ex}my$perl_version_ok=eval {local$SIG{__WARN__}=sub {die @_};!$self->{MIN_PERL_VERSION}or $self->{MIN_PERL_VERSION}<= $]};if (!$perl_version_ok){if (!defined$perl_version_ok){die <<'END'}elsif ($self->{PREREQ_FATAL}){die sprintf <<"END",$self->{MIN_PERL_VERSION},$]}else {warn sprintf "Warning: Perl version %s or higher required. We run %s.\n",$self->{MIN_PERL_VERSION},$]}}my%configure_att;my(%initial_att)=%$self;my(%unsatisfied)=();my%prereq2version;my$cmr;if (_has_cpan_meta_requirements){$cmr=CPAN::Meta::Requirements->new;for my$key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)){$cmr->add_requirements($key2cmr{$key})if$key2cmr{$key}}for my$prereq ($cmr->required_modules){$prereq2version{$prereq}=$cmr->requirements_for_module($prereq)}}else {for my$key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)){next unless my$module2version=$self->{$key};$prereq2version{$_}=$module2version->{$_}for keys %$module2version}}for my$prereq (sort keys%prereq2version){my$required_version=$prereq2version{$prereq};my$pr_version=0;my$installed_file;if ($prereq eq 'perl'){if (defined$required_version && $required_version =~ /^v?[\d_\.]+$/ || $required_version !~ /^v?[\d_\.]+$/){require version;my$normal=eval {version->new($required_version)};$required_version=$normal if defined$normal}$installed_file=$prereq;$pr_version=$]}else {$installed_file=MM->_installed_file_for_module($prereq);$pr_version=MM->parse_version($installed_file)if$installed_file;$pr_version=0 if$pr_version eq 'undef';if (!eval {version->new($pr_version);1}){my$fallback;if ($pr_version =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$!){$fallback=sprintf '%f',$pr_version}else {($fallback)=$pr_version ? ($pr_version =~ /^([0-9.]+)/): 0;$fallback += 0;carp "Unparsable version '$pr_version' for installed prerequisite $prereq treated as $fallback"}$pr_version=$fallback}}$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 $UNDER_CORE;$unsatisfied{$prereq}='not installed'}elsif ($cmr ?!$cmr->accepts_module($prereq,$pr_version): $required_version > $pr_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 $UNDER_CORE;$unsatisfied{$prereq}=$required_version || 'unknown version' }}if (%unsatisfied && $self->{PREREQ_FATAL}){my$failedprereqs=join "\n",map {" $_ $unsatisfied{$_}"}sort {$a cmp $b}keys%unsatisfied;die <<"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"}}my$newclass=++$PACKNAME;local@Parent=@Parent;{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';@{"$newclass\:\:ISA"}='MM'}if (defined$Parent[-2]){$self->{PARENT}=$Parent[-2];for my$key (@Prepend_parent){next unless defined$self->{PARENT}{$key};next if defined$self->{ARGS}{$key}and $self->{ARGS}{$key}eq $self->{$key};$self->{$key}=$self->{PARENT}{$key};if ($Is_VMS && $key =~ /PERL$/){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)}else {my$value=$self->{$key};$value =~ s/^"// if$key =~ /PERL$/;$value=$self->catdir("..",$value)unless$self->file_name_is_absolute($value);$value=qq{"$value} if$key =~ /PERL$/;$self->{$key}=$value}}if ($self->{PARENT}){$self->{PARENT}->{CHILDREN}->{$newclass}=$self;for my$opt (qw(POLLUTE PERL_CORE LINKTYPE LD OPTIMIZE)){if (exists$self->{PARENT}->{$opt}and not exists$self->{$opt}){$self->{$opt}=$self->{PARENT}->{$opt}}}}my@fm=grep /^FIRST_MAKEFILE=/,@ARGV;parse_args($self,@fm)if@fm}else {parse_args($self,_shellwords($ENV{PERL_MM_OPT}|| ''),@ARGV)}if (%unsatisfied && $self->{PREREQ_FATAL}){my$failedprereqs=join "\n",map {" $_ $unsatisfied{$_}"}sort {$a cmp $b}keys%unsatisfied;die <<"END"}$self->{NAME}||= $self->guess_name;warn "Warning: NAME must be a package name\n" unless$self->{NAME}=~ m!^[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*$!;($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@args=@ARGV;@args=map {Encode::decode(locale=>$_)}@args if$CAN_DECODE;my($argv)=neatvalue(\@args);$argv =~ s/^\[/(/;$argv =~ s/\]$/)/;push @{$self->{RESULT}},<<END;push @{$self->{RESULT}},$self->_MakeMaker_Parameters_section(\%initial_att);if (defined$self->{CONFIGURE}){push @{$self->{RESULT}},<<END;if (scalar(keys%configure_att)> 0){for 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}for my$skip (@{$self->{SKIP}|| []}){$self->{SKIPHASH}{$skip}=1}delete$self->{SKIP};if ($self->{PARENT}){for (qw/install dist dist_basics dist_core distdir dist_test dist_ci/){$self->{SKIPHASH}{$_}=1}}unless ($self->{NORECURS}){$self->eval_in_subdirs if @{$self->{DIR}}}for my$section (@MM_Sections){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=@_;$att{DIR}=[]unless$att{DIR};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';close$mfh or die "close $new for write: $!"}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}sub _MakeMaker_Parameters_section {my$self=shift;my$att=shift;my@result=<<'END';for my$key (sort keys %$att){next if$key eq 'ARGS';my$v;if ($key eq 'PREREQ_PM'){$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 _shellwords {my (@lines)=@_;my@allwords;for my$line (@lines){$line =~ s/^\s+//;my@words=_parse_line('\s+',0,$line);pop@words if (@words and!defined$words[-1]);return()unless (@words ||!length($line));push(@allwords,@words)}return(@allwords)}sub _parse_line {my($delimiter,$keep,$line)=@_;my($word,@pieces);no warnings 'uninitialized';while (length($line)){$line =~ s/^
Warning: MIN_PERL_VERSION is not in a recognized format.
Recommended is a quoted numerical value like '5.005' or '5.008001'.
END
MakeMaker FATAL: perl version too low for this distribution.
Required is %s. We run %s.
END
MakeMaker FATAL: prerequisites not found.
$failedprereqs
Please install these modules first and rerun 'perl Makefile.PL'.
END
MakeMaker FATAL: prerequisites not found.
$failedprereqs
Please install these modules first and rerun 'perl Makefile.PL'.
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
# MakeMaker 'CONFIGURE' Parameters:
END
all :
manifypods :
subdirs :
dynamic :
static :
clean :
install :
makemakerdflt :
test :
test_dynamic :
test_static :
EOP
# MakeMaker Parameters:
END
(?:
# double quoted string
(") # $quote
((?>[^\\"]*(?:\\.[^\\"]*)*))" # $quoted
| # --OR--
# singe quoted string
(') # $quote
((?>[^\\']*(?:\\.[^\\']*)*))' # $quoted
| # --OR--
# unquoted string
( # $unquoted
(?:\\.|[^\\"'])*?
)
# followed by
( # $delim
\Z(?!\n) # EOL
| # --OR--
(?-x:$delimiter) # delimiter
| # --OR--
(?!^)(?=["']) # a quote
)
)//xs or return;my ($quote,$quoted,$unquoted,$delim)=(($1 ? ($1,$2): ($3,$4)),$5,$6);return()unless(defined($quote)|| length($unquoted)|| length($delim));if ($keep){$quoted="$quote$quoted$quote"}else {$unquoted =~ s/\\(.)/$1/sg;if (defined$quote){$quoted =~ s/\\(.)/$1/sg if ($quote eq '"')}}$word .= substr($line,0,0);$word .= defined$quote ? $quoted : $unquoted;if (length($delim)){push(@pieces,$word);push(@pieces,$delim)if ($keep eq 'delimiters');undef$word}if (!length($line)){push(@pieces,$word)}}return(@pieces)}sub check_manifest {print "Checking if your kit is complete...\n";require ExtUtils::Manifest;$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)=@_;@args=map {Encode::decode(locale=>$_)}@args if$CAN_DECODE;for (@args){unless (m/(.*?)=(.*)/){++$Verbose if m/^verb/;next}my($name,$value)=($1,$2);if ($value =~ m/^~(\w+)?/){$value =~ s [^~(\w*)]
[$1 ?
((getpwnam($1))[7] || "~$1") :
(getpwuid($>))[7]
]ex}$self->{ARGS}{uc$name}=$self->{uc$name}=$value}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}}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}}if (defined$self->{DIR}&& ref \$self->{DIR}eq 'SCALAR'){$self->{DIR}=[grep $_,split ":",$self->{DIR}]}if (defined$self->{INCLUDE_EXT}&& ref \$self->{INCLUDE_EXT}eq 'SCALAR'){$self->{INCLUDE_EXT}=[grep $_,split '\s+',$self->{INCLUDE_EXT}]}if (defined$self->{EXCLUDE_EXT}&& ref \$self->{EXCLUDE_EXT}eq 'SCALAR'){$self->{EXCLUDE_EXT}=[grep $_,split '\s+',$self->{EXCLUDE_EXT}]}for 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)=@_;require File::Spec;my$curdir=File::Spec->curdir;my$hint_dir=File::Spec->catdir($curdir,"hints");return unless -d $hint_dir;my($hint)="${^O}_$Config{osvers}";$hint =~ s/\./_/g;$hint =~ s/_$//;return unless$hint;while (1){last if -f File::Spec->catfile($hint_dir,"$hint.pl")}continue {last unless$hint =~ s/_[^_]*$//}my$hint_file=File::Spec->catfile($hint_dir,"$hint.pl");return unless -f $hint_file;_run_hintfile($self,$hint_file)}sub _run_hintfile {our$self;local($self)=shift;my($hint_file)=shift;local($@,$!);print "Processing hints file $hint_file\n" if$Verbose;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)=@_;local$SIG{__WARN__}=sub {warn @_ unless $_[0]=~ /^Subroutine .* redefined/};for my$method (@Overridable){next unless defined &{"${from}::$method"};no strict 'refs';*{"${to}::$method"}=\&{"${from}::$method"};{package MY;my$super="SUPER::".$method;*{$method}=sub {shift->$super(@_)}}}}sub skipcheck {my($self)=shift;my($section)=@_;return 'skipped' if$section eq 'metafile' && $UNDER_CORE;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 open_for_writing {my ($file)=@_;open my$fh,">",$file or die "Unable to open $file: $!";my@layers=':raw';push@layers,join ' ',':encoding(locale)' if$CAN_DECODE;binmode$fh,join ' ',@layers;$fh}sub flush {my$self=shift;my$finalname=$self->{MAKEFILE};printf "Generating a %s %s\n",$self->make_type,$finalname if$Verbose ||!$self->{PARENT};print "Writing $finalname for $self->{NAME}\n" if$Verbose ||!$self->{PARENT};unlink($finalname,"MakeMaker.tmp",$Is_VMS ? 'Descrip.MMS' : ());write_file_via_tmp($finalname,$self->{RESULT});print "Writing MYMETA.yml and MYMETA.json\n" if!$self->{NO_MYMETA}and $self->write_mymeta($self->mymeta);if ($self->{PARENT}&&!$self->{_KEEP_AFTER_FLUSH}){my%keep=map {($_=>1)}qw(NEEDS_LINKING HAS_LINK_CODE);delete$self->{$_}for grep!$keep{$_},keys %$self}system("$Config::Config{eunicefix} $finalname")if$Config::Config{eunicefix}ne ":";return}sub write_file_via_tmp {my ($finalname,$contents)=@_;my$fh=open_for_writing("MakeMaker.tmp");die "write_file_via_tmp: 2nd arg must be ref" unless ref$contents;for my$chunk (@$contents){my$to_write=$chunk;utf8::encode$to_write if!$CAN_DECODE && $] > 5.008;print$fh "$to_write\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 if!$Is_VMS;return}sub _rename {my($src,$dest)=@_;_unlink($dest);return rename$src,$dest}sub _unlink {my@files=@_;chmod 0666,@files;return unlink@files}sub mkbootstrap {die <<END}sub mksymlists {die <<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,"[";for 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);for my$key (sort keys %$v){last unless defined$key;push@m,"$key=>".neatvalue($v->{$key})}return "{ ".join(', ',@m)." }"}sub _find_magic_vstring {my$value=shift;return$value if$UNDER_CORE;my$tvalue='';require B;my$sv=B::svref_2object(\$value);my$magic=ref($sv)eq 'B::PVMG' ? $sv->MAGIC : undef;while ($magic){if ($magic->TYPE eq 'V'){$tvalue=$magic->PTR;$tvalue =~ s/^v?(.+)$/v$1/;last}else {$magic=$magic->MOREMAGIC}}return$tvalue}sub selfdocument {my($self)=@_;my(@m);if ($Verbose){push@m,"\n# Full list of MakeMaker attribute values:";for 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"}}push@m,<<'EOF';push@m,join "\n",map "$_ ::\n\t\$(NOECHO) \$(NOOP)\n",grep!$self->{SKIPHASH}{$_},qw(static dynamic config);join "\n",@m}1;
!!! Your Makefile has been built such a long time ago, !!!
!!! that is unlikely to work with current MakeMaker. !!!
!!! Please rebuild your Makefile !!!
END
!!! Your Makefile has been built such a long time ago, !!!
!!! that is unlikely to work with current MakeMaker. !!!
!!! Please rebuild your Makefile !!!
END
# here so even if top_targets is overridden, these will still be defined
# gmake will silently still work if any are .PHONY-ed but nmake won't
EOF
EXTUTILS_MAKEMAKER
$fatpacked{"ExtUtils/MakeMaker/Config.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MAKEMAKER_CONFIG';
package ExtUtils::MakeMaker::Config;use strict;our$VERSION='7.30';$VERSION=eval$VERSION;use Config ();our%Config=%Config::Config;sub import {my$caller=caller;no strict 'refs';*{$caller.'::Config'}=\%Config}1;
EXTUTILS_MAKEMAKER_CONFIG
$fatpacked{"ExtUtils/MakeMaker/Locale.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MAKEMAKER_LOCALE';
package ExtUtils::MakeMaker::Locale;use strict;our$VERSION="7.30";$VERSION=eval$VERSION;use base 'Exporter';our@EXPORT_OK=qw(decode_argv env $ENCODING_LOCALE $ENCODING_LOCALE_FS $ENCODING_CONSOLE_IN $ENCODING_CONSOLE_OUT);use Encode ();use Encode::Alias ();our$ENCODING_LOCALE;our$ENCODING_LOCALE_FS;our$ENCODING_CONSOLE_IN;our$ENCODING_CONSOLE_OUT;sub DEBUG () {0}sub _init {if ($^O eq "MSWin32"){unless ($ENCODING_LOCALE){eval {unless (defined&GetConsoleCP){require Win32;*GetConsoleCP=sub {&Win32::GetConsoleCP}if defined&Win32::GetConsoleCP}unless (defined&GetConsoleCP){require Win32::API;Win32::API->Import('kernel32','int GetConsoleCP()')}if (defined&GetConsoleCP){my$cp=GetConsoleCP();$ENCODING_LOCALE="cp$cp" if$cp}}}unless ($ENCODING_CONSOLE_IN){unless (defined&GetInputCP){eval {require Win32;eval {Win32::GetConsoleCP()};*GetInputCP=sub {&Win32::GetConsoleCP}if defined&Win32::GetConsoleCP;*GetOutputCP=sub {&Win32::GetConsoleOutputCP}if defined&Win32::GetConsoleOutputCP};unless (defined&GetInputCP){eval {require Win32::Console;*GetInputCP=sub {&Win32::Console::InputCP}if defined&Win32::Console::InputCP;*GetOutputCP=sub {&Win32::Console::OutputCP}if defined&Win32::Console::OutputCP}}unless (defined&GetInputCP){*GetInputCP=*GetOutputCP=sub {((qx(chcp) || '')=~ /^Active code page: (\d+)/)? $1 : ()}}}my$cp=GetInputCP();$ENCODING_CONSOLE_IN="cp$cp" if$cp;$cp=GetOutputCP();$ENCODING_CONSOLE_OUT="cp$cp" if$cp}}unless ($ENCODING_LOCALE){eval {require I18N::Langinfo;$ENCODING_LOCALE=I18N::Langinfo::langinfo(I18N::Langinfo::CODESET());$ENCODING_LOCALE="ascii" if$ENCODING_LOCALE eq "646";$ENCODING_LOCALE="hp-roman8" if $^O eq "hpux" && $ENCODING_LOCALE eq "roman8"};$ENCODING_LOCALE ||= $ENCODING_CONSOLE_IN}if ($^O eq "darwin"){$ENCODING_LOCALE_FS ||= "UTF-8"}$ENCODING_LOCALE ||= $^O eq "MSWin32" ? "cp1252" : "UTF-8";$ENCODING_LOCALE_FS ||= $ENCODING_LOCALE;$ENCODING_CONSOLE_IN ||= $ENCODING_LOCALE;$ENCODING_CONSOLE_OUT ||= $ENCODING_CONSOLE_IN;unless (Encode::find_encoding($ENCODING_LOCALE)){my$foundit;if (lc($ENCODING_LOCALE)eq "gb18030"){eval {require Encode::HanExtra};if ($@){die "Need Encode::HanExtra to be installed to support locale codeset ($ENCODING_LOCALE), stopped"}$foundit++ if Encode::find_encoding($ENCODING_LOCALE)}die "The locale codeset ($ENCODING_LOCALE) isn't one that perl can decode, stopped" unless$foundit}}_init();Encode::Alias::define_alias(sub {no strict 'refs';no warnings 'once';return ${"ENCODING_" .uc(shift)}},"locale");sub _flush_aliases {no strict 'refs';for my$a (sort keys%Encode::Alias::Alias){if (defined ${"ENCODING_" .uc($a)}){delete$Encode::Alias::Alias{$a};warn "Flushed alias cache for $a" if DEBUG}}}sub reinit {$ENCODING_LOCALE=shift;$ENCODING_LOCALE_FS=shift;$ENCODING_CONSOLE_IN=$ENCODING_LOCALE;$ENCODING_CONSOLE_OUT=$ENCODING_LOCALE;_init();_flush_aliases()}sub decode_argv {die if defined wantarray;for (@ARGV){$_=Encode::decode(locale=>$_,@_)}}sub env {my$k=Encode::encode(locale=>shift);my$old=$ENV{$k};if (@_){my$v=shift;if (defined$v){$ENV{$k}=Encode::encode(locale=>$v)}else {delete$ENV{$k}}}return Encode::decode(locale=>$old)if defined wantarray}1;
EXTUTILS_MAKEMAKER_LOCALE
$fatpacked{"ExtUtils/MakeMaker/version.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MAKEMAKER_VERSION';
package ExtUtils::MakeMaker::version;use 5.006001;use strict;use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);$VERSION='7.30';$VERSION=eval$VERSION;$CLASS='version';{local$SIG{'__DIE__'};eval "use version";if ($@){eval "use ExtUtils::MakeMaker::version::vpp";die "$@" if ($@);local $^W;delete$INC{'version.pm'};$INC{'version.pm'}=$INC{'ExtUtils/MakeMaker/version.pm'};push@version::ISA,"ExtUtils::MakeMaker::version::vpp";$version::VERSION=$VERSION;*version::qv=\&ExtUtils::MakeMaker::version::vpp::qv;*version::declare=\&ExtUtils::MakeMaker::version::vpp::declare;*version::_VERSION=\&ExtUtils::MakeMaker::version::vpp::_VERSION;*version::vcmp=\&ExtUtils::MakeMaker::version::vpp::vcmp;*version::new=\&ExtUtils::MakeMaker::version::vpp::new;if ($] >= 5.009000){no strict 'refs';*version::stringify=\&ExtUtils::MakeMaker::version::vpp::stringify;*{'version::(""'}=\&ExtUtils::MakeMaker::version::vpp::stringify;*{'version::(<=>'}=\&ExtUtils::MakeMaker::version::vpp::vcmp;*version::parse=\&ExtUtils::MakeMaker::version::vpp::parse}require ExtUtils::MakeMaker::version::regex;*version::is_lax=\&ExtUtils::MakeMaker::version::regex::is_lax;*version::is_strict=\&ExtUtils::MakeMaker::version::regex::is_strict;*LAX=\$ExtUtils::MakeMaker::version::regex::LAX;*STRICT=\$ExtUtils::MakeMaker::version::regex::STRICT}elsif (!version->can('is_qv')){*version::is_qv=sub {exists $_[0]->{qv}}}}1;
EXTUTILS_MAKEMAKER_VERSION
$fatpacked{"ExtUtils/MakeMaker/version/regex.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MAKEMAKER_VERSION_REGEX';
package ExtUtils::MakeMaker::version::regex;use strict;use vars qw($VERSION $CLASS $STRICT $LAX);$VERSION='7.30';$VERSION=eval$VERSION;my$FRACTION_PART=qr/\.[0-9]+/;my$STRICT_INTEGER_PART=qr/0|[1-9][0-9]*/;my$LAX_INTEGER_PART=qr/[0-9]+/;my$STRICT_DOTTED_DECIMAL_PART=qr/\.[0-9]{1,3}/;my$LAX_DOTTED_DECIMAL_PART=qr/\.[0-9]+/;my$LAX_ALPHA_PART=qr/_[0-9]+/;my$STRICT_DECIMAL_VERSION=qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;my$STRICT_DOTTED_DECIMAL_VERSION=qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;$STRICT=qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;my$LAX_DECIMAL_VERSION=qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )?
|
$FRACTION_PART $LAX_ALPHA_PART?
/x;my$LAX_DOTTED_DECIMAL_VERSION=qr/
v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )?
|
$LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART?
/x;$LAX=qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;sub is_strict {defined $_[0]&& $_[0]=~ qr/ \A $STRICT \z /x}sub is_lax {defined $_[0]&& $_[0]=~ qr/ \A $LAX \z /x}1;
EXTUTILS_MAKEMAKER_VERSION_REGEX
$fatpacked{"ExtUtils/MakeMaker/version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MAKEMAKER_VERSION_VPP';
package ExtUtils::MakeMaker::charstar;use overload ('""'=>\&thischar,'0+'=>\&thischar,'++'=>\&increment,'--'=>\&decrement,'+'=>\&plus,'-'=>\&minus,'*'=>\&multiply,'cmp'=>\&cmp,'<=>'=>\&spaceship,'bool'=>\&thischar,'='=>\&clone,);sub new {my ($self,$string)=@_;my$class=ref($self)|| $self;my$obj={string=>[split(//,$string)],current=>0,};return bless$obj,$class}sub thischar {my ($self)=@_;my$last=$#{$self->{string}};my$curr=$self->{current};if ($curr >= 0 && $curr <= $last){return$self->{string}->[$curr]}else {return ''}}sub increment {my ($self)=@_;$self->{current}++}sub decrement {my ($self)=@_;$self->{current}--}sub plus {my ($self,$offset)=@_;my$rself=$self->clone;$rself->{current}+= $offset;return$rself}sub minus {my ($self,$offset)=@_;my$rself=$self->clone;$rself->{current}-= $offset;return$rself}sub multiply {my ($left,$right,$swapped)=@_;my$char=$left->thischar();return$char * $right}sub spaceship {my ($left,$right,$swapped)=@_;unless (ref($right)){$right=$left->new($right)}return$left->{current}<=> $right->{current}}sub cmp {my ($left,$right,$swapped)=@_;unless (ref($right)){if (length($right)==1){return$left->thischar cmp $right}$right=$left->new($right)}return$left->currstr cmp $right->currstr}sub bool {my ($self)=@_;my$char=$self->thischar;return ($char ne '')}sub clone {my ($left,$right,$swapped)=@_;$right={string=>[@{$left->{string}}],current=>$left->{current},};return bless$right,ref($left)}sub currstr {my ($self,$s)=@_;my$curr=$self->{current};my$last=$#{$self->{string}};if (defined($s)&& $s->{current}< $last){$last=$s->{current}}my$string=join('',@{$self->{string}}[$curr..$last]);return$string}package ExtUtils::MakeMaker::version::vpp;use 5.006001;use strict;use Config;use vars qw($VERSION $CLASS @ISA $LAX $STRICT);$VERSION='7.30';$VERSION=eval$VERSION;$CLASS='ExtUtils::MakeMaker::version::vpp';require ExtUtils::MakeMaker::version::regex;*ExtUtils::MakeMaker::version::vpp::is_strict=\&ExtUtils::MakeMaker::version::regex::is_strict;*ExtUtils::MakeMaker::version::vpp::is_lax=\&ExtUtils::MakeMaker::version::regex::is_lax;*LAX=\$ExtUtils::MakeMaker::version::regex::LAX;*STRICT=\$ExtUtils::MakeMaker::version::regex::STRICT;use overload ('""'=>\&stringify,'0+'=>\&numify,'cmp'=>\&vcmp,'<=>'=>\&vcmp,'bool'=>\&vbool,'+'=>\&vnoop,'-'=>\&vnoop,'*'=>\&vnoop,'/'=>\&vnoop,'+='=>\&vnoop,'-='=>\&vnoop,'*='=>\&vnoop,'/='=>\&vnoop,'abs'=>\&vnoop,);eval "use warnings";if ($@){eval '
package
warnings;
sub enabled {return $^W;}
1;
'}sub import {no strict 'refs';my ($class)=shift;unless ($class eq $CLASS){local $^W;*{$class.'::declare'}=\&{$CLASS.'::declare'};*{$class.'::qv'}=\&{$CLASS.'::qv'}}my%args;if (@_){map {$args{$_}=1}@_}else {%args=(qv=>1,'UNIVERSAL::VERSION'=>1,)}my$callpkg=caller();if (exists($args{declare})){*{$callpkg.'::declare'}=sub {return$class->declare(shift)}unless defined(&{$callpkg.'::declare'})}if (exists($args{qv})){*{$callpkg.'::qv'}=sub {return$class->qv(shift)}unless defined(&{$callpkg.'::qv'})}if (exists($args{'UNIVERSAL::VERSION'})){local $^W;*UNIVERSAL::VERSION =\&{$CLASS.'::_VERSION'}}if (exists($args{'VERSION'})){*{$callpkg.'::VERSION'}=\&{$CLASS.'::_VERSION'}}if (exists($args{'is_strict'})){*{$callpkg.'::is_strict'}=\&{$CLASS.'::is_strict'}unless defined(&{$callpkg.'::is_strict'})}if (exists($args{'is_lax'})){*{$callpkg.'::is_lax'}=\&{$CLASS.'::is_lax'}unless defined(&{$callpkg.'::is_lax'})}}my$VERSION_MAX=0x7FFFFFFF;use constant TRUE=>1;use constant FALSE=>0;sub isDIGIT {my ($char)=shift->thischar();return ($char =~ /\d/)}sub isALPHA {my ($char)=shift->thischar();return ($char =~ /[a-zA-Z]/)}sub isSPACE {my ($char)=shift->thischar();return ($char =~ /\s/)}sub BADVERSION {my ($s,$errstr,$error)=@_;if ($errstr){$$errstr=$error}return$s}sub prescan_version {my ($s,$strict,$errstr,$sqv,$ssaw_decimal,$swidth,$salpha)=@_;my$qv=defined$sqv ? $$sqv : FALSE;my$saw_decimal=defined$ssaw_decimal ? $$ssaw_decimal : 0;my$width=defined$swidth ? $$swidth : 3;my$alpha=defined$salpha ? $$salpha : FALSE;my$d=$s;if ($qv && isDIGIT($d)){goto dotted_decimal_version}if ($d eq 'v'){$d++;if (isDIGIT($d)){$qv=TRUE}else {return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}dotted_decimal_version: if ($strict && $d eq '0' && isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)")}while (isDIGIT($d)){$d++}if ($d eq '.'){$saw_decimal++;$d++}else {if ($strict){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}else {goto version_prescan_finish}}{my$i=0;my$j=0;while (isDIGIT($d)){$i++;while (isDIGIT($d)){$d++;$j++;if ($strict && $j > 3){return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)")}}if ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)")}$d++;$alpha=TRUE}elsif ($d eq '.'){if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)")}$saw_decimal++;$d++}elsif (!isDIGIT($d)){last}$j=0}if ($strict && $i < 2){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}}}else {my$j=0;if ($strict){if ($d eq '.'){return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)")}if ($d eq '0' && isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)")}}if ($d eq '-'){return BADVERSION($s,$errstr,"Invalid version format (negative version number)")}while (isDIGIT($d)){$d++}if ($d eq '.'){$saw_decimal++;$d++}elsif (!$d || $d eq ';' || isSPACE($d)|| $d eq '}'){if ($d==$s){return BADVERSION($s,$errstr,"Invalid version format (version required)")}goto version_prescan_finish}elsif ($d==$s){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}elsif ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}elsif (isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)")}else {return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)")}}elsif ($d){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}if ($d &&!isDIGIT($d)&& ($strict ||!($d eq ';' || isSPACE($d)|| $d eq '}'))){return BADVERSION($s,$errstr,"Invalid version format (fractional part required)")}while (isDIGIT($d)){$d++;$j++;if ($d eq '.' && isDIGIT($d-1)){if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)")}if ($strict){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')")}$d=$s;$qv=TRUE;goto dotted_decimal_version}if ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)")}if (!isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)")}$width=$j;$d++;$alpha=TRUE}}}version_prescan_finish: while (isSPACE($d)){$d++}if ($d &&!isDIGIT($d)&& (!($d eq ';' || $d eq '}'))){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}if (defined$sqv){$$sqv=$qv}if (defined$swidth){$$swidth=$width}if (defined$ssaw_decimal){$$ssaw_decimal=$saw_decimal}if (defined$salpha){$$salpha=$alpha}return$d}sub scan_version {my ($s,$rv,$qv)=@_;my$start;my$pos;my$last;my$errstr;my$saw_decimal=0;my$width=3;my$alpha=FALSE;my$vinf=FALSE;my@av;$s=new ExtUtils::MakeMaker::charstar$s;while (isSPACE($s)){$s++}$last=prescan_version($s,FALSE,\$errstr,\$qv,\$saw_decimal,\$width,\$alpha);if ($errstr){if ($s ne 'undef'){require Carp;Carp::croak($errstr)}}$start=$s;if ($s eq 'v'){$s++}$pos=$s;if ($qv){$$rv->{qv}=$qv}if ($alpha){$$rv->{alpha}=$alpha}if (!$qv && $width < 3){$$rv->{width}=$width}while (isDIGIT($pos)){$pos++}if (!isALPHA($pos)){my$rev;for (;;){$rev=0;{my$end=$pos;my$mult=1;my$orev;if (!$qv && $s > $start && $saw_decimal==1){$mult *= 100;while ($s < $end){$orev=$rev;$rev += $s * $mult;$mult /= 10;if ((abs($orev)> abs($rev))|| (abs($rev)> $VERSION_MAX)){warn("Integer overflow in version %d",$VERSION_MAX);$s=$end - 1;$rev=$VERSION_MAX;$vinf=1}$s++;if ($s eq '_'){$s++}}}else {while (--$end >= $s){$orev=$rev;$rev += $end * $mult;$mult *= 10;if ((abs($orev)> abs($rev))|| (abs($rev)> $VERSION_MAX)){warn("Integer overflow in version");$end=$s - 1;$rev=$VERSION_MAX;$vinf=1}}}}push@av,$rev;if ($vinf){$s=$last;last}elsif ($pos eq '.'){$s=++$pos}elsif ($pos eq '_' && isDIGIT($pos+1)){$s=++$pos}elsif ($pos eq ',' && isDIGIT($pos+1)){$s=++$pos}elsif (isDIGIT($pos)){$s=$pos}else {$s=$pos;last}if ($qv){while (isDIGIT($pos)){$pos++}}else {my$digits=0;while ((isDIGIT($pos)|| $pos eq '_')&& $digits < 3){if ($pos ne '_'){$digits++}$pos++}}}}if ($qv){my$len=$#av;$len=2 - $len;while ($len-- > 0){push@av,0}}if ($vinf){$$rv->{original}="v.Inf";$$rv->{vinf}=1}elsif ($s > $start){$$rv->{original}=$start->currstr($s);if ($qv && $saw_decimal==1 && $start ne 'v'){$$rv->{original}='v' .$$rv->{original}}}else {$$rv->{original}='0';push(@av,0)}$$rv->{version}=\@av;if ($s eq 'undef'){$s += 5}return$s}sub new {my$class=shift;unless (defined$class or $#_ > 1){require Carp;Carp::croak('Usage: version::new(class, version)')}my$self=bless ({},ref ($class)|| $class);my$qv=FALSE;if ($#_==1){$qv=TRUE}my$value=pop;if (ref($value)&& eval('$value->isa("version")')){$self->{version}=[@{$value->{version}}];$self->{qv}=1 if$value->{qv};$self->{alpha}=1 if$value->{alpha};$self->{original}=''.$value->{original};return$self}if (not defined$value or $value =~ /^undef$/){push @{$self->{version}},0;$self->{original}="0";return ($self)}if (ref($value)=~ m/ARRAY|HASH/){require Carp;Carp::croak("Invalid version format (non-numeric data)")}$value=_un_vstring($value);if ($Config{d_setlocale}&& eval {require POSIX}){require locale;my$currlocale=POSIX::setlocale(&POSIX::LC_ALL);if (POSIX::localeconv()->{decimal_point}eq ','){$value =~ tr/,/./}}if ($value =~ /\d+.?\d*e[-+]?\d+/){$value=sprintf("%.9f",$value);$value =~ s/(0+)$//}my$s=scan_version($value,\$self,$qv);if ($s){warn("Version string '%s' contains invalid data; " ."ignoring: '%s'",$value,$s)}return ($self)}*parse=\&new;sub numify {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}my$width=$self->{width}|| 3;my$alpha=$self->{alpha}|| "";my$len=$#{$self->{version}};my$digit=$self->{version}[0];my$string=sprintf("%d.",$digit);for (my$i=1 ;$i < $len ;$i++ ){$digit=$self->{version}[$i];if ($width < 3){my$denom=10**(3-$width);my$quot=int($digit/$denom);my$rem=$digit - ($quot * $denom);$string .= sprintf("%0".$width."d_%d",$quot,$rem)}else {$string .= sprintf("%03d",$digit)}}if ($len > 0){$digit=$self->{version}[$len];if ($alpha && $width==3){$string .= "_"}$string .= sprintf("%0".$width."d",$digit)}else {$string .= sprintf("000")}return$string}sub normal {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}my$alpha=$self->{alpha}|| "";my$len=$#{$self->{version}};my$digit=$self->{version}[0];my$string=sprintf("v%d",$digit);for (my$i=1 ;$i < $len ;$i++ ){$digit=$self->{version}[$i];$string .= sprintf(".%d",$digit)}if ($len > 0){$digit=$self->{version}[$len];if ($alpha){$string .= sprintf("_%0d",$digit)}else {$string .= sprintf(".%0d",$digit)}}if ($len <= 2){for ($len=2 - $len;$len!=0;$len-- ){$string .= sprintf(".%0d",0)}}return$string}sub stringify {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}return exists$self->{original}? $self->{original}: exists$self->{qv}? $self->normal : $self->numify}sub vcmp {require UNIVERSAL;my ($left,$right,$swap)=@_;my$class=ref($left);unless (UNIVERSAL::isa($right,$class)){$right=$class->new($right)}if ($swap){($left,$right)=($right,$left)}unless (_verify($left)){require Carp;Carp::croak("Invalid version object")}unless (_verify($right)){require Carp;Carp::croak("Invalid version format")}my$l=$#{$left->{version}};my$r=$#{$right->{version}};my$m=$l < $r ? $l : $r;my$lalpha=$left->is_alpha;my$ralpha=$right->is_alpha;my$retval=0;my$i=0;while ($i <= $m && $retval==0){$retval=$left->{version}[$i]<=> $right->{version}[$i];$i++}if ($retval==0 && $l==$r && $left->{version}[$m]==$right->{version}[$m]&& ($lalpha || $ralpha)){if ($lalpha &&!$ralpha){$retval=-1}elsif ($ralpha &&!$lalpha){$retval=+1}}if ($retval==0 && $l!=$r){if ($l < $r){while ($i <= $r && $retval==0){if ($right->{version}[$i]!=0){$retval=-1}$i++}}else {while ($i <= $l && $retval==0){if ($left->{version}[$i]!=0){$retval=+1}$i++}}}return$retval}sub vbool {my ($self)=@_;return vcmp($self,$self->new("0"),1)}sub vnoop {require Carp;Carp::croak("operation not supported with version object")}sub is_alpha {my ($self)=@_;return (exists$self->{alpha})}sub qv {my$value=shift;my$class=$CLASS;if (@_){$class=ref($value)|| $value;$value=shift}$value=_un_vstring($value);$value='v'.$value unless$value =~ /(^v|\d+\.\d+\.\d)/;my$obj=$CLASS->new($value);return bless$obj,$class}*declare=\&qv;sub is_qv {my ($self)=@_;return (exists$self->{qv})}sub _verify {my ($self)=@_;if (ref($self)&& eval {exists$self->{version}}&& ref($self->{version})eq 'ARRAY'){return 1}else {return 0}}sub _is_non_alphanumeric {my$s=shift;$s=new ExtUtils::MakeMaker::charstar$s;while ($s){return 0 if isSPACE($s);return 1 unless (isALPHA($s)|| isDIGIT($s)|| $s =~ /[.-]/);$s++}return 0}sub _un_vstring {my$value=shift;if (length($value)>= 3 && $value !~ /[._]/ && _is_non_alphanumeric($value)){my$tvalue;if ($] ge 5.008_001){$tvalue=_find_magic_vstring($value);$value=$tvalue if length$tvalue}elsif ($] ge 5.006_000){$tvalue=sprintf("v%vd",$value);if ($tvalue =~ /^v\d+(\.\d+){2,}$/){$value=$tvalue}}}return$value}sub _find_magic_vstring {my$value=shift;my$tvalue='';require B;my$sv=B::svref_2object(\$value);my$magic=ref($sv)eq 'B::PVMG' ? $sv->MAGIC : undef;while ($magic){if ($magic->TYPE eq 'V'){$tvalue=$magic->PTR;$tvalue =~ s/^v?(.+)$/v$1/;last}else {$magic=$magic->MOREMAGIC}}return$tvalue}sub _VERSION {my ($obj,$req)=@_;my$class=ref($obj)|| $obj;no strict 'refs';if (exists$INC{"$class.pm"}and not %{"$class\::"}and $] >= 5.008){require Carp;Carp::croak("$class defines neither package nor VERSION" ."--version check failed")}my$version=eval "\$$class\::VERSION";if (defined$version){local $^W if $] <= 5.008;$version=ExtUtils::MakeMaker::version::vpp->new($version)}if (defined$req){unless (defined$version){require Carp;my$msg=$] < 5.006 ? "$class version $req required--this is only version " : "$class does not define \$$class\::VERSION" ."--version check failed";if ($ENV{VERSION_DEBUG}){Carp::confess($msg)}else {Carp::croak($msg)}}$req=ExtUtils::MakeMaker::version::vpp->new($req);if ($req > $version){require Carp;if ($req->is_qv){Carp::croak(sprintf ("%s version %s required--"."this is only version %s",$class,$req->normal,$version->normal))}else {Carp::croak(sprintf ("%s version %s required--"."this is only version %s",$class,$req->stringify,$version->stringify))}}}return defined$version ? $version->stringify : undef}1;
EXTUTILS_MAKEMAKER_VERSION_VPP
$fatpacked{"ExtUtils/Manifest.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MANIFEST';
package ExtUtils::Manifest;require Exporter;use Config;use File::Basename;use File::Copy 'copy';use File::Find;use File::Spec 0.8;use Carp;use strict;use warnings;our$VERSION='1.70';our@ISA=('Exporter');our@EXPORT_OK=qw(mkmanifest manicheck filecheck fullcheck skipcheck manifind maniread manicopy maniadd maniskip);our$Is_MacOS=$^O eq 'MacOS';our$Is_VMS=$^O eq 'VMS';our$Is_VMS_mode=0;our$Is_VMS_lc=0;our$Is_VMS_nodot=0;if ($Is_VMS){require VMS::Filespec if$Is_VMS;my$vms_unix_rpt;my$vms_efs;my$vms_case;$Is_VMS_mode=1;$Is_VMS_lc=1;$Is_VMS_nodot=1;if (eval {local$SIG{__DIE__};require VMS::Feature}){$vms_unix_rpt=VMS::Feature::current("filename_unix_report");$vms_efs=VMS::Feature::current("efs_charset");$vms_case=VMS::Feature::current("efs_case_preserve")}else {my$unix_rpt=$ENV{'DECC$FILENAME_UNIX_REPORT'}|| '';my$efs_charset=$ENV{'DECC$EFS_CHARSET'}|| '';my$efs_case=$ENV{'DECC$EFS_CASE_PRESERVE'}|| '';$vms_unix_rpt=$unix_rpt =~ /^[ET1]/i;$vms_efs=$efs_charset =~ /^[ET1]/i;$vms_case=$efs_case =~ /^[ET1]/i}$Is_VMS_lc=0 if ($vms_case);$Is_VMS_mode=0 if ($vms_unix_rpt);$Is_VMS_nodot=0 if ($vms_efs)}our$Debug=$ENV{PERL_MM_MANIFEST_DEBUG}|| 0;our$Verbose=defined$ENV{PERL_MM_MANIFEST_VERBOSE}? $ENV{PERL_MM_MANIFEST_VERBOSE}: 1;our$Quiet=0;our$MANIFEST='MANIFEST';our$DEFAULT_MSKIP=File::Spec->catfile(dirname(__FILE__),"$MANIFEST.SKIP");sub _sort {return sort {lc$a cmp lc$b}@_}sub mkmanifest {my$manimiss=0;my$read=(-r 'MANIFEST' && maniread())or $manimiss++;$read={}if$manimiss;local*M;my$bakbase=$MANIFEST;$bakbase =~ s/\./_/g if$Is_VMS_nodot;rename$MANIFEST,"$bakbase.bak" unless$manimiss;open M,"> $MANIFEST" or die "Could not open $MANIFEST: $!";binmode M,':raw';my$skip=maniskip();my$found=manifind();my($key,$val,$file,%all);%all=(%$found,%$read);$all{$MANIFEST}=($Is_VMS_mode ? "$MANIFEST\t\t" : '').'This list of files' if$manimiss;for$file (_sort keys%all){if ($skip->($file)){warn "Removed from $MANIFEST: $file\n" if$Verbose and exists$read->{$file};next}if ($Verbose){warn "Added to $MANIFEST: $file\n" unless exists$read->{$file}}my$text=$all{$file};$file=_unmacify($file);my$tabs=(5 - (length($file)+1)/8);$tabs=1 if$tabs < 1;$tabs=0 unless$text;if ($file =~ /\s/){$file =~ s/([\\'])/\\$1/g;$file="'$file'"}print M$file,"\t" x $tabs,$text,"\n"}close M}sub clean_up_filename {my$filename=shift;$filename =~ s|^\./||;$filename =~ s/^:([^:]+)$/$1/ if$Is_MacOS;if ($Is_VMS){$filename =~ s/\.$//;$filename=VMS::Filespec::unixify($filename);if($Is_VMS_lc){$filename=lc($filename);$filename=uc($filename)if$filename =~ /^MANIFEST(\.SKIP)?$/i}}return$filename}sub manifind {my$p=shift || {};my$found={};my$wanted=sub {my$name=clean_up_filename($File::Find::name);warn "Debug: diskfile $name\n" if$Debug;return if -d $_;$found->{$name}=""};find({wanted=>$wanted,follow_fast=>1},$Is_MacOS ? ":" : ".");return$found}sub manicheck {return _check_files()}sub filecheck {return _check_manifest()}sub fullcheck {return [_check_files()],[_check_manifest()]}sub skipcheck {my($p)=@_;my$found=manifind();my$matches=maniskip();my@skipped=();for my$file (_sort keys %$found){if (&$matches($file)){warn "Skipping $file\n" unless$Quiet;push@skipped,$file;next}}return@skipped}sub _check_files {my$p=shift;my$dosnames=(defined(&Dos::UseLFN)&& Dos::UseLFN()==0);my$read=maniread()|| {};my$found=manifind($p);my(@missfile)=();for my$file (_sort keys %$read){warn "Debug: manicheck checking from $MANIFEST $file\n" if$Debug;if ($dosnames){$file=lc$file;$file =~ s=(\.(\w|-)+)=substr ($1,0,4)=ge;$file =~ s=((\w|-)+)=substr ($1,0,8)=ge}unless (exists$found->{$file}){warn "No such file: $file\n" unless$Quiet;push@missfile,$file}}return@missfile}sub _check_manifest {my($p)=@_;my$read=maniread()|| {};my$found=manifind($p);my$skip=maniskip();my@missentry=();for my$file (_sort keys %$found){next if$skip->($file);warn "Debug: manicheck checking from disk $file\n" if$Debug;unless (exists$read->{$file}){my$canon=$Is_MacOS ? "\t" ._unmacify($file): '';warn "Not in $MANIFEST: $file$canon\n" unless$Quiet;push@missentry,$file}}return@missentry}sub maniread {my ($mfile)=@_;$mfile ||= $MANIFEST;my$read={};local*M;unless (open M,"< $mfile"){warn "Problem opening $mfile: $!";return$read}local $_;while (<M>){chomp;next if /^\s*#/;my($file,$comment);if (($file,$comment)=/^'((?:\\[\\']|.+)+)'\s*(.*)/){$file =~ s/\\([\\'])/$1/g}else {($file,$comment)=/^(\S+)\s*(.*)/}next unless$file;if ($Is_MacOS){$file=_macify($file);$file =~ s/\\([0-3][0-7][0-7])/sprintf("%c", oct($1))/ge}elsif ($Is_VMS_mode){require File::Basename;my($base,$dir)=File::Basename::fileparse($file);if ($Is_VMS_nodot){$dir =~ tr/./_/;my(@pieces)=split(/\./,$base);if (@pieces > 2){$base=shift(@pieces).'.' .join('_',@pieces)}my$okfile="$dir$base";warn "Debug: Illegal name $file changed to $okfile\n" if$Debug;$file=$okfile}if($Is_VMS_lc){$file=lc($file);$file=uc($file)if$file =~ /^MANIFEST(\.SKIP)?$/i}}$read->{$file}=$comment}close M;$read}sub maniskip {my@skip ;my$mfile=shift || "$MANIFEST.SKIP";_check_mskip_directives($mfile)if -f $mfile;local(*M,$_);open M,"< $mfile" or open M,"< $DEFAULT_MSKIP" or return sub {0};while (<M>){chomp;s/\r//;$_ =~ qr{^\s*(?:(?:'([^\\']*(?:\\.[^\\']*)*)')|([^#\s]\S*))?(?:(?:\s*)|(?:\s+(.*?)\s*))$};my$filename=$2;if (defined($1)){$filename=$1;$filename =~ s/\\(['\\])/$1/g}next if (not defined($filename)or not $filename);push@skip,_macify($filename)}close M;return sub {0}unless (scalar@skip > 0);my$opts=$Is_VMS_mode ? '(?i)' : '';my$regex=join '|',map "(?:$_)",@skip;return sub {$_[0]=~ qr{$opts$regex}}}sub _check_mskip_directives {my$mfile=shift;local (*M,$_);my@lines=();my$flag=0;unless (open M,"< $mfile"){warn "Problem opening $mfile: $!";return}while (<M>){if (/^#!include_default\s*$/){if (my@default=_include_mskip_file()){push@lines,@default;warn "Debug: Including default MANIFEST.SKIP\n" if$Debug;$flag++}next}if (/^#!include\s+(.*)\s*$/){my$external_file=$1;if (my@external=_include_mskip_file($external_file)){push@lines,@external;warn "Debug: Including external $external_file\n" if$Debug;$flag++}next}push@lines,$_}close M;return unless$flag;my$bakbase=$mfile;$bakbase =~ s/\./_/g if$Is_VMS_nodot;rename$mfile,"$bakbase.bak";warn "Debug: Saving original $mfile as $bakbase.bak\n" if$Debug;unless (open M,"> $mfile"){warn "Problem opening $mfile: $!";return}binmode M,':raw';print M $_ for (@lines);close M;return}sub _include_mskip_file {my$mskip=shift || $DEFAULT_MSKIP;unless (-f $mskip){warn qq{Included file "$mskip" not found - skipping};return}local (*M,$_);unless (open M,"< $mskip"){warn "Problem opening $mskip: $!";return}my@lines=();push@lines,"\n#!start included $mskip\n";push@lines,$_ while <M>;close M;push@lines,"#!end included $mskip\n\n";return@lines}sub manicopy {my($read,$target,$how)=@_;croak "manicopy() called without target argument" unless defined$target;$how ||= 'cp';require File::Path;require File::Basename;$target=VMS::Filespec::unixify($target)if$Is_VMS_mode;File::Path::mkpath([$target ],!$Quiet,$Is_VMS ? undef : 0755);for my$file (keys %$read){if ($Is_MacOS){if ($file =~ m!:!){my$dir=_maccat($target,$file);$dir =~ s/[^:]+$//;File::Path::mkpath($dir,1,0755)}cp_if_diff($file,_maccat($target,$file),$how)}else {$file=VMS::Filespec::unixify($file)if$Is_VMS_mode;if ($file =~ m!/!){my$dir=File::Basename::dirname($file);$dir=VMS::Filespec::unixify($dir)if$Is_VMS_mode;File::Path::mkpath(["$target/$dir"],!$Quiet,$Is_VMS ? undef : 0755)}cp_if_diff($file,"$target/$file",$how)}}}sub cp_if_diff {my($from,$to,$how)=@_;if (!-f $from){carp "$from not found";return}my($diff)=0;local(*F,*T);open(F,"< $from\0")or die "Can't read $from: $!\n";if (open(T,"< $to\0")){local $_;while (<F>){$diff++,last if $_ ne <T>}$diff++ unless eof(T);close T}else {$diff++}close F;if ($diff){if (-e $to){unlink($to)or confess "unlink $to: $!"}STRICT_SWITCH: {best($from,$to),last STRICT_SWITCH if$how eq 'best';cp($from,$to),last STRICT_SWITCH if$how eq 'cp';ln($from,$to),last STRICT_SWITCH if$how eq 'ln';croak("ExtUtils::Manifest::cp_if_diff " ."called with illegal how argument [$how]. " ."Legal values are 'best', 'cp', and 'ln'.")}}}sub cp {my ($srcFile,$dstFile)=@_;my ($access,$mod)=(stat$srcFile)[8,9];copy($srcFile,$dstFile);utime$access,$mod + ($Is_VMS ? 1 : 0),$dstFile;_manicopy_chmod($srcFile,$dstFile)}sub ln {my ($srcFile,$dstFile)=@_;return&cp if$Is_VMS or ($^O eq 'MSWin32' and Win32::IsWin95());link($srcFile,$dstFile);unless(_manicopy_chmod($srcFile,$dstFile)){unlink$dstFile;return}1}sub _manicopy_chmod {my($srcFile,$dstFile)=@_;my$perm=0444 | (stat$srcFile)[2]& 0700;chmod($perm | ($perm & 0100 ? 0111 : 0),$dstFile)}my@Exceptions=qw(MANIFEST META.yml SIGNATURE);sub best {my ($srcFile,$dstFile)=@_;my$is_exception=grep$srcFile =~ /$_/,@Exceptions;if ($is_exception or!$Config{d_link}or -l $srcFile){cp($srcFile,$dstFile)}else {ln($srcFile,$dstFile)or cp($srcFile,$dstFile)}}sub _macify {my($file)=@_;return$file unless$Is_MacOS;$file =~ s|^\./||;if ($file =~ m|/|){$file =~ s|/+|:|g;$file=":$file"}$file}sub _maccat {my($f1,$f2)=@_;return "$f1/$f2" unless$Is_MacOS;$f1 .= ":$f2";$f1 =~ s/([^:]:):/$1/g;return$f1}sub _unmacify {my($file)=@_;return$file unless$Is_MacOS;$file =~ s|^:||;$file =~ s|([/ \n])|sprintf("\\%03o", unpack("c", $1))|ge;$file =~ y|:|/|;$file}sub maniadd {my($additions)=shift;_normalize($additions);_fix_manifest($MANIFEST);my$manifest=maniread();my@needed=grep {!exists$manifest->{$_}}keys %$additions;return 1 unless@needed;open(MANIFEST,">>$MANIFEST")or die "maniadd() could not open $MANIFEST: $!";binmode MANIFEST,':raw';for my$file (_sort@needed){my$comment=$additions->{$file}|| '';if ($file =~ /\s/){$file =~ s/([\\'])/\\$1/g;$file="'$file'"}printf MANIFEST "%-40s %s\n",$file,$comment}close MANIFEST or die "Error closing $MANIFEST: $!";return 1}sub _fix_manifest {my$manifest_file=shift;open MANIFEST,$MANIFEST or die "Could not open $MANIFEST: $!";local $/;my@manifest=split /(\015\012|\012|\015)/,<MANIFEST>,-1;close MANIFEST;my$must_rewrite="";if ($manifest[-1]eq ""){pop@manifest;for (my$i=1;$i<=$#manifest;$i+=2){unless ($manifest[$i]eq "\n"){$must_rewrite="not a newline at pos $i";last}}}else {$must_rewrite="last line without newline"}if ($must_rewrite){1 while unlink$MANIFEST;open MANIFEST,">",$MANIFEST or die "(must_rewrite=$must_rewrite) Could not open >$MANIFEST: $!";binmode MANIFEST,':raw';for (my$i=0;$i<=$#manifest;$i+=2){print MANIFEST "$manifest[$i]\n"}close MANIFEST or die "could not write $MANIFEST: $!"}}sub _normalize {return}1;
EXTUTILS_MANIFEST
$fatpacked{"ExtUtils/Mkbootstrap.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MKBOOTSTRAP';
package ExtUtils::Mkbootstrap;use strict 'refs';our$VERSION='7.30';$VERSION=eval$VERSION;require Exporter;our@ISA=('Exporter');our@EXPORT=('&Mkbootstrap');use Config;our$Verbose=0;sub Mkbootstrap {my($baseext,@bsloadlibs)=@_;@bsloadlibs=grep($_,@bsloadlibs);print " bsloadlibs=@bsloadlibs\n" if$Verbose;require DynaLoader;rename "$baseext.bs","$baseext.bso" if -s "$baseext.bs";if (-f "${baseext}_BS"){$_="${baseext}_BS";package DynaLoader;local($osname,$dlsrc)=();($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 || (defined$DynaLoader::bscode && length$DynaLoader::bscode)){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";if (@all){print$bs "\@DynaLoader::dl_resolve_using = ";if (" @all" =~ m/ -[lLR]/){print$bs " dl_findfile(qw(\n @all\n ));\n"}else {print$bs " qw(@all);\n"}}print$bs $DynaLoader::bscode if$DynaLoader::bscode;print$bs "\n1;\n";close$bs}}1;
EXTUTILS_MKBOOTSTRAP
$fatpacked{"ExtUtils/Mksymlists.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MKSYMLISTS';
package ExtUtils::Mksymlists;use 5.006;use strict qw[subs refs];use Carp;use Exporter;use Config;our@ISA=qw(Exporter);our@EXPORT=qw(&Mksymlists);our$VERSION='7.30';$VERSION=eval$VERSION;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}){for my$package (sort keys %{$spec{DL_FUNCS}}){my($packprefix,$bootseen);($packprefix=$package)=~ s/\W/_/g;for 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}}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='[email protected]';$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}};_print_imports($def,$data);close$def}sub _print_imports {my ($def,$data)=@_;my$imports=$data->{IMPORTS}or return;if (keys %$imports){print$def "IMPORTS\n";for my$name (sort keys %$imports){print$def " $name=$imports->{$name}\n"}}}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");if ($Config::Config{'cc'}!~ /\bgcc/i){print$def "LIBRARY \"$data->{DLBASE}\"\n"}print$def "EXPORTS\n ";my@syms;unless($] >= 5.016){if ($Config::Config{'cc'}=~ /^bcc/i){push@syms,"_$_","$_ = _$_" for (@{$data->{DL_VARS}},@{$data->{FUNCLIST}})}else {push@syms,"$_","_$_ = $_" for (@{$data->{DL_VARS}},@{$data->{FUNCLIST}})}}else {push@syms,"$_" for (@{$data->{DL_VARS}},@{$data->{FUNCLIST}})}print$def join("\n ",@syms,"\n")if@syms;_print_imports($def,$data);close$def}sub _write_vms {my($data)=@_;require Config;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");print$opt "case_sensitive=yes\n" if$Config::Config{d_vms_case_sensitive_symbols};for my$sym (@{$data->{FUNCLIST}}){my$safe=$set->addsym($sym);if ($isvax){print$opt "UNIVERSAL=$safe\n"}else {print$opt "SYMBOL_VECTOR=($safe=PROCEDURE)\n"}}for 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;
EXTUTILS_MKSYMLISTS
$fatpacked{"ExtUtils/Packlist.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_PACKLIST';
package ExtUtils::Packlist;use 5.00503;use strict;use Carp qw();use Config;use vars qw($VERSION $Relocations);$VERSION='2.06';$VERSION=eval$VERSION;my$fhname="FH1";sub mkfh() {no strict;local $^W;my$fh=\*{$fhname++};use strict;return($fh)}sub __find_relocations {my%paths;while (my ($raw_key,$raw_val)=each%Config){my$exp_key=$raw_key ."exp";next unless exists$Config{$exp_key};next unless$raw_val =~ m!\.\.\./!;$paths{$Config{$exp_key}}++}my$alternations=join "|",map {quotemeta $_}sort {length$b <=> length$a}keys%paths;qr/^($alternations)/o}sub new($$) {my ($class,$packfile)=@_;$class=ref($class)|| $class;my%self;tie(%self,$class,$packfile);return(bless(\%self,$class))}sub TIEHASH {my ($class,$packfile)=@_;my$self={packfile=>$packfile };bless($self,$class);$self->read($packfile)if (defined($packfile)&& -f $packfile);return($self)}sub STORE {$_[0]->{data}->{$_[1]}=$_[2]}sub FETCH {return($_[0]->{data}->{$_[1]})}sub FIRSTKEY {my$reset=scalar(keys(%{$_[0]->{data}}));return(each(%{$_[0]->{data}}))}sub NEXTKEY {return(each(%{$_[0]->{data}}))}sub EXISTS {return(exists($_[0]->{data}->{$_[1]}))}sub DELETE {return(delete($_[0]->{data}->{$_[1]}))}sub CLEAR {%{$_[0]->{data}}=()}sub DESTROY {}sub read($;$) {my ($self,$packfile)=@_;$self=tied(%$self)|| $self;if (defined($packfile)){$self->{packfile}=$packfile}else {$packfile=$self->{packfile}}Carp::croak("No packlist filename specified")if (!defined($packfile));my$fh=mkfh();open($fh,"<$packfile")|| Carp::croak("Can't open file $packfile: $!");$self->{data}={};my ($line);while (defined($line=<$fh>)){chomp$line;my ($key,$data)=$line;if ($key =~ /^(.*?)( \w+=.*)$/){$key=$1;$data={map {split('=',$_)}split(' ',$2)};if ($Config{userelocatableinc}&& $data->{relocate_as}){require File::Spec;require Cwd;my ($vol,$dir)=File::Spec->splitpath($packfile);my$newpath=File::Spec->catpath($vol,$dir,$data->{relocate_as});$key=Cwd::realpath($newpath)}}$key =~ s!/\./!/!g;$self->{data}->{$key}=$data}close($fh)}sub write($;$) {my ($self,$packfile)=@_;$self=tied(%$self)|| $self;if (defined($packfile)){$self->{packfile}=$packfile}else {$packfile=$self->{packfile}}Carp::croak("No packlist filename specified")if (!defined($packfile));my$fh=mkfh();open($fh,">$packfile")|| Carp::croak("Can't open file $packfile: $!");for my$key (sort(keys(%{$self->{data}}))){my$data=$self->{data}->{$key};if ($Config{userelocatableinc}){$Relocations ||= __find_relocations();if ($packfile =~ $Relocations){my$prefix=$1;if (File::Spec->no_upwards(File::Spec->abs2rel($key,$prefix))){my$packfile_prefix;(undef,$packfile_prefix)=File::Spec->splitpath($packfile);my$relocate_as =File::Spec->abs2rel($key,$packfile_prefix);if (!ref$data){$data={}}$data->{relocate_as}=$relocate_as}}}print$fh ("$key");if (ref($data)){for my$k (sort(keys(%$data))){print$fh (" $k=$data->{$k}")}}print$fh ("\n")}close($fh)}sub validate($;$) {my ($self,$remove)=@_;$self=tied(%$self)|| $self;my@missing;for my$key (sort(keys(%{$self->{data}}))){if (!-e $key){push(@missing,$key);delete($self->{data}{$key})if ($remove)}}return(@missing)}sub packlist_file($) {my ($self)=@_;$self=tied(%$self)|| $self;return($self->{packfile})}1;
EXTUTILS_PACKLIST
$fatpacked{"ExtUtils/ParseXS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_PARSEXS';
package ExtUtils::ParseXS;use strict;use 5.006001;use Cwd;use Config;use Exporter 'import';use File::Basename;use File::Spec;use Symbol;our$VERSION;BEGIN {$VERSION='3.35'}use ExtUtils::ParseXS::Constants$VERSION;use ExtUtils::ParseXS::CountLines$VERSION;use ExtUtils::ParseXS::Utilities$VERSION;use ExtUtils::ParseXS::Eval$VERSION;$VERSION=eval$VERSION if$VERSION =~ /_/;use ExtUtils::ParseXS::Utilities qw(standard_typemap_locations trim_whitespace C_string valid_proto_string process_typemaps map_type standard_XS_defs assign_func_args analyze_preprocessor_statements set_cond Warn current_line_number blurt death check_conditional_preprocessor_statements escape_file_for_line_directive report_typemap_failure);our@EXPORT_OK=qw(process_file report_error_count);our ($C_group_rex,$C_arg);$C_group_rex=qr/ [({\[]
(?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
[)}\]] /x;$C_arg=qr/ (?: (?> [^()\[\]{},"']+ )
| (??{ $C_group_rex })
| " (?: (?> [^\\"]+ )
| \\.
)* " # String literal
| ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
)* /xs;my$END="!End!\n\n";my$BLOCK_regexp='\s*(' .$ExtUtils::ParseXS::Constants::XSKeywordsAlternation ."|$END)\\s*:";sub new {return bless {}=>shift}our$Singleton=__PACKAGE__->new;sub process_file {my$self;if (@_ % 2){my$invocant=shift;$self=ref($invocant)? $invocant : $invocant->new}else {$self=$Singleton}my%options=@_;$self->{ProtoUsed}=exists$options{prototypes};my%args=(argtypes=>1,csuffix=>'.c',except=>0,hiertype=>0,inout=>1,linenumbers=>1,optimize=>1,output=>\*STDOUT,prototypes=>0,typemap=>[],versioncheck=>1,FH=>Symbol::gensym(),%options,);$args{except}=$args{except}? ' TRY' : '';my ($Is_VMS,$SymSet);if ($^O eq 'VMS'){$Is_VMS=1;require ExtUtils::XSSymSet;$SymSet=ExtUtils::XSSymSet->new(28)}@{$self->{XSStack}}=({type=>'none'});$self->{InitFileCode}=[@ExtUtils::ParseXS::Constants::InitFileCode ];$self->{Overload}=0;$self->{errors}=0;$self->{Fallback}='&PL_sv_undef';$self->{RetainCplusplusHierarchicalTypes}=$args{hiertype};$self->{WantPrototypes}=$args{prototypes};$self->{WantVersionChk}=$args{versioncheck};$self->{WantLineNumbers}=$args{linenumbers};$self->{IncludedFiles}={};die "Missing required parameter 'filename'" unless$args{filename};$self->{filepathname}=$args{filename};($self->{dir},$self->{filename})=(dirname($args{filename}),basename($args{filename}));$self->{filepathname}=~ s/\\/\\\\/g;$self->{IncludedFiles}->{$args{filename}}++;if (not ref$args{output}){open my($fh),"> $args{output}" or die "Can't create $args{output}: $!";$args{outfile}=$args{output};$args{output}=$fh}my$orig_cwd=cwd();my$orig_fh=select();chdir($self->{dir});my$pwd=cwd();my$csuffix=$args{csuffix};if ($self->{WantLineNumbers}){my$cfile;if ($args{outfile}){$cfile=$args{outfile}}else {$cfile=$args{filename};$cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix}tie(*PSEUDO_STDOUT,'ExtUtils::ParseXS::CountLines',$cfile,$args{output});select PSEUDO_STDOUT}else {select$args{output}}$self->{typemap}=process_typemaps($args{typemap},$pwd);for my$datum (qw|argtypes except inout optimize|){$self->{$datum}=$args{$datum}}$self->{strip_c_func_prefix}=$args{s};print <<EOM;print("#line 1 \"" .escape_file_for_line_directive($self->{filepathname})."\"\n")if$self->{WantLineNumbers};open($self->{FH},'<',$self->{filename})or die "cannot open $self->{filename}: $!\n";FIRSTMODULE: while (readline($self->{FH})){if (/^=/){my$podstartline=$.;do {if (/^=cut\s*$/){print("#if 0\n \"Skipped embedded POD.\"\n#endif\n");printf("#line %d \"%s\"\n",$. + 1,escape_file_for_line_directive($self->{filepathname}))if$self->{WantLineNumbers};next FIRSTMODULE}}while (readline($self->{FH}));die ("Error: Unterminated pod in $self->{filename}, line $podstartline\n")unless$self->{lastline}}last if ($self->{Package},$self->{Prefix})=/^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;print $_}unless (defined $_){warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n";exit 0}print 'ExtUtils::ParseXS::CountLines'->end_marker,"\n" if$self->{WantLineNumbers};standard_XS_defs();print 'ExtUtils::ParseXS::CountLines'->end_marker,"\n" if$self->{WantLineNumbers};$self->{lastline}=$_;$self->{lastline_no}=$.;my$BootCode_ref=[];my$XSS_work_idx=0;my$cpp_next_tmp='XSubPPtmpAAAA';PARAGRAPH: while ($self->fetch_para()){my$outlist_ref=[];while (@{$self->{line}}&& $self->{line}->[0]!~ /^[^\#]/){my$ln=shift(@{$self->{line}});print$ln,"\n";next unless$ln =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;my$statement=$+;($self,$XSS_work_idx,$BootCode_ref)=analyze_preprocessor_statements($self,$statement,$XSS_work_idx,$BootCode_ref)}next PARAGRAPH unless @{$self->{line}};if ($XSS_work_idx &&!$self->{XSStack}->[$XSS_work_idx]{varname}){print "#define $cpp_next_tmp 1\n\n";push(@{$self->{InitFileCode}},"#if $cpp_next_tmp\n");push(@{$BootCode_ref},"#if $cpp_next_tmp");$self->{XSStack}->[$XSS_work_idx]{varname}=$cpp_next_tmp++}$self->death("Code is not inside a function" ." (maybe last function was ended by a blank line " ." followed by a statement on column one?)")if$self->{line}->[0]=~ /^\s/;for my$member (qw(args_match var_types defaults arg_list argtype_seen in_out lengthof)){$self->{$member}={}}$self->{proto_arg}=[];$self->{processing_arg_with_types}=0;$self->{proto_in_this_xsub}=0;$self->{scope_in_this_xsub}=0;$self->{interface}=0;$self->{interface_macro}='XSINTERFACE_FUNC';$self->{interface_macro_set}='XSINTERFACE_FUNC_SET';$self->{ProtoThisXSUB}=$self->{WantPrototypes};$self->{ScopeThisXSUB}=0;my$xsreturn=0;$_=shift(@{$self->{line}});while (my$kwd=$self->check_keyword("REQUIRE|PROTOTYPES|EXPORT_XSUB_SYMBOLS|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")){my$method=$kwd ."_handler";$self->$method($_);next PARAGRAPH unless @{$self->{line}};$_=shift(@{$self->{line}})}if ($self->check_keyword("BOOT")){check_conditional_preprocessor_statements($self);push (@{$BootCode_ref},"#line $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} }] \"" .escape_file_for_line_directive($self->{filepathname})."\"")if$self->{WantLineNumbers}&& $self->{line}->[0]!~ /^\s*#\s*line\b/;push (@{$BootCode_ref},@{$self->{line}},"");next PARAGRAPH}($self->{ret_type})=ExtUtils::Typemaps::tidy_type($_);my$RETVAL_no_return=1 if$self->{ret_type}=~ s/^NO_OUTPUT\s+//;unshift @{$self->{line}},$2 if$self->{argtypes}and $self->{ret_type}=~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;$self->blurt("Error: Function definition too short '$self->{ret_type}'"),next PARAGRAPH unless @{$self->{line}};my$externC=1 if$self->{ret_type}=~ s/^extern "C"\s+//;my$static=1 if$self->{ret_type}=~ s/^static\s+//;my$func_header=shift(@{$self->{line}});$self->blurt("Error: Cannot parse function definition from '$func_header'"),next PARAGRAPH unless$func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;my ($class,$orig_args);($class,$self->{func_name},$orig_args)=($1,$2,$3);$class="$4 $class" if $4;($self->{pname}=$self->{func_name})=~ s/^($self->{Prefix})?/$self->{Packprefix}/;my$clean_func_name;($clean_func_name=$self->{func_name})=~ s/^$self->{Prefix}//;$self->{Full_func_name}="$self->{Packid}_$clean_func_name";if ($Is_VMS){$self->{Full_func_name}=$SymSet->addsym($self->{Full_func_name})}for my$tmp (@{$self->{XSStack}}){next unless defined$tmp->{functions}{$self->{Full_func_name}};Warn($self,"Warning: duplicate function definition '$clean_func_name' detected");last}$self->{XSStack}->[$XSS_work_idx]{functions}{$self->{Full_func_name}}++;delete$self->{XsubAliases};delete$self->{XsubAliasValues};%{$self->{Interfaces}}=();@{$self->{Attributes}}=();$self->{DoSetMagic}=1;$orig_args =~ s/\\\s*/ /g;my@args;my (@fake_INPUT_pre);my (@fake_INPUT);my$only_C_inlist_ref={};if ($self->{argtypes}and $orig_args =~ /\S/){my$args="$orig_args ,";use re 'eval';if ($args =~ /^( (??{ $C_arg }) , )* $ /x){@args=($args =~ /\G ( (??{ $C_arg }) ) , /xg);no re 'eval';for (@args){s/^\s+//;s/\s+$//;my ($arg,$default)=($_ =~ m/ ( [^=]* ) ( (?: = .* )? ) /x);my ($pre,$len_name)=($arg =~ /(.*?) \s*
/*
* This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
* contents of $self->{filename}. Do not edit this file, edit $self->{filename} instead.
*
* ANY CHANGES MADE HERE WILL BE LOST!
*
*/
EOM
\b ( \w+ | length\( \s*\w+\s* \) )
\s* $ /x);next unless defined($pre)&& length($pre);my$out_type='';my$inout_var;if ($self->{inout}and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//){my$type=$1;$out_type=$type if$type ne 'IN';$arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//;$pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//}my$islength;if ($len_name =~ /^length\( \s* (\w+) \s* \)\z/x){$len_name="XSauto_length_of_$1";$islength=1;die "Default value on length() argument: '$_'" if length$default}if (length$pre or $islength){if ($islength){push@fake_INPUT_pre,$arg}else {push@fake_INPUT,$arg}$self->{argtype_seen}->{$len_name}++;$_="$len_name$default"}$only_C_inlist_ref->{$_}=1 if$out_type eq "OUTLIST" or $islength;push @{$outlist_ref},$len_name if$out_type =~ /OUTLIST$/;$self->{in_out}->{$len_name}=$out_type if$out_type}}else {no re 'eval';@args=split(/\s*,\s*/,$orig_args);Warn($self,"Warning: cannot parse argument list '$orig_args', fallback to split")}}else {@args=split(/\s*,\s*/,$orig_args);for (@args){if ($self->{inout}and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\b\s*//){my$out_type=$1;next if$out_type eq 'IN';$only_C_inlist_ref->{$_}=1 if$out_type eq "OUTLIST";if ($out_type =~ /OUTLIST$/){push @{$outlist_ref},undef}$self->{in_out}->{$_}=$out_type}}}if (defined($class)){my$arg0=((defined($static)or $self->{func_name}eq 'new')? "CLASS" : "THIS");unshift(@args,$arg0)}my$extra_args=0;my@args_num=();my$num_args=0;my$report_args='';my$ellipsis;for my$i (0 .. $#args){if ($args[$i]=~ s/\.\.\.//){$ellipsis=1;if ($args[$i]eq '' && $i==$#args){$report_args .= ", ...";pop(@args);last}}if ($only_C_inlist_ref->{$args[$i]}){push@args_num,undef}else {push@args_num,++$num_args;$report_args .= ", $args[$i]"}if ($args[$i]=~ /^([^=]*[^\s=])\s*=\s*(.*)/s){$extra_args++;$args[$i]=$1;$self->{defaults}->{$args[$i]}=$2;$self->{defaults}->{$args[$i]}=~ s/"/\\"/g}$self->{proto_arg}->[$i+1]='$'}my$min_args=$num_args - $extra_args;$report_args =~ s/"/\\"/g;$report_args =~ s/^,\s+//;$self->{func_args}=assign_func_args($self,\@args,$class);@{$self->{args_match}}{@args}=@args_num;my$PPCODE=grep(/^\s*PPCODE\s*:/,@{$self->{line}});my$CODE=grep(/^\s*CODE\s*:/,@{$self->{line}});my$EXPLICIT_RETURN=($CODE && ("@{ $self->{line} }" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x));$self->{ALIAS}=grep(/^\s*ALIAS\s*:/,@{$self->{line}});my$INTERFACE=grep(/^\s*INTERFACE\s*:/,@{$self->{line}});$xsreturn=1 if$EXPLICIT_RETURN;$externC=$externC ? qq[extern "C"] : "";print Q(<<"EOF");print Q(<<"EOF")if$self->{ALIAS};print Q(<<"EOF")if$INTERFACE;$self->{cond}=set_cond($ellipsis,$min_args,$num_args);print Q(<<"EOF")if$self->{except};if($self->{cond}){print Q(<<"EOF")}else {print Q(<<"EOF")}print Q(<<"EOF")if$PPCODE;print Q(<<"EOF")if$PPCODE;$self->{condnum}=0;$self->{cond}='';push(@{$self->{line}},"$END:");push(@{$self->{line_no}},$self->{line_no}->[-1]);$_='';check_conditional_preprocessor_statements();while (@{$self->{line}}){$self->CASE_handler($_)if$self->check_keyword("CASE");print Q(<<"EOF");$self->{thisdone}=0;$self->{retvaldone}=0;$self->{deferred}="";%{$self->{arg_list}}=();$self->{gotRETVAL}=0;$self->INPUT_handler($_);$self->process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD");print Q(<<"EOF")if$self->{ScopeThisXSUB};if (!$self->{thisdone}&& defined($class)){if (defined($static)or $self->{func_name}eq 'new'){print "\tchar *";$self->{var_types}->{"CLASS"}="char *";$self->generate_init({type=>"char *",num=>1,var=>"CLASS",printed_name=>undef,})}else {print "\t" .map_type($self,"$class *");$self->{var_types}->{"THIS"}="$class *";$self->generate_init({type=>"$class *",num=>1,var=>"THIS",printed_name=>undef,})}}$self->{have_OUTPUT}=$self->{have_CODE_with_RETVAL}=0;my ($wantRETVAL);if (/^\s*NOT_IMPLEMENTED_YET/){print "\n\tPerl_croak(aTHX_ \"$self->{pname}: not implemented yet\");\n";$_=''}else {if ($self->{ret_type}ne "void"){print "\t" .map_type($self,$self->{ret_type},'RETVAL').";\n" if!$self->{retvaldone};$self->{args_match}->{"RETVAL"}=0;$self->{var_types}->{"RETVAL"}=$self->{ret_type};my$outputmap=$self->{typemap}->get_outputmap(ctype=>$self->{ret_type});print "\tdXSTARG;\n" if$self->{optimize}and $outputmap and $outputmap->targetable}if (@fake_INPUT or @fake_INPUT_pre){unshift @{$self->{line}},@fake_INPUT_pre,@fake_INPUT,$_;$_="";$self->{processing_arg_with_types}=1;$self->INPUT_handler($_)}print$self->{deferred};$self->process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD");if ($self->check_keyword("PPCODE")){$self->print_section();$self->death("PPCODE must be last thing")if @{$self->{line}};print "\tLEAVE;\n" if$self->{ScopeThisXSUB};print "\tPUTBACK;\n\treturn;\n"}elsif ($self->check_keyword("CODE")){my$consumed_code=$self->print_section();if ($consumed_code =~ /\bRETVAL\b/){$self->{have_CODE_with_RETVAL}=1}}elsif (defined($class)and $self->{func_name}eq "DESTROY"){print "\n\t";print "delete THIS;\n"}else {print "\n\t";if ($self->{ret_type}ne "void"){print "RETVAL = ";$wantRETVAL=1}if (defined($static)){if ($self->{func_name}eq 'new'){$self->{func_name}="$class"}else {print "${class}::"}}elsif (defined($class)){if ($self->{func_name}eq 'new'){$self->{func_name}.= " $class"}else {print "THIS->"}}my$strip=$self->{strip_c_func_prefix};$self->{func_name}=~ s/^\Q$strip// if defined$strip;$self->{func_name}='XSFUNCTION' if$self->{interface};print "$self->{func_name}($self->{func_args});\n"}}$self->{gotRETVAL}=0;undef$self->{RETVAL_code};($wantRETVAL,$self->{ret_type})=(0,'void')if$RETVAL_no_return;undef %{$self->{outargs}};$self->process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");if ($self->{have_CODE_with_RETVAL}and not $self->{have_OUTPUT}and $self->{ret_type}ne 'void'){$self->Warn("Warning: Found a 'CODE' section which seems to be using 'RETVAL' but no 'OUTPUT' section.")}$self->generate_output({type=>$self->{var_types}->{$_},num=>$self->{args_match}->{$_},var=>$_,do_setmagic=>$self->{DoSetMagic},do_push=>undef,})for grep$self->{in_out}->{$_}=~ /OUT$/,sort keys %{$self->{in_out}};my$prepush_done;if ($self->{gotRETVAL}&& $self->{RETVAL_code}){print "\t$self->{RETVAL_code}\n"}elsif ($self->{gotRETVAL}|| $wantRETVAL){my$outputmap=$self->{typemap}->get_outputmap(ctype=>$self->{ret_type});my$trgt=$self->{optimize}&& $outputmap && $outputmap->targetable;my$var='RETVAL';my$type=$self->{ret_type};if ($trgt){my$what=$self->eval_output_typemap_code(qq("$trgt->{what}"),{var=>$var,type=>$self->{ret_type}});if (not $trgt->{with_size}and $trgt->{type}eq 'p'){print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";$prepush_done=1}else {my$tsize=$trgt->{what_size};$tsize='' unless defined$tsize;$tsize=$self->eval_output_typemap_code(qq("$tsize"),{var=>$var,type=>$self->{ret_type}});print "\tXSprePUSH; PUSH$trgt->{type}($what$tsize);\n";$prepush_done=1}}else {$self->generate_output({type=>$self->{ret_type},num=>0,var=>'RETVAL',do_setmagic=>0,do_push=>undef,})}}$xsreturn=1 if$self->{ret_type}ne "void";my$num=$xsreturn;my$c=@{$outlist_ref};print "\tXSprePUSH;" if$c and not $prepush_done;print "\tEXTEND(SP,$c);\n" if$c;$xsreturn += $c;$self->generate_output({type=>$self->{var_types}->{$_},num=>$num++,var=>$_,do_setmagic=>0,do_push=>1,})for @{$outlist_ref};$self->process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");print Q(<<"EOF")if$self->{ScopeThisXSUB};print Q(<<"EOF")if$self->{ScopeThisXSUB}and not $PPCODE;print Q(<<"EOF");print Q(<<"EOF")if$self->{except};if ($self->check_keyword("CASE")){$self->blurt("Error: No 'CASE:' at top of function")unless$self->{condnum};$_="CASE: $_";next}last if $_ eq "$END:";$self->death(/^$BLOCK_regexp/o ? "Misplaced '$1:'" : "Junk at end of function ($_)")}print Q(<<"EOF")if$self->{except};if ($xsreturn){print Q(<<"EOF")unless$PPCODE}else {print Q(<<"EOF")unless$PPCODE}print Q(<<"EOF");$self->{proto}="";unless($self->{ProtoThisXSUB}){$self->{newXS}="newXS_deffile";$self->{file}=""}else {$self->{newXS}="newXSproto_portable";$self->{file}=", file";if ($self->{ProtoThisXSUB}eq 2){}elsif ($self->{ProtoThisXSUB}eq 1){my$s=';';if ($min_args < $num_args){$s='';$self->{proto_arg}->[$min_args].= ";"}push @{$self->{proto_arg}},"$s\@" if$ellipsis;$self->{proto}=join ("",grep defined,@{$self->{proto_arg}})}else {$self->{proto}=$self->{ProtoThisXSUB}}$self->{proto}=qq{, "$self->{proto}"}}if ($self->{XsubAliases}and keys %{$self->{XsubAliases}}){$self->{XsubAliases}->{$self->{pname}}=0 unless defined$self->{XsubAliases}->{$self->{pname}};for my$xname (sort keys %{$self->{XsubAliases}}){my$value=$self->{XsubAliases}{$xname};push(@{$self->{InitFileCode}},Q(<<"EOF"))}}elsif (@{$self->{Attributes}}){push(@{$self->{InitFileCode}},Q(<<"EOF"))}elsif ($self->{interface}){for my$yname (sort keys %{$self->{Interfaces}}){my$value=$self->{Interfaces}{$yname};$yname="$self->{Package}\::$yname" unless$yname =~ /::/;push(@{$self->{InitFileCode}},Q(<<"EOF"))}}elsif($self->{newXS}eq 'newXS_deffile'){push(@{$self->{InitFileCode}}," $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n")}else {push(@{$self->{InitFileCode}}," (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n")}}if ($self->{Overload}){print Q(<<"EOF");unshift(@{$self->{InitFileCode}},<<"MAKE_FETCHMETHOD_WORK")}print Q(<<"EOF");print Q(<<"EOF");print Q(<<"EOF")if$self->{Full_func_name};print Q("#\n");print Q(<<"EOF");if($self->{WantVersionChk}){print Q(<<"EOF")}else {print Q(<<"EOF")}print Q(<<"EOF")if defined$self->{XsubAliases}or defined$self->{interfaces};print Q(<<"EOF")if ($self->{Overload});print @{$self->{InitFileCode}};print Q(<<"EOF")if defined$self->{XsubAliases}or defined$self->{interfaces};if (@{$BootCode_ref}){print "\n /* Initialisation Section */\n\n";@{$self->{line}}=@{$BootCode_ref};$self->print_section();print "\n /* End of Initialisation Section */\n\n"}print Q(<<'EOF');warn("Please specify prototyping behavior for $self->{filename} (see perlxs manual)\n")unless$self->{ProtoUsed};chdir($orig_cwd);select($orig_fh);untie*PSEUDO_STDOUT if tied*PSEUDO_STDOUT;close$self->{FH};return 1}sub report_error_count {if (@_){return $_[0]->{errors}||0}else {return$Singleton->{errors}||0}}sub check_keyword {my$self=shift;$_=shift(@{$self->{line}})while!/\S/ && @{$self->{line}};s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2}sub print_section {my$self=shift;do {$_=shift(@{$self->{line}})}while!/\S/ && @{$self->{line}};my$consumed_code='';print("#line ",$self->{line_no}->[@{$self->{line_no}}- @{$self->{line}}-1]," \"",escape_file_for_line_directive($self->{filepathname}),"\"\n")if$self->{WantLineNumbers}&&!/^\s*#\s*line\b/ &&!/^#if XSubPPtmp/;for (;defined($_)&&!/^$BLOCK_regexp/o;$_=shift(@{$self->{line}})){print "$_\n";$consumed_code .= "$_\n"}print 'ExtUtils::ParseXS::CountLines'->end_marker,"\n" if$self->{WantLineNumbers};return$consumed_code}sub merge_section {my$self=shift;my$in='';while (!/\S/ && @{$self->{line}}){$_=shift(@{$self->{line}})}for (;defined($_)&&!/^$BLOCK_regexp/o;$_=shift(@{$self->{line}})){$in .= "$_\n"}chomp$in;return$in}sub process_keyword {my($self,$pattern)=@_;while (my$kwd=$self->check_keyword($pattern)){my$method=$kwd ."_handler";$self->$method($_)}}sub CASE_handler {my$self=shift;$_=shift;$self->blurt("Error: 'CASE:' after unconditional 'CASE:'")if$self->{condnum}&& $self->{cond}eq '';$self->{cond}=$_;trim_whitespace($self->{cond});print " ",($self->{condnum}++ ? " else" : ""),($self->{cond}? " if ($self->{cond})\n" : "\n");$_=''}sub INPUT_handler {my$self=shift;$_=shift;for (;!/^$BLOCK_regexp/o;$_=shift(@{$self->{line}})){last if /^\s*NOT_IMPLEMENTED_YET/;next unless /\S/;trim_whitespace($_);my$ln=$_;s/\s*;$//g unless /[=;+].*\S/;if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x){print "\tSTRLEN\tSTRLEN_length_of_$2;\n";$self->{lengthof}->{$2}=undef;$self->{deferred}.= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n"}my$var_init='';$var_init=$1 if s/\s*([=;+].*)$//s;$var_init =~ s/"/\\"/g;my$is_overridden_typemap=$var_init =~ /ST\s*\(|\$arg\b/;s/\s+/ /g;my ($var_type,$var_addr,$var_name)=/^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s or $self->blurt("Error: invalid argument declaration '$ln'"),next;$self->blurt("Error: duplicate definition of argument '$var_name' ignored"),next if$self->{arg_list}->{$var_name}++ or defined$self->{argtype_seen}->{$var_name}and not $self->{processing_arg_with_types};$self->{thisdone}|= $var_name eq "THIS";$self->{retvaldone}|= $var_name eq "RETVAL";$self->{var_types}->{$var_name}=$var_type;my$printed_name;if ($var_type =~ / \( \s* \* \s* \) /x){print "\t" .map_type($self,$var_type,$var_name);$printed_name=1}else {print "\t" .map_type($self,$var_type,undef);$printed_name=0}$self->{var_num}=$self->{args_match}->{$var_name};if ($self->{var_num}){my$typemap=$self->{typemap}->get_typemap(ctype=>$var_type);$self->report_typemap_failure($self->{typemap},$var_type,"death")if not $typemap and not $is_overridden_typemap;$self->{proto_arg}->[$self->{var_num}]=($typemap && $typemap->proto)|| "\$"}$self->{func_args}=~ s/\b($var_name)\b/&$1/ if$var_addr;if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/ or $self->{in_out}->{$var_name}and $self->{in_out}->{$var_name}=~ /^OUT/ and $var_init !~ /\S/){if ($printed_name){print ";\n"}else {print "\t$var_name;\n"}}elsif ($var_init =~ /\S/){$self->output_init({type=>$var_type,num=>$self->{var_num},var=>$var_name,init=>$var_init,printed_name=>$printed_name,})}elsif ($self->{var_num}){$self->generate_init({type=>$var_type,num=>$self->{var_num},var=>$var_name,printed_name=>$printed_name,})}else {print ";\n"}}}sub OUTPUT_handler {my$self=shift;$self->{have_OUTPUT}=1;$_=shift;for (;!/^$BLOCK_regexp/o;$_=shift(@{$self->{line}})){next unless /\S/;if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/){$self->{DoSetMagic}=($1 eq "ENABLE" ? 1 : 0);next}my ($outarg,$outcode)=/^\s*(\S+)\s*(.*?)\s*$/s;$self->blurt("Error: duplicate OUTPUT argument '$outarg' ignored"),next if$self->{outargs}->{$outarg}++;if (!$self->{gotRETVAL}and $outarg eq 'RETVAL'){$self->{RETVAL_code}=$outcode;$self->{gotRETVAL}=1;next}$self->blurt("Error: OUTPUT $outarg not an argument"),next unless defined($self->{args_match}->{$outarg});$self->blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"),next unless defined$self->{var_types}->{$outarg};$self->{var_num}=$self->{args_match}->{$outarg};if ($outcode){print "\t$outcode\n";print "\tSvSETMAGIC(ST(",$self->{var_num}- 1,"));\n" if$self->{DoSetMagic}}else {$self->generate_output({type=>$self->{var_types}->{$outarg},num=>$self->{var_num},var=>$outarg,do_setmagic=>$self->{DoSetMagic},do_push=>undef,})}delete$self->{in_out}->{$outarg}if exists$self->{in_out}->{$outarg}and $self->{in_out}->{$outarg}=~ /OUT$/}}sub C_ARGS_handler {my$self=shift;$_=shift;my$in=$self->merge_section();trim_whitespace($in);$self->{func_args}=$in}sub INTERFACE_MACRO_handler {my$self=shift;$_=shift;my$in=$self->merge_section();trim_whitespace($in);if ($in =~ /\s/){($self->{interface_macro},$self->{interface_macro_set})=split ' ',$in}else {$self->{interface_macro}=$in;$self->{interface_macro_set}='UNKNOWN_CVT'}$self->{interface}=1;$self->{interfaces}=1}sub INTERFACE_handler {my$self=shift;$_=shift;my$in=$self->merge_section();trim_whitespace($in);for (split /[\s,]+/,$in){my$iface_name=$_;$iface_name =~ s/^$self->{Prefix}//;$self->{Interfaces}->{$iface_name}=$_}print Q(<<"EOF");$self->{interface}=1;$self->{interfaces}=1}sub CLEANUP_handler {my$self=shift;$self->print_section()}sub PREINIT_handler {my$self=shift;$self->print_section()}sub POSTCALL_handler {my$self=shift;$self->print_section()}sub INIT_handler {my$self=shift;$self->print_section()}sub get_aliases {my$self=shift;my ($line)=@_;my ($orig)=$line;while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//){my ($alias,$value)=($1,$2);my$orig_alias=$alias;$alias=$self->{Packprefix}.$alias if$alias !~ /::/;Warn($self,"Warning: Ignoring duplicate alias '$orig_alias'")if defined$self->{XsubAliases}->{$alias};Warn($self,"Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values")if$self->{XsubAliasValues}->{$value};$self->{XsubAliases}->{$alias}=$value;$self->{XsubAliasValues}->{$value}=$orig_alias}blurt($self,"Error: Cannot parse ALIAS definitions from '$orig'")if$line}sub ATTRS_handler {my$self=shift;$_=shift;for (;!/^$BLOCK_regexp/o;$_=shift(@{$self->{line}})){next unless /\S/;trim_whitespace($_);push @{$self->{Attributes}},$_}}sub ALIAS_handler {my$self=shift;$_=shift;for (;!/^$BLOCK_regexp/o;$_=shift(@{$self->{line}})){next unless /\S/;trim_whitespace($_);$self->get_aliases($_)if $_}}sub OVERLOAD_handler {my$self=shift;$_=shift;for (;!/^$BLOCK_regexp/o;$_=shift(@{$self->{line}})){next unless /\S/;trim_whitespace($_);while (s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//){$self->{Overload}=1 unless$self->{Overload};my$overload="$self->{Package}\::(".$1;push(@{$self->{InitFileCode}}," (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n")}}}sub FALLBACK_handler {my ($self,$setting)=@_;trim_whitespace($setting);$setting=uc($setting);my%map=(TRUE=>"&PL_sv_yes",1=>"&PL_sv_yes",FALSE=>"&PL_sv_no",0=>"&PL_sv_no",UNDEF=>"&PL_sv_undef",);$self->death("Error: FALLBACK: TRUE/FALSE/UNDEF")unless exists$map{$setting};$self->{Fallback}=$map{$setting}}sub REQUIRE_handler {my ($self,$ver)=@_;trim_whitespace($ver);$self->death("Error: REQUIRE expects a version number")unless$ver;$self->death("Error: REQUIRE: expected a number, got '$ver'")unless$ver =~ /^\d+(\.\d*)?/;$self->death("Error: xsubpp $ver (or better) required--this is only $VERSION.")unless$VERSION >= $ver}sub VERSIONCHECK_handler {my ($self,$setting)=@_;trim_whitespace($setting);$self->death("Error: VERSIONCHECK: ENABLE/DISABLE")unless$setting =~ /^(ENABLE|DISABLE)/i;$self->{WantVersionChk}=1 if $1 eq 'ENABLE';$self->{WantVersionChk}=0 if $1 eq 'DISABLE'}sub PROTOTYPE_handler {my$self=shift;$_=shift;my$specified;$self->death("Error: Only 1 PROTOTYPE definition allowed per xsub")if$self->{proto_in_this_xsub}++;for (;!/^$BLOCK_regexp/o;$_=shift(@{$self->{line}})){next unless /\S/;$specified=1;trim_whitespace($_);if ($_ eq 'DISABLE'){$self->{ProtoThisXSUB}=0}elsif ($_ eq 'ENABLE'){$self->{ProtoThisXSUB}=1}else {s/\s+//g;$self->death("Error: Invalid prototype '$_'")unless valid_proto_string($_);$self->{ProtoThisXSUB}=C_string($_)}}$self->{ProtoThisXSUB}=2 unless$specified;$self->{ProtoUsed}=1}sub SCOPE_handler {my ($self,$setting)=@_;$self->death("Error: Only 1 SCOPE declaration allowed per xsub")if$self->{scope_in_this_xsub}++;trim_whitespace($setting);$self->death("Error: SCOPE: ENABLE/DISABLE")unless$setting =~ /^(ENABLE|DISABLE)\b/i;$self->{ScopeThisXSUB}=(uc($1)eq 'ENABLE')}sub PROTOTYPES_handler {my ($self,$setting)=@_;trim_whitespace($setting);$self->death("Error: PROTOTYPES: ENABLE/DISABLE")unless$setting =~ /^(ENABLE|DISABLE)/i;$self->{WantPrototypes}=1 if $1 eq 'ENABLE';$self->{WantPrototypes}=0 if $1 eq 'DISABLE';$self->{ProtoUsed}=1}sub EXPORT_XSUB_SYMBOLS_handler {my ($self,$setting)=@_;trim_whitespace($setting);$self->death("Error: EXPORT_XSUB_SYMBOLS: ENABLE/DISABLE")unless$setting =~ /^(ENABLE|DISABLE)/i;my$xs_impl=$1 eq 'ENABLE' ? 'XS_EXTERNAL' : 'XS_INTERNAL';print Q(<<"EOF")}sub PushXSStack {my$self=shift;my%args=@_;push(@{$self->{XSStack}},{type=>'file',LastLine=>$self->{lastline},LastLineNo=>$self->{lastline_no},Line=>$self->{line},LineNo=>$self->{line_no},Filename=>$self->{filename},Filepathname=>$self->{filepathname},Handle=>$self->{FH},IsPipe=>scalar($self->{filename}=~ /\|\s*$/),%args,})}sub INCLUDE_handler {my$self=shift;$_=shift;trim_whitespace($_);$self->death("INCLUDE: filename missing")unless $_;$self->death("INCLUDE: output pipe is illegal")if /^\s*\|/;$self->death("INCLUDE loop detected")if$self->{IncludedFiles}->{$_};++$self->{IncludedFiles}->{$_}unless /\|\s*$/;if (/\|\s*$/ && /^\s*perl\s/){Warn($self,"The INCLUDE directive with a command is discouraged." ." Use INCLUDE_COMMAND instead! In particular using 'perl'" ." in an 'INCLUDE: ... |' directive is not guaranteed to pick" ." up the correct perl. The INCLUDE_COMMAND directive allows" ." the use of \$^X as the currently running perl, see" ." 'perldoc perlxs' for details.")}$self->PushXSStack();$self->{FH}=Symbol::gensym();open($self->{FH},$_)or $self->death("Cannot open '$_': $!");print Q(<<"EOF");$self->{filename}=$_;$self->{filepathname}=($^O =~ /^mswin/i)? qq($self->{dir}/$self->{filename}) : File::Spec->catfile($self->{dir},$self->{filename});while (readline($self->{FH})){last unless /^\s*$/}$self->{lastline}=$_;$self->{lastline_no}=$.}sub QuoteArgs {my$cmd=shift;my@args=split /\s+/,$cmd;$cmd=shift@args;for (@args){$_=q(").$_.q(") if!/^\"/ && length($_)> 0}return join (' ',($cmd,@args))}{my ($quote,$use_quote)=$^O eq 'MSWin32' ? (q{"},q{"}): (q{"'},q{'});sub _safe_quote {my ($self,$command)=@_;if (defined($command)and $command =~ /\s/ and $command !~ /[$quote]/){return qq{$use_quote$command$use_quote}}return$command}}sub INCLUDE_COMMAND_handler {my$self=shift;$_=shift;trim_whitespace($_);$_=QuoteArgs($_)if $^O eq 'VMS';$self->death("INCLUDE_COMMAND: command missing")unless $_;$self->death("INCLUDE_COMMAND: pipes are illegal")if /^\s*\|/ or /\|\s*$/;$self->PushXSStack(IsPipe=>1);$self->{FH}=Symbol::gensym();my$X=$self->_safe_quote($^X);s/^\s*\$\^X/$X/;open ($self->{FH},"-|",$_)or $self->death($self,"Cannot run command '$_' to include its output: $!");print Q(<<"EOF");$self->{filename}=$_;$self->{filepathname}=$self->{filename};$self->{filepathname}=~ s/\\/\\\\/g;while (readline($self->{FH})){last unless /^\s*$/}$self->{lastline}=$_;$self->{lastline_no}=$.}sub PopFile {my$self=shift;return 0 unless$self->{XSStack}->[-1]{type}eq 'file';my$data=pop @{$self->{XSStack}};my$ThisFile=$self->{filename};my$isPipe=$data->{IsPipe};--$self->{IncludedFiles}->{$self->{filename}}unless$isPipe;close$self->{FH};$self->{FH}=$data->{Handle};$self->{filename}=$data->{Filename};$self->{filepathname}=$data->{Filepathname};$self->{lastline}=$data->{LastLine};$self->{lastline_no}=$data->{LastLineNo};@{$self->{line}}=@{$data->{Line}};@{$self->{line_no}}=@{$data->{LineNo}};if ($isPipe and $?){--$self->{lastline_no};print STDERR "Error reading from pipe '$ThisFile': $! in $self->{filename}, line $self->{lastline_no}\n" ;exit 1}print Q(<<"EOF");return 1}sub Q {my($text)=@_;$text =~ s/^#//gm;$text =~ s/\[\[/{/g;$text =~ s/\]\]/}/g;$text}sub _process_module_xs_line {my ($self,$module,$pkg,$prefix)=@_;($self->{Module_cname}=$module)=~ s/\W/_/g;$self->{Package}=defined($pkg)? $pkg : '';$self->{Prefix}=quotemeta(defined($prefix)? $prefix : '');($self->{Packid}=$self->{Package})=~ tr/:/_/;$self->{Packprefix}=$self->{Package};$self->{Packprefix}.= "::" if$self->{Packprefix}ne "";$self->{lastline}=""}sub _maybe_skip_pod {my ($self)=@_;while ($self->{lastline}=~ /^=/){while ($self->{lastline}=readline($self->{FH})){last if ($self->{lastline}=~ /^=cut\s*$/)}$self->death("Error: Unterminated pod")unless defined$self->{lastline};$self->{lastline}=readline($self->{FH});chomp$self->{lastline};$self->{lastline}=~ s/^\s+$//}}sub _maybe_parse_typemap_block {my ($self)=@_;if ($self->{lastline}=~ /^TYPEMAP\s*:\s*<<\s*(?:(["'])(.+?)\1|([^\s'"]+?))\s*;?\s*$/){my$end_marker=quotemeta(defined($1)? $2 : $3);my@tmaplines;while (1){$self->{lastline}=readline($self->{FH});$self->death("Error: Unterminated TYPEMAP section")if not defined$self->{lastline};last if$self->{lastline}=~ /^$end_marker\s*$/;push@tmaplines,$self->{lastline}}my$tmap=ExtUtils::Typemaps->new(string=>join("",@tmaplines),lineno_offset=>1 + ($self->current_line_number()|| 0),fake_filename=>$self->{filename},);$self->{typemap}->merge(typemap=>$tmap,replace=>1);$self->{lastline}=""}}sub fetch_para {my$self=shift;$self->death("Error: Unterminated '#if/#ifdef/#ifndef'")if!defined$self->{lastline}&& $self->{XSStack}->[-1]{type}eq 'if';@{$self->{line}}=();@{$self->{line_no}}=();return$self->PopFile()if not defined$self->{lastline};if ($self->{lastline}=~ /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/){$self->_process_module_xs_line($1,$2,$3)}for (;;){$self->_maybe_skip_pod;$self->_maybe_parse_typemap_block;if ($self->{lastline}!~ /^\s*#/ || $self->{lastline}=~ /^\#[ \t]*
#$externC
#XS_EUPXS(XS_$self->{Full_func_name}); /* prototype to pass -Wmissing-prototypes */
#XS_EUPXS(XS_$self->{Full_func_name})
#[[
# dVAR; dXSARGS;
EOF
# dXSI32;
EOF
# dXSFUNCTION($self->{ret_type});
EOF
# char errbuf[1024];
# *errbuf = '\\0';
EOF
# if ($self->{cond})
# croak_xs_usage(cv, "$report_args");
EOF
# PERL_UNUSED_VAR(cv); /* -W */
EOF
# PERL_UNUSED_VAR(ax); /* -Wall */
EOF
# SP -= items;
EOF
# $self->{except} [[
EOF
# ENTER;
# [[
EOF
# ]]
EOF
# LEAVE;
EOF
# ]]
EOF
# BEGHANDLERS
# CATCHALL
# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
# ENDHANDLERS
EOF
# if (errbuf[0])
# Perl_croak(aTHX_ errbuf);
EOF
# XSRETURN($xsreturn);
EOF
# XSRETURN_EMPTY;
EOF
#]]
#
EOF
# cv = $self->{newXS}(\"$xname\", XS_$self->{Full_func_name}$self->{file}$self->{proto});
# XSANY.any_i32 = $value;
EOF
# cv = $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});
# apply_attrs_string("$self->{Package}", cv, "@{ $self->{Attributes} }", 0);
EOF
# cv = $self->{newXS}(\"$yname\", XS_$self->{Full_func_name}$self->{file}$self->{proto});
# $self->{interface_macro_set}(cv,$value);
EOF
#XS_EUPXS(XS_$self->{Packid}_nil); /* prototype to pass -Wmissing-prototypes */
#XS_EUPXS(XS_$self->{Packid}_nil)
#{
# dXSARGS;
# XSRETURN_EMPTY;
#}
#
EOF
/* Making a sub named "$self->{Package}::()" allows the package */
/* to be findable via fetchmethod(), and causes */
/* overload::Overloaded("$self->{Package}") to return true. */
(void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil$self->{file}$self->{proto});
MAKE_FETCHMETHOD_WORK
##ifdef __cplusplus
#extern "C"
##endif
EOF
#XS_EXTERNAL(boot_$self->{Module_cname}); /* prototype to pass -Wmissing-prototypes */
#XS_EXTERNAL(boot_$self->{Module_cname})
#[[
##if PERL_VERSION_LE(5, 21, 5)
# dVAR; dXSARGS;
##else
# dVAR; ${\($self->{WantVersionChk} ?
'dXSBOOTARGSXSAPIVERCHK;' : 'dXSBOOTARGSAPIVERCHK;')}
##endif
EOF
##if (PERL_REVISION == 5 && PERL_VERSION < 9)
# char* file = __FILE__;
##else
# const char* file = __FILE__;
##endif
#
# PERL_UNUSED_VAR(file);
EOF
# PERL_UNUSED_VAR(cv); /* -W */
# PERL_UNUSED_VAR(items); /* -W */
EOF
##if PERL_VERSION_LE(5, 21, 5)
# XS_VERSION_BOOTCHECK;
## ifdef XS_APIVERSION_BOOTCHECK
# XS_APIVERSION_BOOTCHECK;
## endif
##endif
EOF
##if PERL_VERSION_LE(5, 21, 5) && defined(XS_APIVERSION_BOOTCHECK)
# XS_APIVERSION_BOOTCHECK;
##endif
EOF
# {
# CV * cv;
#
EOF
# /* register the overloading (type 'A') magic */
##if (PERL_REVISION == 5 && PERL_VERSION < 9)
# PL_amagic_generation++;
##endif
# /* The magic for overload gets a GV* via gv_fetchmeth as */
# /* mentioned above, and looks in the SV* slot of it for */
# /* the "fallback" status. */
# sv_setsv(
# get_sv( "$self->{Package}::()", TRUE ),
# $self->{Fallback}
# );
EOF
# }
EOF
##if PERL_VERSION_LE(5, 21, 5)
## if PERL_VERSION_GE(5, 9, 0)
# if (PL_unitcheckav)
# call_list(PL_scopestack_ix, PL_unitcheckav);
## endif
# XSRETURN_YES;
##else
# Perl_xs_boot_epilog(aTHX_ ax);
##endif
#]]
#
EOF
# XSFUNCTION = $self->{interface_macro}($self->{ret_type},cv,XSANY.any_dptr);
EOF
##undef XS_EUPXS
##if defined(PERL_EUPXS_ALWAYS_EXPORT)
## define XS_EUPXS(name) XS_EXTERNAL(name)
##elif defined(PERL_EUPXS_NEVER_EXPORT)
## define XS_EUPXS(name) XS_INTERNAL(name)
##else
## define XS_EUPXS(name) $xs_impl(name)
##endif
EOF
#
#/* INCLUDE: Including '$_' from '$self->{filename}' */
#
EOF
#
#/* INCLUDE_COMMAND: Including output of '$_' from '$self->{filename}' */
#
EOF
#
#/* INCLUDE: Returning to '$self->{filename}' from '$ThisFile' */
#
EOF
(?:
(?:if|ifn?def|elif|else|endif|
define|undef|pragma|error|
warning|line\s+\d+|ident)
\b
| (?:include(?:_next)?|import)
\s* ["<] .* [>"]
)
/x){last if$self->{lastline}=~ /^\S/ && @{$self->{line}}&& $self->{line}->[-1]eq "";push(@{$self->{line}},$self->{lastline});push(@{$self->{line_no}},$self->{lastline_no})}last unless defined($self->{lastline}=readline($self->{FH}));$self->{lastline_no}=$.;my$tmp_line;$self->{lastline}.= $tmp_line while ($self->{lastline}=~ /\\$/ && defined($tmp_line=readline($self->{FH})));chomp$self->{lastline};$self->{lastline}=~ s/^\s+$//}pop(@{$self->{line}}),pop(@{$self->{line_no}})while @{$self->{line}}&& $self->{line}->[-1]eq "";return 1}sub output_init {my$self=shift;my$argsref=shift;my ($type,$num,$var,$init,$printed_name)=@{$argsref}{qw(type num var init printed_name)};local$argsref->{arg}=$num ? "ST(" .($num-1).")" : "/* not a parameter */";if ($init =~ /^=/){if ($printed_name){$self->eval_input_typemap_code(qq/print " $init\\n"/,$argsref)}else {$self->eval_input_typemap_code(qq/print "\\t$var $init\\n"/,$argsref)}}else {if ($init =~ s/^\+// && $num){$self->generate_init({type=>$type,num=>$num,var=>$var,printed_name=>$printed_name,})}elsif ($printed_name){print ";\n";$init =~ s/^;//}else {$self->eval_input_typemap_code(qq/print "\\t$var;\\n"/,$argsref);$init =~ s/^;//}$self->{deferred}.= $self->eval_input_typemap_code(qq/"\\n\\t$init\\n"/,$argsref)}}sub generate_init {my$self=shift;my$argsref=shift;my ($type,$num,$var,$printed_name)=@{$argsref}{qw(type num var printed_name)};my$argoff=$num - 1;my$arg="ST($argoff)";my$typemaps=$self->{typemap};$type=ExtUtils::Typemaps::tidy_type($type);if (not $typemaps->get_typemap(ctype=>$type)){$self->report_typemap_failure($typemaps,$type);return}(my$ntype=$type)=~ s/\s*\*/Ptr/g;(my$subtype=$ntype)=~ s/(?:Array)?(?:Ptr)?$//;my$typem=$typemaps->get_typemap(ctype=>$type);my$xstype=$typem->xstype;$xstype =~ s/OBJ$/REF/ || $xstype =~ s/^T_REF_IV_PTR$/T_PTRREF/ if$self->{func_name}=~ /DESTROY$/;if ($xstype eq 'T_PV' and exists$self->{lengthof}->{$var}){print "\t$var" unless$printed_name;print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";die "default value not supported with length(NAME) supplied" if defined$self->{defaults}->{$var};return}$type =~ tr/:/_/ unless$self->{RetainCplusplusHierarchicalTypes};my$inputmap=$typemaps->get_inputmap(xstype=>$xstype);if (not defined$inputmap){$self->blurt("Error: No INPUT definition for type '$type', typekind '" .$type->xstype ."' found");return}my$expr=$inputmap->cleaned_code;if ($expr =~ /DO_ARRAY_ELEM/){my$subtypemap=$typemaps->get_typemap(ctype=>$subtype);if (not $subtypemap){$self->report_typemap_failure($typemaps,$subtype);return}my$subinputmap=$typemaps->get_inputmap(xstype=>$subtypemap->xstype);if (not $subinputmap){$self->blurt("Error: No INPUT definition for type '$subtype', typekind '" .$subtypemap->xstype ."' found");return}my$subexpr=$subinputmap->cleaned_code;$subexpr =~ s/\$type/\$subtype/g;$subexpr =~ s/ntype/subtype/g;$subexpr =~ s/\$arg/ST(ix_$var)/g;$subexpr =~ s/\n\t/\n\t\t/g;$subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;$subexpr =~ s/\$var/${var}\[ix_$var - $argoff]/;$expr =~ s/DO_ARRAY_ELEM/$subexpr/}if ($expr =~ m#/\*.*scope.*\*/#i){$self->{ScopeThisXSUB}=1}my$eval_vars={var=>$var,printed_name=>$printed_name,type=>$type,ntype=>$ntype,subtype=>$subtype,num=>$num,arg=>$arg,argoff=>$argoff,};if (defined($self->{defaults}->{$var})){$expr =~ s/(\t+)/$1 /g;$expr =~ s/ /\t/g;if ($printed_name){print ";\n"}else {$self->eval_input_typemap_code(qq/print "\\t$var;\\n"/,$eval_vars)}if ($self->{defaults}->{$var}eq 'NO_INIT'){$self->{deferred}.= $self->eval_input_typemap_code(qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/,$eval_vars)}else {$self->{deferred}.= $self->eval_input_typemap_code(qq/"\\n\\tif (items < $num)\\n\\t $var = $self->{defaults}->{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/,$eval_vars)}}elsif ($self->{ScopeThisXSUB}or $expr !~ /^\s*\$var =/){if ($printed_name){print ";\n"}else {$self->eval_input_typemap_code(qq/print "\\t$var;\\n"/,$eval_vars)}$self->{deferred}.= $self->eval_input_typemap_code(qq/"\\n$expr;\\n"/,$eval_vars)}else {die "panic: do not know how to handle this branch for function pointers" if$printed_name;$self->eval_input_typemap_code(qq/print "$expr;\\n"/,$eval_vars)}}sub generate_output {my$self=shift;my$argsref=shift;my ($type,$num,$var,$do_setmagic,$do_push)=@{$argsref}{qw(type num var do_setmagic do_push)};my$arg="ST(" .($num - ($num!=0)).")";my$typemaps=$self->{typemap};$type=ExtUtils::Typemaps::tidy_type($type);local$argsref->{type}=$type;if ($type =~ /^array\(([^,]*),(.*)\)/){print "\t$arg = sv_newmortal();\n";print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";print "\tSvSETMAGIC($arg);\n" if$do_setmagic}else {my$typemap=$typemaps->get_typemap(ctype=>$type);if (not $typemap){$self->report_typemap_failure($typemaps,$type);return}my$outputmap=$typemaps->get_outputmap(xstype=>$typemap->xstype);if (not $outputmap){$self->blurt("Error: No OUTPUT definition for type '$type', typekind '" .$typemap->xstype ."' found");return}(my$ntype=$type)=~ s/\s*\*/Ptr/g;$ntype =~ s/\(\)//g;(my$subtype=$ntype)=~ s/(?:Array)?(?:Ptr)?$//;my$eval_vars={%$argsref,subtype=>$subtype,ntype=>$ntype,arg=>$arg};my$expr=$outputmap->cleaned_code;if ($expr =~ /DO_ARRAY_ELEM/){my$subtypemap=$typemaps->get_typemap(ctype=>$subtype);if (not $subtypemap){$self->report_typemap_failure($typemaps,$subtype);return}my$suboutputmap=$typemaps->get_outputmap(xstype=>$subtypemap->xstype);if (not $suboutputmap){$self->blurt("Error: No OUTPUT definition for type '$subtype', typekind '" .$subtypemap->xstype ."' found");return}my$subexpr=$suboutputmap->cleaned_code;$subexpr =~ s/ntype/subtype/g;$subexpr =~ s/\$arg/ST(ix_$var)/g;$subexpr =~ s/\$var/${var}\[ix_$var]/g;$subexpr =~ s/\n\t/\n\t\t/g;$expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;$self->eval_output_typemap_code("print qq\a$expr\a",$eval_vars);print "\t\tSvSETMAGIC(ST(ix_$var));\n" if$do_setmagic}elsif ($var eq 'RETVAL'){my$orig_arg=$arg;my$indent;my$use_RETVALSV=1;my$do_mortal=0;my$do_copy_tmp=1;my$pre_expr;local$eval_vars->{arg}=$arg='RETVALSV';my$evalexpr=$self->eval_output_typemap_code("qq\a$expr\a",$eval_vars);if ($expr =~ /^\t\Q$arg\E = new/){$do_mortal=1}elsif ($evalexpr =~ /^\t\Q$arg\E\s*=\s*(boolSV\(|(&PL_sv_yes|&PL_sv_no|&PL_sv_undef)\s*;)/){$do_copy_tmp=0;$use_RETVALSV=0}elsif ($evalexpr =~ /^\s*\Q$arg\E\s*=/){$use_RETVALSV=0 if$ntype eq "SVPtr";$do_mortal=1}else {$pre_expr="RETVALSV = sv_newmortal();\n";$do_setmagic=0}if($use_RETVALSV){print "\t{\n\t SV * RETVALSV;\n";$indent="\t "}else {$indent="\t"}print$indent.$pre_expr if$pre_expr;if($use_RETVALSV){$evalexpr =~ s/^(\t| )/$indent/gm;$evalexpr =~ s/\t/ /g;$evalexpr =~ s/ /\t/g}else {if($do_mortal || $do_setmagic){$evalexpr =~ s/RETVALSV/RETVAL/g}else {$evalexpr =~ s/RETVALSV/$orig_arg/g}}print$evalexpr if$evalexpr !~ /^\s*RETVAL = RETVAL;$/;print$indent.'RETVAL'.($use_RETVALSV ? 'SV':'').' = sv_2mortal(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if$do_mortal;print$indent.'SvSETMAGIC(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if$do_setmagic;print$indent."$orig_arg = RETVAL".($use_RETVALSV ? 'SV':'').";\n" if$do_mortal || $do_setmagic || $do_copy_tmp;print "\t}\n" if$use_RETVALSV}elsif ($do_push){print "\tPUSHs(sv_newmortal());\n";local$eval_vars->{arg}="ST($num)";$self->eval_output_typemap_code("print qq\a$expr\a",$eval_vars);print "\tSvSETMAGIC($arg);\n" if$do_setmagic}elsif ($arg =~ /^ST\(\d+\)$/){$self->eval_output_typemap_code("print qq\a$expr\a",$eval_vars);print "\tSvSETMAGIC($arg);\n" if$do_setmagic}}}sub eval_output_typemap_code {my ($self,$code,$other)=@_;return ExtUtils::ParseXS::Eval::eval_output_typemap_code($self,$code,$other)}sub eval_input_typemap_code {my ($self,$code,$other)=@_;return ExtUtils::ParseXS::Eval::eval_input_typemap_code($self,$code,$other)}1;
EXTUTILS_PARSEXS
$fatpacked{"ExtUtils/ParseXS/Constants.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_PARSEXS_CONSTANTS';
package ExtUtils::ParseXS::Constants;use strict;use warnings;use Symbol;our$VERSION='3.35';our@InitFileCode;our$PrototypeRegexp="[" .quotemeta('\$%&*@;[]_')."]";our@XSKeywords=qw(REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE INCLUDE_COMMAND SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK EXPORT_XSUB_SYMBOLS);our$XSKeywordsAlternation=join('|',@XSKeywords);1;
EXTUTILS_PARSEXS_CONSTANTS
$fatpacked{"ExtUtils/ParseXS/CountLines.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_PARSEXS_COUNTLINES';
package ExtUtils::ParseXS::CountLines;use strict;our$VERSION='3.35';our$SECTION_END_MARKER;sub TIEHANDLE {my ($class,$cfile,$fh)=@_;$cfile =~ s/\\/\\\\/g;$cfile =~ s/"/\\"/g;$SECTION_END_MARKER=qq{#line --- "$cfile"};return bless {buffer=>'',fh=>$fh,line_no=>1,},$class}sub PRINT {my$self=shift;for (@_){$self->{buffer}.= $_;while ($self->{buffer}=~ s/^([^\n]*\n)//){my$line=$1;++$self->{line_no};$line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;print {$self->{fh}}$line}}}sub PRINTF {my$self=shift;my$fmt=shift;$self->PRINT(sprintf($fmt,@_))}sub DESTROY {my$self=shift;print {$self->{fh}}$self->{buffer}}sub UNTIE {}sub end_marker {return$SECTION_END_MARKER}1;
EXTUTILS_PARSEXS_COUNTLINES
$fatpacked{"ExtUtils/ParseXS/Eval.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_PARSEXS_EVAL';
package ExtUtils::ParseXS::Eval;use strict;use warnings;our$VERSION='3.35';sub eval_output_typemap_code {my ($_pxs,$_code,$_other)=@_;my ($Package,$ALIAS,$func_name,$Full_func_name,$pname)=@{$_pxs}{qw(Package ALIAS func_name Full_func_name pname)};my ($var,$type,$ntype,$subtype,$arg)=@{$_other}{qw(var type ntype subtype arg)};my$rv=eval$_code;warn $@ if $@;return$rv}sub eval_input_typemap_code {my ($_pxs,$_code,$_other)=@_;my ($Package,$ALIAS,$func_name,$Full_func_name,$pname)=@{$_pxs}{qw(Package ALIAS func_name Full_func_name pname)};my ($var,$type,$num,$init,$printed_name,$arg,$ntype,$argoff,$subtype)=@{$_other}{qw(var type num init printed_name arg ntype argoff subtype)};my$rv=eval$_code;warn $@ if $@;return$rv}1;
EXTUTILS_PARSEXS_EVAL
$fatpacked{"ExtUtils/ParseXS/Utilities.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_PARSEXS_UTILITIES';
package ExtUtils::ParseXS::Utilities;use strict;use warnings;use Exporter;use File::Spec;use ExtUtils::ParseXS::Constants ();our$VERSION='3.35';our (@ISA,@EXPORT_OK);@ISA=qw(Exporter);@EXPORT_OK=qw(standard_typemap_locations trim_whitespace C_string valid_proto_string process_typemaps map_type standard_XS_defs assign_func_args analyze_preprocessor_statements set_cond Warn current_line_number blurt death check_conditional_preprocessor_statements escape_file_for_line_directive report_typemap_failure);SCOPE: {my@tm_template;sub standard_typemap_locations {my$include_ref=shift;if (not @tm_template){@tm_template=qw(typemap);my$updir=File::Spec->updir();for my$dir (File::Spec->catdir(($updir)x 1),File::Spec->catdir(($updir)x 2),File::Spec->catdir(($updir)x 3),File::Spec->catdir(($updir)x 4),){unshift@tm_template,File::Spec->catfile($dir,'typemap');unshift@tm_template,File::Spec->catfile($dir,lib=>ExtUtils=>'typemap')}}my@tm=@tm_template;for my$dir (@{$include_ref}){my$file=File::Spec->catfile($dir,ExtUtils=>'typemap');unshift@tm,$file if -e $file}return@tm}}sub trim_whitespace {$_[0]=~ s/^\s+|\s+$//go}sub C_string {my($string)=@_;$string =~ s[\\][\\\\]g;$string}sub valid_proto_string {my ($string)=@_;if ($string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/){return$string}return 0}sub process_typemaps {my ($tmap,$pwd)=@_;my@tm=ref$tmap ? @{$tmap}: ($tmap);for my$typemap (@tm){die "Can't find $typemap in $pwd\n" unless -r $typemap}push@tm,standard_typemap_locations(\@INC);require ExtUtils::Typemaps;my$typemap=ExtUtils::Typemaps->new;for my$typemap_loc (@tm){next unless -f $typemap_loc;warn("Warning: ignoring non-text typemap file '$typemap_loc'\n"),next unless -T $typemap_loc;$typemap->merge(file=>$typemap_loc,replace=>1)}return$typemap}sub map_type {my ($self,$type,$varname)=@_;$type =~ tr/:/_/ unless$self->{RetainCplusplusHierarchicalTypes};$type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;if ($varname){if ($type =~ / \( \s* \* (?= \s* \) ) /xg){(substr$type,pos$type,0)=" $varname "}else {$type .= "\t$varname"}}return$type}sub standard_XS_defs {print <<"EOF";print <<"EOF";return 1}sub assign_func_args {my ($self,$argsref,$class)=@_;my@func_args=@{$argsref};shift@func_args if defined($class);for my$arg (@func_args){$arg =~ s/^/&/ if$self->{in_out}->{$arg}}return join(", ",@func_args)}sub analyze_preprocessor_statements {my ($self,$statement,$XSS_work_idx,$BootCode_ref)=@_;if ($statement eq 'if'){$XSS_work_idx=@{$self->{XSStack}};push(@{$self->{XSStack}},{type=>'if'})}else {$self->death("Error: '$statement' with no matching 'if'")if$self->{XSStack}->[-1]{type}ne 'if';if ($self->{XSStack}->[-1]{varname}){push(@{$self->{InitFileCode}},"#endif\n");push(@{$BootCode_ref},"#endif")}my(@fns)=keys %{$self->{XSStack}->[-1]{functions}};if ($statement ne 'endif'){@{$self->{XSStack}->[-1]{other_functions}}{@fns}=(1)x @fns;@{$self->{XSStack}->[-1]}{qw(varname functions)}=('',{})}else {my($tmp)=pop(@{$self->{XSStack}});0 while (--$XSS_work_idx && $self->{XSStack}->[$XSS_work_idx]{type}ne 'if');push(@fns,keys %{$tmp->{other_functions}});@{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns}=(1)x @fns}}return ($self,$XSS_work_idx,$BootCode_ref)}sub set_cond {my ($ellipsis,$min_args,$num_args)=@_;my$cond;if ($ellipsis){$cond=($min_args ? qq(items < $min_args) : 0)}elsif ($min_args==$num_args){$cond=qq(items != $min_args)}else {$cond=qq(items < $min_args || items > $num_args)}return$cond}sub current_line_number {my$self=shift;my$line_number=$self->{line_no}->[@{$self->{line_no}}- @{$self->{line}}-1];return$line_number}sub Warn {my$self=shift;my$warn_line_number=$self->current_line_number();print STDERR "@_ in $self->{filename}, line $warn_line_number\n"}sub blurt {my$self=shift;$self->Warn(@_);$self->{errors}++}sub death {my$self=shift;$self->Warn(@_);exit 1}sub check_conditional_preprocessor_statements {my ($self)=@_;my@cpp=grep(/^\#\s*(?:if|e\w+)/,@{$self->{line}});if (@cpp){my$cpplevel;for my$cpp (@cpp){if ($cpp =~ /^\#\s*if/){$cpplevel++}elsif (!$cpplevel){$self->Warn("Warning: #else/elif/endif without #if in this function");print STDERR " (precede it with a blank line if the matching #if is outside the function)\n" if$self->{XSStack}->[-1]{type}eq 'if';return}elsif ($cpp =~ /^\#\s*endif/){$cpplevel--}}$self->Warn("Warning: #if without #endif in this function")if$cpplevel}}sub escape_file_for_line_directive {my$string=shift;$string =~ s/\\/\\\\/g;$string =~ s/"/\\"/g;return$string}sub report_typemap_failure {my ($self,$tm,$ctype,$error_method)=@_;$error_method ||= 'blurt';my@avail_ctypes=$tm->list_mapped_ctypes;my$err="Could not find a typemap for C type '$ctype'.\n" ."The following C types are mapped by the current typemap:\n'" .join("', '",@avail_ctypes)."'\n";$self->$error_method($err);return()}1;
#ifndef PERL_UNUSED_VAR
# define PERL_UNUSED_VAR(var) if (0) var = var
#endif
#ifndef dVAR
# define dVAR dNOOP
#endif
/* This stuff is not part of the API! You have been warned. */
#ifndef PERL_VERSION_DECIMAL
# define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
#endif
#ifndef PERL_DECIMAL_VERSION
# define PERL_DECIMAL_VERSION \\
PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
#endif
#ifndef PERL_VERSION_GE
# define PERL_VERSION_GE(r,v,s) \\
(PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
#endif
#ifndef PERL_VERSION_LE
# define PERL_VERSION_LE(r,v,s) \\
(PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s))
#endif
/* XS_INTERNAL is the explicit static-linkage variant of the default
* XS macro.
*
* XS_EXTERNAL is the same as XS_INTERNAL except it does not include
* "STATIC", ie. it exports XSUB symbols. You probably don't want that
* for anything but the BOOT XSUB.
*
* See XSUB.h in core!
*/
/* TODO: This might be compatible further back than 5.10.0. */
#if PERL_VERSION_GE(5, 10, 0) && PERL_VERSION_LE(5, 15, 1)
# undef XS_EXTERNAL
# undef XS_INTERNAL
# if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING)
# define XS_EXTERNAL(name) __declspec(dllexport) XSPROTO(name)
# define XS_INTERNAL(name) STATIC XSPROTO(name)
# endif
# if defined(__SYMBIAN32__)
# define XS_EXTERNAL(name) EXPORT_C XSPROTO(name)
# define XS_INTERNAL(name) EXPORT_C STATIC XSPROTO(name)
# endif
# ifndef XS_EXTERNAL
# if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus)
# define XS_EXTERNAL(name) void name(pTHX_ CV* cv __attribute__unused__)
# define XS_INTERNAL(name) STATIC void name(pTHX_ CV* cv __attribute__unused__)
# else
# ifdef __cplusplus
# define XS_EXTERNAL(name) extern "C" XSPROTO(name)
# define XS_INTERNAL(name) static XSPROTO(name)
# else
# define XS_EXTERNAL(name) XSPROTO(name)
# define XS_INTERNAL(name) STATIC XSPROTO(name)
# endif
# endif
# endif
#endif
/* perl >= 5.10.0 && perl <= 5.15.1 */
/* The XS_EXTERNAL macro is used for functions that must not be static
* like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL
* macro defined, the best we can do is assume XS is the same.
* Dito for XS_INTERNAL.
*/
#ifndef XS_EXTERNAL
# define XS_EXTERNAL(name) XS(name)
#endif
#ifndef XS_INTERNAL
# define XS_INTERNAL(name) XS(name)
#endif
/* Now, finally, after all this mess, we want an ExtUtils::ParseXS
* internal macro that we're free to redefine for varying linkage due
* to the EXPORT_XSUB_SYMBOLS XS keyword. This is internal, use
* XS_EXTERNAL(name) or XS_INTERNAL(name) in your code if you need to!
*/
#undef XS_EUPXS
#if defined(PERL_EUPXS_ALWAYS_EXPORT)
# define XS_EUPXS(name) XS_EXTERNAL(name)
#else
/* default to internal */
# define XS_EUPXS(name) XS_INTERNAL(name)
#endif
EOF
#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
/* prototype to pass -Wmissing-prototypes */
STATIC void
S_croak_xs_usage(const CV *const cv, const char *const params);
STATIC void
S_croak_xs_usage(const CV *const cv, const char *const params)
{
const GV *const gv = CvGV(cv);
PERL_ARGS_ASSERT_CROAK_XS_USAGE;
if (gv) {
const char *const gvname = GvNAME(gv);
const HV *const stash = GvSTASH(gv);
const char *const hvname = stash ? HvNAME(stash) : NULL;
if (hvname)
Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname, params);
else
Perl_croak_nocontext("Usage: %s(%s)", gvname, params);
} else {
/* Pants. I don't think that it should be possible to get here. */
Perl_croak_nocontext("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
}
}
#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
#define croak_xs_usage S_croak_xs_usage
#endif
/* NOTE: the prototype of newXSproto() is different in versions of perls,
* so we define a portable version of newXSproto()
*/
#ifdef newXS_flags
#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
#else
#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
#endif /* !defined(newXS_flags) */
#if PERL_VERSION_LE(5, 21, 5)
# define newXS_deffile(a,b) Perl_newXS(aTHX_ a,b,file)
#else
# define newXS_deffile(a,b) Perl_newXS_deffile(aTHX_ a,b)
#endif
EOF
EXTUTILS_PARSEXS_UTILITIES
$fatpacked{"ExtUtils/Typemaps.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_TYPEMAPS';
package ExtUtils::Typemaps;use 5.006001;use strict;use warnings;our$VERSION='3.35';require ExtUtils::ParseXS;require ExtUtils::ParseXS::Constants;require ExtUtils::Typemaps::InputMap;require ExtUtils::Typemaps::OutputMap;require ExtUtils::Typemaps::Type;sub new {my$class=shift;my%args=@_;if (defined$args{file}and defined$args{string}){die("Cannot handle both 'file' and 'string' arguments to constructor")}my$self=bless {file=>undef,%args,typemap_section=>[],typemap_lookup=>{},input_section=>[],input_lookup=>{},output_section=>[],output_lookup=>{},}=>$class;$self->_init();return$self}sub _init {my$self=shift;if (defined$self->{string}){$self->_parse(\($self->{string}),$self->{lineno_offset},$self->{fake_filename});delete$self->{string}}elsif (defined$self->{file}and -e $self->{file}){open my$fh,'<',$self->{file}or die "Cannot open typemap file '" .$self->{file}."' for reading: $!";local $/=undef;my$string=<$fh>;$self->_parse(\$string,$self->{lineno_offset},$self->{file})}}sub file {$_[0]->{file}=$_[1]if @_ > 1;$_[0]->{file}}sub add_typemap {my$self=shift;my$type;my%args;if ((@_ % 2)==1){my$orig=shift;$type=$orig->new();%args=@_}else {%args=@_;my$ctype=$args{ctype};die("Need ctype argument")if not defined$ctype;my$xstype=$args{xstype};die("Need xstype argument")if not defined$xstype;$type=ExtUtils::Typemaps::Type->new(xstype=>$xstype,'prototype'=>$args{'prototype'},ctype=>$ctype,)}if ($args{skip}and $args{replace}){die("Cannot use both 'skip' and 'replace'")}if ($args{replace}){$self->remove_typemap(ctype=>$type->ctype)}elsif ($args{skip}){return()if exists$self->{typemap_lookup}{$type->ctype}}else {$self->validate(typemap_xstype=>$type->xstype,ctype=>$type->ctype)}push @{$self->{typemap_section}},$type;$self->{typemap_lookup}{$type->tidy_ctype}=$#{$self->{typemap_section}};return 1}sub add_inputmap {my$self=shift;my$input;my%args;if ((@_ % 2)==1){my$orig=shift;$input=$orig->new();%args=@_}else {%args=@_;my$xstype=$args{xstype};die("Need xstype argument")if not defined$xstype;my$code=$args{code};die("Need code argument")if not defined$code;$input=ExtUtils::Typemaps::InputMap->new(xstype=>$xstype,code=>$code,)}if ($args{skip}and $args{replace}){die("Cannot use both 'skip' and 'replace'")}if ($args{replace}){$self->remove_inputmap(xstype=>$input->xstype)}elsif ($args{skip}){return()if exists$self->{input_lookup}{$input->xstype}}else {$self->validate(inputmap_xstype=>$input->xstype)}push @{$self->{input_section}},$input;$self->{input_lookup}{$input->xstype}=$#{$self->{input_section}};return 1}sub add_outputmap {my$self=shift;my$output;my%args;if ((@_ % 2)==1){my$orig=shift;$output=$orig->new();%args=@_}else {%args=@_;my$xstype=$args{xstype};die("Need xstype argument")if not defined$xstype;my$code=$args{code};die("Need code argument")if not defined$code;$output=ExtUtils::Typemaps::OutputMap->new(xstype=>$xstype,code=>$code,)}if ($args{skip}and $args{replace}){die("Cannot use both 'skip' and 'replace'")}if ($args{replace}){$self->remove_outputmap(xstype=>$output->xstype)}elsif ($args{skip}){return()if exists$self->{output_lookup}{$output->xstype}}else {$self->validate(outputmap_xstype=>$output->xstype)}push @{$self->{output_section}},$output;$self->{output_lookup}{$output->xstype}=$#{$self->{output_section}};return 1}sub add_string {my$self=shift;my%args=@_;die("Need 'string' argument")if not defined$args{string};my$other=ExtUtils::Typemaps->new(string=>$args{string});$self->merge(typemap=>$other)}sub remove_typemap {my$self=shift;my$ctype;if (@_ > 1){my%args=@_;$ctype=$args{ctype};die("Need ctype argument")if not defined$ctype;$ctype=tidy_type($ctype)}else {$ctype=$_[0]->tidy_ctype}return$self->_remove($ctype,$self->{typemap_section},$self->{typemap_lookup})}sub remove_inputmap {my$self=shift;my$xstype;if (@_ > 1){my%args=@_;$xstype=$args{xstype};die("Need xstype argument")if not defined$xstype}else {$xstype=$_[0]->xstype}return$self->_remove($xstype,$self->{input_section},$self->{input_lookup})}sub remove_outputmap {my$self=shift;my$xstype;if (@_ > 1){my%args=@_;$xstype=$args{xstype};die("Need xstype argument")if not defined$xstype}else {$xstype=$_[0]->xstype}return$self->_remove($xstype,$self->{output_section},$self->{output_lookup})}sub _remove {my$self=shift;my$rm=shift;my$array=shift;my$lookup=shift;my$index=$lookup->{$rm};return()if not defined$index;splice(@$array,$index,1);for my$key (keys %$lookup){if ($lookup->{$key}> $index){$lookup->{$key}--}}return()}sub get_typemap {my$self=shift;die("Need named parameters, got uneven number")if @_ % 2;my%args=@_;my$ctype=$args{ctype};die("Need ctype argument")if not defined$ctype;$ctype=tidy_type($ctype);my$index=$self->{typemap_lookup}{$ctype};return()if not defined$index;return$self->{typemap_section}[$index]}sub get_inputmap {my$self=shift;die("Need named parameters, got uneven number")if @_ % 2;my%args=@_;my$xstype=$args{xstype};my$ctype=$args{ctype};die("Need xstype or ctype argument")if not defined$xstype and not defined$ctype;die("Need xstype OR ctype arguments, not both")if defined$xstype and defined$ctype;if (defined$ctype){my$tm=$self->get_typemap(ctype=>$ctype);$xstype=$tm && $tm->xstype;return()if not defined$xstype}my$index=$self->{input_lookup}{$xstype};return()if not defined$index;return$self->{input_section}[$index]}sub get_outputmap {my$self=shift;die("Need named parameters, got uneven number")if @_ % 2;my%args=@_;my$xstype=$args{xstype};my$ctype=$args{ctype};die("Need xstype or ctype argument")if not defined$xstype and not defined$ctype;die("Need xstype OR ctype arguments, not both")if defined$xstype and defined$ctype;if (defined$ctype){my$tm=$self->get_typemap(ctype=>$ctype);$xstype=$tm && $tm->xstype;return()if not defined$xstype}my$index=$self->{output_lookup}{$xstype};return()if not defined$index;return$self->{output_section}[$index]}sub write {my$self=shift;my%args=@_;my$file=defined$args{file}? $args{file}: $self->file();die("write() needs a file argument (or set the file name of the typemap using the 'file' method)")if not defined$file;open my$fh,'>',$file or die "Cannot open typemap file '$file' for writing: $!";print$fh $self->as_string();close$fh}sub as_string {my$self=shift;my$typemap=$self->{typemap_section};my@code;push@code,"TYPEMAP\n";for my$entry (@$typemap){push@code,$entry->ctype ."\t" .$entry->xstype .($entry->proto ne '' ? "\t".$entry->proto : '')."\n"}my$input=$self->{input_section};if (@$input){push@code,"\nINPUT\n";for my$entry (@$input){push@code,$entry->xstype,"\n",$entry->code,"\n"}}my$output=$self->{output_section};if (@$output){push@code,"\nOUTPUT\n";for my$entry (@$output){push@code,$entry->xstype,"\n",$entry->code,"\n"}}return join '',@code}sub as_embedded_typemap {my$self=shift;my$string=$self->as_string;my@ident_cand=qw(END_TYPEMAP END_OF_TYPEMAP END);my$icand=0;my$cand_suffix="";while ($string =~ /^\Q$ident_cand[$icand]$cand_suffix\E\s*$/m){$icand++;if ($icand==@ident_cand){$icand=0;++$cand_suffix}}my$marker="$ident_cand[$icand]$cand_suffix";return "TYPEMAP: <<$marker;\n$string\n$marker\n"}sub merge {my$self=shift;my%args=@_;if (exists$args{typemap}and exists$args{file}){die("Need {file} OR {typemap} argument. Not both!")}elsif (not exists$args{typemap}and not exists$args{file}){die("Need {file} or {typemap} argument!")}my@params;push@params,'replace'=>$args{replace}if exists$args{replace};push@params,'skip'=>$args{skip}if exists$args{skip};my$typemap=$args{typemap};if (not defined$typemap){$typemap=ref($self)->new(file=>$args{file},@params)}for my$entry (@{$typemap->{typemap_section}}){$self->add_typemap($entry,@params)}for my$entry (@{$typemap->{input_section}}){$self->add_inputmap($entry,@params)}for my$entry (@{$typemap->{output_section}}){$self->add_outputmap($entry,@params)}return 1}sub is_empty {my$self=shift;return @{$self->{typemap_section}}==0 && @{$self->{input_section}}==0 && @{$self->{output_section}}==0}sub list_mapped_ctypes {my$self=shift;return sort keys %{$self->{typemap_lookup}}}sub _get_typemap_hash {my$self=shift;my$lookup=$self->{typemap_lookup};my$storage=$self->{typemap_section};my%rv;for my$ctype (keys %$lookup){$rv{$ctype}=$storage->[$lookup->{$ctype}]->xstype}return \%rv}sub _get_inputmap_hash {my$self=shift;my$lookup=$self->{input_lookup};my$storage=$self->{input_section};my%rv;for my$xstype (keys %$lookup){$rv{$xstype}=$storage->[$lookup->{$xstype}]->code;$rv{$xstype}=~ s/\s*\z/\n/}return \%rv}sub _get_outputmap_hash {my$self=shift;my$lookup=$self->{output_lookup};my$storage=$self->{output_section};my%rv;for my$xstype (keys %$lookup){$rv{$xstype}=$storage->[$lookup->{$xstype}]->code;$rv{$xstype}=~ s/\s*\z/\n/}return \%rv}sub _get_prototype_hash {my$self=shift;my$lookup=$self->{typemap_lookup};my$storage=$self->{typemap_section};my%rv;for my$ctype (keys %$lookup){$rv{$ctype}=$storage->[$lookup->{$ctype}]->proto || '$'}return \%rv}sub validate {my$self=shift;my%args=@_;if (exists$args{ctype}and exists$self->{typemap_lookup}{tidy_type($args{ctype})}){die("Multiple definition of ctype '$args{ctype}' in TYPEMAP section")}if (exists$args{inputmap_xstype}and exists$self->{input_lookup}{$args{inputmap_xstype}}){die("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section")}if (exists$args{outputmap_xstype}and exists$self->{output_lookup}{$args{outputmap_xstype}}){die("Multiple definition of xstype '$args{outputmap_xstype}' in OUTPUTMAP section")}return 1}sub clone {my$proto=shift;my%args=@_;my$self;if ($args{shallow}){$self=bless({%$proto,typemap_section=>[@{$proto->{typemap_section}}],typemap_lookup=>{%{$proto->{typemap_lookup}}},input_section=>[@{$proto->{input_section}}],input_lookup=>{%{$proto->{input_lookup}}},output_section=>[@{$proto->{output_section}}],output_lookup=>{%{$proto->{output_lookup}}},}=>ref($proto))}else {$self=bless({%$proto,typemap_section=>[map $_->new,@{$proto->{typemap_section}}],typemap_lookup=>{%{$proto->{typemap_lookup}}},input_section=>[map $_->new,@{$proto->{input_section}}],input_lookup=>{%{$proto->{input_lookup}}},output_section=>[map $_->new,@{$proto->{output_section}}],output_lookup=>{%{$proto->{output_lookup}}},}=>ref($proto))}return$self}sub tidy_type {local $_=shift;if (/[<>]/){s/\s*([<>])\s*/$1/g;s/>>/> >/g}s#\s*(\*+)\s*#$1#g;s#(\*+)# $1 #g ;s/^\s+//;s/\s+$//;s/\s+/ /g;$_}sub _parse {my$self=shift;my$stringref=shift;my$lineno_offset=shift;$lineno_offset=0 if not defined$lineno_offset;my$filename=shift;$filename='<string>' if not defined$filename;my$replace=$self->{replace};my$skip=$self->{skip};die "Can only replace OR skip" if$replace and $skip;my@add_params;push@add_params,replace=>1 if$replace;push@add_params,skip=>1 if$skip;my$section='typemap';my$lineno=$lineno_offset;my$junk="";my$current=\$junk;my@input_expr;my@output_expr;while ($$stringref =~ /^(.*)$/gcm){local $_=$1;++$lineno;chomp;next if /^\s*#/;if (/^INPUT\s*$/){$section='input';$current=\$junk;next}elsif (/^OUTPUT\s*$/){$section='output';$current=\$junk;next}elsif (/^TYPEMAP\s*$/){$section='typemap';$current=\$junk;next}if ($section eq 'typemap'){my$line=$_;s/^\s+//;s/\s+$//;next if $_ eq '' or /^#/;my($type,$kind,$proto)=/^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"),next;$proto='$' unless$proto;warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n")unless _valid_proto_string($proto);$self->add_typemap(ExtUtils::Typemaps::Type->new(xstype=>$kind,proto=>$proto,ctype=>$type),@add_params)}elsif (/^\s/){s/\s+$//;$$current .= $$current eq '' ? $_ : "\n".$_}elsif ($_ eq ''){next}elsif ($section eq 'input'){s/\s+$//;push@input_expr,{xstype=>$_,code=>''};$current=\$input_expr[-1]{code}}else {s/\s+$//;push@output_expr,{xstype=>$_,code=>''};$current=\$output_expr[-1]{code}}}for my$inexpr (@input_expr){$self->add_inputmap(ExtUtils::Typemaps::InputMap->new(%$inexpr),@add_params)}for my$outexpr (@output_expr){$self->add_outputmap(ExtUtils::Typemaps::OutputMap->new(%$outexpr),@add_params)}return 1}sub _valid_proto_string {my$string=shift;if ($string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/o){return$string}return 0 }sub _escape_backslashes {my$string=shift;$string =~ s[\\][\\\\]g;$string}1;
EXTUTILS_TYPEMAPS
$fatpacked{"ExtUtils/Typemaps/Cmd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_TYPEMAPS_CMD';
package ExtUtils::Typemaps::Cmd;use 5.006001;use strict;use warnings;our$VERSION='3.35';use ExtUtils::Typemaps;require Exporter;our@ISA=qw(Exporter);our@EXPORT=qw(embeddable_typemap);our%EXPORT_TAGS=(all=>\@EXPORT);sub embeddable_typemap {my@tms=@_;my@tm_objs=map [$_,_intuit_typemap_source($_)],@tms;my$final_tm;if (@tm_objs==1){$final_tm=shift(@tm_objs)->[1]}else {$final_tm=ExtUtils::Typemaps->new;for my$other_tm (@tm_objs){my ($tm_ident,$tm_obj)=@$other_tm;eval {$final_tm->merge(typemap=>$tm_obj);1}or do {my$err=$@ || 'Zombie error';die "Failed to merge typ"}}}return$final_tm->as_embedded_typemap()}sub _load_module {my$name=shift;return eval "require $name; 1"}SCOPE: {my%sources=(module=>sub {my$ident=shift;my$tm;if (/::/){for my$module ($ident,"ExtUtils::Typemaps::$ident"){if (_load_module($module)){eval {$tm=$module->new}and return$tm}}}else {for my$module ("ExtUtils::Typemaps::$ident","$ident"){if (_load_module($module)){eval {$tm=$module->new}and return$tm}}}return()},file=>sub {my$ident=shift;return unless -e $ident and -r _;return ExtUtils::Typemaps->new(file=>$ident)},);sub _intuit_typemap_source {my$identifier=shift;my@locate_attempts;if ($identifier =~ /::/ || $identifier !~ /[^\w_]/){@locate_attempts=qw(module file)}else {@locate_attempts=qw(file module)}for my$source (@locate_attempts){my$tm=$sources{$source}->($identifier);return$tm if defined$tm}die "Unable to find typemap for '$identifier': " ."Tried to load both as file or module and failed.\n"}}1;
EXTUTILS_TYPEMAPS_CMD
$fatpacked{"ExtUtils/Typemaps/InputMap.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_TYPEMAPS_INPUTMAP';
package ExtUtils::Typemaps::InputMap;use 5.006001;use strict;use warnings;our$VERSION='3.35';sub new {my$prot=shift;my$class=ref($prot)||$prot;my%args=@_;if (!ref($prot)){if (not defined$args{xstype}or not defined$args{code}){die("Need xstype and code parameters")}}my$self=bless((ref($prot)? {%$prot}: {})=>$class);$self->{xstype}=$args{xstype}if defined$args{xstype};$self->{code}=$args{code}if defined$args{code};$self->{code}=~ s/^(?=\S)/\t/mg;return$self}sub code {$_[0]->{code}=$_[1]if @_ > 1;return $_[0]->{code}}sub xstype {return $_[0]->{xstype}}sub cleaned_code {my$self=shift;my$code=$self->code;$code =~ s/(?:;+\s*|;*\s+)\z//s;$code =~ s/^\s+#/#/mg;$code =~ s/\s*\z/\n/;return$code}1;
EXTUTILS_TYPEMAPS_INPUTMAP
$fatpacked{"ExtUtils/Typemaps/OutputMap.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_TYPEMAPS_OUTPUTMAP';
package ExtUtils::Typemaps::OutputMap;use 5.006001;use strict;use warnings;our$VERSION='3.35';sub new {my$prot=shift;my$class=ref($prot)||$prot;my%args=@_;if (!ref($prot)){if (not defined$args{xstype}or not defined$args{code}){die("Need xstype and code parameters")}}my$self=bless((ref($prot)? {%$prot}: {})=>$class);$self->{xstype}=$args{xstype}if defined$args{xstype};$self->{code}=$args{code}if defined$args{code};$self->{code}=~ s/^(?=\S)/\t/mg;return$self}sub code {$_[0]->{code}=$_[1]if @_ > 1;return $_[0]->{code}}sub xstype {return $_[0]->{xstype}}sub cleaned_code {my$self=shift;my$code=$self->code;$code =~ s/^\s+#/#/mg;$code =~ s/\s*\z/\n/;return$code}sub targetable {my$self=shift;return$self->{targetable}if exists$self->{targetable};our$bal;$bal=qr[
(?:
(?>[^()]+)
|
\( (??{ $bal }) \)
)*
]x;my$bal_no_comma=qr[
(?:
(?>[^(),]+)
|
\( (??{ $bal }) \)
)+
]x;my$sv_cast=qr[
(?:
\( \s* SV \s* \* \s* \) \s*
)?
]x;my$size=qr[ # Third arg (to setpvn)
, \s* (??{ $bal })
]xo;my$code=$self->code;use re 'eval';my ($type,$with_size,$arg,$sarg)=($code =~ m[^
\s+
sv_set([iunp])v(n)? # Type, is_setpvn
\s*
\( \s*
$sv_cast \$arg \s* , \s*
( $bal_no_comma ) # Set from
( $size )? # Possible sizeof set-from
\s* \) \s* ; \s* $
]xo);my$rv=undef;if ($type){$rv={type=>$type,with_size=>$with_size,what=>$arg,what_size=>$sarg,}}$self->{targetable}=$rv;return$rv}1;
EXTUTILS_TYPEMAPS_OUTPUTMAP
$fatpacked{"ExtUtils/Typemaps/Type.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_TYPEMAPS_TYPE';
package ExtUtils::Typemaps::Type;use 5.006001;use strict;use warnings;require ExtUtils::Typemaps;our$VERSION='3.35';sub new {my$prot=shift;my$class=ref($prot)||$prot;my%args=@_;if (!ref($prot)){if (not defined$args{xstype}or not defined$args{ctype}){die("Need xstype and ctype parameters")}}my$self=bless((ref($prot)? {%$prot}: {proto=>''})=>$class);$self->{xstype}=$args{xstype}if defined$args{xstype};$self->{ctype}=$args{ctype}if defined$args{ctype};$self->{tidy_ctype}=ExtUtils::Typemaps::tidy_type($self->{ctype});$self->{proto}=$args{'prototype'}if defined$args{'prototype'};return$self}sub proto {$_[0]->{proto}=$_[1]if @_ > 1;return $_[0]->{proto}}sub xstype {return $_[0]->{xstype}}sub ctype {return defined($_[0]->{ctype})? $_[0]->{ctype}: $_[0]->{tidy_ctype}}sub tidy_ctype {return $_[0]->{tidy_ctype}}1;
EXTUTILS_TYPEMAPS_TYPE
$fatpacked{"ExtUtils/testlib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_TESTLIB';
package ExtUtils::testlib;use strict;use warnings;our$VERSION='7.30';$VERSION=eval$VERSION;use Cwd;use File::Spec;my$cwd;BEGIN {($cwd)=getcwd()=~ /(.*)/}use lib map {File::Spec->rel2abs($_,$cwd)}qw(blib/arch blib/lib);1;
EXTUTILS_TESTLIB
$fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP';
package JSON::PP;use 5.005;use strict;use Exporter ();BEGIN {@JSON::PP::ISA=('Exporter')}use overload ();use JSON::PP::Boolean;use Carp ();$JSON::PP::VERSION='2.94';@JSON::PP::EXPORT=qw(encode_json decode_json from_json to_json);use constant P_ASCII=>0;use constant P_LATIN1=>1;use constant P_UTF8=>2;use constant P_INDENT=>3;use constant P_CANONICAL=>4;use constant P_SPACE_BEFORE=>5;use constant P_SPACE_AFTER=>6;use constant P_ALLOW_NONREF=>7;use constant P_SHRINK=>8;use constant P_ALLOW_BLESSED=>9;use constant P_CONVERT_BLESSED=>10;use constant P_RELAXED=>11;use constant P_LOOSE=>12;use constant P_ALLOW_BIGNUM=>13;use constant P_ALLOW_BAREKEY=>14;use constant P_ALLOW_SINGLEQUOTE=>15;use constant P_ESCAPE_SLASH=>16;use constant P_AS_NONBLESSED=>17;use constant P_ALLOW_UNKNOWN=>18;use constant OLD_PERL=>$] < 5.008 ? 1 : 0;use constant USE_B=>0;BEGIN {if (USE_B){require B}}BEGIN {my@xs_compati_bit_properties=qw(latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink allow_blessed convert_blessed relaxed allow_unknown);my@pp_bit_properties=qw(allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed);if (OLD_PERL){my$helper=$] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005';eval qq| require $helper |;if ($@){Carp::croak $@}}for my$name (@xs_compati_bit_properties,@pp_bit_properties){my$property_id='P_' .uc($name);eval qq/
sub $name {
my \$enable = defined \$_[1] ? \$_[1] : 1;
if (\$enable) {
\$_[0]->{PROPS}->[$property_id] = 1;
}
else {
\$_[0]->{PROPS}->[$property_id] = 0;
}
\$_[0];
}
sub get_$name {
\$_[0]->{PROPS}->[$property_id] ? 1 : '';
}
/}}my$JSON;sub encode_json ($) {($JSON ||= __PACKAGE__->new->utf8)->encode(@_)}sub decode_json {($JSON ||= __PACKAGE__->new->utf8)->decode(@_)}sub to_json($) {Carp::croak ("JSON::PP::to_json has been renamed to encode_json.")}sub from_json($) {Carp::croak ("JSON::PP::from_json has been renamed to decode_json.")}sub new {my$class=shift;my$self={max_depth=>512,max_size=>0,indent_length=>3,};bless$self,$class}sub encode {return $_[0]->PP_encode_json($_[1])}sub decode {return $_[0]->PP_decode_json($_[1],0x00000000)}sub decode_prefix {return $_[0]->PP_decode_json($_[1],0x00000001)}sub pretty {my ($self,$v)=@_;my$enable=defined$v ? $v : 1;if ($enable){$self->indent(1)->space_before(1)->space_after(1)}else {$self->indent(0)->space_before(0)->space_after(0)}$self}sub max_depth {my$max=defined $_[1]? $_[1]: 0x80000000;$_[0]->{max_depth}=$max;$_[0]}sub get_max_depth {$_[0]->{max_depth}}sub max_size {my$max=defined $_[1]? $_[1]: 0;$_[0]->{max_size}=$max;$_[0]}sub get_max_size {$_[0]->{max_size}}sub filter_json_object {if (defined $_[1]and ref $_[1]eq 'CODE'){$_[0]->{cb_object}=$_[1]}else {delete $_[0]->{cb_object}}$_[0]->{F_HOOK}=($_[0]->{cb_object}or $_[0]->{cb_sk_object})? 1 : 0;$_[0]}sub filter_json_single_key_object {if (@_==1 or @_ > 3){Carp::croak("Usage: JSON::PP::filter_json_single_key_object(self, key, callback = undef)")}if (defined $_[2]and ref $_[2]eq 'CODE'){$_[0]->{cb_sk_object}->{$_[1]}=$_[2]}else {delete $_[0]->{cb_sk_object}->{$_[1]};delete $_[0]->{cb_sk_object}unless %{$_[0]->{cb_sk_object}|| {}}}$_[0]->{F_HOOK}=($_[0]->{cb_object}or $_[0]->{cb_sk_object})? 1 : 0;$_[0]}sub indent_length {if (!defined $_[1]or $_[1]> 15 or $_[1]< 0){Carp::carp "The acceptable range of indent_length() is 0 to 15."}else {$_[0]->{indent_length}=$_[1]}$_[0]}sub get_indent_length {$_[0]->{indent_length}}sub sort_by {$_[0]->{sort_by}=defined $_[1]? $_[1]: 1;$_[0]}sub allow_bigint {Carp::carp("allow_bigint() is obsoleted. use allow_bignum() instead.");$_[0]->allow_bignum}{my$max_depth;my$indent;my$ascii;my$latin1;my$utf8;my$space_before;my$space_after;my$canonical;my$allow_blessed;my$convert_blessed;my$indent_length;my$escape_slash;my$bignum;my$as_nonblessed;my$depth;my$indent_count;my$keysort;sub PP_encode_json {my$self=shift;my$obj=shift;$indent_count=0;$depth=0;my$props=$self->{PROPS};($ascii,$latin1,$utf8,$indent,$canonical,$space_before,$space_after,$allow_blessed,$convert_blessed,$escape_slash,$bignum,$as_nonblessed)=@{$props}[P_ASCII .. P_SPACE_AFTER,P_ALLOW_BLESSED,P_CONVERT_BLESSED,P_ESCAPE_SLASH,P_ALLOW_BIGNUM,P_AS_NONBLESSED];($max_depth,$indent_length)=@{$self}{qw/max_depth indent_length/};$keysort=$canonical ? sub {$a cmp $b}: undef;if ($self->{sort_by}){$keysort=ref($self->{sort_by})eq 'CODE' ? $self->{sort_by}: $self->{sort_by}=~ /\D+/ ? $self->{sort_by}: sub {$a cmp $b}}encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")if(!ref$obj and!$props->[P_ALLOW_NONREF ]);my$str=$self->object_to_json($obj);$str .= "\n" if ($indent);unless ($ascii or $latin1 or $utf8){utf8::upgrade($str)}if ($props->[P_SHRINK ]){utf8::downgrade($str,1)}return$str}sub object_to_json {my ($self,$obj)=@_;my$type=ref($obj);if($type eq 'HASH'){return$self->hash_to_json($obj)}elsif($type eq 'ARRAY'){return$self->array_to_json($obj)}elsif ($type){if (blessed($obj)){return$self->value_to_json($obj)if ($obj->isa('JSON::PP::Boolean'));if ($convert_blessed and $obj->can('TO_JSON')){my$result=$obj->TO_JSON();if (defined$result and ref($result)){if (refaddr($obj)eq refaddr($result)){encode_error(sprintf("%s::TO_JSON method returned same object as was passed instead of a new one",ref$obj))}}return$self->object_to_json($result)}return "$obj" if ($bignum and _is_bignum($obj));if ($allow_blessed){return$self->blessed_to_json($obj)if ($as_nonblessed);return 'null'}encode_error(sprintf("encountered object '%s', but neither allow_blessed " ."nor convert_blessed settings are enabled",$obj))}else {return$self->value_to_json($obj)}}else{return$self->value_to_json($obj)}}sub hash_to_json {my ($self,$obj)=@_;my@res;encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")if (++$depth > $max_depth);my ($pre,$post)=$indent ? $self->_up_indent(): ('','');my$del=($space_before ? ' ' : '').':' .($space_after ? ' ' : '');for my$k (_sort($obj)){if (OLD_PERL){utf8::decode($k)}push@res,$self->string_to_json($k).$del .(ref$obj->{$k}? $self->object_to_json($obj->{$k}): $self->value_to_json($obj->{$k}))}--$depth;$self->_down_indent()if ($indent);return '{}' unless@res;return '{' .$pre .join(",$pre",@res).$post .'}'}sub array_to_json {my ($self,$obj)=@_;my@res;encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")if (++$depth > $max_depth);my ($pre,$post)=$indent ? $self->_up_indent(): ('','');for my$v (@$obj){push@res,ref($v)? $self->object_to_json($v): $self->value_to_json($v)}--$depth;$self->_down_indent()if ($indent);return '[]' unless@res;return '[' .$pre .join(",$pre",@res).$post .']'}sub _looks_like_number {my$value=shift;if (USE_B){my$b_obj=B::svref_2object(\$value);my$flags=$b_obj->FLAGS;return 1 if$flags & (B::SVp_IOK()| B::SVp_NOK())and!($flags & B::SVp_POK());return}else {no warnings 'numeric';return unless length((my$dummy="")& $value);return unless 0 + $value eq $value;return 1 if$value * 0==0;return -1}}sub value_to_json {my ($self,$value)=@_;return 'null' if(!defined$value);my$type=ref($value);if (!$type){if (_looks_like_number($value)){return$value}return$self->string_to_json($value)}elsif(blessed($value)and $value->isa('JSON::PP::Boolean')){return $$value==1 ? 'true' : 'false'}else {if ((overload::StrVal($value)=~ /=(\w+)/)[0]){return$self->value_to_json("$value")}if ($type eq 'SCALAR' and defined $$value){return $$value eq '1' ? 'true' : $$value eq '0' ? 'false' : $self->{PROPS}->[P_ALLOW_UNKNOWN ]? 'null' : encode_error("cannot encode reference to scalar")}if ($self->{PROPS}->[P_ALLOW_UNKNOWN ]){return 'null'}else {if ($type eq 'SCALAR' or $type eq 'REF'){encode_error("cannot encode reference to scalar")}else {encode_error("encountered $value, but JSON can only represent references to arrays or hashes")}}}}my%esc=("\n"=>'\n',"\r"=>'\r',"\t"=>'\t',"\f"=>'\f',"\b"=>'\b',"\""=>'\"',"\\"=>'\\\\',"\'"=>'\\\'',);sub string_to_json {my ($self,$arg)=@_;$arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;$arg =~ s/\//\\\//g if ($escape_slash);$arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;if ($ascii){$arg=JSON_PP_encode_ascii($arg)}if ($latin1){$arg=JSON_PP_encode_latin1($arg)}if ($utf8){utf8::encode($arg)}return '"' .$arg .'"'}sub blessed_to_json {my$reftype=reftype($_[1])|| '';if ($reftype eq 'HASH'){return $_[0]->hash_to_json($_[1])}elsif ($reftype eq 'ARRAY'){return $_[0]->array_to_json($_[1])}else {return 'null'}}sub encode_error {my$error=shift;Carp::croak "$error"}sub _sort {defined$keysort ? (sort$keysort (keys %{$_[0]})): keys %{$_[0]}}sub _up_indent {my$self=shift;my$space=' ' x $indent_length;my ($pre,$post)=('','');$post="\n" .$space x $indent_count;$indent_count++;$pre="\n" .$space x $indent_count;return ($pre,$post)}sub _down_indent {$indent_count--}sub PP_encode_box {{depth=>$depth,indent_count=>$indent_count,}}}sub _encode_ascii {join('',map {$_ <= 127 ? chr($_): $_ <= 65535 ? sprintf('\u%04x',$_): sprintf('\u%x\u%x',_encode_surrogates($_))}unpack('U*',$_[0]))}sub _encode_latin1 {join('',map {$_ <= 255 ? chr($_): $_ <= 65535 ? sprintf('\u%04x',$_): sprintf('\u%x\u%x',_encode_surrogates($_))}unpack('U*',$_[0]))}sub _encode_surrogates {my$uni=$_[0]- 0x10000;return ($uni / 0x400 + 0xD800,$uni % 0x400 + 0xDC00)}sub _is_bignum {$_[0]->isa('Math::BigInt')or $_[0]->isa('Math::BigFloat')}my$max_intsize;BEGIN {my$checkint=1111;for my$d (5..64){$checkint .= 1;my$int=eval qq| $checkint |;if ($int =~ /[eE]/){$max_intsize=$d - 1;last}}}{my%escapes=(b=>"\x8",t=>"\x9",n=>"\xA",f=>"\xC",r=>"\xD",'\\'=>'\\','"'=>'"','/'=>'/',);my$text;my$at;my$ch;my$len;my$depth;my$encoding;my$is_valid_utf8;my$utf8_len;my$utf8;my$max_depth;my$max_size;my$relaxed;my$cb_object;my$cb_sk_object;my$F_HOOK;my$allow_bignum;my$singlequote;my$loose;my$allow_barekey;sub _detect_utf_encoding {my$text=shift;my@octets=unpack('C4',$text);return 'unknown' unless defined$octets[3];return ($octets[0]and $octets[1])? 'UTF-8' : (!$octets[0]and $octets[1])? 'UTF-16BE' : (!$octets[0]and!$octets[1])? 'UTF-32BE' : ($octets[2])? 'UTF-16LE' : (!$octets[2])? 'UTF-32LE' : 'unknown'}sub PP_decode_json {my ($self,$want_offset);($self,$text,$want_offset)=@_;($at,$ch,$depth)=(0,'',0);if (!defined$text or ref$text){decode_error("malformed JSON string, neither array, object, number, string or atom")}my$props=$self->{PROPS};($utf8,$relaxed,$loose,$allow_bignum,$allow_barekey,$singlequote)=@{$props}[P_UTF8,P_RELAXED,P_LOOSE .. P_ALLOW_SINGLEQUOTE];if ($utf8){$encoding=_detect_utf_encoding($text);if ($encoding ne 'UTF-8' and $encoding ne 'unknown'){require Encode;Encode::from_to($text,$encoding,'utf-8')}else {utf8::downgrade($text,1)or Carp::croak("Wide character in subroutine entry")}}else {utf8::upgrade($text);utf8::encode($text)}$len=length$text;($max_depth,$max_size,$cb_object,$cb_sk_object,$F_HOOK)=@{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/};if ($max_size > 1){use bytes;my$bytes=length$text;decode_error(sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" ,$bytes,$max_size),1)if ($bytes > $max_size)}white();decode_error("malformed JSON string, neither array, object, number, string or atom")unless defined$ch;my$result=value();if (!$props->[P_ALLOW_NONREF ]and!ref$result){decode_error('JSON text must be an object or array (but found number, string, true, false or null,' .' use allow_nonref to allow this)',1)}Carp::croak('something wrong.')if$len < $at;my$consumed=defined$ch ? $at - 1 : $at;white();return ($result,$consumed)if$want_offset;decode_error("garbage after JSON object")if defined$ch;$result}sub next_chr {return$ch=undef if($at >= $len);$ch=substr($text,$at++,1)}sub value {white();return if(!defined$ch);return object()if($ch eq '{');return array()if($ch eq '[');return string()if($ch eq '"' or ($singlequote and $ch eq "'"));return number()if($ch =~ /[0-9]/ or $ch eq '-');return word()}sub string {my$utf16;my$is_utf8;($is_valid_utf8,$utf8_len)=('',0);my$s='';if($ch eq '"' or ($singlequote and $ch eq "'")){my$boundChar=$ch;OUTER: while(defined(next_chr())){if($ch eq $boundChar){next_chr();if ($utf16){decode_error("missing low surrogate character in surrogate pair")}utf8::decode($s)if($is_utf8);return$s}elsif($ch eq '\\'){next_chr();if(exists$escapes{$ch}){$s .= $escapes{$ch}}elsif($ch eq 'u'){my$u='';for(1..4){$ch=next_chr();last OUTER if($ch !~ /[0-9a-fA-F]/);$u .= $ch}if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/){$utf16=$u}elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/){unless (defined$utf16){decode_error("missing high surrogate character in surrogate pair")}$is_utf8=1;$s .= JSON_PP_decode_surrogates($utf16,$u)|| next;$utf16=undef}else {if (defined$utf16){decode_error("surrogate pair expected")}if ((my$hex=hex($u))> 127){$is_utf8=1;$s .= JSON_PP_decode_unicode($u)|| next}else {$s .= chr$hex}}}else{unless ($loose){$at -= 2;decode_error('illegal backslash escape sequence in string')}$s .= $ch}}else{if (ord$ch > 127){unless($ch=is_valid_utf8($ch)){$at -= 1;decode_error("malformed UTF-8 character in JSON string")}else {$at += $utf8_len - 1}$is_utf8=1}if (!$loose){if ($ch =~ /[\x00-\x1f\x22\x5c]/){$at--;decode_error('invalid character encountered while parsing JSON string')}}$s .= $ch}}}decode_error("unexpected end of string while parsing JSON string")}sub white {while(defined$ch){if($ch eq '' or $ch =~ /\A[ \t\r\n]\z/){next_chr()}elsif($relaxed and $ch eq '/'){next_chr();if(defined$ch and $ch eq '/'){1 while(defined(next_chr())and $ch ne "\n" and $ch ne "\r")}elsif(defined$ch and $ch eq '*'){next_chr();while(1){if(defined$ch){if($ch eq '*'){if(defined(next_chr())and $ch eq '/'){next_chr();last}}else{next_chr()}}else{decode_error("Unterminated comment")}}next}else{$at--;decode_error("malformed JSON string, neither array, object, number, string or atom")}}else{if ($relaxed and $ch eq '#'){pos($text)=$at;$text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;$at=pos($text);next_chr;next}last}}}sub array {my$a=$_[0]|| [];decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')if (++$depth > $max_depth);next_chr();white();if(defined$ch and $ch eq ']'){--$depth;next_chr();return$a}else {while(defined($ch)){push @$a,value();white();if (!defined$ch){last}if($ch eq ']'){--$depth;next_chr();return$a}if($ch ne ','){last}next_chr();white();if ($relaxed and $ch eq ']'){--$depth;next_chr();return$a}}}$at-- if defined$ch and $ch ne '';decode_error(", or ] expected while parsing array")}sub object {my$o=$_[0]|| {};my$k;decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')if (++$depth > $max_depth);next_chr();white();if(defined$ch and $ch eq '}'){--$depth;next_chr();if ($F_HOOK){return _json_object_hook($o)}return$o}else {while (defined$ch){$k=($allow_barekey and $ch ne '"' and $ch ne "'")? bareKey(): string();white();if(!defined$ch or $ch ne ':'){$at--;decode_error("':' expected")}next_chr();$o->{$k}=value();white();last if (!defined$ch);if($ch eq '}'){--$depth;next_chr();if ($F_HOOK){return _json_object_hook($o)}return$o}if($ch ne ','){last}next_chr();white();if ($relaxed and $ch eq '}'){--$depth;next_chr();if ($F_HOOK){return _json_object_hook($o)}return$o}}}$at-- if defined$ch and $ch ne '';decode_error(", or } expected while parsing object/hash")}sub bareKey {my$key;while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){$key .= $ch;next_chr()}return$key}sub word {my$word=substr($text,$at-1,4);if($word eq 'true'){$at += 3;next_chr;return$JSON::PP::true}elsif($word eq 'null'){$at += 3;next_chr;return undef}elsif($word eq 'fals'){$at += 3;if(substr($text,$at,1)eq 'e'){$at++;next_chr;return$JSON::PP::false}}$at--;decode_error("'null' expected")if ($word =~ /^n/);decode_error("'true' expected")if ($word =~ /^t/);decode_error("'false' expected")if ($word =~ /^f/);decode_error("malformed JSON string, neither array, object, number, string or atom")}sub number {my$n='';my$v;my$is_dec;my$is_exp;if($ch eq '-'){$n='-';next_chr;if (!defined$ch or $ch !~ /\d/){decode_error("malformed number (no digits after initial minus)")}}if($ch eq '0'){my$peek=substr($text,$at,1);if($peek =~ /^[0-9a-dfA-DF]/){decode_error("malformed number (leading zero must not be followed by another digit)")}$n .= $ch;next_chr}while(defined$ch and $ch =~ /\d/){$n .= $ch;next_chr}if(defined$ch and $ch eq '.'){$n .= '.';$is_dec=1;next_chr;if (!defined$ch or $ch !~ /\d/){decode_error("malformed number (no digits after decimal point)")}else {$n .= $ch}while(defined(next_chr)and $ch =~ /\d/){$n .= $ch}}if(defined$ch and ($ch eq 'e' or $ch eq 'E')){$n .= $ch;$is_exp=1;next_chr;if(defined($ch)and ($ch eq '+' or $ch eq '-')){$n .= $ch;next_chr;if (!defined$ch or $ch =~ /\D/){decode_error("malformed number (no digits after exp sign)")}$n .= $ch}elsif(defined($ch)and $ch =~ /\d/){$n .= $ch}else {decode_error("malformed number (no digits after exp sign)")}while(defined(next_chr)and $ch =~ /\d/){$n .= $ch}}$v .= $n;if ($is_dec or $is_exp){if ($allow_bignum){require Math::BigFloat;return Math::BigFloat->new($v)}}else {if (length$v > $max_intsize){if ($allow_bignum){require Math::BigInt;return Math::BigInt->new($v)}else {return "$v"}}}return$is_dec ? $v/1.0 : 0+$v}sub is_valid_utf8 {$utf8_len=$_[0]=~ /[\x00-\x7F]/ ? 1 : $_[0]=~ /[\xC2-\xDF]/ ? 2 : $_[0]=~ /[\xE0-\xEF]/ ? 3 : $_[0]=~ /[\xF0-\xF4]/ ? 4 : 0 ;return unless$utf8_len;my$is_valid_utf8=substr($text,$at - 1,$utf8_len);return ($is_valid_utf8 =~ /^(?:
[\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]
)$/x)? $is_valid_utf8 : ''}sub decode_error {my$error=shift;my$no_rep=shift;my$str=defined$text ? substr($text,$at): '';my$mess='';my$type='U*';if (OLD_PERL){my$type=$] < 5.006 ? 'C*' : utf8::is_utf8($str)? 'U*' : 'C*' }for my$c (unpack($type,$str)){$mess .= $c==0x07 ? '\a' : $c==0x09 ? '\t' : $c==0x0a ? '\n' : $c==0x0d ? '\r' : $c==0x0c ? '\f' : $c < 0x20 ? sprintf('\x{%x}',$c): $c==0x5c ? '\\\\' : $c < 0x80 ? chr($c): sprintf('\x{%x}',$c);if (length$mess >= 20){$mess .= '...';last}}unless (length$mess){$mess='(end of string)'}Carp::croak ($no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")")}sub _json_object_hook {my$o=$_[0];my@ks=keys %{$o};if ($cb_sk_object and @ks==1 and exists$cb_sk_object->{$ks[0]}and ref$cb_sk_object->{$ks[0]}){my@val=$cb_sk_object->{$ks[0]}->($o->{$ks[0]});if (@val==1){return$val[0]}}my@val=$cb_object->($o)if ($cb_object);if (@val==0 or @val > 1){return$o}else {return$val[0]}}sub PP_decode_box {{text=>$text,at=>$at,ch=>$ch,len=>$len,depth=>$depth,encoding=>$encoding,is_valid_utf8=>$is_valid_utf8,}}}sub _decode_surrogates {my$uni=0x10000 + (hex($_[0])- 0xD800)* 0x400 + (hex($_[1])- 0xDC00);my$un=pack('U*',$uni);utf8::encode($un);return$un}sub _decode_unicode {my$un=pack('U',hex shift);utf8::encode($un);return$un}BEGIN {unless (defined&utf8::is_utf8){require Encode;*utf8::is_utf8=*Encode::is_utf8}if (!OLD_PERL){*JSON::PP::JSON_PP_encode_ascii=\&_encode_ascii;*JSON::PP::JSON_PP_encode_latin1=\&_encode_latin1;*JSON::PP::JSON_PP_decode_surrogates=\&_decode_surrogates;*JSON::PP::JSON_PP_decode_unicode=\&_decode_unicode;if ($] < 5.008003){package JSON::PP;require subs;subs->import('join');eval q|
sub join {
return '' if (@_ < 2);
my $j = shift;
my $str = shift;
for (@_) { $str .= $j . $_; }
return $str;
}
|}}sub JSON::PP::incr_parse {local$Carp::CarpLevel=1;($_[0]->{_incr_parser}||= JSON::PP::IncrParser->new)->incr_parse(@_)}sub JSON::PP::incr_skip {($_[0]->{_incr_parser}||= JSON::PP::IncrParser->new)->incr_skip}sub JSON::PP::incr_reset {($_[0]->{_incr_parser}||= JSON::PP::IncrParser->new)->incr_reset}eval q{
sub JSON::PP::incr_text : lvalue {
$_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
if ( $_[0]->{_incr_parser}->{incr_pos} ) {
Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
}
$_[0]->{_incr_parser}->{incr_text};
}
} if ($] >= 5.006)}BEGIN {eval 'require Scalar::Util';unless($@){*JSON::PP::blessed=\&Scalar::Util::blessed;*JSON::PP::reftype=\&Scalar::Util::reftype;*JSON::PP::refaddr=\&Scalar::Util::refaddr}else{eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';*JSON::PP::blessed=sub {local($@,$SIG{__DIE__},$SIG{__WARN__});ref($_[0])? eval {$_[0]->a_sub_not_likely_to_be_here}: undef};require B;my%tmap=qw(B::NULL SCALAR B::HV HASH B::AV ARRAY B::CV CODE B::IO IO B::GV GLOB B::REGEXP REGEXP);*JSON::PP::reftype=sub {my$r=shift;return undef unless length(ref($r));my$t=ref(B::svref_2object($r));return exists$tmap{$t}? $tmap{$t}: length(ref($$r))? 'REF' : 'SCALAR'};*JSON::PP::refaddr=sub {return undef unless length(ref($_[0]));my$addr;if(defined(my$pkg=blessed($_[0]))){$addr .= bless $_[0],'Scalar::Util::Fake';bless $_[0],$pkg}else {$addr .= $_[0]}$addr =~ /0x(\w+)/;local $^W;hex($1)}}}$JSON::PP::true=do {bless \(my$dummy=1),"JSON::PP::Boolean"};$JSON::PP::false=do {bless \(my$dummy=0),"JSON::PP::Boolean"};sub is_bool {defined $_[0]and UNIVERSAL::isa($_[0],"JSON::PP::Boolean")}sub true {$JSON::PP::true}sub false {$JSON::PP::false}sub null {undef}package JSON::PP::IncrParser;use strict;use constant INCR_M_WS=>0;use constant INCR_M_STR=>1;use constant INCR_M_BS=>2;use constant INCR_M_JSON=>3;use constant INCR_M_C0=>4;use constant INCR_M_C1=>5;$JSON::PP::IncrParser::VERSION='1.01';sub new {my ($class)=@_;bless {incr_nest=>0,incr_text=>undef,incr_pos=>0,incr_mode=>0,},$class}sub incr_parse {my ($self,$coder,$text)=@_;$self->{incr_text}='' unless (defined$self->{incr_text});if (defined$text){if (utf8::is_utf8($text)and!utf8::is_utf8($self->{incr_text})){utf8::upgrade($self->{incr_text});utf8::decode($self->{incr_text})}$self->{incr_text}.= $text}if (defined wantarray){my$max_size=$coder->get_max_size;my$p=$self->{incr_pos};my@ret;{do {unless ($self->{incr_nest}<= 0 and $self->{incr_mode}==INCR_M_JSON){$self->_incr_parse($coder);if ($max_size and $self->{incr_pos}> $max_size){Carp::croak("attempted decode of JSON text of $self->{incr_pos} bytes size, but max_size is set to $max_size")}unless ($self->{incr_nest}<= 0 and $self->{incr_mode}==INCR_M_JSON){if ($self->{incr_mode}==INCR_M_WS and $self->{incr_pos}){$self->{incr_pos}=0;$self->{incr_text}=''}last}}my ($obj,$offset)=$coder->PP_decode_json($self->{incr_text},0x00000001);push@ret,$obj;use bytes;$self->{incr_text}=substr($self->{incr_text},$offset || 0);$self->{incr_pos}=0;$self->{incr_nest}=0;$self->{incr_mode}=0;last unless wantarray}while (wantarray)}if (wantarray){return@ret}else {return$ret[0]? $ret[0]: undef}}}sub _incr_parse {my ($self,$coder)=@_;my$text=$self->{incr_text};my$len=length$text;my$p=$self->{incr_pos};INCR_PARSE: while ($len > $p){my$s=substr($text,$p,1);last INCR_PARSE unless defined$s;my$mode=$self->{incr_mode};if ($mode==INCR_M_WS){while ($len > $p){$s=substr($text,$p,1);last INCR_PARSE unless defined$s;if (ord($s)> 0x20){if ($s eq '#'){$self->{incr_mode}=INCR_M_C0;redo INCR_PARSE}else {$self->{incr_mode}=INCR_M_JSON;redo INCR_PARSE}}$p++}}elsif ($mode==INCR_M_BS){$p++;$self->{incr_mode}=INCR_M_STR;redo INCR_PARSE}elsif ($mode==INCR_M_C0 or $mode==INCR_M_C1){while ($len > $p){$s=substr($text,$p,1);last INCR_PARSE unless defined$s;if ($s eq "\n"){$self->{incr_mode}=$self->{incr_mode}==INCR_M_C0 ? INCR_M_WS : INCR_M_JSON;last}$p++}next}elsif ($mode==INCR_M_STR){while ($len > $p){$s=substr($text,$p,1);last INCR_PARSE unless defined$s;if ($s eq '"'){$p++;$self->{incr_mode}=INCR_M_JSON;last INCR_PARSE unless$self->{incr_nest};redo INCR_PARSE}elsif ($s eq '\\'){$p++;if (!defined substr($text,$p,1)){$self->{incr_mode}=INCR_M_BS;last INCR_PARSE}}$p++}}elsif ($mode==INCR_M_JSON){while ($len > $p){$s=substr($text,$p++,1);if ($s eq "\x00"){$p--;last INCR_PARSE}elsif ($s eq "\x09" or $s eq "\x0a" or $s eq "\x0d" or $s eq "\x20"){if (!$self->{incr_nest}){$p--;last INCR_PARSE}next}elsif ($s eq '"'){$self->{incr_mode}=INCR_M_STR;redo INCR_PARSE}elsif ($s eq '[' or $s eq '{'){if (++$self->{incr_nest}> $coder->get_max_depth){Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')}next}elsif ($s eq ']' or $s eq '}'){if (--$self->{incr_nest}<= 0){last INCR_PARSE}}elsif ($s eq '#'){$self->{incr_mode}=INCR_M_C1;redo INCR_PARSE}}}}$self->{incr_pos}=$p;$self->{incr_parsing}=$p ? 1 : 0}sub incr_text {if ($_[0]->{incr_pos}){Carp::croak("incr_text cannot be called when the incremental parser already started parsing")}$_[0]->{incr_text}}sub incr_skip {my$self=shift;$self->{incr_text}=substr($self->{incr_text},$self->{incr_pos});$self->{incr_pos}=0;$self->{incr_mode}=0;$self->{incr_nest}=0}sub incr_reset {my$self=shift;$self->{incr_text}=undef;$self->{incr_pos}=0;$self->{incr_mode}=0;$self->{incr_nest}=0}1;
JSON_PP
$fatpacked{"JSON/PP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP_BOOLEAN';
package JSON::PP::Boolean;use strict;use overload ("0+"=>sub {${$_[0]}},"++"=>sub {$_[0]=${$_[0]}+ 1},"--"=>sub {$_[0]=${$_[0]}- 1},fallback=>1,);$JSON::PP::Boolean::VERSION='2.94';1;
JSON_PP_BOOLEAN
$fatpacked{"Math/Calc/Units.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MATH_CALC_UNITS';
package Math::Calc::Units;use Math::Calc::Units::Compute qw(compute);use Math::Calc::Units::Rank qw(render render_unit choose_juicy_ones);use Math::Calc::Units::Convert;use base 'Exporter';use vars qw($VERSION @EXPORT_OK);BEGIN {$VERSION='1.07';@EXPORT_OK=qw(calc readable convert equal exact)}use strict;sub calc ($;$) {my ($expr,$exact)=@_;my$v=compute($expr);return$exact ? ($v->[0],render_unit($v->[1])): render($v)}sub readable {my$expr=shift;my%options;if (@_==1){$options{verbose}=shift}else {%options=@_}my$v=compute($expr);return map {render($_,\%options)}choose_juicy_ones($v,\%options)}sub convert ($$;$) {my ($expr,$units,$exact)=@_;my$v=compute($expr);my$u=compute("# $units");my$c=Math::Calc::Units::Convert::convert($v,$u->[1]);return$exact ? ($c->[0],render_unit($c->[1])): render($c)}use constant EPSILON=>1e-12;sub equal {my ($u,$v)=@_;$u=compute($u);$v=compute($v);$v=Math::Calc::Units::Convert::convert($v,$u->[1]);$u=$u->[0];$v=$v->[0];return 1 if ($u==0)&& abs($v)< EPSILON;return abs(($u-$v)/$u)< EPSILON}if (!(caller)){my$verbose;my%options;if ($ARGV[0]eq '-v'){shift;$options{verbose}=1}if ($ARGV[0]eq '-a'){shift;$options{abbreviate}=1}print "$_\n" foreach readable($ARGV[0],%options)}1;
MATH_CALC_UNITS
$fatpacked{"Math/Calc/Units/Compute.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MATH_CALC_UNITS_COMPUTE';
package Math::Calc::Units::Compute;use base 'Exporter';use vars qw(@EXPORT_OK);@EXPORT_OK=qw(compute plus minus mult divide power unit_mult unit_divide unit_power construct);use strict;use Math::Calc::Units::Convert qw(reduce);use Math::Calc::Units::Rank qw(render_unit);use Math::Calc::Units::Convert::Base;require Math::Calc::Units::Grammar;sub equivalent {my ($u,$v)=@_;return Math::Calc::Units::Convert::Base->same($u,$v)}sub is_unit {my ($x,$unit)=@_;return equivalent($x,{$unit=>1 })}sub plus {my ($u,$v)=@_;$u=reduce($u);$v=reduce($v);if (equivalent($u->[1],$v->[1])){return [$u->[0]+ $v->[0],$u->[1]]}elsif (is_unit($u->[1],'timestamp')&& is_unit($v->[1],'sec')){return [$u->[0]+ $v->[0],$u->[1]]}elsif (is_unit($u->[1],'sec')&& is_unit($v->[1],'timestamp')){return [$u->[0]+ $v->[0],$v->[1]]}die "Unable to add incompatible units `".render_unit($u->[1])."' and `".render_unit($v->[1])."'"}sub minus {my ($u,$v)=@_;$u=reduce($u);$v=reduce($v);if (is_unit($u->[1],'timestamp')&& is_unit($v->[1],'timestamp')){return [$u->[0]- $v->[0],{sec=>1 }]}elsif (equivalent($u->[1],$v->[1])){return [$u->[0]- $v->[0],$u->[1]]}elsif (is_unit($u->[1],'timestamp')&& is_unit($v->[1],'sec')){return [$u->[0]- $v->[0],$u->[1]]}die "Unable to subtract incompatible units `".render_unit($u->[1])."' and `".render_unit($v->[1])."'"}sub mult {my ($u,$v)=@_;return [$u->[0]* $v->[0],unit_mult($u->[1],$v->[1])]}sub divide {my ($u,$v)=@_;return [$u->[0]/ $v->[0],unit_divide($u->[1],$v->[1])]}sub power {my ($u,$v)=@_;die "Can only raise to unit-less powers" if keys %{$v->[1]};$u=reduce($u);if (keys %{$u->[1]}!=0){my$power=$v->[0];die "Can only raise a value with units to an integral power" if abs($power - int($power))> 1e-20;return [$u->[0]** $power,unit_power($u->[1],$power)]}return [$u->[0]** $v->[0],{}]}sub unit_mult {my ($u,$v,$mult)=@_;$mult ||= 1;while (my ($unit,$vp)=each %$v){$u->{$unit}+= $vp * $mult;delete$u->{$unit}if$u->{$unit}==0}return$u}sub unit_divide {my ($u,$v)=@_;return unit_mult($u,$v,-1)}sub unit_power {my ($u,$power)=@_;return {}if$power==0;$u->{$_}*= $power foreach (keys %$u);return$u}sub construct {my$s=shift;my ($constructor,$args)=$s =~ /^(\w+)\((.*)\)/;return Math::Calc::Units::Convert::construct($constructor,$args)}package Math::Calc::Units::Compute;sub tokenize {my$data=shift;my@tokens=$data =~ m{\s*
(
\w+\([^\(\)]*\) # constructed (eg date(2001...))
|[\d.]+ # Numbers
|\w+ # Words
|\*\* # Exponentiation (**)
|[-+*/()@] # Operators
)}xg;my@types=map {/\w\(/ ? 'CONSTRUCT' :(/\d/ ? 'NUMBER' :(/\w/ ? 'WORD' :($_)))}@tokens;return \@tokens,\@types}sub compute {my$expr=shift;my$canonicalize=$expr !~ /^\#/;my ($vals,$types)=tokenize($expr);my$lexer=sub {return shift(@$types),shift(@$vals)if (@$types);return ('',undef)};my$parser=new Math::Calc::Units::Grammar;my$v=$parser->YYParse(yylex=>$lexer,yyerror=>sub {my$parser=shift;die "Error: expected ".join(" ",$parser->YYExpect)." got `".$parser->YYCurtok."', rest=".join(" ",@$types)."\nfrom ".join(" ",@$vals)."\n"},yydebug=>0);return$canonicalize ? reduce($v): $v};1;
MATH_CALC_UNITS_COMPUTE
$fatpacked{"Math/Calc/Units/Convert.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MATH_CALC_UNITS_CONVERT';
package Math::Calc::Units::Convert;use base 'Exporter';use strict;use vars qw(@EXPORT_OK);BEGIN {@EXPORT_OK=qw(convert reduce canonical find_top construct)};use Math::Calc::Units::Convert::Multi qw(to_canonical);sub convert {my ($from,$unit)=@_;my$to=[1,$unit ];my$canon_from=canonical($from);my$canon_to=canonical($to);die "conversion between incompatible units" if not same_units($canon_from->[1],$canon_to->[1]);return [$canon_from->[0]/ $canon_to->[0],$unit ]}sub same_units {my ($u1,$u2)=@_;return if keys %$u1!=keys %$u2;while (my ($bu1,$bp1)=each %$u1){return if!exists$u2->{$bu1};return if$bp1!=$u2->{$bu1}}return 1}sub canonical {my ($v)=@_;my$c=to_canonical($v->[1]);my$w=[$v->[0]* $c->[0],$c->[1]];return$w}sub reduce {my ($v)=@_;return canonical($v,'reduce, please')}sub construct {my ($constructor,$args)=@_;return Math::Calc::Units::Convert::Multi::construct($constructor,$args)}1;
MATH_CALC_UNITS_CONVERT
$fatpacked{"Math/Calc/Units/Convert/Base.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MATH_CALC_UNITS_CONVERT_BASE';
package Math::Calc::Units::Convert::Base;use strict;sub major_pref {return 0}sub major_variants {my ($self,$unit)=@_;return$unit}sub singular {my$self=shift;local $_=shift;return $_ unless /s$/;return $1 if /^(.*[^e])s$/;return $1 if /^(.*(ch|sh))es$/;return $1 if /^(.*[aeiou][^aeiou]e)s$/;chop;return $_}sub unit_map {return {}}sub variants {my ($self,$base)=@_;my$map=$self->unit_map();return ($base,keys %$map)}sub same {my ($self,$u,$v)=@_;return 0 if keys %$u!=keys %$v;while (my ($name,$power)=each %$u){return 0 if!exists$v->{$name};return 0 if$v->{$name}!=$power}return 1}sub simple_convert {my ($self,$from,$to)=@_;return 1 if$from eq $to;my$map=$self->unit_map();my$w=$map->{$from}|| $map->{lc($from)};if (!$w){$from=$self->singular($from);$w=$map->{$from}|| $map->{lc($from)}}return if!$w;if ($w->[1]ne $to){my$submult=$self->simple_convert($w->[1],$to);return if!defined$submult;return$w->[0]* $submult}else {return$w->[0]}}sub to_canonical {my ($self,$unitName)=@_;my$canon=$self->canonical_unit();if ($canon){my$mult=$self->simple_convert($unitName,$canon);return if!defined$mult;return ($mult,$canon)}else {return (1,$self->singular($unitName))}}sub canonical_unit {return}sub abbreviated_canonical_unit {my ($self)=@_;return$self->canonical_unit}my$THRESHOLD=0.01;sub spread {my ($self,$mag,$base,$start,$units)=@_;die if$mag < 0;return [0,$base ]if$mag==0;my$orig=$mag;my@desc;my$started=0;for my$unit (@$units){$started=1 if$unit eq $start;next unless$started;last if ($mag / $orig)< $THRESHOLD;my$mult=$self->simple_convert($unit,$base);my$n=int($mag / $mult);next if$n==0;$mag -= $n * $mult;push@desc,[$n,$unit ]}return@desc}sub range_score {my ($self,$val,$unitName)=@_;my$ranges=$self->get_ranges();my$range=$ranges->{$unitName}|| $ranges->{default};if ($val >= $range->[0]){if (!defined$range->[1]|| ($val <= $range->[1])){return 1}}$val=_sillylog($val);my$r0=_sillylog($range->[0]);my$r1;if (defined$range->[1]){$r1=_sillylog($range->[1])}else {$r1=4}my$width=$r1 - $r0;my$mean=($r0 + $r1)/ 2;my$stddev=$width / 2;my$n=($val - $mean)/ $stddev;our$mulconst;$mulconst ||= 0.999 * exp(1/8);return 0.001 + $mulconst * exp(-$n**2/2)}sub _sillylog {my$x=shift;return log($x)if$x;return log(1e-50)}sub pref_score {my ($self,$unitName)=@_;my$prefs=$self->get_prefs();my$specific=$prefs->{$unitName};return defined($specific)? $specific : $prefs->{default}}sub get_prefs {return {default=>0.1 }}sub get_ranges {return {default=>[1,undef ]}}sub render_unit {my ($self,$name,$power,$options)=@_;if ($power==1){return$name}else {return "$name**$power"}}sub render {my ($self,$val,$name,$power,$options)=@_;return sprintf("%.5g ",$val).$self->render_unit($name,$power,$options)}sub construct {return}1;
MATH_CALC_UNITS_CONVERT_BASE
$fatpacked{"Math/Calc/Units/Convert/Base2Metric.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MATH_CALC_UNITS_CONVERT_BASE2METRIC';
package Math::Calc::Units::Convert::Base2Metric;use base 'Math::Calc::Units::Convert::Metric';use strict;use vars qw(%metric_base2 %abbrev $metric_prefix_test %pref);%metric_base2=(kilo=>2**10,mega=>2**20,giga=>2**30,tera=>2**40,peta=>2**50,exa=>2**60,);%abbrev=(k=>'kilo',m=>'mega',g=>'giga',t=>'tera',p=>'peta',e=>'exa',);%pref=(unit=>1.0,kilo=>0.8,mega=>0.8,giga=>0.8,tera=>0.7,peta=>0.6,exa=>0.3,);sub get_metric {my ($self,$what)=@_;return$metric_base2{$what}}sub get_abbrev {my ($self,$what)=@_;return$abbrev{$what}|| $abbrev{lc($what)}}$metric_prefix_test=qr/^(${\join("|",keys %metric_base2)})/i;sub get_prefix {my ($self,$what)=@_;if ($what =~ $metric_prefix_test){return $1}else {return}}sub prefix_pref {my ($self,$prefix)=@_;return$pref{lc($prefix)}|| $pref{unit}}sub get_prefixes {return keys%metric_base2}sub expand {my ($self,$char)=@_;return$self->get_abbrev($char)}1;
MATH_CALC_UNITS_CONVERT_BASE2METRIC
$fatpacked{"Math/Calc/Units/Convert/Byte.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MATH_CALC_UNITS_CONVERT_BYTE';
package Math::Calc::Units::Convert::Byte;use base 'Math::Calc::Units::Convert::Base2Metric';use strict;my%units=(bit=>[1/8,'byte' ]);my%pref=(bit=>0.1,default=>1);my%ranges=(default=>[1,999 ]);my%total_unit_map;sub major_pref {return 1}sub major_variants {my ($self)=@_;return$self->variants('byte')}sub get_ranges {return \%ranges}sub get_prefs {return \%pref}sub unit_map {my ($self)=@_;if (keys%total_unit_map==0){%total_unit_map=(%{$self->SUPER::unit_map()},%units)}return \%total_unit_map}sub canonical_unit {return 'byte'}sub abbreviated_canonical_unit {return 'B'}sub simple_convert {my ($self,$from,$to)=@_;return 1 if$from =~ /^b(yte(s?))?$/i;if (my$easy=$self->SUPER::simple_convert($from,$to)){return$easy}if ($from =~ /^(.)b(yte(s?))?$/i){if (my ($prefix)=$self->expand($1)){return$self->simple_convert($prefix ."byte",$to)}}return}1;
MATH_CALC_UNITS_CONVERT_BYTE
$fatpacked{"Math/Calc/Units/Convert/Combo.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MATH_CALC_UNITS_CONVERT_COMBO';
package Math::Calc::Units::Convert::Combo;use base 'Math::Calc::Units::Convert::Base2Metric';use strict;use vars qw(%units %metric_units %prefixable_metric_units %total_unit_map);use vars qw(%ranges %pref);%units=();%metric_units=();%prefixable_metric_units=(bps=>[1,{bit=>1,sec=>-1 }]);%ranges=(default=>[1,999 ]);%pref=(default=>1);sub canonical_unit {return}sub unit_map {my ($self)=@_;if (keys%total_unit_map==0){%total_unit_map=(%{$self->SUPER::unit_map()},%units,%metric_units,%prefixable_metric_units)}return \%total_unit_map}sub singular {my ($self,$unit)=@_;return$self->SUPER::singular($unit)unless$unit =~ /bps$/;return$unit}sub demetric {my ($self,$string)=@_;if (my$prefix=$self->get_prefix($string)){my$tail=lc($self->singular(substr($string,length($prefix))));if ($metric_units{$tail}){return ($self->get_metric($prefix),$tail)}}elsif (my$abbrev=$self->get_abbrev_prefix($string)){my$tail=lc($self->singular(substr($string,length($abbrev))));if ($prefixable_metric_units{$tail}){my$prefix=$self->get_abbrev($abbrev);return ($self->get_metric($prefix),$tail)}}return (1,$string)}sub to_canonical {return}sub lookup_compound {my ($self,$unitName)=@_;for (keys%units,keys%metric_units,keys%prefixable_metric_units){if (my$mult=$self->simple_convert($unitName,$_)){my$u=$units{$_}|| $metric_units{$_}|| $prefixable_metric_units{$_};return [$mult * $u->[0],$u->[1]]}}return}sub get_ranges {return \%ranges}sub get_prefs {return \%pref}1;
MATH_CALC_UNITS_CONVERT_COMBO
$fatpacked{"Math/Calc/Units/Convert/Date.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MATH_CALC_UNITS_CONVERT_DATE';
package Math::Calc::Units::Convert::Date;use base 'Math::Calc::Units::Convert::Base';use Time::Local qw(timegm);use strict;use vars qw(%units %pref %ranges %total_unit_map);my$min_nice_time=timegm(0,0,0,1,0,1975-1900);my$max_nice_time=timegm(0,0,0,1,0,2030-1900);%units=();%pref=(default=>1);%ranges=(timestamp=>[$min_nice_time,$max_nice_time ]);sub major_pref {return 2}sub canonical_unit {return 'timestamp'}sub unit_map {my ($self)=@_;if (keys%total_unit_map==0){%total_unit_map=(%{$self->SUPER::unit_map()},%units)}return \%total_unit_map}sub get_ranges {return \%ranges}sub get_prefs {return \%pref}use vars qw(@MonthNames);BEGIN {@MonthNames=qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)}sub construct {my ($self,$constructor,$args)=@_;if ($constructor eq 'timestamp'){$args=time if$args eq '';return [$args,{'timestamp'=>1 }]}return unless$constructor eq 'date';$args =~ s/\s+GMT\s+$//;my ($Mon,$d,$y,$h,$m,$s,$tz,$M);$tz='GMT';if ($args =~ /^((?:\w\w\w\s+)?)
(\w\w\w)\s*
(\d+)\s+
(\d+):(\d+)[:.](\d+)\s+
(\w+)?\s*
(\d\d\d\d)$/x){(undef,$Mon,$d,$h,$m,$s,$tz,$y)=($1,$2,$3,$4,$5,$6,$7,$8)}elsif ($args =~ /^(\w\w\w)[\s-]*
(\d+)[,\s-]+
(\d\d\d\d)$/x){($Mon,$d,$y)=($1,$2,$3)}elsif ($args =~ /^(\d\d\d\d)-(\d+)-(\d+)\s+
(\d+):(\d+)[:.](\d+)$/x){($y,$M,$d,$h,$m,$s)=($1,$2,$3,$4,$5,$6);$M--}elsif ($args =~ /^(\d\d\d\d)-(\d+)-(\d+)$/){($y,$M,$d)=($1,$2,$3);$M--}else {die "Unparseable date string '$args'"}$h ||= 0;$m ||= 0;$s ||= 0;if (defined$Mon){$M=0;for (@MonthNames){last if lc($_)eq lc($Mon);$M++}die "Unparseable month '$Mon'" if$M > 11}if (defined($tz)&& $tz ne 'GMT'){warn "Timezones not supported. Assuming GMT.\n"}my$timestamp=timegm($s,$m,$h,$d,$M,$y-1900);die "Date '$args' is out of range" if$timestamp==-1;return [$timestamp,{'timestamp'=>1 }]}sub render {my ($self,$mag,$name,$power)=@_;return "\@$mag" if$power!=1;return "\@$mag" if$mag < $min_nice_time;return "\@$mag" if$mag > $max_nice_time;return gmtime($mag)." (\@$mag)"}1;
MATH_CALC_UNITS_CONVERT_DATE
$fatpacked{"Math/Calc/Units/Convert/Distance.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MATH_CALC_UNITS_CONVERT_DISTANCE';
package Math::Calc::Units::Convert::Distance;use base 'Math::Calc::Units::Convert::Metric';use strict;my%total_unit_map;my%ranges=(default=>[1,999 ]);my%distance_units=(inch=>[2.54,'centimeter' ],foot=>[12,'inch' ],yard=>[3,'foot' ],mile=>[5280,'foot' ],);my%distance_pref=(meter=>1.1,inch=>0.7,foot=>0.9,yard=>0,mile=>1.0,);my%aliases=('feet'=>'foot',);sub canonical_unit {return 'meter'}sub abbreviated_canonical_unit {return 'm'}sub major_pref {return 1}sub major_variants {my ($self)=@_;return$self->variants('meter')}sub get_ranges {return \%ranges}sub get_prefs {return \%distance_pref}sub singular {my ($self,$unit)=@_;$unit=$self->SUPER::singular($unit);return$aliases{$unit}|| $unit}sub unit_map {my ($self)=@_;if (keys%total_unit_map==0){%total_unit_map=(%{$self->SUPER::unit_map()},%distance_units)}return \%total_unit_map}sub simple_convert {my ($self,$from,$to)=@_;return 1 if$from =~ /^m(eter(s?))?$/i;if (my$easy=$self->SUPER::simple_convert($from,$to)){return$easy}if ($from =~ /^(.)m(eter(s?))?$/i){if (my ($prefix)=$self->expand($1)){return$self->simple_convert($prefix ."meter",$to)}}return}sub variants {my ($self,$base)=@_;my$canon=$self->canonical_unit();return ($base,keys %{$self->unit_map()},map {"$_$canon"}$self->get_prefixes())}1;
MATH_CALC_UNITS_CONVERT_DISTANCE
$fatpacked{"Math/Calc/Units/Convert/Metric.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MATH_CALC_UNITS_CONVERT_METRIC';
package Math::Calc::Units::Convert::Metric;use base 'Math::Calc::Units::Convert::Base';use strict;use vars qw(%niceSmallMetric %metric %pref %abbrev %reverse_abbrev $metric_prefix_test);%niceSmallMetric=(milli=>1e-3,micro=>1e-6,nano=>1e-9,pico=>1e-12,femto=>1e-15,);%metric=(kilo=>1e3,mega=>1e6,giga=>1e9,tera=>1e12,peta=>1e15,exa=>1e18,centi=>1e-2,%niceSmallMetric,);%pref=(unit=>1.0,kilo=>0.8,mega=>0.8,giga=>0.8,tera=>0.7,peta=>0.6,exa=>0.3,centi=>0.1,milli=>0.8,micro=>0.8,nano=>0.6,pico=>0.4,femto=>0.3,);%abbrev=(k=>'kilo',M=>'mega',G=>'giga',T=>'tera',P=>'peta',E=>'exa',c=>'centi',m=>'milli',u=>'micro',n=>'nano',p=>'pico',f=>'femto',);%reverse_abbrev=reverse%abbrev;sub pref_score {my ($self,$unitName)=@_;my$prefix=$self->get_prefix($unitName);$unitName=substr($unitName,length($prefix || ""));my$prefix_pref=defined($prefix)? $self->prefix_pref($prefix): 1;return$prefix_pref * $self->SUPER::pref_score($unitName)}sub get_metric {my ($self,$what)=@_;return$metric{$what}}sub get_abbrev {my ($self,$what)=@_;return$abbrev{$what}}$metric_prefix_test=qr/^(${\join("|",keys %metric)})/i;sub get_prefix {my ($self,$what)=@_;if ($what =~ $metric_prefix_test){return $1}else {return}}sub get_prefixes {my ($self,$options)=@_;if ($options->{small}){return grep {$metric{$_}< 1}keys%metric}else {return keys%metric}}sub get_abbrev_prefix {my ($self,$what)=@_;my$prefix=substr($what,0,1);if ($abbrev{$prefix}|| $abbrev{lc($prefix)}){return$prefix}else {return}}sub variants {my ($self,$base)=@_;my@main=$self->SUPER::variants($base);my@variants;for my$u (@main){push@variants,$u,map {"$_$u"}$self->get_prefixes()}return@variants}sub prefix_pref {my ($self,$prefix)=@_;return$pref{lc($prefix)}|| $pref{unit}}sub demetric {my ($self,$string)=@_;if (my$prefix=$self->get_prefix($string)){my$base=substr($string,length($prefix));return ($self->get_metric($prefix),$base)}else {return (1,$string)}}sub expand {my ($self,$char)=@_;my@expansions;my ($exact,$lower);if ($exact=$self->get_abbrev($char)){push@expansions,$exact}elsif (($char ne lc($char))&& ($lower=$self->get_abbrev(lc($char)))){push@expansions,$lower}return@expansions}sub simple_convert {my ($self,$from,$to)=@_;my ($mult_from,$base_from)=$self->demetric($from)or return;my ($mult_to,$base_to)=$self->demetric($to)or return;my$submult=$self->SUPER::simple_convert($base_from,$base_to);return if!defined$submult;return$submult * ($mult_from / $mult_to)}sub metric_abbreviation {my ($self,$prefix)=@_;return$reverse_abbrev{$prefix}|| $prefix}sub render {my ($self,$val,$name,$power,$options)=@_;if ($options->{abbreviate}){my$stem=$self->canonical_unit;if ($name =~ /(\w+)\Q$stem\E$/){my$prefix=$reverse_abbrev{$1};if (defined($prefix)){$name=$prefix .$self->abbreviated_canonical_unit}}}return$self->SUPER::render($val,$name,$power,$options)}1;
MATH_CALC_UNITS_CONVERT_METRIC
$fatpacked{"Math/Calc/Units/Convert/Multi.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MATH_CALC_UNITS_CONVERT_MULTI';
package Math::Calc::Units::Convert::Multi;use base 'Exporter';use vars qw(@EXPORT_OK);BEGIN {@EXPORT_OK=qw(to_canonical simple_convert singular variants major_variants major_pref range_score pref_score get_class construct)};require Math::Calc::Units::Convert::Time;require Math::Calc::Units::Convert::Byte;require Math::Calc::Units::Convert::Date;require Math::Calc::Units::Convert::Distance;require Math::Calc::Units::Convert::Combo;use strict;use vars qw(@UnitClasses);@UnitClasses=qw(Math::Calc::Units::Convert::Time Math::Calc::Units::Convert::Byte Math::Calc::Units::Convert::Date Math::Calc::Units::Convert::Distance Math::Calc::Units::Convert::Combo);sub to_canonical {my ($unit)=@_;my$val=1;my%newUnit;while (my ($unitName,$power)=each %$unit){my ($mult,$canon)=name_to_canonical($unitName);$val *= $mult ** $power;if (ref$canon){my$c=to_canonical($canon);$val *= $c->[0]** $power;while (my ($name,$subPower)=each %{$c->[1]}){if (($newUnit{$name}+= $subPower * $power)==0){delete$newUnit{$name}}}}else {if (($newUnit{$canon}+= $power)==0){delete$newUnit{$canon}}}}return [$val,\%newUnit ]}my%CANON_CACHE;sub name_to_canonical {my$unitName=shift;$CANON_CACHE{$unitName}||= [_name_to_canonical($unitName)];return @{$CANON_CACHE{$unitName}}}sub _name_to_canonical {my ($unitName)=@_;if (my$v=Math::Calc::Units::Convert::Combo->lookup_compound($unitName)){return @$v}for my$uclass (@UnitClasses){if (my ($val,$base)=$uclass->to_canonical($unitName)){return ($val,$base)}}return Math::Calc::Units::Convert::Base->to_canonical($unitName)}sub get_class {my ($unitName)=@_;my (undef,$canon)=name_to_canonical($unitName);for my$uclass (@UnitClasses){my$canon_unit=$uclass->canonical_unit();next if!defined$canon_unit;return$uclass if$canon_unit eq $canon}return 'Math::Calc::Units::Convert::Base'}sub simple_convert {my ($u,$v)=@_;for my$uclass (@UnitClasses){my$c;return$c if$c=$uclass->simple_convert($u,$v)}return}sub singular {my ($unitName)=@_;return get_class($unitName)->singular($unitName)}sub variants {my ($base)=@_;return get_class($base)->variants($base)}sub major_variants {my ($base)=@_;return get_class($base)->major_variants($base)}sub major_pref {my ($base)=@_;return get_class($base)->major_pref($base)}sub range_score {my ($val,$unitName)=@_;die if ref$unitName;return get_class($unitName)->range_score($val,$unitName)}sub pref_score {my ($unitName)=@_;die if ref$unitName;return get_class($unitName)->pref_score($unitName)}sub construct {my ($constructor,$args)=@_;for my$uclass (@UnitClasses){my$c;return$c if$c=$uclass->construct($constructor,$args)}return}1;
MATH_CALC_UNITS_CONVERT_MULTI
$fatpacked{"Math/Calc/Units/Convert/Time.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MATH_CALC_UNITS_CONVERT_TIME';
package Math::Calc::Units::Convert::Time;use base 'Math::Calc::Units::Convert::Metric';use strict;use vars qw(%units %pref %ranges %total_unit_map);%units=(minute=>[60,'sec' ],hour=>[60,'minute' ],day=>[24,'hour' ],week=>[7,'day' ],year=>[365,'day' ],);%pref=(default=>1,hour=>0.8,day=>0.8,week=>0.4,minute=>0.9,year=>0.9,);%ranges=(default=>[1,300 ],millisec=>[1,999 ],sec=>[1,200 ],minute=>[2,100 ],hour=>[1,80 ],day=>[1,500 ],week=>[1,4 ],year=>[1,undef ],);sub major_pref {return 2}sub major_variants {my ($self)=@_;return grep {($_ ne 'default')&& ($_ ne 'week')}keys%ranges}sub variants {my ($self,$base)=@_;return 'sec',(keys%units),map {"${_}sec"}$self->get_prefixes({small=>1 })}sub unit_map {my ($self)=@_;if (keys%total_unit_map==0){%total_unit_map=(%{$self->SUPER::unit_map()},%units)}return \%total_unit_map}sub canonical_unit {return 'sec'}sub abbreviated_canonical_unit {return 's'}sub demetric {my ($self,$string)=@_;if (my$prefix=$self->get_prefix($string)){my$tail=substr($string,length($prefix));if ($tail =~ /^sec(ond)?s?$/){return ($self->get_metric($prefix),"sec")}return}else {return (1,$string)}}sub simple_convert {my ($self,$from,$to)=@_;$from="sec" if$from =~ /^sec(ond)?s?$/i;$from="minute" if$from =~ /^min(ute)?s?$/i;if (my$easy=$self->SUPER::simple_convert($from,$to)){return$easy}if ($from =~ /^(.)s$/){my ($expansion)=$self->expand($1);return$self->simple_convert($expansion ."sec",$to)}return}sub preference {my ($self,$v)=@_;my ($val,$unit)=@$v;my$base=lc(($self->demetric($unit))[1]);my$pref=$pref{$base}|| $pref{default};return$pref * $self->prefix_pref(substr($unit,0,-length($base)))}sub get_ranges {return \%ranges}sub get_prefs {return \%pref}my@BREAKDOWN=qw(year week day hour minute sec ms us ns ps);sub render {my ($self,$val,$name,$power,$options)=@_;my$full_name=$name;if ($options->{abbreviate}){if ($name =~ /(\w+)sec/){my$prefix=$1;my$mabbrev=$self->metric_abbreviation($prefix);$name=$mabbrev ."s" unless$mabbrev eq $prefix}}my$basic=$self->SUPER::render($val,$name,$power,$options);return$basic if$power!=1;$val *= $self->simple_convert($full_name,'sec');my@spread=$self->spread($val,'sec',$name,\@BREAKDOWN);my$spread=join(" ",map {"$_->[0] $_->[1]"}@spread);return "($basic = $spread)" if@spread > 1;return$basic}1;
MATH_CALC_UNITS_CONVERT_TIME
$fatpacked{"Math/Calc/Units/Grammar.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MATH_CALC_UNITS_GRAMMAR';
package Math::Calc::Units::Grammar;use vars qw ( @ISA);use strict;@ISA=qw ( Parse::Yapp::Driver);{package Parse::Yapp::Driver;require 5.004;use strict;use vars qw ( $VERSION $COMPATIBLE $FILENAME);$VERSION='1.04';$COMPATIBLE='0.07';$FILENAME=__FILE__;use Carp;my(%params)=(YYLEX=>'CODE','YYERROR'=>'CODE',YYVERSION=>'',YYRULES=>'ARRAY',YYSTATES=>'ARRAY',YYDEBUG=>'');my(@params)=('LEX','RULES','STATES');sub new {my($class)=shift;my($errst,$nberr,$token,$value,$check,$dotpos);my($self)={ERROR=>\&_Error,ERRST=>\$errst,NBERR=>\$nberr,TOKEN=>\$token,VALUE=>\$value,DOTPOS=>\$dotpos,STACK=>[],DEBUG=>0,CHECK=>\$check };_CheckParams([],\%params,\@_,$self);exists($$self{VERSION})and $$self{VERSION}< $COMPATIBLE and croak "Yapp driver version $VERSION "."incompatible with version $$self{VERSION}:\n"."Please recompile parser module.";ref($class)and $class=ref($class);bless($self,$class)}sub YYParse {my($self)=shift;my($retval);_CheckParams(\@params,\%params,\@_,$self);if($$self{DEBUG}){_DBLoad();$retval=eval '$self->_DBParse()';$@ and die $@}else {$retval=$self->_Parse()}$retval}sub YYData {my($self)=shift;exists($$self{USER})or $$self{USER}={};$$self{USER}}sub YYErrok {my($self)=shift;${$$self{ERRST}}=0;undef}sub YYNberr {my($self)=shift;${$$self{NBERR}}}sub YYRecovering {my($self)=shift;${$$self{ERRST}}!=0}sub YYAbort {my($self)=shift;${$$self{CHECK}}='ABORT';undef}sub YYAccept {my($self)=shift;${$$self{CHECK}}='ACCEPT';undef}sub YYError {my($self)=shift;${$$self{CHECK}}='ERROR';undef}sub YYSemval {my($self)=shift;my($index)=$_[0]- ${$$self{DOTPOS}}- 1;$index < 0 and -$index <= @{$$self{STACK}}and return $$self{STACK}[$index][1];undef}sub YYCurtok {my($self)=shift;@_ and ${$$self{TOKEN}}=$_[0];${$$self{TOKEN}}}sub YYCurval {my($self)=shift;@_ and ${$$self{VALUE}}=$_[0];${$$self{VALUE}}}sub YYExpect {my($self)=shift;keys %{$self->{STATES}[$self->{STACK}[-1][0]]{ACTIONS}}}sub YYLexer {my($self)=shift;$$self{LEX}}sub _CheckParams {my($mandatory,$checklist,$inarray,$outhash)=@_;my($prm,$value);my($prmlst)={};while(($prm,$value)=splice(@$inarray,0,2)){$prm=uc($prm);exists($$checklist{$prm})or croak("Unknow parameter '$prm'");ref($value)eq $$checklist{$prm}or croak("Invalid value for parameter '$prm'");$prm=unpack('@2A*',$prm);$$outhash{$prm}=$value}for (@$mandatory){exists($$outhash{$_})or croak("Missing mandatory parameter '".lc($_)."'")}}sub _Error {print "Parse error.\n"}sub _DBLoad {{no strict 'refs';exists(${__PACKAGE__.'::'}{_DBParse})and return}my($fname)=__FILE__;my(@drv);open(DRV,"<$fname")or die "Report this as a BUG: Cannot open $fname";while(<DRV>){/^\s*sub\s+_Parse\s*{\s*$/ .. /^\s*}\s*#\s*_Parse\s*$/ and do {s/^#DBG>//;push(@drv,$_)}}close(DRV);$drv[0]=~s/_P/_DBP/;eval join('',@drv)}sub _Parse {my($self)=shift;my($rules,$states,$lex,$error)=@$self{'RULES','STATES','LEX','ERROR' };my($errstatus,$nberror,$token,$value,$stack,$check,$dotpos)=@$self{'ERRST','NBERR','TOKEN','VALUE','STACK','CHECK','DOTPOS' };$$errstatus=0;$$nberror=0;($$token,$$value)=(undef,undef);@$stack=([0,undef ]);$$check='';while(1){my($actions,$act,$stateno);$stateno=$$stack[-1][0];$actions=$$states[$stateno];if (exists($$actions{ACTIONS})){defined($$token)or do {($$token,$$value)=&$lex($self)};$act=exists($$actions{ACTIONS}{$$token})? $$actions{ACTIONS}{$$token}: exists($$actions{DEFAULT})? $$actions{DEFAULT}: undef}else {$act=$$actions{DEFAULT}}defined($act)and do {$act > 0 and do {$$errstatus and do {--$$errstatus};push(@$stack,[$act,$$value ]);$$token ne '' and $$token=$$value=undef;next};my($lhs,$len,$code,@sempar,$semval);($lhs,$len,$code)=@{$$rules[-$act]};$act or $self->YYAccept();$$dotpos=$len;unpack('A1',$lhs)eq '@' and do {$lhs =~ /^\@[0-9]+\-([0-9]+)$/ or die "In line rule name '$lhs' ill formed: "."report it as a BUG.\n";$$dotpos=$1};@sempar=$$dotpos ? map {$$_[1]}@$stack[-$$dotpos .. -1 ]: ();$semval=$code ? &$code($self,@sempar): @sempar ? $sempar[0]: undef;splice(@$stack,-$len,$len);$$check eq 'ACCEPT' and do {return($semval)};$$check eq 'ABORT' and do {return(undef)};$$check eq 'ERROR' or do {push(@$stack,[$$states[$$stack[-1][0]]{GOTOS}{$lhs},$semval ]);$$check='';next};$$check=''};$$errstatus or do {$$errstatus=1;&$error($self);$$errstatus or next;++$$nberror};$$errstatus==3 and do {$$token eq '' and do {return(undef)};$$token=$$value=undef};$$errstatus=3;while(@$stack and (not exists($$states[$$stack[-1][0]]{ACTIONS})or not exists($$states[$$stack[-1][0]]{ACTIONS}{error})or $$states[$$stack[-1][0]]{ACTIONS}{error}<= 0)){pop(@$stack)}@$stack or do {return(undef)};push(@$stack,[$$states[$$stack[-1][0]]{ACTIONS}{error},undef ])}croak("Error in driver logic. Please, report it as a BUG")}1}use Math::Calc::Units::Compute qw(plus minus mult divide power construct);sub new {my($class)=shift;ref($class)and $class=ref($class);my($self)=$class->SUPER::new(yyversion=>'1.04',yystates=>[{ACTIONS=>{'NUMBER'=>5,"#"=>2,"-"=>6,'WORD'=>7,'CONSTRUCT'=>3,"\@"=>9,"("=>4 },GOTOS=>{'unit'=>1,'value'=>8,'START'=>10,'expr'=>11 }},{DEFAULT=>-12 },{ACTIONS=>{'WORD'=>7 },GOTOS=>{'unit'=>12 }},{DEFAULT=>-16 },{ACTIONS=>{'NUMBER'=>5,"-"=>6,'WORD'=>7,'CONSTRUCT'=>3,"\@"=>9,"("=>4 },GOTOS=>{'unit'=>1,'value'=>8,'expr'=>13 }},{ACTIONS=>{'WORD'=>7 },DEFAULT=>-13,GOTOS=>{'unit'=>14 }},{ACTIONS=>{'NUMBER'=>15 }},{DEFAULT=>-17 },{DEFAULT=>-9 },{ACTIONS=>{'NUMBER'=>17 }},{ACTIONS=>{''=>18 }},{ACTIONS=>{"*"=>21,"+"=>22,"**"=>20,"-"=>23,'WORD'=>7,"/"=>24 },DEFAULT=>-1,GOTOS=>{'unit'=>19 }},{DEFAULT=>-2 },{ACTIONS=>{"*"=>21,"+"=>22,"**"=>20,"-"=>23,'WORD'=>7,"/"=>24,")"=>25 },GOTOS=>{'unit'=>19 }},{DEFAULT=>-11 },{DEFAULT=>-14 },{DEFAULT=>-18 },{DEFAULT=>-15 },{DEFAULT=>-0 },{DEFAULT=>-10 },{ACTIONS=>{'NUMBER'=>5,"-"=>6,'WORD'=>7,'CONSTRUCT'=>3,"\@"=>9,"("=>4 },GOTOS=>{'unit'=>1,'value'=>8,'expr'=>26 }},{ACTIONS=>{'NUMBER'=>5,"-"=>6,'WORD'=>7,'CONSTRUCT'=>3,"\@"=>9,"("=>4 },GOTOS=>{'unit'=>1,'value'=>8,'expr'=>27 }},{ACTIONS=>{'NUMBER'=>5,"-"=>6,'WORD'=>7,'CONSTRUCT'=>3,"\@"=>9,"("=>4 },GOTOS=>{'unit'=>1,'value'=>8,'expr'=>28 }},{ACTIONS=>{'NUMBER'=>5,"-"=>6,'WORD'=>7,'CONSTRUCT'=>3,"\@"=>9,"("=>4 },GOTOS=>{'unit'=>1,'value'=>8,'expr'=>29 }},{ACTIONS=>{'NUMBER'=>5,"-"=>6,'WORD'=>7,'CONSTRUCT'=>3,"\@"=>9,"("=>4 },GOTOS=>{'unit'=>1,'value'=>8,'expr'=>30 }},{DEFAULT=>-8 },{DEFAULT=>-7,GOTOS=>{'unit'=>19 }},{ACTIONS=>{"**"=>20,'WORD'=>7 },DEFAULT=>-5,GOTOS=>{'unit'=>19 }},{ACTIONS=>{"**"=>20,"*"=>21,'WORD'=>7,"/"=>24 },DEFAULT=>-3,GOTOS=>{'unit'=>19 }},{ACTIONS=>{"**"=>20,"*"=>21,'WORD'=>7,"/"=>24 },DEFAULT=>-4,GOTOS=>{'unit'=>19 }},{ACTIONS=>{"**"=>20,'WORD'=>7 },DEFAULT=>-6,GOTOS=>{'unit'=>19 }}],yyrules=>[['$start',2,undef ],['START',1,undef ],['START',2,undef ],['expr',3,sub {return plus($_[1],$_[3])}],['expr',3,sub {return minus($_[1],$_[3])}],['expr',3,sub {return mult($_[1],$_[3])}],['expr',3,sub {return divide($_[1],$_[3])}],['expr',3,sub {return power($_[1],$_[3])}],['expr',3,sub {return $_[2]}],['expr',1,sub {return $_[1]}],['expr',2,sub {return mult($_[1],[1,$_[2]])}],['value',2,sub {return [$_[1]=>$_[2]]}],['value',1,sub {return [1=>$_[1]]}],['value',1,sub {return [$_[1]=>{}]}],['value',2,sub {return [-$_[2]=>{}]}],['value',2,sub {return [$_[2]=>{'timestamp'=>1 }]}],['value',1,sub {return construct($_[1])}],['unit',1,sub {return {$_[1]=>1 }}],['unit',2,sub {my$u={};$u->{$_[1]}++;$u->{$_[2]}++;return$u}]],@_);bless($self,$class)}1;
MATH_CALC_UNITS_GRAMMAR
$fatpacked{"Math/Calc/Units/Rank.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MATH_CALC_UNITS_RANK';
package Math::Calc::Units::Rank;use base 'Exporter';use vars qw(@EXPORT_OK);BEGIN {@EXPORT_OK=qw(choose_juicy_ones render render_unit)}use Math::Calc::Units::Convert qw(convert canonical);use Math::Calc::Units::Convert::Multi qw(variants major_variants major_pref pref_score range_score get_class);use strict;sub choose_juicy_ones {my ($v,$options)=@_;my@variants=rank_variants($v,$options);my%variants;for my$variant (@variants){my$id=join(";;",values %{$variant->[0]});$variants{$id}=$variant}my@options;for my$variant (values%variants){my ($map,$score)=@$variant;my%copy;my ($magnitude,$units)=@$v;while (my ($unit,$count)=each %$units){$copy{$map->{$unit}}=$count}push@options,[$score,convert($v,\%copy)]}my@juicy;my$first;my$prev;for (sort {$b->[0]<=> $a->[0]}@options){my ($score,$val)=@$_;last if (defined$prev && ($prev / $score)> 8);last if (defined$first && ($first / $score)> 25);push@juicy,$val;$first=$score unless defined$first;$prev=$score;last if@juicy==5}return@juicy}sub rank_variants {my ($v,$options)=@_;$v=canonical($v);my ($mag,$count)=@$v;my@rangeable=grep {$count->{$_}> 0}keys %$count;if (@rangeable==0){@rangeable=keys %$count}return rank_power_variants($mag,\@rangeable,$count,$options)}sub choose_major {my (@possibilities)=@_;my@majors=map {[major_pref($_),$_ ]}@possibilities;return (sort {$a->[0]<=> $b->[0]}@majors)[-1]->[1]}sub rank_power_variants {my ($mag,$top,$power,$options)=@_;if (keys %$power > 1){my$major=choose_major(keys %$power);my$majorClass=get_class($major);my%powerless=%$power;delete$powerless{$major};my@ranked;for my$variant (major_variants($major,$options)){my$mult=$majorClass->simple_convert($variant,$major);my$cval=$mag / $mult ** $power->{$major};print "\n --- for $variant ---\n" if$options->{verbose};my@r=rank_power_variants($cval,$top,\%powerless,$options);next if@r==0;my$best=$r[0];$best->[0]->{$major}=$variant;$best->[1]=pref_score($variant);push@ranked,$best}return@ranked}if (keys %$power==0){return [{},1 ]}my$unit=(keys %$power)[0];$power=$power->{$unit};my$class=get_class($unit);my (undef,$canon)=$class->to_canonical($unit);my$mult=$class->simple_convert($unit,$canon);$mag *= $mult ** $power;my@choices;my@subtop=grep {$_ ne $canon}@$top;my$add_variant=(@subtop==@$top);for my$variant (variants($canon)){my$mult=$class->simple_convert($variant,$canon);my$minimag=$mag / $mult ** $power;my@vtop=@subtop;push@vtop,$variant if$add_variant;my$score=score($minimag,$variant,\@vtop);printf "($mag $unit) score %.6f:\t $minimag $variant\n",$score if$options->{verbose};push@choices,[$score,$variant ]}@choices=sort {$b->[0]<=> $a->[0]}@choices;return ()if@choices==0;return map {[{$unit=>$_->[1]},$_->[0]]}@choices}sub render_unit {my ($units,$options)=@_;my$str='';while (my ($name,$power)=each %$units){if ($power > 0){$str .= get_class($name)->render_unit($name,$power,$options);$str .= " "}}chop($str);my$botstr='';while (my ($name,$power)=each %$units){if ($power < 0){$botstr .= get_class($name)->render_unit($name,-$power,$options);$botstr .= " "}}chop($botstr);if ($botstr eq ''){return$str}elsif ($botstr =~ /\s/){return "$str / ($botstr)"}else {return "$str / $botstr"}}sub render {my ($v,$options)=@_;my ($mag,$units)=@$v;if (keys %$units==0){my$str=sprintf("%.4g",$mag);if (($mag < 1)&& ($mag >= 0.01)){if ($options->{abbreviate}){$str .= sprintf(" = %.4g percent",100 * $mag)}else {$str .= sprintf(" = %.4g%%",100 * $mag)}}return$str}my@top;my@bottom;while (my ($name,$power)=each %$units){if ($power > 0){push@top,$name}else {push@bottom,$name}}my$str;if (@top==1){my ($name)=@top;$str=get_class($name)->render($mag,$name,$units->{$name},$options);$str .= " "}else {$str=sprintf("%.4g ",$mag);for my$name (@top){$str .= get_class($name)->render_unit($name,$units->{$name},$options);$str .= " "}}if (@bottom > 0){my$botstr;for my$name (@bottom){$botstr .= get_class($name)->render_unit($name,-$units->{$name},$options);$botstr .= " "}chop($botstr);if (@bottom > 1){$str .= "/ ($botstr) "}else {$str .= "/ $botstr "}}chop($str);return$str}sub max_range_score {my ($mag,$units)=@_;my$score=0;for my$name (@$units){my$uscore=range_score($mag,$name);$score=$uscore if$score < $uscore}return$score}sub score {my ($mag,$unit,$top)=@_;my@rangeable=@$top ? @$top : ($unit);my$pref=pref_score($unit);my$range_score=max_range_score($mag,\@rangeable);return$pref * $range_score}1;
MATH_CALC_UNITS_RANK
$fatpacked{"Module/Implementation.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_IMPLEMENTATION';
package Module::Implementation;$Module::Implementation::VERSION='0.09';use strict;use warnings;use Module::Runtime 0.012 qw(require_module);use Try::Tiny;unless (exists$Module::Implementation::{VERSION}&& ${$Module::Implementation::{VERSION}}){$Module::Implementation::{VERSION}=\42}my%Implementation;sub build_loader_sub {my$caller=caller();return _build_loader($caller,@_)}sub _build_loader {my$package=shift;my%args=@_;my@implementations=@{$args{implementations}};my@symbols=@{$args{symbols}|| []};my$implementation;my$env_var=uc$package;$env_var =~ s/::/_/g;$env_var .= '_IMPLEMENTATION';return sub {my ($implementation,$loaded)=_load_implementation($package,$ENV{$env_var},\@implementations,);$Implementation{$package}=$implementation;_copy_symbols($loaded,$package,\@symbols);return$loaded}}sub implementation_for {my$package=shift;return$Implementation{$package}}sub _load_implementation {my$package=shift;my$env_value=shift;my$implementations=shift;if ($env_value){die "$env_value is not a valid implementation for $package" unless grep {$_ eq $env_value}@{$implementations};my$requested="${package}::$env_value";($requested)=$requested =~ /^(.+)$/;try {require_module($requested)}catch {require Carp;Carp::croak("Could not load $requested: $_")};return ($env_value,$requested)}else {my$err;for my$possible (@{$implementations}){my$try="${package}::$possible";my$ok;try {require_module($try);$ok=1}catch {$err .= $_ if defined $_};return ($possible,$try)if$ok}require Carp;if (defined$err && length$err){Carp::croak("Could not find a suitable $package implementation: $err")}else {Carp::croak('Module::Runtime failed to load a module but did not throw a real error. This should never happen. Something is very broken')}}}sub _copy_symbols {my$from_package=shift;my$to_package=shift;my$symbols=shift;for my$sym (@{$symbols}){my$type=$sym =~ s/^([\$\@\%\&\*])// ? $1 : '&';my$from="${from_package}::$sym";my$to="${to_package}::$sym";{no strict 'refs';no warnings 'once';*{$to}=$type eq '&' ? \&{$from}: $type eq '$' ? \${$from}: $type eq '@' ? \@{$from}: $type eq '%' ? \%{$from}: $type eq '*' ? *{$from}: die "Can't copy symbol from $from_package to $to_package: $type$sym"}}}1;
MODULE_IMPLEMENTATION
$fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_METADATA';
package Module::Metadata;sub __clean_eval {eval $_[0]}use strict;use warnings;our$VERSION='1.000033';use Carp qw/croak/;use File::Spec;BEGIN {eval {require Fcntl;Fcntl->import('SEEK_SET');1}or *SEEK_SET=sub {0}}use version 0.87;BEGIN {if ($INC{'Log/Contextual.pm'}){require "Log/Contextual/WarnLogger.pm";Log::Contextual->import('log_info','-default_logger'=>Log::Contextual::WarnLogger->new({env_prefix=>'MODULE_METADATA',}),)}else {*log_info=sub (&) {warn $_[0]->()}}}use File::Find qw(find);my$V_NUM_REGEXP=qr{v?[0-9._]+};my$PKG_FIRST_WORD_REGEXP=qr{ # the FIRST word in a package name
[a-zA-Z_] # the first word CANNOT start with a digit
(?:
[\w']? # can contain letters, digits, _, or ticks
\w # But, NO multi-ticks or trailing ticks
)*
}x;my$PKG_ADDL_WORD_REGEXP=qr{ # the 2nd+ word in a package name
\w # the 2nd+ word CAN start with digits
(?:
[\w']? # and can contain letters or ticks
\w # But, NO multi-ticks or trailing ticks
)*
}x;my$PKG_NAME_REGEXP=qr{ # match a package name
(?: :: )? # a pkg name can start with arisdottle
$PKG_FIRST_WORD_REGEXP # a package word
(?:
(?: :: )+ ### arisdottle (allow one or many times)
$PKG_ADDL_WORD_REGEXP ### a package word
)* # ^ zero, one or many times
(?:
:: # allow trailing arisdottle
)?
}x;my$PKG_REGEXP=qr{ # match a package declaration
^[\s\{;]* # intro chars on a line
package # the word 'package'
\s+ # whitespace
($PKG_NAME_REGEXP) # a package name
\s* # optional whitespace
($V_NUM_REGEXP)? # optional version number
\s* # optional whitesapce
[;\{] # semicolon line terminator or block start (since 5.16)
}x;my$VARNAME_REGEXP=qr{ # match fully-qualified VERSION name
([\$*]) # sigil - $ or *
(
( # optional leading package name
(?:::|\')? # possibly starting like just :: (a la $::VERSION)
(?:\w+(?:::|\'))* # Foo::Bar:: ...
)?
VERSION
)\b
}x;my$VERS_REGEXP=qr{ # match a VERSION definition
(?:
\(\s*$VARNAME_REGEXP\s*\) # with parens
|
$VARNAME_REGEXP # without parens
)
\s*
=[^=~>] # = but not ==, nor =~, nor =>
}x;sub new_from_file {my$class=shift;my$filename=File::Spec->rel2abs(shift);return undef unless defined($filename)&& -f $filename;return$class->_init(undef,$filename,@_)}sub new_from_handle {my$class=shift;my$handle=shift;my$filename=shift;return undef unless defined($handle)&& defined($filename);$filename=File::Spec->rel2abs($filename);return$class->_init(undef,$filename,@_,handle=>$handle)}sub new_from_module {my$class=shift;my$module=shift;my%props=@_;$props{inc}||= \@INC;my$filename=$class->find_module_by_name($module,$props{inc});return undef unless defined($filename)&& -f $filename;return$class->_init($module,$filename,%props)}{my$compare_versions=sub {my ($v1,$op,$v2)=@_;$v1=version->new($v1)unless UNIVERSAL::isa($v1,'version');my$eval_str="\$v1 $op \$v2";my$result=eval$eval_str;log_info {"error comparing versions: '$eval_str' $@"}if $@;return$result};my$normalize_version=sub {my ($version)=@_;if ($version =~ /[=<>!,]/){}elsif (ref$version eq 'version'){$version=$version->is_qv ? $version->normal : $version->stringify}elsif ($version =~ /^[^v][^.]*\.[^.]+\./){$version="v$version"}else {}return$version};my$resolve_module_versions=sub {my$packages=shift;my($file,$version);my$err='';for my$p (@$packages){if (defined($p->{version})){if (defined($version)){if ($compare_versions->($version,'!=',$p->{version})){$err .= " $p->{file} ($p->{version})\n"}else {}}else {$file=$p->{file};$version=$p->{version}}}$file ||= $p->{file}if defined($p->{file})}if ($err){$err=" $file ($version)\n" .$err}my%result=(file=>$file,version=>$version,err=>$err);return \%result};sub provides {my$class=shift;croak "provides() requires key/value pairs \n" if @_ % 2;my%args=@_;croak "provides() takes only one of 'dir' or 'files'\n" if$args{dir}&& $args{files};croak "provides() requires a 'version' argument" unless defined$args{version};croak "provides() does not support version '$args{version}' metadata" unless grep {$args{version}eq $_}qw/1.4 2/;$args{prefix}='lib' unless defined$args{prefix};my$p;if ($args{dir}){$p=$class->package_versions_from_directory($args{dir})}else {croak "provides() requires 'files' to be an array reference\n" unless ref$args{files}eq 'ARRAY';$p=$class->package_versions_from_directory($args{files})}if (length$args{prefix}){$args{prefix}=~ s{/$}{};for my$v (values %$p){$v->{file}="$args{prefix}/$v->{file}"}}return$p}sub package_versions_from_directory {my ($class,$dir,$files)=@_;my@files;if ($files){@files=@$files}else {find({wanted=>sub {push@files,$_ if -f $_ && /\.pm$/},no_chdir=>1,},$dir)}my(%prime,%alt);for my$file (@files){my$mapped_filename=File::Spec::Unix->abs2rel($file,$dir);my@path=split(/\//,$mapped_filename);(my$prime_package=join('::',@path))=~ s/\.pm$//;my$pm_info=$class->new_from_file($file);for my$package ($pm_info->packages_inside){next if$package eq 'main';next if$package eq 'DB';next if grep /^_/,split(/::/,$package);my$version=$pm_info->version($package);$prime_package=$package if lc($prime_package)eq lc($package);if ($package eq $prime_package){if (exists($prime{$package})){croak "Unexpected conflict in '$package'; multiple versions found.\n"}else {$mapped_filename="$package.pm" if lc("$package.pm")eq lc($mapped_filename);$prime{$package}{file}=$mapped_filename;$prime{$package}{version}=$version if defined($version)}}else {push(@{$alt{$package}},{file=>$mapped_filename,version=>$version,})}}}for my$package (keys(%alt)){my$result=$resolve_module_versions->($alt{$package});if (exists($prime{$package})){if ($result->{err}){log_info {"Found conflicting versions for package '$package'\n" ." $prime{$package}{file} ($prime{$package}{version})\n" .$result->{err}}}elsif (defined($result->{version})){if (exists($prime{$package}{version})&& defined($prime{$package}{version})){if ($compare_versions->($prime{$package}{version},'!=',$result->{version})){log_info {"Found conflicting versions for package '$package'\n" ." $prime{$package}{file} ($prime{$package}{version})\n" ." $result->{file} ($result->{version})\n"}}}else {$prime{$package}{file}=$result->{file};$prime{$package}{version}=$result->{version}}}else {}}else {if ($result->{err}){log_info {"Found conflicting versions for package '$package'\n" .$result->{err}}}$prime{$package}{file}=$result->{file};$prime{$package}{version}=$result->{version}if defined($result->{version})}}for (grep defined $_->{version},values%prime){$_->{version}=$normalize_version->($_->{version})}return \%prime}}sub _init {my$class=shift;my$module=shift;my$filename=shift;my%props=@_;my$handle=delete$props{handle};my(%valid_props,@valid_props);@valid_props=qw(collect_pod inc);@valid_props{@valid_props}=delete(@props{@valid_props});warn "Unknown properties: @{[keys %props]}\n" if scalar(%props);my%data=(module=>$module,filename=>$filename,version=>undef,packages=>[],versions=>{},pod=>{},pod_headings=>[],collect_pod=>0,%valid_props,);my$self=bless(\%data,$class);if (not $handle){my$filename=$self->{filename};open$handle,'<',$filename or croak("Can't open '$filename': $!");$self->_handle_bom($handle,$filename)}$self->_parse_fh($handle);@{$self->{packages}}=__uniq(@{$self->{packages}});unless($self->{module}and length($self->{module})){if ($self->{filename}=~ /\.pm$/){my ($v,$d,$f)=File::Spec->splitpath($self->{filename});$f =~ s/\..+$//;my@candidates=grep /(^|::)$f$/,@{$self->{packages}};$self->{module}=shift(@candidates)}else {if ((grep /main/,@{$self->{packages}})or (grep /main/,keys %{$self->{versions}})){$self->{module}='main'}else {$self->{module}=$self->{packages}[0]|| ''}}}$self->{version}=$self->{versions}{$self->{module}}if defined($self->{module});return$self}sub _do_find_module {my$class=shift;my$module=shift || croak 'find_module_by_name() requires a package name';my$dirs=shift || \@INC;my$file=File::Spec->catfile(split(/::/,$module));for my$dir (@$dirs){my$testfile=File::Spec->catfile($dir,$file);return [File::Spec->rel2abs($testfile),$dir ]if -e $testfile and!-d _;$testfile .= '.pm';return [File::Spec->rel2abs($testfile),$dir ]if -e $testfile}return}sub find_module_by_name {my$found=shift()->_do_find_module(@_)or return;return$found->[0]}sub find_module_dir_by_name {my$found=shift()->_do_find_module(@_)or return;return$found->[1]}sub _parse_version_expression {my$self=shift;my$line=shift;my($sigil,$variable_name,$package);if ($line =~ /$VERS_REGEXP/o){($sigil,$variable_name,$package)=$2 ? ($1,$2,$3): ($4,$5,$6);if ($package){$package=($package eq '::')? 'main' : $package;$package =~ s/::$//}}return ($sigil,$variable_name,$package)}sub _handle_bom {my ($self,$fh,$filename)=@_;my$pos=tell$fh;return unless defined$pos;my$buf=' ' x 2;my$count=read$fh,$buf,length$buf;return unless defined$count and $count >= 2;my$encoding;if ($buf eq "\x{FE}\x{FF}"){$encoding='UTF-16BE'}elsif ($buf eq "\x{FF}\x{FE}"){$encoding='UTF-16LE'}elsif ($buf eq "\x{EF}\x{BB}"){$buf=' ';$count=read$fh,$buf,length$buf;if (defined$count and $count >= 1 and $buf eq "\x{BF}"){$encoding='UTF-8'}}if (defined$encoding){if ("$]" >= 5.008){binmode($fh,":encoding($encoding)")}}else {seek$fh,$pos,SEEK_SET or croak(sprintf "Can't reset position to the top of '$filename'")}return$encoding}sub _parse_fh {my ($self,$fh)=@_;my($in_pod,$seen_end,$need_vers)=(0,0,0);my(@packages,%vers,%pod,@pod);my$package='main';my$pod_sect='';my$pod_data='';my$in_end=0;while (defined(my$line=<$fh>)){my$line_num=$.;chomp($line);my$is_cut;if ($line =~ /^=([a-zA-Z].*)/){my$cmd=$1;$is_cut=$cmd =~ /^cut(?:[^a-zA-Z]|$)/;$in_pod=!$is_cut}if ($in_pod){if ($line =~ /^=head[1-4]\s+(.+)\s*$/){push(@pod,$1);if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data;$pod_data=''}$pod_sect=$1}elsif ($self->{collect_pod}){$pod_data .= "$line\n"}next}elsif ($is_cut){if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data;$pod_data=''}$pod_sect='';next}next if$in_end;next if$line =~ /^\s*#/;if ($line eq '__END__'){$in_end++;next}last if$line eq '__DATA__';my($version_sigil,$version_fullname,$version_package)=index($line,'VERSION')>= 1 ? $self->_parse_version_expression($line): ();if ($line =~ /$PKG_REGEXP/o){$package=$1;my$version=$2;push(@packages,$package)unless grep($package eq $_,@packages);$need_vers=defined$version ? 0 : 1;if (not exists$vers{$package}and defined$version){my$dwim_version=eval {_dwim_version($version)};croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n" unless defined$dwim_version;$vers{$package}=$dwim_version}}elsif ($version_fullname && $version_package){$need_vers=0 if$version_package eq $package;unless (defined$vers{$version_package}&& length$vers{$version_package}){$vers{$version_package}=$self->_evaluate_version_line($version_sigil,$version_fullname,$line)}}elsif ($package eq 'main' && $version_fullname &&!exists($vers{main})){$need_vers=0;my$v=$self->_evaluate_version_line($version_sigil,$version_fullname,$line);$vers{$package}=$v;push(@packages,'main')}elsif ($package eq 'main' &&!exists($vers{main})&& $line =~ /\w/){$need_vers=1;$vers{main}='';push(@packages,'main')}elsif ($version_fullname && $need_vers){$need_vers=0;my$v=$self->_evaluate_version_line($version_sigil,$version_fullname,$line);unless (defined$vers{$package}&& length$vers{$package}){$vers{$package}=$v}}}if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data}$self->{versions}=\%vers;$self->{packages}=\@packages;$self->{pod}=\%pod;$self->{pod_headings}=\@pod}sub __uniq (@) {my (%seen,$key);grep {not $seen{$key=$_ }++}@_}{my$pn=0;sub _evaluate_version_line {my$self=shift;my($sigil,$variable_name,$line)=@_;$pn++;my$eval=qq{ my \$dummy = q# Hide from _packages_inside()
#; package Module::Metadata::_version::p${pn};
use version;
sub {
local $sigil$variable_name;
$line;
return \$$variable_name if defined \$$variable_name;
return \$Module::Metadata::_version::p${pn}::$variable_name;
};
};$eval=$1 if$eval =~ m{^(.+)}s;local $^W;my$vsub=__clean_eval($eval);if ($@ =~ /Can't locate/ && -d 'lib'){local@INC=('lib',@INC);$vsub=__clean_eval($eval)}warn "Error evaling version line '$eval' in $self->{filename}: $@\n" if $@;(ref($vsub)eq 'CODE')or croak "failed to build version sub for $self->{filename}";my$result=eval {$vsub->()};croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" if $@;my$version=eval {_dwim_version($result)};croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" unless defined$version;return$version}}{my@version_prep=(sub {return shift},sub {my$v=shift;$v =~ s{([0-9])[a-z-].*$}{$1}i;return$v},sub {my$v=shift;my$num_dots=()=$v =~ m{(\.)}g;my$num_unders=()=$v =~ m{(_)}g;my$leading_v=substr($v,0,1)eq 'v';if (!$leading_v && $num_dots < 2 && $num_unders > 1){$v =~ s{_}{}g;$num_unders=()=$v =~ m{(_)}g}return$v},sub {my$v=shift;no warnings 'numeric';return 0 + $v},);sub _dwim_version {my ($result)=shift;return$result if ref($result)eq 'version';my ($version,$error);for my$f (@version_prep){$result=$f->($result);$version=eval {version->new($result)};$error ||= $@ if $@;last if defined$version}croak$error unless defined$version;return$version}}sub name {$_[0]->{module}}sub filename {$_[0]->{filename}}sub packages_inside {@{$_[0]->{packages}}}sub pod_inside {@{$_[0]->{pod_headings}}}sub contains_pod {0+@{$_[0]->{pod_headings}}}sub version {my$self=shift;my$mod=shift || $self->{module};my$vers;if (defined($mod)&& length($mod)&& exists($self->{versions}{$mod})){return$self->{versions}{$mod}}else {return undef}}sub pod {my$self=shift;my$sect=shift;if (defined($sect)&& length($sect)&& exists($self->{pod}{$sect})){return$self->{pod}{$sect}}else {return undef}}sub is_indexable {my ($self,$package)=@_;my@indexable_packages=grep {$_ ne 'main'}$self->packages_inside;return!!grep {$_ eq $package}@indexable_packages if$package;return!!@indexable_packages}1;
MODULE_METADATA
$fatpacked{"Module/Pluggable.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_PLUGGABLE';
package Module::Pluggable;use strict;use vars qw($VERSION $FORCE_SEARCH_ALL_PATHS);use Module::Pluggable::Object;use if $] > 5.017,'deprecate';$VERSION='5.2';$FORCE_SEARCH_ALL_PATHS=0;sub import {my$class=shift;my%opts=@_;my ($pkg,$file)=caller;my$sub=$opts{'sub_name'}|| 'plugins';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;
MODULE_PLUGGABLE
$fatpacked{"Module/Pluggable/Object.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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 $MR);use if $] > 5.017,'deprecate';$VERSION='5.2';BEGIN {eval {require Module::Runtime};unless ($@){Module::Runtime->import('require_module')}else {*require_module=sub {my$module=shift;my$path=$module .".pm";$path =~ s{::}{/}g;require$path}}}sub new {my$class=shift;my%opts=@_;return bless \%opts,$class}sub plugins {my$self=shift;my@args=@_;$self->{'require'}=1 if$self->{'inner'};my$filename=$self->{'filename'};my$pkg=$self->{'package'};$self->_setup_exceptions;for (qw(search_path search_dirs)){$self->{$_}=[$self->{$_}]if exists$self->{$_}&&!ref($self->{$_})}$self->{'search_path'}||= ["${pkg}::Plugin"];$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};$self->{'follow_symlinks'}=1 unless exists$self->{'follow_symlinks'};my@SEARCHDIR=exists$INC{"blib.pm"}&& defined$filename && $filename =~ m!(^|/)blib/! &&!$self->{'force_search_all_paths'}? grep {/blib/}@INC : @INC;unshift@SEARCHDIR,@{$self->{'search_dirs'}}if defined$self->{'search_dirs'};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_inc_hooks($_,@SEARCHDIR))for @{$self->{'search_path'}};push(@plugins,$self->handle_innerpackages($_))for @{$self->{'search_path'}};return ()unless@plugins;my%plugins;for(@plugins){next unless$self->_is_legit($_);$plugins{$_}=1}if (defined$self->{'instantiate'}){my$method=$self->{'instantiate'};my@objs=();for 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 {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;for 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$/;for my$searchpath (@{$self->{'search_path'}}){my$sp=catdir($dir,(split /::/,$searchpath));next unless (-e $sp && -d _);my@files=$self->find_files($sp);for my$file (@files){next unless ($file)=($file =~ /(.*$file_regex)$/);my ($name,$directory,$suffix)=fileparse($file,$file_regex);next if (!$self->{include_editor_junk}&& $self->_is_editor_junk($name));$directory=abs2rel($directory,$sp);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/);next if$line =~ /^\s*#/;if ($line =~ m/^\s*package\s+(.*::)?($name)\s*;/i){@pkg_dirs=split /::/,$1 if defined $1;;$name=$2;last}}close PKGFILE}$directory =~ s/^[a-z]://i if($^O =~ /MSWin32|dos/);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}}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)}push@plugins,$self->handle_innerpackages($searchpath)}return@plugins}sub _is_editor_junk {my$self=shift;my$name=shift;return 1 if$name =~ /~$/;return 1 if$name =~ /^\.#/;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 {require_module($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$/;my@files=();{local $_;File::Find::find({no_chdir=>1,follow=>$self->{'follow_symlinks'},wanted=>sub {return unless$File::Find::name =~ /$file_regex/;(my$path=$File::Find::name)=~ s#^\\./##;push@files,$path}},$search_path)}return@files}sub handle_inc_hooks {my$self=shift;my$path=shift;my@SEARCHDIR=@_;my@plugins;for my$dir (@SEARCHDIR){next unless ref$dir && eval {$dir->can('files')};for my$plugin ($dir->files){$plugin =~ s/\.pm$//;$plugin =~ s{/}{::}g;next unless$plugin =~ m!^${path}::!;$self->handle_finding_plugin($plugin,\@plugins)}}return@plugins}sub handle_innerpackages {my$self=shift;return ()if (exists$self->{inner}&&!$self->{inner});my$path=shift;my@plugins;for my$plugin (Devel::InnerPackage::list_packages($path)){$self->handle_finding_plugin($plugin,\@plugins,1)}return@plugins}1;
MODULE_PLUGGABLE_OBJECT
$fatpacked{"Module/Runtime.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_RUNTIME';
package Module::Runtime;BEGIN {require 5.006}BEGIN {${^WARNING_BITS}=""}our$VERSION="0.015";our@EXPORT_OK=qw($module_name_rx is_module_name is_valid_module_name check_module_name module_notional_filename require_module use_module use_package_optimistically $top_module_spec_rx $sub_module_spec_rx is_module_spec is_valid_module_spec check_module_spec compose_module_name);my%export_ok=map {($_=>undef)}@EXPORT_OK;sub import {my$me=shift;my$callpkg=caller(0);my$errs="";for(@_){if(exists$export_ok{$_}){if(/\A\$(.*)\z/s){*{$callpkg."::".$1}=\$$1}else {*{$callpkg."::".$_}=\&$_}}else {$errs .= "\"$_\" is not exported by the $me module\n"}}if($errs ne ""){die "${errs}Can't continue after import errors "."at @{[(caller(0))[1]]} line @{[(caller(0))[2]]}.\n"}}sub _is_string($) {my($arg)=@_;return defined($arg)&& ref(\$arg)eq "SCALAR"}our$module_name_rx=qr/[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*/;my$qual_module_spec_rx=qr#(?:/|::)[A-Z_a-z][0-9A-Z_a-z]*(?:(?:/|::)[0-9A-Z_a-z]+)*#;my$unqual_top_module_spec_rx=qr#[A-Z_a-z][0-9A-Z_a-z]*(?:(?:/|::)[0-9A-Z_a-z]+)*#;our$top_module_spec_rx=qr/$qual_module_spec_rx|$unqual_top_module_spec_rx/o;my$unqual_sub_module_spec_rx=qr#[0-9A-Z_a-z]+(?:(?:/|::)[0-9A-Z_a-z]+)*#;our$sub_module_spec_rx=qr/$qual_module_spec_rx|$unqual_sub_module_spec_rx/o;sub is_module_name($) {_is_string($_[0])&& $_[0]=~ /\A$module_name_rx\z/o}*is_valid_module_name=\&is_module_name;sub check_module_name($) {unless(&is_module_name){die +(_is_string($_[0])? "`$_[0]'" : "argument")." is not a module name\n"}}sub module_notional_filename($) {&check_module_name;my($name)=@_;$name =~ s!::!/!g;return$name.".pm"}BEGIN {*_WORK_AROUND_HINT_LEAKAGE="$]" < 5.011 &&!("$]" >= 5.009004 && "$]" < 5.010001)? sub(){1}: sub(){0};*_WORK_AROUND_BROKEN_MODULE_STATE="$]" < 5.009 ? sub(){1}: sub(){0}}BEGIN {if(_WORK_AROUND_BROKEN_MODULE_STATE){eval q{
sub Module::Runtime::__GUARD__::DESTROY {
delete $INC{$_[0]->[0]} if @{$_[0]};
}
1;
};die $@ if $@ ne ""}}sub require_module($) {local %^H if _WORK_AROUND_HINT_LEAKAGE;if(_WORK_AROUND_BROKEN_MODULE_STATE){my$notional_filename=&module_notional_filename;my$guard=bless([$notional_filename ],"Module::Runtime::__GUARD__");my$result=CORE::require($notional_filename);pop @$guard;return$result}else {return scalar(CORE::require(&module_notional_filename))}}sub use_module($;$) {my($name,$version)=@_;require_module($name);$name->VERSION($version)if @_ >= 2;return$name}sub use_package_optimistically($;$) {my($name,$version)=@_;my$fn=module_notional_filename($name);eval {local$SIG{__DIE__};require_module($name)};die $@ if $@ ne "" && ($@ !~ /\ACan't locate \Q$fn\E .+ at \Q@{[__FILE__]}\E line/s || $@ =~ /^Compilation\ failed\ in\ require
\ at\ \Q@{[__FILE__]}\E\ line/xm);$name->VERSION($version)if @_ >= 2;return$name}sub is_module_spec($$) {my($prefix,$spec)=@_;return _is_string($spec)&& $spec =~ ($prefix ? qr/\A$sub_module_spec_rx\z/o : qr/\A$top_module_spec_rx\z/o)}*is_valid_module_spec=\&is_module_spec;sub check_module_spec($$) {unless(&is_module_spec){die +(_is_string($_[1])? "`$_[1]'" : "argument")." is not a module specification\n"}}sub compose_module_name($$) {my($prefix,$spec)=@_;check_module_name($prefix)if defined$prefix;&check_module_spec;if($spec =~ s#\A(?:/|::)##){}else {$spec=$prefix."::".$spec if defined$prefix}$spec =~ s#/#::#g;return$spec}1;
MODULE_RUNTIME
$fatpacked{"Monitoring/Plugin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MONITORING_PLUGIN';
package Monitoring::Plugin;use Monitoring::Plugin::Functions qw(:codes %ERRORS %STATUS_TEXT @STATUS_CODES);use Params::Validate qw(:all);use 5.006;use strict;use warnings;use Carp;use base qw(Class::Accessor::Fast);Monitoring::Plugin->mk_accessors(qw(shortname perfdata messages opts threshold));use Exporter;our@ISA=qw(Exporter);our@EXPORT=(@STATUS_CODES);our@EXPORT_OK=qw(%ERRORS %STATUS_TEXT);our$VERSION="0.39";sub new {my$class=shift;my%args=validate(@_,{shortname=>0,usage=>0,version=>0,url=>0,plugin=>0,blurb=>0,extra=>0,license=>0,timeout=>0 },);my$shortname=Monitoring::Plugin::Functions::get_shortname(\%args);delete$args{shortname}if (exists$args{shortname});my$self={shortname=>$shortname,perfdata=>[],messages=>{warning=>[],critical=>[],ok=>[]},opts=>undef,threshold=>undef,};bless$self,$class;if (exists$args{usage}){require Monitoring::Plugin::Getopt;$self->opts(new Monitoring::Plugin::Getopt(%args))}return$self}sub add_perfdata {my ($self,%args)=@_;require Monitoring::Plugin::Performance;my$perf=Monitoring::Plugin::Performance->new(%args);push @{$self->perfdata},$perf}sub all_perfoutput {my$self=shift;return join(" ",map {$_->perfoutput}(@{$self->perfdata}))}sub set_thresholds {my$self=shift;require Monitoring::Plugin::Threshold;return$self->threshold(Monitoring::Plugin::Threshold->set_thresholds(@_))}sub plugin_exit {my$self=shift;Monitoring::Plugin::Functions::plugin_exit(@_,{plugin=>$self })}sub plugin_die {my$self=shift;Monitoring::Plugin::Functions::plugin_die(@_,{plugin=>$self })}sub nagios_exit {my$self=shift;Monitoring::Plugin::Functions::plugin_exit(@_,{plugin=>$self })}sub nagios_die {my$self=shift;Monitoring::Plugin::Functions::plugin_die(@_,{plugin=>$self })}sub die {my$self=shift;Monitoring::Plugin::Functions::plugin_die(@_,{plugin=>$self })}sub max_state {Monitoring::Plugin::Functions::max_state(@_)}sub max_state_alt {Monitoring::Plugin::Functions::max_state_alt(@_)}sub check_threshold {my$self=shift;my%args;if ($#_==0 && (!ref $_[0]|| ref $_[0]eq "ARRAY")){%args=(check=>shift)}else {%args=validate (@_,{check=>1,warning=>0,critical=>0,})}if (exists$args{warning}|| exists$args{critical}){$self->set_thresholds(warning=>$args{warning},critical=>$args{critical},)}elsif (defined$self->threshold){}elsif (defined$self->opts){$self->set_thresholds(warning=>$self->opts->warning,critical=>$self->opts->critical,)}else {return UNKNOWN}return$self->threshold->get_status($args{check})}sub add_arg {my$self=shift;$self->opts->arg(@_)if$self->_check_for_opts}sub getopts {my$self=shift;$self->opts->getopts(@_)if$self->_check_for_opts}sub _check_for_opts {my$self=shift;croak "You have to supply a 'usage' param to Monitoring::Plugin::new() if you want to use Getopts from your Monitoring::Plugin object." unless ref$self->opts()eq 'Monitoring::Plugin::Getopt';return$self}sub add_message {my$self=shift;my ($code,@messages)=@_;croak "Invalid error code '$code'" unless defined($ERRORS{uc$code})|| defined($STATUS_TEXT{$code});$code=$STATUS_TEXT{$code}if$STATUS_TEXT{$code};$code=lc$code;croak "Error code '$code' not supported by add_message" if$code eq 'unknown' || $code eq 'dependent';$self->messages($code,[])unless$self->messages->{$code};push @{$self->messages->{$code}},@messages}sub check_messages {my$self=shift;my%args=@_;for my$code (qw(critical warning ok)){my$messages=$self->messages->{$code}|| [];if ($args{$code}){unless (ref$args{$code}eq 'ARRAY'){if ($code eq 'ok'){$args{$code}=[$args{$code}]}else {croak "Invalid argument '$code'"}}push @{$args{$code}},@$messages}else {$args{$code}=$messages}}Monitoring::Plugin::Functions::check_messages(%args)}1;
MONITORING_PLUGIN
$fatpacked{"Monitoring/Plugin/Config.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MONITORING_PLUGIN_CONFIG';
package Monitoring::Plugin::Config;use 5.006;use strict;use warnings;use Carp;use File::Spec;use base qw(Config::Tiny);my$FILENAME1='plugins.ini';my$FILENAME2='nagios-plugins.ini';my$FILENAME3='monitoring-plugins.ini';my$CURRENT_FILE=undef;my@MONITORING_CONFIG_PATH=qw(/etc/nagios /usr/local/nagios/etc /usr/local/etc/nagios /etc/opt/nagios);my@CONFIG_PATH=qw(/etc /usr/local/etc /etc/opt);sub read {my$class=shift;unless ($_[0]){SEARCH: {if ($ENV{MONITORING_CONFIG_PATH}|| $ENV{NAGIOS_CONFIG_PATH}){for (split /:/,($ENV{MONITORING_CONFIG_PATH}|| $ENV{NAGIOS_CONFIG_PATH})){my$file=File::Spec->catfile($_,$FILENAME1);unshift(@_,$file),last SEARCH if -f $file;$file=File::Spec->catfile($_,$FILENAME2);unshift(@_,$file),last SEARCH if -f $file;$file=File::Spec->catfile($_,$FILENAME3);unshift(@_,$file),last SEARCH if -f $file}}for (@MONITORING_CONFIG_PATH){my$file=File::Spec->catfile($_,$FILENAME1);unshift(@_,$file),last SEARCH if -f $file}for (@CONFIG_PATH){my$file=File::Spec->catfile($_,$FILENAME2);unshift(@_,$file),last SEARCH if -f $file;$file=File::Spec->catfile($_,$FILENAME3);unshift(@_,$file),last SEARCH if -f $file}}die "Cannot find '$FILENAME1', '$FILENAME2' or '$FILENAME3' in any standard location.\n" unless $_[0]}$CURRENT_FILE=$_[0];$class->SUPER::read(@_)}sub read_string {my$class=ref $_[0]? ref shift : shift;my$self=bless {},$class;return undef unless defined $_[0];my$ns='_';my$counter=0;for (split /(?:\015{1,2}\012|\015|\012)/,shift){$counter++;next if /^\s*(?:\#|\;|$)/;if (/^\s*\[\s*(.+?)\s*\]\s*$/){$self->{$ns=$1}||= {};next}if (/^\s*([^=]+?)\s*=\s*(.*?)\s*$/){push @{$self->{$ns}->{$1}},$2;next}return$self->_error("Syntax error at line $counter: '$_'")}$self}sub write {croak "Write access not permitted"}sub mp_getfile {return$CURRENT_FILE}1;
MONITORING_PLUGIN_CONFIG
$fatpacked{"Monitoring/Plugin/ExitResult.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MONITORING_PLUGIN_EXITRESULT';
package Monitoring::Plugin::ExitResult;use 5.006;use strict;use warnings;use overload '""'=>sub {shift->{message}};sub new {my$class=shift;return bless {return_code=>$_[0],message=>$_[1]},$class}sub message {shift->{message}}sub return_code {shift->{return_code}}sub code {shift->{return_code}}1;
MONITORING_PLUGIN_EXITRESULT
$fatpacked{"Monitoring/Plugin/Functions.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MONITORING_PLUGIN_FUNCTIONS';
package Monitoring::Plugin::Functions;use 5.006;use strict;use warnings;use File::Basename;use Params::Validate qw(:types validate);use Math::Calc::Units;our$VERSION="0.39";our@STATUS_CODES=qw(OK WARNING CRITICAL UNKNOWN DEPENDENT);require Exporter;our@ISA=qw(Exporter);our@EXPORT=(@STATUS_CODES,qw(plugin_exit plugin_die check_messages));our@EXPORT_OK=qw(%ERRORS %STATUS_TEXT @STATUS_CODES get_shortname max_state max_state_alt convert $value_re);our%EXPORT_TAGS=(all=>[@EXPORT,@EXPORT_OK ],codes=>[@STATUS_CODES ],functions=>[qw(plugin_exit plugin_die check_messages max_state max_state_alt convert) ],);use constant OK=>0;use constant WARNING=>1;use constant CRITICAL=>2;use constant UNKNOWN=>3;use constant DEPENDENT=>4;our%ERRORS=('OK'=>OK,'WARNING'=>WARNING,'CRITICAL'=>CRITICAL,'UNKNOWN'=>UNKNOWN,'DEPENDENT'=>DEPENDENT,);our%STATUS_TEXT=reverse%ERRORS;my$value=qr/[-+]?[\d\.]+/;our$value_re=qr/$value(?:e$value)?/;my$_fake_exit=0;sub _fake_exit {@_ ? $_fake_exit=shift : $_fake_exit};my$_use_die=0;sub _use_die {@_ ? $_use_die=shift : $_use_die};sub get_shortname {my$arg=shift;my$shortname=undef;return$arg->{shortname}if (defined($arg->{shortname}));$shortname=$arg->{plugin}if (defined($arg->{plugin}));$shortname=uc basename($shortname || $ENV{PLUGIN_NAME}|| $ENV{NAGIOS_PLUGIN}|| $0);$shortname =~ s/^CHECK_(?:BY_)?//;$shortname =~ s/\..*$//;return$shortname}sub max_state {return CRITICAL if grep {$_==CRITICAL}@_;return WARNING if grep {$_==WARNING}@_;return OK if grep {$_==OK}@_;return UNKNOWN if grep {$_==UNKNOWN}@_;return DEPENDENT if grep {$_==DEPENDENT}@_;return UNKNOWN}sub max_state_alt {return CRITICAL if grep {$_==CRITICAL}@_;return WARNING if grep {$_==WARNING}@_;return UNKNOWN if grep {$_==UNKNOWN}@_;return DEPENDENT if grep {$_==DEPENDENT}@_;return OK if grep {$_==OK}@_;return UNKNOWN}sub plugin_exit {my ($code,$message,$arg)=@_;if (defined$code && ($code eq 'return_code' || $code eq 'message')){if (int(@_ / 2)!=@_ / 2 && ref $_[$#_]){$arg=pop @_}else {undef$arg}my%arg=@_;$code=$arg{return_code};$message=$arg{message}}$arg ||= {};$code=$ERRORS{$code}if defined$code && exists$ERRORS{$code};$code=UNKNOWN unless defined$code && exists$STATUS_TEXT{$code};$message='' unless defined$message;if (ref$message && ref$message eq 'ARRAY'){$message=join(' ',map {chomp;$_}@$message)}else {chomp$message}my$output="$STATUS_TEXT{$code}";$output .= " - $message" if defined$message && $message ne '';my$shortname=($arg->{plugin}? $arg->{plugin}->shortname : undef);$shortname ||= get_shortname();$output="$shortname $output" if$shortname;if ($arg->{plugin}){my$plugin=$arg->{plugin};$output .= " | ".$plugin->all_perfoutput if$plugin->perfdata && $plugin->all_perfoutput}$output .= "\n";if ($_fake_exit){require Monitoring::Plugin::ExitResult;return Monitoring::Plugin::ExitResult->new($code,$output)}_plugin_exit($code,$output)}sub _plugin_exit {my ($code,$output)=@_;if ($_use_die){for (my$i=0;;$i++){@_=caller($i);last unless @_;if ($_[3]=~ m/die/){$!=$code;die($output)}}}print$output;exit$code}sub plugin_die {my ($arg1,$arg2,$rest)=@_;if (defined$arg1 && ($arg1 eq 'return_code' || $arg1 eq 'message')){return plugin_exit(@_)}elsif (defined$arg1 && (exists$ERRORS{$arg1}|| exists$STATUS_TEXT{$arg1})){return plugin_exit(@_)}elsif (defined$arg2 && (exists$ERRORS{$arg2}|| exists$STATUS_TEXT{$arg2})){return plugin_exit($arg2,$arg1,$rest)}else {return plugin_exit(UNKNOWN,$arg1,$arg2)}}sub die {plugin_die(@_)}sub convert {my ($value,$from,$to)=@_;my ($newval)=Math::Calc::Units::convert("$value $from",$to,'exact');return$newval}sub check_messages {my%arg=validate(@_,{critical=>{type=>ARRAYREF },warning=>{type=>ARRAYREF },ok=>{type=>ARRAYREF | SCALAR,optional=>1 },'join'=>{default=>' ' },join_all=>0,});$arg{join}=' ' unless defined$arg{join};my$code=OK;$code ||= CRITICAL if @{$arg{critical}};$code ||= WARNING if @{$arg{warning}};return$code unless wantarray;my$message='';if ($arg{join_all}){$message=join($arg{join_all},map {@$_ ? join($arg{'join'},@$_): ()}$arg{critical},$arg{warning},$arg{ok}? (ref$arg{ok}? $arg{ok}: [$arg{ok}]): [])}else {$message ||= join($arg{'join'},@{$arg{critical}})if$code==CRITICAL;$message ||= join($arg{'join'},@{$arg{warning}})if$code==WARNING;$message ||= ref$arg{ok}? join($arg{'join'},@{$arg{ok}}): $arg{ok}if$arg{ok}}return ($code,$message)}1;
MONITORING_PLUGIN_FUNCTIONS
$fatpacked{"Monitoring/Plugin/Getopt.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MONITORING_PLUGIN_GETOPT';
package Monitoring::Plugin::Getopt;use 5.006;use strict;use warnings;use File::Basename;use Getopt::Long qw(:config no_ignore_case bundling);use Carp;use Params::Validate qw(:all);use base qw(Class::Accessor);use Monitoring::Plugin::Functions;use Monitoring::Plugin::Config;use vars qw($VERSION);$VERSION=$Monitoring::Plugin::Functions::VERSION;my%DEFAULT=(timeout=>15,verbose=>0,license=>"This nagios plugin is free software, and comes with ABSOLUTELY NO WARRANTY.
It may be used, redistributed and/or modified under the terms of the GNU
General Public Licence (see http://www.fsf.org/licensing/licenses/gpl.txt).",);my@ARGS=({spec=>'usage|?',help=>"-?, --usage\n Print usage information",},{spec=>'help|h',help=>"-h, --help\n Print detailed help screen",},{spec=>'version|V',help=>"-V, --version\n Print version information",},{spec=>'extra-opts:s@',help=>"--extra-opts=[section][\@file]\n Read options from an ini file. See https://www.monitoring-plugins.org/doc/extra-opts.html\n for usage and examples.",},{spec=>'timeout|t=i',help=>"-t, --timeout=INTEGER\n Seconds before plugin times out (default: %s)",default=>$DEFAULT{timeout},},{spec=>'verbose|v+',help=>"-v, --verbose\n Show details for command-line debugging (can repeat up to 3 times)",default=>$DEFAULT{verbose},},);my%DEFER_ARGS=map {$_=>1}qw(timeout verbose);sub _die {my$self=shift;my ($msg)=@_;$msg .= "\n" unless substr($msg,-1)eq "\n";Monitoring::Plugin::Functions::_plugin_exit(3,$msg)}sub _attr {my$self=shift;my ($item,$extra)=@_;$extra='' unless defined$extra;return '' unless$self->{_attr}->{$item};$self->{_attr}->{$item}."\n" .$extra}sub _spec_to_help {my ($self,$spec,$label)=@_;my ($opts,$type)=split /=|:/,$spec,2;my$optional=($spec =~ m/:/);my (@short,@long);for (split /\|/,$opts){if (length $_==1){push@short,"-$_"}else {push@long,"--$_"}}my$help=join(', ',@short,@long);if ($type){if (!$label){if ($type eq 'i' || $type eq '+' || $type =~ /\d+/){$label='INTEGER'}else {$label='STRING'}}if ($optional){$help .= '[=' .$label .']'}else {$help .= '=' .$label}}elsif ($label){carp "Label specified, but there's no type in spec '$spec'"}$help .= "\n ";return$help}sub _options {my$self=shift;my@args=();my@defer=();for (@{$self->{_args}}){if (exists$DEFER_ARGS{$_->{name}}){push@defer,$_}else {push@args,$_}}my@options=();for my$arg (@args,@defer){my$help_array=ref$arg->{help}&& ref$arg->{help}eq 'ARRAY' ? $arg->{help}: [$arg->{help}];my$label_array=$arg->{label}&& ref$arg->{label}&& ref$arg->{label}eq 'ARRAY' ? $arg->{label}: [$arg->{label}];my$help_string='';for (my$i=0;$i <= $#$help_array;$i++){my$help=$help_array->[$i];if ($help =~ m/^\s*-/){$help_string .= $help}else {$help_string .= $self->_spec_to_help($arg->{spec},$label_array->[$i]).$help;$help_string .= "\n " if$i < $#$help_array}}if ($help_string =~ m/%s/){my$default=defined$arg->{default}? $arg->{default}: '';my$replaced=$help_string;$replaced =~ s|%s|$default|gmx;push@options,$replaced}else {push@options,$help_string}}return ' ' .join("\n ",@options)}sub _usage {my$self=shift;my$usage=$self->_attr('usage');$usage =~ s|%s|$self->{_attr}->{plugin}|gmx;return($usage)}sub _revision {my$self=shift;my$revision=sprintf "%s %s",$self->{_attr}->{plugin},$self->{_attr}->{version};$revision .= sprintf " [%s]",$self->{_attr}->{url}if$self->{_attr}->{url};$revision .= "\n";$revision}sub _help {my$self=shift;my$help='';$help .= $self->_revision ."\n";$help .= $self->_attr('license',"\n");$help .= $self->_attr('blurb',"\n");$help .= $self->_usage ? $self->_usage ."\n" : '';$help .= $self->_options ? $self->_options ."\n" : '';$help .= $self->_attr('extra',"\n");return$help}sub _process_specs_getopt_long {my$self=shift;my@opts=();for my$arg (@{$self->{_args}}){push@opts,$arg->{spec};my$spec=$arg->{spec};$spec =~ s/[=:].*$//;my$name=(split /\s*\|\s*/,$spec)[0];$arg->{name}=$name;if (defined$self->{$name}){$arg->{default}=$self->{$name}}else {$self->{$name}=$arg->{default}}}return@opts}sub _check_required_opts {my$self=shift;my@missing=();for my$arg (@{$self->{_args}}){if ($arg->{required}&&!defined$self->{$arg->{name}}){push@missing,$arg->{name}}}if (@missing){$self->_die($self->_usage ."\n" .join("\n",map {sprintf "Missing argument: %s",$_}@missing)."\n")}}sub _process_opts {my$self=shift;$self->_die($self->_usage)if$self->{usage};$self->_die($self->_revision)if$self->{version};$self->_die($self->_help)if$self->{help}}sub _load_config_section {my$self=shift;my ($section,$file,$flags)=@_;$section ||= $self->{_attr}->{plugin};my$Config;eval {$Config=Monitoring::Plugin::Config->read($file)};$self->_die($@)if ($@);$file ||= $Config->mp_getfile();$self->_die("Invalid section '$section' in config file '$file'")unless exists$Config->{$section};return$Config->{$section}}sub _setup_spec_index {my$self=shift;return if defined$self->{_spec};$self->{_spec}={map {$_->{name}=>$_->{spec}}@{$self->{_args}}}}sub _cmdline_value {my$self=shift;local $_=shift;if (m/\s/ && (m/^[^"']/ || m/[^"']$/)){return qq("$_")}elsif ($_ eq ''){return q("")}else {return $_}}sub _cmdline {my$self=shift;my ($hash)=@_;$hash ||= $self;$self->_setup_spec_index;my@args=();for my$key (sort keys %$hash){next if$key =~ m/^_/;next if exists$DEFAULT{$key}&& $hash->{$key}eq $DEFAULT{$key};next if grep {$key eq $_}qw(help usage version extra-opts);next unless defined$hash->{$key};my$spec=$self->{_spec}->{$key}|| '';if ($spec =~ m/[=:].+$/){for my$value (ref$hash->{$key}eq 'ARRAY' ? @{$hash->{$key}}: ($hash->{$key})){$value=$self->_cmdline_value($value);if (length($key)> 1){push@args,sprintf "--%s=%s",$key,$value}else {push@args,"-$key",$value}}}else {push@args,(length($key)> 1 ? '--' : '-').$key}}return wantarray ? @args : join(' ',@args)}sub _process_extra_opts {my$self=shift;my ($args)=@_;my$extopts_list=$args->{'extra-opts'};my@sargs=();for my$extopts (@$extopts_list){$extopts ||= $self->{_attr}->{plugin};my$section=$extopts;my$file='';if ($extopts =~ m/^([^@]*)@(.*?)\s*$/){$section=$1;$file=$2}my$shash=$self->_load_config_section($section,$file);push@sargs,$self->_cmdline($shash)}@ARGV=(@sargs,@{$self->{_attr}->{argv}});printf "[extra-opts] %s %s\n",$self->{_attr}->{plugin},join(' ',@ARGV)if$args->{verbose}&& $args->{verbose}>= 3}sub arg {my$self=shift;my%args;if ($_[0]=~ m/^(spec|help|required|default)$/ && scalar(@_)% 2==0){%args=validate(@_,{spec=>1,help=>1,default=>0,required=>0,label=>0,})}else {my@args=validate_pos(@_,1,1,0,0,0);%args=(spec=>$args[0],help=>$args[1],default=>$args[2],required=>$args[3],label=>$args[4],)}push @{$self->{_args}},\%args}sub getopts {my$self=shift;my@opt_array=$self->_process_specs_getopt_long;$self->{_attr}->{argv}=[@ARGV ];my$args1={};my$ok=GetOptions($args1,@opt_array);$self->_die($self->_usage)unless$ok;$self->_process_extra_opts($args1);$ok=GetOptions($self,@opt_array);$self->_die($self->_usage)unless$ok;$self->_process_opts;$self->_check_required_opts;$self->mk_ro_accessors(grep!/^_/,keys %$self);$SIG{ALRM}=sub {my$plugin=uc$self->{_attr}->{plugin};$plugin =~ s/^check_//;$self->_die(sprintf("%s UNKNOWN - plugin timed out (timeout %ss)",$plugin,$self->timeout))}}sub _init {my$self=shift;my$plugin=basename($ENV{PLUGIN_NAME}|| $ENV{NAGIOS_PLUGIN}|| $0);my%attr=validate(@_,{usage=>1,version=>0,url=>0,plugin=>{default=>$plugin },blurb=>0,extra=>0,'extra-opts'=>0,license=>{default=>$DEFAULT{license}},timeout=>{default=>$DEFAULT{timeout}},});$self->{timeout}=delete$attr{timeout};$self->{_attr}={%attr };chomp foreach values %{$self->{_attr}};$self->{_args}=[@ARGS ];$self}sub new {my$class=shift;my$self=bless {},$class;$self->_init(@_)}1;
MONITORING_PLUGIN_GETOPT
$fatpacked{"Monitoring/Plugin/Performance.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MONITORING_PLUGIN_PERFORMANCE';
package Monitoring::Plugin::Performance;use 5.006;use strict;use warnings;use Carp;use base qw(Class::Accessor::Fast);__PACKAGE__->mk_ro_accessors(qw(label value uom warning critical min max));use Monitoring::Plugin::Functions;use Monitoring::Plugin::Threshold;use Monitoring::Plugin::Range;our ($VERSION)=$Monitoring::Plugin::Functions::VERSION;sub import {my ($class,%attr)=@_;$_=$attr{use_die}|| 0;Monitoring::Plugin::Functions::_use_die($_)}my$value=qr/[-+]?[\d\.,]+/;my$value_re=qr/$value(?:e$value)?/;my$value_with_negative_infinity=qr/$value_re|~/;sub _parse {my$class=shift;my$string=shift;$string =~ /^'?([^'=]+)'?=($value_re)([\w%]*);?($value_with_negative_infinity\:?$value_re?)?;?($value_with_negative_infinity\:?$value_re?)?;?($value_re)?;?($value_re)?/o;return undef unless ((defined $1 && $1 ne "")&& (defined $2 && $2 ne ""));my@info=($1,$2,$3,$4,$5,$6,$7);map {defined$info[$_]&& $info[$_]=~ s/,/./go}(1,3,4,5,6);my$performance_value;{my$not_value;local$SIG{__WARN__}=sub {$not_value++};$performance_value=$info[1]+0;return undef if$not_value}my$p=$class->new(label=>$info[0],value=>$performance_value,uom=>$info[2],warning=>$info[3],critical=>$info[4],min=>$info[5],max=>$info[6]);return$p}sub _nvl {my ($self,$value)=@_;defined$value ? $value : ''}sub perfoutput {my$self=shift;my$label=$self->label;if ($label =~ / /){$label="'$label'"}my$out=sprintf "%s=%s%s;%s;%s;%s;%s",$label,$self->value,$self->_nvl($self->uom),$self->_nvl($self->warning),$self->_nvl($self->critical),$self->_nvl($self->min),$self->_nvl($self->max);$out =~ s/;;$//;return$out}sub parse_perfstring {my ($class,$perfstring)=@_;my@perfs=();my$obj;while ($perfstring){$perfstring =~ s/^\s*//;if (@{[$perfstring =~ /=/g]}> 1){$perfstring =~ s/^(.*?=.*?)\s//;if (defined $1){$obj=$class->_parse($1)}else {$perfstring="";$obj=$class->_parse($perfstring)}}else {$obj=$class->_parse($perfstring);$perfstring=""}push@perfs,$obj if$obj}return@perfs}sub rrdlabel {my$self=shift;my$name=$self->clean_label;return substr($name,0,19)}sub clean_label {my$self=shift;my$name=$self->label;if ($name eq "/"){$name="root"}elsif ($name =~ s/^\///){$name =~ s/\//_/g}$name =~ s/\W/_/g;return$name}sub threshold {my$self=shift;return Monitoring::Plugin::Threshold->set_thresholds(warning=>$self->warning,critical=>$self->critical)}sub new {my$class=shift;my%arg=@_;if (my$threshold=delete$arg{threshold}){$arg{warning}||= $threshold->warning ."";$arg{critical}||= $threshold->critical .""}$class->SUPER::new(\%arg)}1;
MONITORING_PLUGIN_PERFORMANCE
$fatpacked{"Monitoring/Plugin/Range.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MONITORING_PLUGIN_RANGE';
package Monitoring::Plugin::Range;use 5.006;use strict;use warnings;use Carp;use base qw(Class::Accessor::Fast);__PACKAGE__->mk_accessors(qw(start end start_infinity end_infinity alert_on));use Monitoring::Plugin::Functions qw(:DEFAULT $value_re);our ($VERSION)=$Monitoring::Plugin::Functions::VERSION;use overload 'eq'=>sub {shift->_stringify},'""'=>sub {shift->_stringify};use constant OUTSIDE=>0;use constant INSIDE=>1;sub _stringify {my$self=shift;return "" unless$self->is_set;return (($self->alert_on)? "@" : "").(($self->start_infinity==1)? "~:" : (($self->start==0)?"":$self->start.":")).(($self->end_infinity==1)? "" : $self->end)}sub is_set {my$self=shift;(!defined$self->alert_on)? 0 : 1}sub _set_range_start {my ($self,$value)=@_;$self->start($value+0);$self->start_infinity(0)}sub _set_range_end {my ($self,$value)=@_;$self->end($value+0);$self->end_infinity(0)}sub parse_range_string {my ($class,$string)=@_;my$valid=0;my$range=$class->new(start=>0,start_infinity=>0,end=>0,end_infinity=>1,alert_on=>OUTSIDE);$string =~ s/\s//g;unless ($string =~ /[\d~]/ && $string =~ m/^\@?($value_re|~)?(:($value_re)?)?$/){carp "invalid range definition '$string'";return undef}if ($string =~ s/^\@//){$range->alert_on(INSIDE)}if ($string =~ s/^~//){$range->start_infinity(1)}if ($string =~ m/^($value_re)?:/){my$start=$1;$range->_set_range_start($start)if defined$start;$range->end_infinity(1);$string =~ s/^($value_re)?://;$valid++}if ($string =~ /^($value_re)$/){$range->_set_range_end($string);$valid++}if ($valid && ($range->start_infinity==1 || $range->end_infinity==1 || $range->start <= $range->end)){return$range}return undef}sub check_range {my ($self,$value)=@_;my$false=0;my$true=1;if ($self->alert_on==INSIDE){$false=1;$true=0}if ($self->end_infinity==0 && $self->start_infinity==0){if ($self->start <= $value && $value <= $self->end){return$false}else {return$true}}elsif ($self->start_infinity==0 && $self->end_infinity==1){if ($value >= $self->start){return$false}else {return$true}}elsif ($self->start_infinity==1 && $self->end_infinity==0){if ($value <= $self->end){return$false}else {return$true}}else {return$false}}sub new {shift->SUPER::new({@_})}1;
MONITORING_PLUGIN_RANGE
$fatpacked{"Monitoring/Plugin/Threshold.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MONITORING_PLUGIN_THRESHOLD';
package Monitoring::Plugin::Threshold;use 5.006;use strict;use warnings;use base qw(Class::Accessor::Fast);__PACKAGE__->mk_accessors(qw(warning critical));use Monitoring::Plugin::Range;use Monitoring::Plugin::Functions qw(:codes plugin_die);our ($VERSION)=$Monitoring::Plugin::Functions::VERSION;sub get_status {my ($self,$value)=@_;$value=[$value ]if (ref$value eq "");for my$v (@$value){if ($self->critical->is_set){return CRITICAL if$self->critical->check_range($v)}}for my$v (@$value){if ($self->warning->is_set){return WARNING if$self->warning->check_range($v)}}return OK}sub _inflate {my ($self,$value,$key)=@_;return Monitoring::Plugin::Range->new if!defined$value;if (ref$value){plugin_die("Invalid $key object: type " .ref$value)unless$value->isa("Monitoring::Plugin::Range");return$value}return Monitoring::Plugin::Range->new if$value eq "";my$range=Monitoring::Plugin::Range->parse_range_string($value);plugin_die("Cannot parse $key range: '$value'")unless(defined($range));return$range}sub set_thresholds {my ($self,%arg)=@_;return$self->new(%arg)unless ref$self;$self->set($_,$arg{$_})foreach qw(warning critical)}sub set {my$self=shift;my ($key,$value)=@_;$self->SUPER::set($key,$self->_inflate($value,$key))}sub new {my ($self,%arg)=@_;$self->SUPER::new({map {$_=>$self->_inflate($arg{$_},$_)}qw(warning critical)})}1;
MONITORING_PLUGIN_THRESHOLD
$fatpacked{"Params/Validate.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARAMS_VALIDATE';
package Params::Validate;use 5.008001;use strict;use warnings;our$VERSION='1.29';use Exporter;use Module::Implementation;use Params::Validate::Constants;use vars qw($NO_VALIDATION %OPTIONS $options);our@ISA='Exporter';my@types=qw(SCALAR ARRAYREF HASHREF CODEREF GLOB GLOBREF SCALARREF HANDLE BOOLEAN UNDEF OBJECT);our%EXPORT_TAGS=('all'=>[qw(validate validate_pos validation_options validate_with),@types ],types=>\@types,);our@EXPORT_OK=(@{$EXPORT_TAGS{all}},'set_options');our@EXPORT=qw(validate validate_pos);$NO_VALIDATION=$ENV{PERL_NO_VALIDATION};{my$loader=Module::Implementation::build_loader_sub(implementations=>['XS','PP' ],symbols=>[qw(validate validate_pos validate_with validation_options set_options),],);$ENV{PARAMS_VALIDATE_IMPLEMENTATION}='PP' if$ENV{PV_TEST_PERL};$loader->()}1;
PARAMS_VALIDATE
$fatpacked{"Params/Validate/Constants.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARAMS_VALIDATE_CONSTANTS';
package Params::Validate::Constants;use strict;use warnings;our$VERSION='1.29';our@ISA='Exporter';our@EXPORT=qw(SCALAR ARRAYREF HASHREF CODEREF GLOB GLOBREF SCALARREF HANDLE BOOLEAN UNDEF OBJECT UNKNOWN);sub SCALAR () {1}sub ARRAYREF () {2}sub HASHREF () {4}sub CODEREF () {8}sub GLOB () {16}sub GLOBREF () {32}sub SCALARREF () {64}sub UNKNOWN () {128}sub UNDEF () {256}sub OBJECT () {512}sub HANDLE () {16 | 32}sub BOOLEAN () {1 | 256}1;
PARAMS_VALIDATE_CONSTANTS
$fatpacked{"Params/Validate/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARAMS_VALIDATE_PP';
package Params::Validate::PP;use strict;use warnings;our$VERSION='1.29';use Params::Validate::Constants;use Scalar::Util 1.10 ();our$options;sub validate_pos (\@@) {return if$Params::Validate::NO_VALIDATION &&!defined wantarray;my$p=shift;my@specs=@_;my@p=@$p;if ($Params::Validate::NO_VALIDATION){for (my$x=$#p + 1;$x <= $#specs;$x++ ){$p[$x]=$specs[$x]->{default}if ref$specs[$x]&& exists$specs[$x]->{default}}return wantarray ? @p : \@p}local$options ||= _get_options((caller(0))[0])unless defined$options;my$min=0;while (1){last unless (ref$specs[$min]?!(exists$specs[$min]->{default}|| $specs[$min]->{optional}): $specs[$min]);$min++}my$max=scalar@specs;my$actual=scalar@p;unless ($actual >= $min && ($options->{allow_extra}|| $actual <= $max)){my$minmax=($options->{allow_extra}? "at least $min" : ($min!=$max ? "$min - $max" : $max));my$val=$options->{allow_extra}? $min : $max;$minmax .= $val!=1 ? ' were' : ' was';my$called=_get_called();$options->{on_fail}->("$actual parameter" .($actual!=1 ? 's' : '')." " .($actual!=1 ? 'were' : 'was')." passed to $called but $minmax expected\n")}my$bigger=$#p > $#specs ? $#p : $#specs;for (0 .. $bigger){my$spec=$specs[$_];next unless ref$spec;if ($_ <= $#p){_validate_one_param($p[$_],\@p,$spec,'Parameter #' .($_ + 1).' (%s)')}$p[$_]=$spec->{default}if $_ > $#p && exists$spec->{default}}_validate_pos_depends(\@p,\@specs);for (grep {defined$p[$_]&&!ref$p[$_]&& ref$specs[$_]&& $specs[$_]{untaint}}0 .. $bigger){($p[$_])=$p[$_]=~ /(.+)/}return wantarray ? @p : \@p}sub _validate_pos_depends {my ($p,$specs)=@_;for my$p_idx (0 .. $#$p){my$spec=$specs->[$p_idx];next unless$spec && UNIVERSAL::isa($spec,'HASH')&& exists$spec->{depends};my$depends=$spec->{depends};if (ref$depends){require Carp;local$Carp::CarpLevel=2;Carp::croak("Arguments to 'depends' for validate_pos() must be a scalar")}my$p_size=scalar @$p;if ($p_size < $depends - 1){my$error =("Parameter #" .($p_idx + 1)." depends on parameter #" .$depends .", which was not given");$options->{on_fail}->($error)}}return 1}sub _validate_named_depends {my ($p,$specs)=@_;for my$pname (keys %$p){my$spec=$specs->{$pname};next unless$spec && UNIVERSAL::isa($spec,'HASH')&& $spec->{depends};unless (UNIVERSAL::isa($spec->{depends},'ARRAY')||!ref$spec->{depends}){require Carp;local$Carp::CarpLevel=2;Carp::croak("Arguments to 'depends' must be a scalar or arrayref")}for my$depends_name (ref$spec->{depends}? @{$spec->{depends}}: $spec->{depends}){unless (exists$p->{$depends_name}){my$error =("Parameter '$pname' depends on parameter '" .$depends_name ."', which was not given");$options->{on_fail}->($error)}}}}sub validate (\@$) {return if$Params::Validate::NO_VALIDATION &&!defined wantarray;my$p=$_[0];my$specs=$_[1];local$options=_get_options((caller(0))[0])unless defined$options;if (ref$p eq 'ARRAY'){if (ref$p->[0]){$p={%{$p->[0]}}}elsif (@$p % 2){my$called=_get_called();$options->{on_fail}->("Odd number of parameters in call to $called " ."when named parameters were expected\n")}else {$p={@$p}}}if ($options->{normalize_keys}){$specs=_normalize_callback($specs,$options->{normalize_keys});$p=_normalize_callback($p,$options->{normalize_keys})}elsif ($options->{ignore_case}|| $options->{strip_leading}){$specs=_normalize_named($specs);$p=_normalize_named($p)}if ($Params::Validate::NO_VALIDATION){return (wantarray ? ((map {$_=>$specs->{$_}->{default}}grep {ref$specs->{$_}&& exists$specs->{$_}->{default}}keys %$specs),(ref$p eq 'ARRAY' ? (ref$p->[0]? %{$p->[0]}: @$p): %$p)): do {my$ref=(ref$p eq 'ARRAY' ? (ref$p->[0]? $p->[0]: {@$p}): $p);for (grep {ref$specs->{$_}&& exists$specs->{$_}->{default}}keys %$specs){$ref->{$_}=$specs->{$_}->{default}unless exists$ref->{$_}}return$ref})}_validate_named_depends($p,$specs);unless ($options->{allow_extra}){if (my@unmentioned=grep {!exists$specs->{$_}}keys %$p){my$called=_get_called();$options->{on_fail}->("The following parameter" .(@unmentioned > 1 ? 's were' : ' was')." passed in the call to $called but " .(@unmentioned > 1 ? 'were' : 'was')." not listed in the validation options: @unmentioned\n")}}my@missing;keys %$specs;OUTER: while (my ($key,$spec)=each %$specs){if (!exists$p->{$key}&& (ref$spec ?!(do {if (exists$spec->{default}){$p->{$key}=$spec->{default};next OUTER}}|| do {next OUTER if$spec->{optional}}): $spec)){push@missing,$key}elsif (ref$spec){my$value=defined$p->{$key}? qq|"$p->{$key}"| : 'undef';_validate_one_param($p->{$key},$p,$spec,qq{The '$key' parameter (%s)})}}if (@missing){my$called=_get_called();my$missing=join ', ',map {"'$_'"}sort@missing;$options->{on_fail}->("Mandatory parameter" .(@missing > 1 ? 's' : '')." $missing missing in call to $called\n")}for my$key (grep {defined$p->{$_}&&!ref$p->{$_}&& ref$specs->{$_}&& $specs->{$_}{untaint}}keys %$p){($p->{$key})=$p->{$key}=~ /(.+)/}return wantarray ? %$p : $p}sub validate_with {return if$Params::Validate::NO_VALIDATION &&!defined wantarray;my%p=@_;local$options=_get_options((caller(0))[0],%p);unless ($Params::Validate::NO_VALIDATION){unless (exists$options->{called}){$options->{called}=(caller($options->{stack_skip}))[3]}}if (UNIVERSAL::isa($p{spec},'ARRAY')){return validate_pos(@{$p{params}},@{$p{spec}})}else {return&validate($p{params},$p{spec})}}sub _normalize_callback {my ($p,$func)=@_;my%new;for my$key (keys %$p){my$new_key=$func->($key);unless (defined$new_key){die "The normalize_keys callback did not return a defined value when normalizing the key '$key'"}if (exists$new{$new_key}){die "The normalize_keys callback returned a key that already exists, '$new_key', when normalizing the key '$key'"}$new{$new_key}=$p->{$key}}return \%new}sub _normalize_named {my%h=(ref $_[0])=~ /ARRAY/ ? @{$_[0]}: %{$_[0]};if ($options->{ignore_case}){$h{lc $_ }=delete$h{$_}for keys%h}if ($options->{strip_leading}){for my$key (keys%h){my$new;($new=$key)=~ s/^\Q$options->{strip_leading}\E//;$h{$new}=delete$h{$key}}}return \%h}my%Valid=map {$_=>1}qw(callbacks can default depends isa optional regex type untaint);sub _validate_one_param {my ($value,$params,$spec,$id)=@_;if (exists$spec->{type}){unless (defined$spec->{type}&& Scalar::Util::looks_like_number($spec->{type})&& $spec->{type}> 0){my$msg ="$id has a type specification which is not a number. It is ";if (defined$spec->{type}){$msg .= "a string - $spec->{type}"}else {$msg .= "undef"}$msg .= ".\n Use the constants exported by Params::Validate to declare types.";$options->{on_fail}->(sprintf($msg,_stringify($value)))}unless (_get_type($value)& $spec->{type}){my$type=_get_type($value);my@is=_typemask_to_strings($type);my@allowed=_typemask_to_strings($spec->{type});my$article=$is[0]=~ /^[aeiou]/i ? 'an' : 'a';my$called=_get_called(1);$options->{on_fail}->(sprintf("$id to $called was $article '@is', which " ."is not one of the allowed types: @allowed\n",_stringify($value)))}}return unless ($spec->{isa}|| $spec->{can}|| $spec->{callbacks}|| $spec->{regex});if (exists$spec->{isa}){for (ref$spec->{isa}? @{$spec->{isa}}: $spec->{isa}){unless (do {local $@=q{};eval {$value->isa($_)}}){my$is=ref$value ? ref$value : 'plain scalar';my$article1=$_ =~ /^[aeiou]/i ? 'an' : 'a';my$article2=$is =~ /^[aeiou]/i ? 'an' : 'a';my$called=_get_called(1);$options->{on_fail}->(sprintf("$id to $called was not $article1 '$_' " ."(it is $article2 $is)\n",_stringify($value)))}}}if (exists$spec->{can}){for (ref$spec->{can}? @{$spec->{can}}: $spec->{can}){unless (do {local $@=q{};eval {$value->can($_)}}){my$called=_get_called(1);$options->{on_fail}->(sprintf("$id to $called does not have the method: '$_'\n",_stringify($value)))}}}if ($spec->{callbacks}){unless (UNIVERSAL::isa($spec->{callbacks},'HASH')){my$called=_get_called(1);$options->{on_fail}->("'callbacks' validation parameter for $called must be a hash reference\n")}for (keys %{$spec->{callbacks}}){unless (UNIVERSAL::isa($spec->{callbacks}{$_},'CODE')){my$called=_get_called(1);$options->{on_fail}->("callback '$_' for $called is not a subroutine reference\n")}my$ok;my$e=do {local $@=q{};local$SIG{__DIE__};$ok=eval {$spec->{callbacks}{$_}->($value,$params)};$@};if (!$ok){my$called=_get_called(1);if (ref$e){$options->{on_fail}->($e)}else {my$msg="$id to $called did not pass the '$_' callback";$msg .= ": $e" if length$e;$msg .= "\n";$options->{on_fail}->(sprintf($msg,_stringify($value)))}}}}if (exists$spec->{regex}){unless ((defined$value ? $value : '')=~ /$spec->{regex}/){my$called=_get_called(1);$options->{on_fail}->(sprintf("$id to $called did not pass regex check\n",_stringify($value)))}}}{my%isas=('ARRAY'=>ARRAYREF,'HASH'=>HASHREF,'CODE'=>CODEREF,'GLOB'=>GLOBREF,'SCALAR'=>SCALARREF,'REGEXP'=>SCALARREF,);my%simple_refs=map {$_=>1}keys%isas;sub _get_type {return UNDEF unless defined $_[0];my$ref=ref $_[0];unless ($ref){return GLOB if UNIVERSAL::isa(\$_[0],'GLOB');return SCALAR}return$isas{$ref}if$simple_refs{$ref};for (keys%isas){return$isas{$_}| OBJECT if UNIVERSAL::isa($_[0],$_)}return UNKNOWN}}{my%type_to_string=(SCALAR()=>'scalar',ARRAYREF()=>'arrayref',HASHREF()=>'hashref',CODEREF()=>'coderef',GLOB()=>'glob',GLOBREF()=>'globref',SCALARREF()=>'scalarref',UNDEF()=>'undef',OBJECT()=>'object',UNKNOWN()=>'unknown',);sub _typemask_to_strings {my$mask=shift;my@types;for (SCALAR,ARRAYREF,HASHREF,CODEREF,GLOB,GLOBREF,SCALARREF,UNDEF,OBJECT,UNKNOWN){push@types,$type_to_string{$_}if$mask & $_}return@types ? @types : ('unknown')}}{my%defaults=(ignore_case=>0,strip_leading=>0,allow_extra=>0,on_fail=>sub {require Carp;Carp::croak($_[0])},stack_skip=>1,normalize_keys=>undef,);*set_options=\&validation_options;sub validation_options {my%opts=@_;my$caller=caller;for (keys%defaults){$opts{$_}=$defaults{$_}unless exists$opts{$_}}$Params::Validate::OPTIONS{$caller}=\%opts}sub _get_options {my$caller=shift;if (@_){return ($Params::Validate::OPTIONS{$caller}? {%{$Params::Validate::OPTIONS{$caller}},@_ }: {%defaults,@_ })}else {return (exists$Params::Validate::OPTIONS{$caller}? $Params::Validate::OPTIONS{$caller}: \%defaults)}}}sub _get_called {my$extra_skip=$_[0]|| 0;$extra_skip++;my$called=(exists$options->{called}? $options->{called}: (caller($options->{stack_skip}+ $extra_skip))[3]);$called='(unknown)' unless defined$called;return$called}sub _stringify {return defined $_[0]? qq{"$_[0]"} : 'undef'}1;
PARAMS_VALIDATE_PP
$fatpacked{"Params/Validate/XS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARAMS_VALIDATE_XS';
package Params::Validate::XS;use strict;use warnings;our$VERSION='1.29';use Carp;my$default_fail=sub {Carp::confess($_[0])};{my%defaults=(ignore_case=>0,strip_leading=>0,allow_extra=>0,on_fail=>$default_fail,stack_skip=>1,normalize_keys=>undef,);*set_options=\&validation_options;sub validation_options {my%opts=@_;my$caller=caller;for (keys%defaults){$opts{$_}=$defaults{$_}unless exists$opts{$_}}$Params::Validate::OPTIONS{$caller}=\%opts}use XSLoader;XSLoader::load(__PACKAGE__,exists$Params::Validate::XS::{VERSION}? ${$Params::Validate::XS::{VERSION}}: (),)}sub _check_regex_from_xs {return (defined $_[0]? $_[0]: '')=~ /$_[1]/ ? 1 : 0}1;
PARAMS_VALIDATE_XS
$fatpacked{"Params/ValidatePP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARAMS_VALIDATEPP';
package Params::Validate;our$VERSION='1.29';BEGIN {$ENV{PARAMS_VALIDATE_IMPLEMENTATION}='PP'}use Params::Validate;1;
PARAMS_VALIDATEPP
$fatpacked{"Params/ValidateXS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARAMS_VALIDATEXS';
package Params::Validate;our$VERSION='1.29';BEGIN {$ENV{PARAMS_VALIDATE_IMPLEMENTATION}='XS'}use Params::Validate;1;
PARAMS_VALIDATEXS
$fatpacked{"Perl/OSType.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERL_OSTYPE';
use strict;use warnings;package Perl::OSType;our$VERSION='1.010';require Exporter;our@ISA=qw(Exporter);our%EXPORT_TAGS=(all=>[qw(os_type is_os_type)]);our@EXPORT_OK=@{$EXPORT_TAGS{all}};my%OSTYPES=qw(aix Unix bsdos Unix beos Unix bitrig Unix dgux Unix dragonfly Unix dynixptx Unix freebsd Unix linux Unix haiku Unix hpux Unix iphoneos Unix irix Unix darwin Unix machten Unix midnightbsd Unix minix Unix mirbsd Unix next Unix openbsd Unix netbsd Unix dec_osf Unix nto Unix svr4 Unix svr5 Unix sco Unix sco_sv Unix unicos Unix unicosmk Unix solaris Unix sunos Unix cygwin Unix msys Unix os2 Unix interix Unix gnu Unix gnukfreebsd Unix nto Unix qnx Unix android Unix dos Windows MSWin32 Windows os390 EBCDIC os400 EBCDIC posix-bc EBCDIC vmesa EBCDIC MacOS MacOS VMS VMS vos VOS riscos RiscOS amigaos Amiga mpeix MPEiX);sub os_type {my ($os)=@_;$os=$^O unless defined$os;return$OSTYPES{$os}|| q{}}sub is_os_type {my ($type,$os)=@_;return unless$type;$os=$^O unless defined$os;return os_type($os)eq $type}1;
PERL_OSTYPE
$fatpacked{"TAP/Base.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_BASE';
package TAP::Base;use strict;use warnings;use base 'TAP::Object';our$VERSION='3.39';use constant GOT_TIME_HIRES=>do {eval 'use Time::HiRes qw(time);';$@ ? 0 : 1};sub _initialize {my ($self,$arg_for,$ok_callback)=@_;my%ok_map=map {$_=>1}@$ok_callback;$self->{ok_callbacks}=\%ok_map;if (my$cb=delete$arg_for->{callbacks}){while (my ($event,$callback)=each %$cb){$self->callback($event,$callback)}}return$self}sub callback {my ($self,$event,$callback)=@_;my%ok_map=%{$self->{ok_callbacks}};$self->_croak('No callbacks may be installed')unless%ok_map;$self->_croak("Callback $event is not supported. Valid callbacks are " .join(', ',sort keys%ok_map))unless exists$ok_map{$event};push @{$self->{code_for}{$event}},$callback;return}sub _has_callbacks {my$self=shift;return keys %{$self->{code_for}}!=0}sub _callback_for {my ($self,$event)=@_;return$self->{code_for}{$event}}sub _make_callback {my$self=shift;my$event=shift;my$cb=$self->_callback_for($event);return unless defined$cb;return map {$_->(@_)}@$cb}sub get_time {return time()}sub time_is_hires {return GOT_TIME_HIRES}sub get_times {return [times()]}1;
TAP_BASE
$fatpacked{"TAP/Formatter/Base.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_FORMATTER_BASE';
package TAP::Formatter::Base;use strict;use warnings;use base 'TAP::Base';use POSIX qw(strftime);my$MAX_ERRORS=5;my%VALIDATION_FOR;BEGIN {%VALIDATION_FOR=(directives=>sub {shift;shift},verbosity=>sub {shift;shift},normalize=>sub {shift;shift},timer=>sub {shift;shift},failures=>sub {shift;shift},comments=>sub {shift;shift},errors=>sub {shift;shift},color=>sub {shift;shift},jobs=>sub {shift;shift},show_count=>sub {shift;shift},stdout=>sub {my ($self,$ref)=@_;$self->_croak("option 'stdout' needs a filehandle")unless$self->_is_filehandle($ref);return$ref},);sub _is_filehandle {my ($self,$ref)=@_;return 0 if!defined$ref;return 1 if ref$ref eq 'GLOB';return 1 if!ref$ref && ref \$ref eq 'GLOB';return 1 if eval {$ref->can('print')};return 0}my@getter_setters=qw(_longest _printed_summary_header _colorizer);__PACKAGE__->mk_methods(@getter_setters,keys%VALIDATION_FOR)}our$VERSION='3.39';sub _initialize {my ($self,$arg_for)=@_;$arg_for ||= {};$self->SUPER::_initialize($arg_for);my%arg_for=%$arg_for;$self->verbosity(0);for my$name (keys%VALIDATION_FOR){my$property=delete$arg_for{$name};if (defined$property){my$validate=$VALIDATION_FOR{$name};$self->$name($self->$validate($property))}}if (my@props=keys%arg_for){$self->_croak("Unknown arguments to " .__PACKAGE__ ."::new (@props)")}$self->stdout(\*STDOUT)unless$self->stdout;if ($self->color){require TAP::Formatter::Color;$self->_colorizer(TAP::Formatter::Color->new)}return$self}sub verbose {shift->verbosity >= 1}sub quiet {shift->verbosity <= -1}sub really_quiet {shift->verbosity <= -2}sub silent {shift->verbosity <= -3}sub prepare {my ($self,@tests)=@_;my$longest=0;for my$test (@tests){$longest=length$test if length$test > $longest}$self->_longest($longest)}sub _format_now {strftime "[%H:%M:%S]",localtime}sub _format_name {my ($self,$test)=@_;my$name=$test;my$periods='.' x ($self->_longest + 2 - length$test);$periods=" $periods ";if ($self->timer){my$stamp=$self->_format_now();return "$stamp $name$periods"}else {return "$name$periods"}}sub open_test {die "Unimplemented."}sub _output_success {my ($self,$msg)=@_;$self->_output($msg)}sub summary {my ($self,$aggregate,$interrupted)=@_;return if$self->silent;my@t=$aggregate->descriptions;my$tests=\@t;my$runtime=$aggregate->elapsed_timestr;my$total=$aggregate->total;my$passed=$aggregate->passed;if ($self->timer){$self->_output($self->_format_now(),"\n")}$self->_failure_output("Test run interrupted!\n")if$interrupted;if ($aggregate->all_passed){$self->_output_success("All tests successful.\n")}if ($total!=$passed or $aggregate->has_problems){$self->_output("\nTest Summary Report");$self->_output("\n-------------------\n");for my$test (@$tests){$self->_printed_summary_header(0);my ($parser)=$aggregate->parsers($test);$self->_output_summary_failure('failed',[' Failed test: ',' Failed tests: ' ],$test,$parser);$self->_output_summary_failure('todo_passed'," TODO passed: ",$test,$parser);if (my$exit=$parser->exit){$self->_summary_test_header($test,$parser);$self->_failure_output(" Non-zero exit status: $exit\n")}elsif (my$wait=$parser->wait){$self->_summary_test_header($test,$parser);$self->_failure_output(" Non-zero wait status: $wait\n")}if (my@errors=$parser->parse_errors){my$explain;if (@errors > $MAX_ERRORS &&!$self->errors){$explain ="Displayed the first $MAX_ERRORS of " .scalar(@errors)." TAP syntax errors.\n" ."Re-run prove with the -p option to see them all.\n";splice@errors,$MAX_ERRORS}$self->_summary_test_header($test,$parser);$self->_failure_output(sprintf " Parse errors: %s\n",shift@errors);for my$error (@errors){my$spaces=' ' x 16;$self->_failure_output("$spaces$error\n")}$self->_failure_output($explain)if$explain}}}my$files=@$tests;$self->_output("Files=$files, Tests=$total, $runtime\n");my$status=$aggregate->get_status;$self->_output("Result: $status\n")}sub _output_summary_failure {my ($self,$method,$name,$test,$parser)=@_;my$output=$method eq 'failed' ? '_failure_output' : '_output';if (my@r=$parser->$method()){$self->_summary_test_header($test,$parser);my ($singular,$plural)='ARRAY' eq ref$name ? @$name : ($name,$name);$self->$output(@r==1 ? $singular : $plural);my@results=$self->_balanced_range(40,@r);$self->$output(sprintf "%s\n"=>shift@results);my$spaces=' ' x 16;while (@results){$self->$output(sprintf "$spaces%s\n"=>shift@results)}}}sub _summary_test_header {my ($self,$test,$parser)=@_;return if$self->_printed_summary_header;my$spaces=' ' x ($self->_longest - length$test);$spaces=' ' unless$spaces;my$output=$self->_get_output_method($parser);my$wait=$parser->wait;defined$wait or $wait='(none)';$self->$output(sprintf "$test$spaces(Wstat: %s Tests: %d Failed: %d)\n",$wait,$parser->tests_run,scalar$parser->failed);$self->_printed_summary_header(1)}sub _output {my$self=shift;print {$self->stdout}@_}sub _failure_output {my$self=shift;$self->_output(@_)}sub _balanced_range {my ($self,$limit,@range)=@_;@range=$self->_range(@range);my$line="";my@lines;my$curr=0;while (@range){if ($curr < $limit){my$range=(shift@range).", ";$line .= $range;$curr += length$range}elsif (@range){$line =~ s/, $//;push@lines=>$line;$line='';$curr=0}}if ($line){$line =~ s/, $//;push@lines=>$line}return@lines}sub _range {my ($self,@numbers)=@_;@numbers=sort {$a <=> $b}@numbers;my ($min,@range);for my$i (0 .. $#numbers){my$num=$numbers[$i];my$next=$numbers[$i + 1 ];if (defined$next && $next==$num + 1){if (!defined$min){$min=$num}}elsif (defined$min){push@range=>"$min-$num";undef$min}else {push@range=>$num}}return@range}sub _get_output_method {my ($self,$parser)=@_;return$parser->has_problems ? '_failure_output' : '_output'}1;
TAP_FORMATTER_BASE
$fatpacked{"TAP/Formatter/Color.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_FORMATTER_COLOR';
package TAP::Formatter::Color;use strict;use warnings;use constant IS_WIN32=>($^O =~ /^(MS)?Win32$/);use base 'TAP::Object';my$NO_COLOR;BEGIN {$NO_COLOR=0;if (IS_WIN32){eval 'use Win32::Console';if ($@){$NO_COLOR=$@}else {my$console=Win32::Console->new(STD_OUTPUT_HANDLE());my$fg=eval '$FG_LIGHTGRAY';my$bg=eval '$BG_BLACK';*set_color=sub {my ($self,$output,$color)=@_;my$var;if ($color eq 'reset'){$fg=eval '$FG_LIGHTGRAY';$bg=eval '$BG_BLACK'}elsif ($color =~ /^on_(.+)$/){$bg=eval '$BG_' .uc($1)}else {$fg=eval '$FG_' .uc($color)}$self->set_color('reset')unless defined$bg && defined$fg;$console->Attr($bg | $fg)}}}else {eval 'use Term::ANSIColor';if ($@){$NO_COLOR=$@}else {*set_color=sub {my ($self,$output,$color)=@_;$output->(color($color))}}}if ($NO_COLOR){*set_color=sub {}}}our$VERSION='3.39';sub _initialize {my$self=shift;if ($NO_COLOR){(my$error=$NO_COLOR)=~ s/ in \@INC .*//s;warn "Note: Cannot run tests in color: $error\n";return}return$self}sub can_color {return!$NO_COLOR}1;
TAP_FORMATTER_COLOR
$fatpacked{"TAP/Formatter/Console.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_FORMATTER_CONSOLE';
package TAP::Formatter::Console;use strict;use warnings;use base 'TAP::Formatter::Base';use POSIX qw(strftime);our$VERSION='3.39';sub open_test {my ($self,$test,$parser)=@_;my$class =$self->jobs > 1 ? 'TAP::Formatter::Console::ParallelSession' : 'TAP::Formatter::Console::Session';eval "require $class";$self->_croak($@)if $@;my$session=$class->new({name=>$test,formatter=>$self,parser=>$parser,show_count=>$self->show_count,});$session->header;return$session}sub _set_colors {my ($self,@colors)=@_;if (my$colorizer=$self->_colorizer){my$output_func=$self->{_output_func}||= sub {$self->_output(@_)};$colorizer->set_color($output_func,$_)for@colors}}sub _failure_color {my ($self)=@_;return$ENV{'HARNESS_SUMMARY_COLOR_FAIL'}|| 'red'}sub _success_color {my ($self)=@_;return$ENV{'HARNESS_SUMMARY_COLOR_SUCCESS'}|| 'green'}sub _output_success {my ($self,$msg)=@_;$self->_set_colors($self->_success_color());$self->_output($msg);$self->_set_colors('reset')}sub _failure_output {my$self=shift;$self->_set_colors($self->_failure_color());my$out=join '',@_;my$has_newline=chomp$out;$self->_output($out);$self->_set_colors('reset');$self->_output($/)if$has_newline}1;
TAP_FORMATTER_CONSOLE
$fatpacked{"TAP/Formatter/Console/ParallelSession.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_FORMATTER_CONSOLE_PARALLELSESSION';
package TAP::Formatter::Console::ParallelSession;use strict;use warnings;use File::Spec;use File::Path;use Carp;use base 'TAP::Formatter::Console::Session';use constant WIDTH=>72;my%shared;sub _initialize {my ($self,$arg_for)=@_;$self->SUPER::_initialize($arg_for);my$formatter=$self->formatter;my$context=$shared{$formatter}||= $self->_create_shared_context;push @{$context->{active}},$self;return$self}sub _create_shared_context {my$self=shift;return {active=>[],tests=>0,fails=>0,}}our$VERSION='3.39';sub header {}sub _clear_ruler {my$self=shift;$self->formatter->_output("\r" .(' ' x WIDTH)."\r")}my$now=0;my$start;my$trailer='... )===';my$chop_length=WIDTH - length$trailer;sub _output_ruler {my ($self,$refresh)=@_;my$new_now=time;return if$new_now==$now and!$refresh;$now=$new_now;$start ||= $now;my$formatter=$self->formatter;return if$formatter->really_quiet;my$context=$shared{$formatter};my$ruler=sprintf '===( %7d;%d ',$context->{tests},$now - $start;for my$active (@{$context->{active}}){my$parser=$active->parser;my$tests=$parser->tests_run;my$planned=$parser->tests_planned || '?';$ruler .= sprintf '%' .length($planned)."d/$planned ",$tests}chop$ruler;$ruler .= ')===';if (length$ruler > WIDTH){$ruler =~ s/(.{$chop_length}).*/$1$trailer/o}else {$ruler .= '=' x (WIDTH - length($ruler))}$formatter->_output("\r$ruler")}sub result {my ($self,$result)=@_;my$formatter=$self->formatter;if ($result->is_test){my$context=$shared{$formatter};$context->{tests}++;my$active=$context->{active};if (@$active==1){return$self->SUPER::result($result)}$self->_output_ruler($self->parser->tests_run==1)}elsif ($result->is_bailout){$formatter->_failure_output("Bailout called. Further testing stopped: " .$result->explanation ."\n")}}sub clear_for_close {my$self=shift;my$formatter=$self->formatter;return if$formatter->really_quiet;my$context=$shared{$formatter};if (@{$context->{active}}==1){$self->SUPER::clear_for_close}else {$self->_clear_ruler}}sub close_test {my$self=shift;my$name=$self->name;my$parser=$self->parser;my$formatter=$self->formatter;my$context=$shared{$formatter};$self->SUPER::close_test;my$active=$context->{active};my@pos=grep {$active->[$_]->name eq $name}0 .. $#$active;die "Can't find myself" unless@pos;splice @$active,$pos[0],1;if (@$active > 1){$self->_output_ruler(1)}elsif (@$active==1){$active->[0]->SUPER::header}else {delete$shared{$formatter}}}1;
TAP_FORMATTER_CONSOLE_PARALLELSESSION
$fatpacked{"TAP/Formatter/Console/Session.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_FORMATTER_CONSOLE_SESSION';
package TAP::Formatter::Console::Session;use strict;use warnings;use base 'TAP::Formatter::Session';my@ACCESSOR;BEGIN {my@CLOSURE_BINDING=qw(header result clear_for_close close_test);for my$method (@CLOSURE_BINDING){no strict 'refs';*$method=sub {my$self=shift;return ($self->{_closures}||= $self->_closures)->{$method}->(@_)}}}our$VERSION='3.39';sub _get_output_result {my$self=shift;my@color_map=({test=>sub {$_->is_test &&!$_->is_ok},colors=>['red'],},{test=>sub {$_->is_test && $_->has_skip},colors=>['white','on_blue' ],},{test=>sub {$_->is_test && $_->has_todo},colors=>['yellow'],},);my$formatter=$self->formatter;my$parser=$self->parser;return$formatter->_colorizer ? sub {my$result=shift;for my$col (@color_map){local $_=$result;if ($col->{test}->()){$formatter->_set_colors(@{$col->{colors}});last}}$formatter->_output($self->_format_for_output($result));$formatter->_set_colors('reset')}: sub {$formatter->_output($self->_format_for_output(shift))}}sub _closures {my$self=shift;my$parser=$self->parser;my$formatter=$self->formatter;my$pretty=$formatter->_format_name($self->name);my$show_count=$self->show_count;my$really_quiet=$formatter->really_quiet;my$quiet=$formatter->quiet;my$verbose=$formatter->verbose;my$directives=$formatter->directives;my$failures=$formatter->failures;my$comments=$formatter->comments;my$output_result=$self->_get_output_result;my$output='_output';my$plan='';my$newline_printed=0;my$last_status_printed=0;return {header=>sub {$formatter->_output($pretty)unless$really_quiet},result=>sub {my$result=shift;if ($result->is_bailout){$formatter->_failure_output("Bailout called. Further testing stopped: " .$result->explanation ."\n")}return if$really_quiet;my$is_test=$result->is_test;if (!$plan){my$planned=$parser->tests_planned || '?';$plan="/$planned "}$output=$formatter->_get_output_method($parser);if ($show_count and $is_test){my$number=$result->number;my$now=CORE::time;if ($last_status_printed!=$now){$formatter->$output("\r$pretty$number$plan");$last_status_printed=$now}}if (!$quiet && ($verbose || ($is_test && $failures &&!$result->is_ok)|| ($comments && $result->is_comment)|| ($directives && $result->has_directive))){unless ($newline_printed){$formatter->_output("\n");$newline_printed=1}$output_result->($result);$formatter->_output("\n")}},clear_for_close=>sub {my$spaces =' ' x length('.' .$pretty .$plan .$parser->tests_run);$formatter->$output("\r$spaces")},close_test=>sub {if ($show_count &&!$really_quiet){$self->clear_for_close;$formatter->$output("\r$pretty")}$self->parser(undef);$self->{_closures}={};return if$really_quiet;if (my$skip_all=$parser->skip_all){$formatter->_output("skipped: $skip_all\n")}elsif ($parser->has_problems){$self->_output_test_failure($parser)}else {my$time_report=$self->time_report($formatter,$parser);$formatter->_output($self->_make_ok_line($time_report))}},}}1;
TAP_FORMATTER_CONSOLE_SESSION
$fatpacked{"TAP/Formatter/File.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_FORMATTER_FILE';
package TAP::Formatter::File;use strict;use warnings;use TAP::Formatter::File::Session;use POSIX qw(strftime);use base 'TAP::Formatter::Base';our$VERSION='3.39';sub open_test {my ($self,$test,$parser)=@_;my$session=TAP::Formatter::File::Session->new({name=>$test,formatter=>$self,parser=>$parser,});$session->header;return$session}sub _should_show_count {return 0}1;
TAP_FORMATTER_FILE
$fatpacked{"TAP/Formatter/File/Session.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_FORMATTER_FILE_SESSION';
package TAP::Formatter::File::Session;use strict;use warnings;use base 'TAP::Formatter::Session';our$VERSION='3.39';sub result {my$self=shift;my$result=shift;my$parser=$self->parser;my$formatter=$self->formatter;if ($result->is_bailout){$formatter->_failure_output("Bailout called. Further testing stopped: " .$result->explanation ."\n");return}if (!$formatter->quiet && ($formatter->verbose || ($result->is_test && $formatter->failures &&!$result->is_ok)|| ($formatter->comments && $result->is_comment)|| ($result->has_directive && $formatter->directives))){$self->{results}.= $self->_format_for_output($result)."\n"}}sub close_test {my$self=shift;$self->parser(undef);my$parser=$self->parser;my$formatter=$self->formatter;my$pretty=$formatter->_format_name($self->name);return if$formatter->really_quiet;if (my$skip_all=$parser->skip_all){$formatter->_output($pretty ."skipped: $skip_all\n")}elsif ($parser->has_problems){$formatter->_output($pretty .($self->{results}? "\n" .$self->{results}: "\n"));$self->_output_test_failure($parser)}else {my$time_report=$self->time_report($formatter,$parser);$formatter->_output($pretty .($self->{results}? "\n" .$self->{results}: "").$self->_make_ok_line($time_report))}}1;
TAP_FORMATTER_FILE_SESSION
$fatpacked{"TAP/Formatter/Session.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_FORMATTER_SESSION';
package TAP::Formatter::Session;use strict;use warnings;use base 'TAP::Base';my@ACCESSOR;BEGIN {@ACCESSOR=qw(name formatter parser show_count);for my$method (@ACCESSOR){no strict 'refs';*$method=sub {shift->{$method}}}}our$VERSION='3.39';sub _initialize {my ($self,$arg_for)=@_;$arg_for ||= {};$self->SUPER::_initialize($arg_for);my%arg_for=%$arg_for;for my$name (@ACCESSOR){$self->{$name}=delete$arg_for{$name}}if (!defined$self->show_count){$self->{show_count}=1}if ($self->show_count){$self->{show_count}=$self->_should_show_count}if (my@props=sort keys%arg_for){$self->_croak("Unknown arguments to " .__PACKAGE__ ."::new (@props)")}return$self}sub header {}sub result {}sub close_test {}sub clear_for_close {}sub _should_show_count {my$self=shift;return !$self->formatter->verbose && -t $self->formatter->stdout &&!$ENV{HARNESS_NOTTY}}sub _format_for_output {my ($self,$result)=@_;return$self->formatter->normalize ? $result->as_string : $result->raw}sub _output_test_failure {my ($self,$parser)=@_;my$formatter=$self->formatter;return if$formatter->really_quiet;my$tests_run=$parser->tests_run;my$tests_planned=$parser->tests_planned;my$total =defined$tests_planned ? $tests_planned : $tests_run;my$passed=$parser->passed;my$failed=$parser->failed + $total - $tests_run;my$exit=$parser->exit;if (my$exit=$parser->exit){my$wstat=$parser->wait;my$status=sprintf("%d (wstat %d, 0x%x)",$exit,$wstat,$wstat);$formatter->_failure_output("Dubious, test returned $status\n")}if ($failed==0){$formatter->_failure_output($total ? "All $total subtests passed " : 'No subtests run ')}else {$formatter->_failure_output("Failed $failed/$total subtests ");if (!$total){$formatter->_failure_output("\nNo tests run!")}}if (my$skipped=$parser->skipped){$passed -= $skipped;my$test='subtest' .($skipped!=1 ? 's' : '');$formatter->_output("\n\t(less $skipped skipped $test: $passed okay)")}if (my$failed=$parser->todo_passed){my$test=$failed > 1 ? 'tests' : 'test';$formatter->_output("\n\t($failed TODO $test unexpectedly succeeded)")}$formatter->_output("\n")}sub _make_ok_line {my ($self,$suffix)=@_;return "ok$suffix\n"}sub time_report {my ($self,$formatter,$parser)=@_;my@time_report;if ($formatter->timer){my$start_time=$parser->start_time;my$end_time=$parser->end_time;if (defined$start_time and defined$end_time){my$elapsed=$end_time - $start_time;push@time_report,$self->time_is_hires ? sprintf(' %8d ms',$elapsed * 1000): sprintf(' %8s s',$elapsed || '<1')}my$start_times=$parser->start_times();my$end_times=$parser->end_times();my$usr=$end_times->[0]- $start_times->[0];my$sys=$end_times->[1]- $start_times->[1];my$cusr=$end_times->[2]- $start_times->[2];my$csys=$end_times->[3]- $start_times->[3];push@time_report,sprintf('(%5.2f usr %5.2f sys + %5.2f cusr %5.2f csys = %5.2f CPU)',$usr,$sys,$cusr,$csys,$usr + $sys + $cusr + $csys)}return "@time_report"}1;
TAP_FORMATTER_SESSION
$fatpacked{"TAP/Harness.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_HARNESS';
package TAP::Harness;use strict;use warnings;use Carp;use File::Spec;use File::Path;use IO::Handle;use base 'TAP::Base';our$VERSION='3.39';$ENV{HARNESS_ACTIVE}=1;$ENV{HARNESS_VERSION}=$VERSION;END {delete$ENV{HARNESS_ACTIVE};delete$ENV{HARNESS_VERSION}}my%VALIDATION_FOR;my@FORMATTER_ARGS;sub _error {my$self=shift;return$self->{error}unless @_;$self->{error}=shift}BEGIN {@FORMATTER_ARGS=qw(directives verbosity timer failures comments errors stdout color show_count normalize);%VALIDATION_FOR=(lib=>sub {my ($self,$libs)=@_;$libs=[$libs]unless 'ARRAY' eq ref$libs;return [map {"-I$_"}@$libs ]},switches=>sub {shift;shift},exec=>sub {shift;shift},merge=>sub {shift;shift},aggregator_class=>sub {shift;shift},formatter_class=>sub {shift;shift},multiplexer_class=>sub {shift;shift},parser_class=>sub {shift;shift},scheduler_class=>sub {shift;shift},formatter=>sub {shift;shift},jobs=>sub {shift;shift},test_args=>sub {shift;shift},ignore_exit=>sub {shift;shift},rules=>sub {shift;shift},rulesfile=>sub {shift;shift},sources=>sub {shift;shift},version=>sub {shift;shift},trap=>sub {shift;shift},);for my$method (sort keys%VALIDATION_FOR){no strict 'refs';if ($method eq 'lib' || $method eq 'switches'){*{$method}=sub {my$self=shift;unless (@_){$self->{$method}||= [];return wantarray ? @{$self->{$method}}: $self->{$method}}$self->_croak("Too many arguments to method '$method'")if @_ > 1;my$args=shift;$args=[$args]unless ref$args;$self->{$method}=$args;return$self}}else {*{$method}=sub {my$self=shift;return$self->{$method}unless @_;$self->{$method}=shift}}}for my$method (@FORMATTER_ARGS){no strict 'refs';*{$method}=sub {my$self=shift;return$self->formatter->$method(@_)}}}{my@legal_callback=qw(parser_args made_parser before_runtests after_runtests after_test);my%default_class=(aggregator_class=>'TAP::Parser::Aggregator',formatter_class=>'TAP::Formatter::Console',multiplexer_class=>'TAP::Parser::Multiplexer',parser_class=>'TAP::Parser',scheduler_class=>'TAP::Parser::Scheduler',);sub _initialize {my ($self,$arg_for)=@_;$arg_for ||= {};$self->SUPER::_initialize($arg_for,\@legal_callback);my%arg_for=%$arg_for;for my$name (sort keys%VALIDATION_FOR){my$property=delete$arg_for{$name};if (defined$property){my$validate=$VALIDATION_FOR{$name};my$value=$self->$validate($property);if ($self->_error){$self->_croak}$self->$name($value)}}$self->jobs(1)unless defined$self->jobs;if (!defined$self->rules){$self->_maybe_load_rulesfile}local$default_class{formatter_class}='TAP::Formatter::File' unless -t ($arg_for{stdout}|| \*STDOUT)&&!$ENV{HARNESS_NOTTY};while (my ($attr,$class)=each%default_class){$self->$attr($self->$attr()|| $class)}unless ($self->formatter){my%formatter_args=(jobs=>$self->jobs);for my$name (@FORMATTER_ARGS){if (defined(my$property=delete$arg_for{$name})){$formatter_args{$name}=$property}}$self->formatter($self->_construct($self->formatter_class,\%formatter_args))}if (my@props=sort keys%arg_for){$self->_croak("Unknown arguments to TAP::Harness::new (@props)")}return$self}sub _maybe_load_rulesfile {my ($self)=@_;my ($rulesfile)=defined$self->rulesfile ? $self->rulesfile : defined($ENV{HARNESS_RULESFILE})? $ENV{HARNESS_RULESFILE}: grep {-r}qw(./testrules.yml t/testrules.yml);if (defined$rulesfile && -r $rulesfile){if (!eval {require CPAN::Meta::YAML;1}){warn "CPAN::Meta::YAML required to process $rulesfile" ;return}my$layer=$] lt "5.008" ? "" : ":encoding(UTF-8)";open my$fh,"<$layer",$rulesfile or die "Couldn't open $rulesfile: $!";my$yaml_text=do {local $/;<$fh>};my$yaml=CPAN::Meta::YAML->read_string($yaml_text)or die CPAN::Meta::YAML->errstr;$self->rules($yaml->[0])}return}}sub runtests {my ($self,@tests)=@_;my$aggregate=$self->_construct($self->aggregator_class);$self->_make_callback('before_runtests',$aggregate);$aggregate->start;my$finish=sub {my$interrupted=shift;$aggregate->stop;$self->summary($aggregate,$interrupted);$self->_make_callback('after_runtests',$aggregate)};my$run=sub {$self->aggregate_tests($aggregate,@tests);$finish->()};if ($self->trap){local$SIG{INT}=sub {print "\n";$finish->(1);exit};$run->()}else {$run->()}return$aggregate}sub summary {my ($self,@args)=@_;$self->formatter->summary(@args)}sub _after_test {my ($self,$aggregate,$job,$parser)=@_;$self->_make_callback('after_test',$job->as_array_ref,$parser);$aggregate->add($job->description,$parser)}sub _bailout {my ($self,$result)=@_;my$explanation=$result->explanation;die "FAILED--Further testing stopped" .($explanation ? ": $explanation\n" : ".\n")}sub _aggregate_parallel {my ($self,$aggregate,$scheduler)=@_;my$jobs=$self->jobs;my$mux=$self->_construct($self->multiplexer_class);RESULT: {FILL: while ($mux->parsers < $jobs){my$job=$scheduler->get_job;last FILL if!defined$job || $job->is_spinner;my ($parser,$session)=$self->make_parser($job);$mux->add($parser,[$session,$job ])}if (my ($parser,$stash,$result)=$mux->next){my ($session,$job)=@$stash;if (defined$result){$session->result($result);$self->_bailout($result)if$result->is_bailout}else {$self->finish_parser($parser,$session);$self->_after_test($aggregate,$job,$parser);$job->finish}redo RESULT}}return}sub _aggregate_single {my ($self,$aggregate,$scheduler)=@_;JOB: while (my$job=$scheduler->get_job){next JOB if$job->is_spinner;my ($parser,$session)=$self->make_parser($job);while (defined(my$result=$parser->next)){$session->result($result);if ($result->is_bailout){1 while$parser->next;$self->_bailout($result)}}$self->finish_parser($parser,$session);$self->_after_test($aggregate,$job,$parser);$job->finish}return}sub aggregate_tests {my ($self,$aggregate,@tests)=@_;my$jobs=$self->jobs;my$scheduler=$self->make_scheduler(@tests);local$ENV{HARNESS_IS_VERBOSE}=1 if$self->formatter->verbosity > 0;$self->formatter->prepare(map {$_->description}$scheduler->get_all);if ($self->jobs > 1){$self->_aggregate_parallel($aggregate,$scheduler)}else {$self->_aggregate_single($aggregate,$scheduler)}return}sub _add_descriptions {my$self=shift;return map {@$_==1 ? [$_->[0],$_->[0]]: $_}map {'ARRAY' eq ref $_ ? $_ : [$_]}@_}sub make_scheduler {my ($self,@tests)=@_;return$self->_construct($self->scheduler_class,tests=>[$self->_add_descriptions(@tests)],rules=>$self->rules)}sub _get_parser_args {my ($self,$job)=@_;my$test_prog=$job->filename;my%args=();$args{sources}=$self->sources if$self->sources;my@switches;@switches=$self->lib if$self->lib;push@switches=>$self->switches if$self->switches;$args{switches}=\@switches;$args{spool}=$self->_open_spool($test_prog);$args{merge}=$self->merge;$args{ignore_exit}=$self->ignore_exit;$args{version}=$self->version if$self->version;if (my$exec=$self->exec){$args{exec}=ref$exec eq 'CODE' ? $exec->($self,$test_prog): [@$exec,$test_prog ];if (not defined$args{exec}){$args{source}=$test_prog}elsif ((ref($args{exec})|| "")ne "ARRAY"){$args{source}=delete$args{exec}}}else {$args{source}=$test_prog}if (defined(my$test_args=$self->test_args)){if (ref($test_args)eq 'HASH'){if (exists($test_args->{$job->description })){$test_args=$test_args->{$job->description }}else {$self->_croak("TAP::Harness Can't find test_args for " .$job->description)}}$args{test_args}=$test_args}return \%args}sub make_parser {my ($self,$job)=@_;my$args=$self->_get_parser_args($job);$self->_make_callback('parser_args',$args,$job->as_array_ref);my$parser=$self->_construct($self->parser_class,$args);$self->_make_callback('made_parser',$parser,$job->as_array_ref);my$session=$self->formatter->open_test($job->description,$parser);return ($parser,$session)}sub finish_parser {my ($self,$parser,$session)=@_;$session->close_test;$self->_close_spool($parser);return$parser}sub _open_spool {my$self=shift;my$test=shift;if (my$spool_dir=$ENV{PERL_TEST_HARNESS_DUMP_TAP}){my$spool=File::Spec->catfile($spool_dir,$test);my ($vol,$dir,undef)=File::Spec->splitpath($spool);my$path=File::Spec->catpath($vol,$dir,'');eval {mkpath($path)};$self->_croak($@)if $@;my$spool_handle=IO::Handle->new;open($spool_handle,">$spool")or $self->_croak(" Can't write $spool ( $! ) ");return$spool_handle}return}sub _close_spool {my$self=shift;my ($parser)=@_;if (my$spool_handle=$parser->delete_spool){close($spool_handle)or $self->_croak(" Error closing TAP spool file( $! ) \n ")}return}sub _croak {my ($self,$message)=@_;unless ($message){$message=$self->_error}$self->SUPER::_croak($message);return}1;
TAP_HARNESS
$fatpacked{"TAP/Harness/Env.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_HARNESS_ENV';
package TAP::Harness::Env;use strict;use warnings;use constant IS_VMS=>($^O eq 'VMS');use TAP::Object;use Text::ParseWords qw/shellwords/;our$VERSION='3.39';sub _filtered_inc_vms {my@inc=grep {!ref}@INC;@inc=grep {!/perl_root/i}@inc;my@default_inc=_default_inc();my@new_inc;my%seen;for my$dir (@inc){next if$seen{$dir}++;if ($dir eq ($default_inc[0]|| '')){shift@default_inc}else {push@new_inc,$dir}shift@default_inc while@default_inc and $seen{$default_inc[0]}}return@new_inc}my@inc;sub _default_inc {return@inc if@inc;local$ENV{PERL5LIB};local$ENV{PERLLIB};my$perl=$ENV{HARNESS_PERL}|| $^X;chomp(@inc=`"$perl" -e "print join qq[\\n], \@INC, q[]"`);return@inc}sub create {my$package=shift;my%input=%{shift || {}};my@libs=@{delete$input{libs}|| []};my@raw_switches=@{delete$input{switches}|| []};my@opt =(@raw_switches,shellwords($ENV{HARNESS_PERL_SWITCHES}|| ''));my@switches;while (my$opt=shift@opt){if ($opt =~ /^ -I (.*) $ /x){push@libs,length($1)? $1 : shift@opt}else {push@switches,$opt}}push@libs,_filtered_inc_vms()if IS_VMS;my$verbose =$ENV{HARNESS_VERBOSE}? $ENV{HARNESS_VERBOSE}!~ /\d/ ? 1 : $ENV{HARNESS_VERBOSE}: 0;my%args=(lib=>\@libs,timer=>$ENV{HARNESS_TIMER}|| 0,switches=>\@switches,color=>$ENV{HARNESS_COLOR}|| 0,verbosity=>$verbose,ignore_exit=>$ENV{HARNESS_IGNORE_EXIT}|| 0,);my$class=delete$input{harness_class}|| $ENV{HARNESS_SUBCLASS}|| 'TAP::Harness';if (defined(my$env_opt=$ENV{HARNESS_OPTIONS})){for my$opt (split /:/,$env_opt){if ($opt =~ /^j(\d*)$/){$args{jobs}=$1 || 9}elsif ($opt eq 'c'){$args{color}=1}elsif ($opt =~ m/^f(.*)$/){my$fmt=$1;$fmt =~ s/-/::/g;$args{formatter_class}=$fmt}elsif ($opt =~ m/^a(.*)$/){my$archive=$1;$class='TAP::Harness::Archive';$args{archive}=$archive}else {die "Unknown HARNESS_OPTIONS item: $opt\n"}}}return TAP::Object->_construct($class,{%args,%input })}1;
TAP_HARNESS_ENV
$fatpacked{"TAP/Object.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_OBJECT';
package TAP::Object;use strict;use warnings;our$VERSION='3.39';sub new {my$class=shift;my$self=bless {},$class;return$self->_initialize(@_)}sub _initialize {return $_[0]}sub _croak {my$proto=shift;require Carp;Carp::croak(@_);return}sub _confess {my$proto=shift;require Carp;Carp::confess(@_);return}sub _construct {my ($self,$class,@args)=@_;$self->_croak("Bad module name $class")unless$class =~ /^ \w+ (?: :: \w+ ) *$/x;unless ($class->can('new')){local $@;eval "require $class";$self->_croak("Can't load $class: $@")if $@}return$class->new(@args)}sub mk_methods {my ($class,@methods)=@_;for my$method_name (@methods){my$method="${class}::$method_name";no strict 'refs';*$method=sub {my$self=shift;$self->{$method_name}=shift if @_;return$self->{$method_name}}}}1;
TAP_OBJECT
$fatpacked{"TAP/Parser.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER';
package TAP::Parser;use strict;use warnings;use TAP::Parser::Grammar ();use TAP::Parser::Result ();use TAP::Parser::ResultFactory ();use TAP::Parser::Source ();use TAP::Parser::Iterator ();use TAP::Parser::IteratorFactory ();use TAP::Parser::SourceHandler::Executable ();use TAP::Parser::SourceHandler::Perl ();use TAP::Parser::SourceHandler::File ();use TAP::Parser::SourceHandler::RawTAP ();use TAP::Parser::SourceHandler::Handle ();use Carp qw(confess);use base 'TAP::Base';our$VERSION='3.39';my$DEFAULT_TAP_VERSION=12;my$MAX_TAP_VERSION=13;$ENV{TAP_VERSION}=$MAX_TAP_VERSION;END {delete$ENV{TAP_VERSION}}BEGIN {__PACKAGE__->mk_methods(qw(_iterator _spool exec exit is_good_plan plan tests_planned tests_run wait version in_todo start_time end_time start_times end_times skip_all grammar_class result_factory_class iterator_factory_class));sub _stream {my$self=shift;$self->_iterator(@_)}}sub _default_grammar_class {'TAP::Parser::Grammar'}sub _default_result_factory_class {'TAP::Parser::ResultFactory'}sub _default_iterator_factory_class {'TAP::Parser::IteratorFactory'}sub next {my$self=shift;return ($self->{_iter}||= $self->_iter)->()}sub run {my$self=shift;while (defined(my$result=$self->next)){}}sub make_iterator_factory {shift->iterator_factory_class->new(@_)}sub make_grammar {shift->grammar_class->new(@_)}sub make_result {shift->result_factory_class->make_result(@_)}{my%initialize=(version=>$DEFAULT_TAP_VERSION,plan=>'',tests_run=>0,skipped=>[],todo=>[],passed=>[],failed=>[],actual_failed=>[],actual_passed=>[],todo_passed=>[],parse_errors=>[],);my@legal_callback=qw(test version plan comment bailout unknown yaml ALL ELSE EOF);my@class_overrides=qw(grammar_class result_factory_class iterator_factory_class);sub _initialize {my ($self,$arg_for)=@_;my%args=%{$arg_for || {}};$self->SUPER::_initialize(\%args,\@legal_callback);for my$key (@class_overrides){my$default_method="_default_$key";my$val=delete$args{$key}|| $self->$default_method();$self->$key($val)}my$iterator=delete$args{iterator};$iterator ||= delete$args{stream};my$tap=delete$args{tap};my$version=delete$args{version};my$raw_source=delete$args{source};my$sources=delete$args{sources};my$exec=delete$args{exec};my$merge=delete$args{merge};my$spool=delete$args{spool};my$switches=delete$args{switches};my$ignore_exit=delete$args{ignore_exit};my$test_args=delete$args{test_args}|| [];if (1 < grep {defined}$iterator,$tap,$raw_source,$exec){$self->_croak("You may only choose one of 'exec', 'tap', 'source' or 'iterator'")}if (my@excess=sort keys%args){$self->_croak("Unknown options: @excess")}my$type='';my$source=TAP::Parser::Source->new;if ($tap){$type='raw TAP';$source->raw(\$tap)}elsif ($exec){$type='exec ' .$exec->[0];$source->raw({exec=>$exec })}elsif ($raw_source){$type='source ' .ref($raw_source)|| $raw_source;$source->raw(ref($raw_source)? $raw_source : \$raw_source)}elsif ($iterator){$type='iterator ' .ref($iterator)}if ($source->raw){my$src_factory=$self->make_iterator_factory($sources);$source->merge($merge)->switches($switches)->test_args($test_args);$iterator=$src_factory->make_iterator($source)}unless ($iterator){$self->_croak("PANIC: could not determine iterator for input $type")}while (my ($k,$v)=each%initialize){$self->{$k}='ARRAY' eq ref$v ? []: $v}$self->version($version)if$version;$self->_iterator($iterator);$self->_spool($spool);$self->ignore_exit($ignore_exit);return$self}}sub passed {return @{$_[0]->{passed}}if ref $_[0]->{passed};return wantarray ? 1 .. $_[0]->{passed}: $_[0]->{passed}}sub failed {@{shift->{failed}}}sub actual_passed {return @{$_[0]->{actual_passed}}if ref $_[0]->{actual_passed};return wantarray ? 1 .. $_[0]->{actual_passed}: $_[0]->{actual_passed}}*actual_ok=\&actual_passed;sub actual_failed {@{shift->{actual_failed}}}sub todo {@{shift->{todo}}}sub todo_passed {@{shift->{todo_passed}}}sub todo_failed {warn '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';goto&todo_passed}sub skipped {@{shift->{skipped}}}sub pragma {my ($self,$pragma)=splice @_,0,2;return$self->{pragma}->{$pragma}unless @_;if (my$state=shift){$self->{pragma}->{$pragma}=1}else {delete$self->{pragma}->{$pragma}}return}sub pragmas {sort keys %{shift->{pragma}|| {}}}sub good_plan {warn 'good_plan() is deprecated. Please use "is_good_plan()"';goto&is_good_plan}sub has_problems {my$self=shift;return $self->failed || $self->parse_errors || (!$self->ignore_exit && ($self->wait || $self->exit))}sub ignore_exit {shift->pragma('ignore_exit',@_)}sub parse_errors {@{shift->{parse_errors}}}sub _add_error {my ($self,$error)=@_;push @{$self->{parse_errors}}=>$error;return$self}sub _make_state_table {my$self=shift;my%states;my%planned_todo=();my%state_globals=(comment=>{},bailout=>{},yaml=>{},version=>{act=>sub {$self->_add_error('If TAP version is present it must be the first line of output')},},unknown=>{act=>sub {my$unk=shift;if ($self->pragma('strict')){$self->_add_error('Unknown TAP token: "' .$unk->raw .'"')}},},pragma=>{act=>sub {my ($pragma)=@_;for my$pr ($pragma->pragmas){if ($pr =~ /^ ([-+])(\w+) $/x){$self->pragma($2,$1 eq '+')}}},},);my%state_defaults=(plan=>{act=>sub {my ($plan)=@_;$self->tests_planned($plan->tests_planned);$self->plan($plan->plan);if ($plan->has_skip){$self->skip_all($plan->explanation || '(no reason given)')}$planned_todo{$_}++ for @{$plan->todo_list}},},test=>{act=>sub {my ($test)=@_;my ($number,$tests_run)=($test->number,++$self->{tests_run});if (defined$number && delete$planned_todo{$number}){$test->set_directive('TODO')}my$has_todo=$test->has_todo;$self->in_todo($has_todo);if (defined(my$tests_planned=$self->tests_planned)){if ($tests_run > $tests_planned){$test->is_unplanned(1)}}if (defined$number){if ($number!=$tests_run){my$count=$tests_run;$self->_add_error("Tests out of sequence. Found " ."($number) but expected ($count)")}}else {$test->_number($number=$tests_run)}push @{$self->{todo}}=>$number if$has_todo;push @{$self->{todo_passed}}=>$number if$test->todo_passed;push @{$self->{skipped}}=>$number if$test->has_skip;push @{$self->{$test->is_ok ? 'passed' : 'failed' }}=>$number;push @{$self->{$test->is_actual_ok ? 'actual_passed' : 'actual_failed' }}=>$number},},yaml=>{act=>sub {},},);%states=(INIT=>{version=>{act=>sub {my ($version)=@_;my$ver_num=$version->version;if ($ver_num <= $DEFAULT_TAP_VERSION){my$ver_min=$DEFAULT_TAP_VERSION + 1;$self->_add_error("Explicit TAP version must be at least " ."$ver_min. Got version $ver_num");$ver_num=$DEFAULT_TAP_VERSION}if ($ver_num > $MAX_TAP_VERSION){$self->_add_error("TAP specified version $ver_num but " ."we don't know about versions later " ."than $MAX_TAP_VERSION");$ver_num=$MAX_TAP_VERSION}$self->version($ver_num);$self->_grammar->set_version($ver_num)},goto=>'PLAN' },plan=>{goto=>'PLANNED' },test=>{goto=>'UNPLANNED' },},PLAN=>{plan=>{goto=>'PLANNED' },test=>{goto=>'UNPLANNED' },},PLANNED=>{test=>{goto=>'PLANNED_AFTER_TEST' },plan=>{act=>sub {my ($version)=@_;$self->_add_error('More than one plan found in TAP output')},},},PLANNED_AFTER_TEST=>{test=>{goto=>'PLANNED_AFTER_TEST' },plan=>{act=>sub {},continue=>'PLANNED' },yaml=>{goto=>'PLANNED' },},GOT_PLAN=>{test=>{act=>sub {my ($plan)=@_;my$line=$self->plan;$self->_add_error("Plan ($line) must be at the beginning " ."or end of the TAP output");$self->is_good_plan(0)},continue=>'PLANNED' },plan=>{continue=>'PLANNED' },},UNPLANNED=>{test=>{goto=>'UNPLANNED_AFTER_TEST' },plan=>{goto=>'GOT_PLAN' },},UNPLANNED_AFTER_TEST=>{test=>{act=>sub {},continue=>'UNPLANNED' },plan=>{act=>sub {},continue=>'UNPLANNED' },yaml=>{goto=>'UNPLANNED' },},);for my$name (keys%states){my$st={%state_globals,%{$states{$name}}};for my$next (sort keys %{$st}){if (my$default=$state_defaults{$next}){for my$def (sort keys %{$default}){$st->{$next}->{$def}||= $default->{$def}}}}$states{$name}=$st}return \%states}sub get_select_handles {shift->_iterator->get_select_handles}sub _grammar {my$self=shift;return$self->{_grammar}=shift if @_;return$self->{_grammar}||= $self->make_grammar({iterator=>$self->_iterator,parser=>$self,version=>$self->version })}sub _iter {my$self=shift;my$iterator=$self->_iterator;my$grammar=$self->_grammar;my$spool=$self->_spool;my$state='INIT';my$state_table=$self->_make_state_table;$self->start_time($self->get_time);$self->start_times($self->get_times);my$next_state=sub {my$token=shift;my$type=$token->type;TRANS: {my$state_spec=$state_table->{$state}or die "Illegal state: $state";if (my$next=$state_spec->{$type}){if (my$act=$next->{act}){$act->($token)}if (my$cont=$next->{continue}){$state=$cont;redo TRANS}elsif (my$goto=$next->{goto}){$state=$goto}}else {confess("Unhandled token type: $type\n")}}return$token};my$end_handler=sub {$self->exit($iterator->exit);$self->wait($iterator->wait);$self->_finish;return};if ($self->_has_callbacks){return sub {my$result=eval {$grammar->tokenize};$self->_add_error($@)if $@;if (defined$result){$result=$next_state->($result);if (my$code=$self->_callback_for($result->type)){$_->($result)for @{$code}}else {$self->_make_callback('ELSE',$result)}$self->_make_callback('ALL',$result);print {$spool}$result->raw,"\n" if$spool}else {$result=$end_handler->();$self->_make_callback('EOF',$self)unless defined$result}return$result}}else {return sub {my$result=eval {$grammar->tokenize};$self->_add_error($@)if $@;if (defined$result){$result=$next_state->($result);print {$spool}$result->raw,"\n" if$spool}else {$result=$end_handler->()}return$result}}}sub _finish {my$self=shift;$self->end_time($self->get_time);$self->end_times($self->get_times);$self->_iterator(undef);$self->_grammar(undef);$self->{_iter}=sub {return}if $] >= 5.006;if (!$self->plan){$self->_add_error('No plan found in TAP output')}else {$self->is_good_plan(1)unless defined$self->is_good_plan}if ($self->tests_run!=($self->tests_planned || 0)){$self->is_good_plan(0);if (defined(my$planned=$self->tests_planned)){my$ran=$self->tests_run;$self->_add_error("Bad plan. You planned $planned tests but ran $ran.")}}if ($self->tests_run!=($self->passed + $self->failed)){my$actual=$self->tests_run;my$passed=$self->passed;my$failed=$self->failed;$self->_croak("Panic: planned test count ($actual) did not equal " ."sum of passed ($passed) and failed ($failed) tests!")}$self->is_good_plan(0)unless defined$self->is_good_plan;unless ($self->parse_errors){if ($self->tests_run==@{$self->{passed}}){$self->{passed}=$self->tests_run}if ($self->tests_run==@{$self->{actual_passed}}){$self->{actual_passed}=$self->tests_run}}return$self}sub delete_spool {my$self=shift;return delete$self->{_spool}}1;
TAP_PARSER
$fatpacked{"TAP/Parser/Aggregator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_AGGREGATOR';
package TAP::Parser::Aggregator;use strict;use warnings;use Benchmark;use base 'TAP::Object';our$VERSION='3.39';my%SUMMARY_METHOD_FOR;BEGIN {%SUMMARY_METHOD_FOR=map {$_=>$_}qw(failed parse_errors passed skipped todo todo_passed total wait exit);$SUMMARY_METHOD_FOR{total}='tests_run';$SUMMARY_METHOD_FOR{planned}='tests_planned';for my$method (keys%SUMMARY_METHOD_FOR){next if 'total' eq $method;no strict 'refs';*$method=sub {my$self=shift;return wantarray ? @{$self->{"descriptions_for_$method"}}: $self->{$method}}}}sub _initialize {my ($self)=@_;$self->{parser_for}={};$self->{parse_order}=[];for my$summary (keys%SUMMARY_METHOD_FOR){$self->{$summary}=0;next if 'total' eq $summary;$self->{"descriptions_for_$summary"}=[]}return$self}sub add {my ($self,$description,$parser)=@_;if (exists$self->{parser_for}{$description}){$self->_croak("You already have a parser for ($description)." ." Perhaps you have run the same test twice.")}push @{$self->{parse_order}}=>$description;$self->{parser_for}{$description}=$parser;while (my ($summary,$method)=each%SUMMARY_METHOD_FOR){next if ($method eq 'exit' || $method eq 'wait')&& $parser->ignore_exit;if (my$count=$parser->$method()){$self->{$summary}+= $count;push @{$self->{"descriptions_for_$summary"}}=>$description}}return$self}sub parsers {my$self=shift;return$self->_get_parsers(@_)if @_;my$descriptions=$self->{parse_order};my@parsers=@{$self->{parser_for}}{@$descriptions};return@parsers}sub _get_parsers {my ($self,@descriptions)=@_;my@parsers;for my$description (@descriptions){$self->_croak("A parser for ($description) could not be found")unless exists$self->{parser_for}{$description};push@parsers=>$self->{parser_for}{$description}}return wantarray ? @parsers : \@parsers}sub descriptions {@{shift->{parse_order}|| []}}sub start {my$self=shift;$self->{start_time}=Benchmark->new}sub stop {my$self=shift;$self->{end_time}=Benchmark->new}sub elapsed {my$self=shift;require Carp;Carp::croak q{Can't call elapsed without first calling start and then stop} unless defined$self->{start_time}&& defined$self->{end_time};return timediff($self->{end_time},$self->{start_time})}sub elapsed_timestr {my$self=shift;my$elapsed=$self->elapsed;return timestr($elapsed)}sub all_passed {my$self=shift;return $self->total && $self->total==$self->passed &&!$self->has_errors}sub get_status {my$self=shift;my$total=$self->total;my$passed=$self->passed;return ($self->has_errors || $total!=$passed)? 'FAIL' : $total ? 'PASS' : 'NOTESTS'}sub total {shift->{total}}sub has_problems {my$self=shift;return$self->todo_passed || $self->has_errors}sub has_errors {my$self=shift;return $self->failed || $self->parse_errors || $self->exit || $self->wait}sub todo_failed {warn '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';goto&todo_passed}1;
TAP_PARSER_AGGREGATOR
$fatpacked{"TAP/Parser/Grammar.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_GRAMMAR';
package TAP::Parser::Grammar;use strict;use warnings;use TAP::Parser::ResultFactory ();use TAP::Parser::YAMLish::Reader ();use base 'TAP::Object';our$VERSION='3.39';sub _initialize {my ($self,$args)=@_;$self->{iterator}=$args->{iterator};$self->{iterator}||= $args->{stream};$self->{parser}=$args->{parser};$self->set_version($args->{version}|| 12);return$self}my%language_for;{my$ok=qr/(?:not )?ok\b/;my$num=qr/\d+/;my%v12=(version=>{syntax=>qr/^TAP\s+version\s+(\d+)\s*\z/i,handler=>sub {my ($self,$line)=@_;my$version=$1;return$self->_make_version_token($line,$version,)},},plan=>{syntax=>qr/^1\.\.(\d+)\s*(.*)\z/,handler=>sub {my ($self,$line)=@_;my ($tests_planned,$tail)=($1,$2);my$explanation=undef;my$skip='';if ($tail =~ /^todo((?:\s+\d+)+)/){my@todo=split /\s+/,_trim($1);return$self->_make_plan_token($line,$tests_planned,'TODO','',\@todo)}elsif (0==$tests_planned){$skip='SKIP';($explanation)=$tail =~ /^#\s*SKIP\S*\s+(.*)/i}elsif ($tail !~ /^\s*$/){return$self->_make_unknown_token($line)}$explanation='' unless defined$explanation;return$self->_make_plan_token($line,$tests_planned,$skip,$explanation,[])},},simple_test=>{syntax=>qr/^($ok) \ ($num) (?:\ ([^#]+))? \z/x,handler=>sub {my ($self,$line)=@_;my ($ok,$num,$desc)=($1,$2,$3);return$self->_make_test_token($line,$ok,$num,$desc)},},test=>{syntax=>qr/^($ok) \s* ($num)? \s* (.*) \z/x,handler=>sub {my ($self,$line)=@_;my ($ok,$num,$desc)=($1,$2,$3);my ($dir,$explanation)=('','');if ($desc =~ m/^ ( [^\\\#]* (?: \\. [^\\\#]* )* )
\# \s* (SKIP|TODO) \b \s* (.*) $/ix){($desc,$dir,$explanation)=($1,$2,$3)}return$self->_make_test_token($line,$ok,$num,$desc,$dir,$explanation)},},comment=>{syntax=>qr/^#(.*)/,handler=>sub {my ($self,$line)=@_;my$comment=$1;return$self->_make_comment_token($line,$comment)},},bailout=>{syntax=>qr/^\s*Bail out!\s*(.*)/,handler=>sub {my ($self,$line)=@_;my$explanation=$1;return$self->_make_bailout_token($line,$explanation)},},);my%v13=(%v12,plan=>{syntax=>qr/^1\.\.(\d+)(?:\s*#\s*SKIP\b(.*))?\z/i,handler=>sub {my ($self,$line)=@_;my ($tests_planned,$explanation)=($1,$2);my$skip =(0==$tests_planned || defined$explanation)? 'SKIP' : '';$explanation='' unless defined$explanation;return$self->_make_plan_token($line,$tests_planned,$skip,$explanation,[])},},yaml=>{syntax=>qr/^ (\s+) (---.*) $/x,handler=>sub {my ($self,$line)=@_;my ($pad,$marker)=($1,$2);return$self->_make_yaml_token($pad,$marker)},},pragma=>{syntax=>qr/^ pragma \s+ ( [-+] \w+ \s* (?: , \s* [-+] \w+ \s* )* ) $/x,handler=>sub {my ($self,$line)=@_;my$pragmas=$1;return$self->_make_pragma_token($line,$pragmas)},},);%language_for=('12'=>{tokens=>\%v12,},'13'=>{tokens=>\%v13,setup=>sub {shift->{iterator}->handle_unicode},},)}sub set_version {my$self=shift;my$version=shift;if (my$language=$language_for{$version}){$self->{version}=$version;$self->{tokens}=$language->{tokens};if (my$setup=$language->{setup}){$self->$setup()}$self->_order_tokens}else {require Carp;Carp::croak("Unsupported syntax version: $version")}}sub _order_tokens {my$self=shift;my%copy=%{$self->{tokens}};my@ordered_tokens=grep {defined}map {delete$copy{$_}}qw(simple_test test comment plan);push@ordered_tokens,values%copy;$self->{ordered_tokens}=\@ordered_tokens}sub tokenize {my$self=shift;my$line=$self->{iterator}->next;unless (defined$line){delete$self->{parser};return}my$token;for my$token_data (@{$self->{ordered_tokens}}){if ($line =~ $token_data->{syntax}){my$handler=$token_data->{handler};$token=$self->$handler($line);last}}$token=$self->_make_unknown_token($line)unless$token;return$self->{parser}->make_result($token)}sub token_types {my$self=shift;return keys %{$self->{tokens}}}sub syntax_for {my ($self,$type)=@_;return$self->{tokens}->{$type}->{syntax}}sub handler_for {my ($self,$type)=@_;return$self->{tokens}->{$type}->{handler}}sub _make_version_token {my ($self,$line,$version)=@_;return {type=>'version',raw=>$line,version=>$version,}}sub _make_plan_token {my ($self,$line,$tests_planned,$directive,$explanation,$todo)=@_;if ($directive eq 'SKIP' && 0!=$tests_planned && $self->{version}< 13){warn "Specified SKIP directive in plan but more than 0 tests ($line)\n"}return {type=>'plan',raw=>$line,tests_planned=>$tests_planned,directive=>$directive,explanation=>_trim($explanation),todo_list=>$todo,}}sub _make_test_token {my ($self,$line,$ok,$num,$desc,$dir,$explanation)=@_;return {ok=>$ok,test_num=>(defined$num ? 0 + $num : undef),description=>_trim($desc),directive=>(defined$dir ? uc$dir : ''),explanation=>_trim($explanation),raw=>$line,type=>'test',}}sub _make_unknown_token {my ($self,$line)=@_;return {raw=>$line,type=>'unknown',}}sub _make_comment_token {my ($self,$line,$comment)=@_;return {type=>'comment',raw=>$line,comment=>_trim($comment)}}sub _make_bailout_token {my ($self,$line,$explanation)=@_;return {type=>'bailout',raw=>$line,bailout=>_trim($explanation)}}sub _make_yaml_token {my ($self,$pad,$marker)=@_;my$yaml=TAP::Parser::YAMLish::Reader->new;my$iterator=$self->{iterator};my$leader=length($pad);my$strip=qr{ ^ (\s{$leader}) (.*) $ }x;my@extra=($marker);my$reader=sub {return shift@extra if@extra;my$line=$iterator->next;return $2 if$line =~ $strip;return};my$data=$yaml->read($reader);chomp(my$raw=$yaml->get_raw);$raw =~ s/^/$pad/mg;return {type=>'yaml',raw=>$raw,data=>$data }}sub _make_pragma_token {my ($self,$line,$pragmas)=@_;return {type=>'pragma',raw=>$line,pragmas=>[split /\s*,\s*/,_trim($pragmas)],}}sub _trim {my$data=shift;return '' unless defined$data;$data =~ s/^\s+//;$data =~ s/\s+$//;return$data}1;
TAP_PARSER_GRAMMAR
$fatpacked{"TAP/Parser/Iterator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_ITERATOR';
package TAP::Parser::Iterator;use strict;use warnings;use base 'TAP::Object';our$VERSION='3.39';sub next {my$self=shift;my$line=$self->next_raw;if (defined($line)and $line =~ /^\s*not\s*$/){$line .= ($self->next_raw || '')}return$line}sub next_raw {require Carp;my$msg=Carp::longmess('abstract method called directly!');$_[0]->_croak($msg)}sub handle_unicode {}sub get_select_handles {return}sub wait {require Carp;my$msg=Carp::longmess('abstract method called directly!');$_[0]->_croak($msg)}sub exit {require Carp;my$msg=Carp::longmess('abstract method called directly!');$_[0]->_croak($msg)}1;
TAP_PARSER_ITERATOR
$fatpacked{"TAP/Parser/Iterator/Array.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_ITERATOR_ARRAY';
package TAP::Parser::Iterator::Array;use strict;use warnings;use base 'TAP::Parser::Iterator';our$VERSION='3.39';sub _initialize {my ($self,$thing)=@_;chomp @$thing;$self->{idx}=0;$self->{array}=$thing;$self->{exit}=undef;return$self}sub wait {shift->exit}sub exit {my$self=shift;return 0 if$self->{idx}>= @{$self->{array}};return}sub next_raw {my$self=shift;return$self->{array}->[$self->{idx}++ ]}1;
TAP_PARSER_ITERATOR_ARRAY
$fatpacked{"TAP/Parser/Iterator/Process.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_ITERATOR_PROCESS';
package TAP::Parser::Iterator::Process;use strict;use warnings;use Config;use IO::Handle;use base 'TAP::Parser::Iterator';my$IS_WIN32=($^O =~ /^(MS)?Win32$/);our$VERSION='3.39';{no warnings 'uninitialized';local$SIG{__DIE__}=undef;eval {require POSIX;&POSIX::WEXITSTATUS(0)};if ($@){*_wait2exit=sub {$_[1]>> 8}}else {*_wait2exit=sub {POSIX::WEXITSTATUS($_[1])}}}sub _use_open3 {my$self=shift;return unless$Config{d_fork}|| $IS_WIN32;for my$module (qw(IPC::Open3 IO::Select)){eval "use $module";return if $@}return 1}{my$got_unicode;sub _get_unicode {return$got_unicode if defined$got_unicode;eval 'use Encode qw(decode_utf8);';$got_unicode=$@ ? 0 : 1}}sub _initialize {my ($self,$args)=@_;my@command=@{delete$args->{command}|| []}or die "Must supply a command to execute";$self->{command}=[@command];my$chunk_size=delete$args->{_chunk_size}|| 65536;my$merge=delete$args->{merge};my ($pid,$err,$sel);if (my$setup=delete$args->{setup}){$setup->(@command)}my$out=IO::Handle->new;if ($self->_use_open3){my$xclose=\&IPC::Open3::xclose;no warnings;local*IPC::Open3::xclose=sub {my$fh=shift;no strict 'refs';return if (fileno($fh)==fileno(STDIN));$xclose->($fh)};if ($IS_WIN32){$err=$merge ? '' : '>&STDERR';eval {$pid=open3('<&STDIN',$out,$merge ? '' : $err,@command)};die "Could not execute (@command): $@" if $@;if ($] >= 5.006){binmode($out,":crlf")}}else {$err=$merge ? '' : IO::Handle->new;eval {$pid=open3('<&STDIN',$out,$err,@command)};die "Could not execute (@command): $@" if $@;$sel=$merge ? undef : IO::Select->new($out,$err)}}else {$err='';my$command =join(' ',map {$_ =~ /\s/ ? qq{"$_"} : $_}@command);open($out,"$command|")or die "Could not execute ($command): $!"}$self->{out}=$out;$self->{err}=$err;$self->{sel}=$sel;$self->{pid}=$pid;$self->{exit}=undef;$self->{chunk_size}=$chunk_size;if (my$teardown=delete$args->{teardown}){$self->{teardown}=sub {$teardown->(@command)}}return$self}sub handle_unicode {my$self=shift;if ($self->{sel}){if (_get_unicode()){my$next=$self->{_next}||= $self->_next;$self->{_next}=sub {my$line=$next->();return decode_utf8($line)if defined$line;return}}}else {if ($] >= 5.008){eval 'binmode($self->{out}, ":utf8")'}}}sub wait {shift->{wait}}sub exit {shift->{exit}}sub _next {my$self=shift;if (my$out=$self->{out}){if (my$sel=$self->{sel}){my$err=$self->{err};my@buf=();my$partial='';my$chunk_size=$self->{chunk_size};return sub {return shift@buf if@buf;READ: while (my@ready=$sel->can_read){for my$fh (@ready){my$got=sysread$fh,my ($chunk),$chunk_size;if ($got==0){$sel->remove($fh)}elsif ($fh==$err){print STDERR$chunk}else {$chunk=$partial .$chunk;$partial='';unless (substr($chunk,-1,1)eq "\n"){my$nl=rindex$chunk,"\n";if ($nl==-1){$partial=$chunk;redo READ}else {$partial=substr($chunk,$nl + 1);$chunk=substr($chunk,0,$nl)}}push@buf,split /\n/,$chunk;return shift@buf if@buf}}}if (length$partial){my$last=$partial;$partial='';return$last}$self->_finish;return}}else {return sub {if (defined(my$line=<$out>)){chomp$line;return$line}$self->_finish;return}}}else {return sub {$self->_finish;return}}}sub next_raw {my$self=shift;return ($self->{_next}||= $self->_next)->()}sub _finish {my$self=shift;my$status=$?;$self->{_next}=sub {return}if $] >= 5.006;if (defined$self->{pid}){if ($self->{pid}==waitpid($self->{pid},0)){$status=$?}}(delete$self->{out})->close if$self->{out};if ($self->{sel}){(delete$self->{err})->close;delete$self->{sel}}else {$status=$?}$status=0 if$IS_WIN32 && $status==-1;$self->{wait}=$status;$self->{exit}=$self->_wait2exit($status);if (my$teardown=$self->{teardown}){$teardown->()}return$self}sub get_select_handles {my$self=shift;return grep $_,($self->{out},$self->{err})}1;
TAP_PARSER_ITERATOR_PROCESS
$fatpacked{"TAP/Parser/Iterator/Stream.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_ITERATOR_STREAM';
package TAP::Parser::Iterator::Stream;use strict;use warnings;use base 'TAP::Parser::Iterator';our$VERSION='3.39';sub _initialize {my ($self,$thing)=@_;$self->{fh}=$thing;return$self}sub wait {shift->exit}sub exit {shift->{fh}? (): 0}sub next_raw {my$self=shift;my$fh=$self->{fh};if (defined(my$line=<$fh>)){chomp$line;return$line}else {$self->_finish;return}}sub _finish {my$self=shift;close delete$self->{fh}}1;
TAP_PARSER_ITERATOR_STREAM
$fatpacked{"TAP/Parser/IteratorFactory.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_ITERATORFACTORY';
package TAP::Parser::IteratorFactory;use strict;use warnings;use Carp qw(confess);use File::Basename qw(fileparse);use base 'TAP::Object';use constant handlers=>[];our$VERSION='3.39';sub _initialize {my ($self,$config)=@_;$self->config($config || {})->load_handlers;return$self}sub register_handler {my ($class,$dclass)=@_;confess("$dclass must implement can_handle & make_iterator methods!")unless UNIVERSAL::can($dclass,'can_handle')&& UNIVERSAL::can($dclass,'make_iterator');my$handlers=$class->handlers;push @{$handlers},$dclass unless grep {$_ eq $dclass}@{$handlers};return$class}sub config {my$self=shift;return$self->{config}unless @_;unless ('HASH' eq ref $_[0]){$self->_croak('Argument to &config must be a hash reference')}$self->{config}=shift;return$self}sub _last_handler {my$self=shift;return$self->{last_handler}unless @_;$self->{last_handler}=shift;return$self}sub _testing {my$self=shift;return$self->{testing}unless @_;$self->{testing}=shift;return$self}sub load_handlers {my ($self)=@_;for my$handler (keys %{$self->config}){my$sclass=$self->_load_handler($handler)}return$self}sub _load_handler {my ($self,$handler)=@_;my@errors;for my$dclass ("TAP::Parser::SourceHandler::$handler",$handler){return$dclass if UNIVERSAL::can($dclass,'can_handle')&& UNIVERSAL::can($dclass,'make_iterator');eval "use $dclass";if (my$e=$@){push@errors,$e;next}return$dclass if UNIVERSAL::can($dclass,'can_handle')&& UNIVERSAL::can($dclass,'make_iterator');push@errors,"handler '$dclass' does not implement can_handle & make_iterator"}$self->_croak("Cannot load handler '$handler': " .join("\n",@errors))}sub make_iterator {my ($self,$source)=@_;$self->_croak('no raw source defined!')unless defined$source->raw;$source->config($self->config)->assemble_meta;return$source->raw if ($source->meta->{is_object}&& UNIVERSAL::isa($source->raw,'TAP::Parser::SourceHandler'));my$sd_class=$self->detect_source($source);$self->_last_handler($sd_class);return if$self->_testing;my$iterator=$sd_class->make_iterator($source);return$iterator}sub detect_source {my ($self,$source)=@_;confess('no raw source ref defined!')unless defined$source->raw;my%handlers;for my$dclass (@{$self->handlers}){my$confidence=$dclass->can_handle($source);$handlers{$dclass}=$confidence if$confidence}if (!%handlers){my$raw_source_short=substr(${$source->raw},0,50);confess("Cannot detect source of '$raw_source_short'!");return}my@handlers=(map {$_}sort {$handlers{$a}cmp $handlers{$b}}keys%handlers);if ($ENV{TAP_HARNESS_SOURCE_FACTORY_VOTES}){warn("votes: ",join(', ',map {"$_: $handlers{$_}"}@handlers),"\n")}return pop@handlers}1;
TAP_PARSER_ITERATORFACTORY
$fatpacked{"TAP/Parser/Multiplexer.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_MULTIPLEXER';
package TAP::Parser::Multiplexer;use strict;use warnings;use IO::Select;use base 'TAP::Object';use constant IS_WIN32=>$^O =~ /^(MS)?Win32$/;use constant IS_VMS=>$^O eq 'VMS';use constant SELECT_OK=>!(IS_VMS || IS_WIN32);our$VERSION='3.39';sub _initialize {my$self=shift;$self->{select}=IO::Select->new;$self->{avid}=[];$self->{count}=0;return$self}sub add {my ($self,$parser,$stash)=@_;if (SELECT_OK && (my@handles=$parser->get_select_handles)){my$sel=$self->{select};my@filenos=map {fileno $_}@handles;for my$h (@handles){$sel->add([$h,$parser,$stash,@filenos ])}$self->{count}++}else {push @{$self->{avid}},[$parser,$stash ]}}sub parsers {my$self=shift;return$self->{count}+ scalar @{$self->{avid}}}sub _iter {my$self=shift;my$sel=$self->{select};my$avid=$self->{avid};my@ready=();return sub {if (@$avid){my ($parser,$stash)=@{$avid->[0]};my$result=$parser->next;shift @$avid unless defined$result;return ($parser,$stash,$result)}unless (@ready){return unless$sel->count;@ready=$sel->can_read}my ($h,$parser,$stash,@handles)=@{shift@ready};my$result=$parser->next;unless (defined$result){$sel->remove(@handles);$self->{count}--;@ready=()}return ($parser,$stash,$result)}}sub next {my$self=shift;return ($self->{_iter}||= $self->_iter)->()}1;
TAP_PARSER_MULTIPLEXER
$fatpacked{"TAP/Parser/Result.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_RESULT';
package TAP::Parser::Result;use strict;use warnings;use base 'TAP::Object';BEGIN {my@attrs=qw(plan pragma test comment bailout version unknown yaml);no strict 'refs';for my$token (@attrs){my$method="is_$token";*$method=sub {return$token eq shift->type}}}our$VERSION='3.39';sub _initialize {my ($self,$token)=@_;if ($token){@{$self}{keys %$token }=values %$token}return$self}sub raw {shift->{raw}}sub type {shift->{type}}sub as_string {shift->{raw}}sub is_ok {1}sub passed {warn 'passed() is deprecated. Please use "is_ok()"';shift->is_ok}sub has_directive {my$self=shift;return ($self->has_todo || $self->has_skip)}sub has_todo {'TODO' eq (shift->{directive}|| '')}sub has_skip {'SKIP' eq (shift->{directive}|| '')}sub set_directive {my ($self,$dir)=@_;$self->{directive}=$dir}1;
TAP_PARSER_RESULT
$fatpacked{"TAP/Parser/Result/Bailout.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_RESULT_BAILOUT';
package TAP::Parser::Result::Bailout;use strict;use warnings;use base 'TAP::Parser::Result';our$VERSION='3.39';sub explanation {shift->{bailout}}sub as_string {shift->{bailout}}1;
TAP_PARSER_RESULT_BAILOUT
$fatpacked{"TAP/Parser/Result/Comment.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_RESULT_COMMENT';
package TAP::Parser::Result::Comment;use strict;use warnings;use base 'TAP::Parser::Result';our$VERSION='3.39';sub comment {shift->{comment}}sub as_string {shift->{raw}}1;
TAP_PARSER_RESULT_COMMENT
$fatpacked{"TAP/Parser/Result/Plan.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_RESULT_PLAN';
package TAP::Parser::Result::Plan;use strict;use warnings;use base 'TAP::Parser::Result';our$VERSION='3.39';sub plan {'1..' .shift->{tests_planned}}sub tests_planned {shift->{tests_planned}}sub directive {shift->{directive}}sub explanation {shift->{explanation}}sub todo_list {shift->{todo_list}}1;
TAP_PARSER_RESULT_PLAN
$fatpacked{"TAP/Parser/Result/Pragma.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_RESULT_PRAGMA';
package TAP::Parser::Result::Pragma;use strict;use warnings;use base 'TAP::Parser::Result';our$VERSION='3.39';sub pragmas {my@pragmas=@{shift->{pragmas}};return wantarray ? @pragmas : \@pragmas}1;
TAP_PARSER_RESULT_PRAGMA
$fatpacked{"TAP/Parser/Result/Test.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_RESULT_TEST';
package TAP::Parser::Result::Test;use strict;use warnings;use base 'TAP::Parser::Result';our$VERSION='3.39';sub ok {shift->{ok}}sub number {shift->{test_num}}sub _number {my ($self,$number)=@_;$self->{test_num}=$number}sub description {shift->{description}}sub directive {shift->{directive}}sub explanation {shift->{explanation}}sub is_ok {my$self=shift;return if$self->is_unplanned;return$self->has_todo ? 1 : $self->ok !~ /not/}sub is_actual_ok {my$self=shift;return$self->{ok}!~ /not/}sub actual_passed {warn 'actual_passed() is deprecated. Please use "is_actual_ok()"';goto&is_actual_ok}sub todo_passed {my$self=shift;return$self->has_todo && $self->is_actual_ok}sub todo_failed {warn 'todo_failed() is deprecated. Please use "todo_passed()"';goto&todo_passed}sub as_string {my$self=shift;my$string=$self->ok ." " .$self->number;if (my$description=$self->description){$string .= " $description"}if (my$directive=$self->directive){my$explanation=$self->explanation;$string .= " # $directive $explanation"}return$string}sub is_unplanned {my$self=shift;return ($self->{unplanned}|| '')unless @_;$self->{unplanned}=!!shift;return$self}1;
TAP_PARSER_RESULT_TEST
$fatpacked{"TAP/Parser/Result/Unknown.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_RESULT_UNKNOWN';
package TAP::Parser::Result::Unknown;use strict;use warnings;use base 'TAP::Parser::Result';our$VERSION='3.39';1;
TAP_PARSER_RESULT_UNKNOWN
$fatpacked{"TAP/Parser/Result/Version.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_RESULT_VERSION';
package TAP::Parser::Result::Version;use strict;use warnings;use base 'TAP::Parser::Result';our$VERSION='3.39';sub version {shift->{version}}1;
TAP_PARSER_RESULT_VERSION
$fatpacked{"TAP/Parser/Result/YAML.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_RESULT_YAML';
package TAP::Parser::Result::YAML;use strict;use warnings;use base 'TAP::Parser::Result';our$VERSION='3.39';sub data {shift->{data}}1;
TAP_PARSER_RESULT_YAML
$fatpacked{"TAP/Parser/ResultFactory.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_RESULTFACTORY';
package TAP::Parser::ResultFactory;use strict;use warnings;use TAP::Parser::Result::Bailout ();use TAP::Parser::Result::Comment ();use TAP::Parser::Result::Plan ();use TAP::Parser::Result::Pragma ();use TAP::Parser::Result::Test ();use TAP::Parser::Result::Unknown ();use TAP::Parser::Result::Version ();use TAP::Parser::Result::YAML ();use base 'TAP::Object';our$VERSION='3.39';sub make_result {my ($proto,$token)=@_;my$type=$token->{type};return$proto->class_for($type)->new($token)}our%CLASS_FOR=(plan=>'TAP::Parser::Result::Plan',pragma=>'TAP::Parser::Result::Pragma',test=>'TAP::Parser::Result::Test',comment=>'TAP::Parser::Result::Comment',bailout=>'TAP::Parser::Result::Bailout',version=>'TAP::Parser::Result::Version',unknown=>'TAP::Parser::Result::Unknown',yaml=>'TAP::Parser::Result::YAML',);sub class_for {my ($class,$type)=@_;return$CLASS_FOR{$type}if exists$CLASS_FOR{$type};require Carp;Carp::croak("Could not determine class for result type '$type'")}sub register_type {my ($class,$type,$rclass)=@_;$CLASS_FOR{$type}=$rclass;return$class}1;
TAP_PARSER_RESULTFACTORY
$fatpacked{"TAP/Parser/Scheduler.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_SCHEDULER';
package TAP::Parser::Scheduler;use strict;use warnings;use Carp;use TAP::Parser::Scheduler::Job;use TAP::Parser::Scheduler::Spinner;our$VERSION='3.39';sub new {my$class=shift;croak "Need a number of key, value pairs" if @_ % 2;my%args=@_;my$tests=delete$args{tests}|| croak "Need a 'tests' argument";my$rules=delete$args{rules}|| {par=>'**' };croak "Unknown arg(s): ",join ', ',sort keys%args if keys%args;my$self=bless {},$class;$self->_set_rules($rules,$tests);return$self}sub _set_rules {my ($self,$rules,$tests)=@_;my@tests=map {TAP::Parser::Scheduler::Job->new(@$_)}map {'ARRAY' eq ref $_ ? $_ : [$_,$_ ]}@$tests;my$schedule=$self->_rule_clause($rules,\@tests);$schedule=[[$schedule,@tests ]]if@tests;$self->{schedule}=$schedule}sub _rule_clause {my ($self,$rule,$tests)=@_;croak 'Rule clause must be a hash' unless 'HASH' eq ref$rule;my@type=keys %$rule;croak 'Rule clause must have exactly one key' unless@type==1;my%handlers=(par=>sub {[map {[$_]}@_ ]},seq=>sub {[[@_]]},);my$handler=$handlers{$type[0]}|| croak 'Unknown scheduler type: ',$type[0];my$val=$rule->{$type[0]};return$handler->(map {'HASH' eq ref $_ ? $self->_rule_clause($_,$tests): $self->_expand($_,$tests)}'ARRAY' eq ref$val ? @$val : $val)}sub _glob_to_regexp {my ($self,$glob)=@_;my$nesting;my$pattern;while (1){if ($glob =~ /\G\*\*/gc){$pattern .= '.*?'}elsif ($glob =~ /\G\*/gc){$pattern .= '[^/]*'}elsif ($glob =~ /\G\?/gc){$pattern .= '[^/]'}elsif ($glob =~ /\G\{/gc){$pattern .= '(?:';++$nesting}elsif ($nesting and $glob =~ /\G,/gc){$pattern .= '|'}elsif ($nesting and $glob =~ /\G\}/gc){$pattern .= ')';--$nesting}elsif ($glob =~ /\G(\\.)/gc){$pattern .= $1}elsif ($glob =~ /\G([\},])/gc){$pattern .= '\\' .$1}else {$glob =~ /\G([^{?*\\\},]*)/gc;$pattern .= quotemeta $1}return$pattern if pos$glob==length$glob}}sub _expand {my ($self,$name,$tests)=@_;my$pattern=$self->_glob_to_regexp($name);$pattern=qr/^ $pattern $/x;my@match=();for (my$ti=0;$ti < @$tests;$ti++ ){if ($tests->[$ti]->filename =~ $pattern){push@match,splice @$tests,$ti,1;$ti--}}return@match}sub get_all {my$self=shift;my@all=$self->_gather($self->{schedule});$self->{count}=@all;@all}sub _gather {my ($self,$rule)=@_;return unless defined$rule;return$rule unless 'ARRAY' eq ref$rule;return map {defined()? $self->_gather($_): ()}map {@$_}@$rule}sub get_job {my$self=shift;$self->{count}||= $self->get_all;my@jobs=$self->_find_next_job($self->{schedule});if (@jobs){--$self->{count};return$jobs[0]}return TAP::Parser::Scheduler::Spinner->new if$self->{count};return}sub _not_empty {my$ar=shift;return 1 unless 'ARRAY' eq ref$ar;for (@$ar){return 1 if _not_empty($_)}return}sub _is_empty {!_not_empty(@_)}sub _find_next_job {my ($self,$rule)=@_;my@queue=();my$index=0;while ($index < @$rule){my$seq=$rule->[$index];shift @$seq while @$seq && _is_empty($seq->[0]);if (@$seq){if (defined$seq->[0]){if ('ARRAY' eq ref$seq->[0]){push@queue,$seq}else {my$job=splice @$seq,0,1,undef;$job->on_finish(sub {shift @$seq});return$job}}++$index}else {splice @$rule,$index,1}}for my$seq (@queue){if (my@jobs=$self->_find_next_job($seq->[0])){return@jobs}}return}sub as_string {my$self=shift;return$self->_as_string($self->{schedule})}sub _as_string {my ($self,$rule,$depth)=(shift,shift,shift || 0);my$pad=' ' x 2;my$indent=$pad x $depth;if (!defined$rule){return "$indent(undef)\n"}elsif ('ARRAY' eq ref$rule){return unless @$rule;my$type=('par','seq')[$depth % 2 ];return join('',"$indent$type:\n",map {$self->_as_string($_,$depth + 1)}@$rule)}else {return "$indent'" .$rule->filename ."'\n"}}1;
TAP_PARSER_SCHEDULER
$fatpacked{"TAP/Parser/Scheduler/Job.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_SCHEDULER_JOB';
package TAP::Parser::Scheduler::Job;use strict;use warnings;use Carp;our$VERSION='3.39';sub new {my ($class,$name,$desc,@ctx)=@_;return bless {filename=>$name,description=>$desc,@ctx ? (context=>\@ctx): (),},$class}sub on_finish {my ($self,$cb)=@_;$self->{on_finish}=$cb}sub finish {my$self=shift;if (my$cb=$self->{on_finish}){$cb->($self)}}sub filename {shift->{filename}}sub description {shift->{description}}sub context {@{shift->{context}|| []}}sub as_array_ref {my$self=shift;return [$self->filename,$self->description,$self->{context}||= []]}sub is_spinner {0}1;
TAP_PARSER_SCHEDULER_JOB
$fatpacked{"TAP/Parser/Scheduler/Spinner.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_SCHEDULER_SPINNER';
package TAP::Parser::Scheduler::Spinner;use strict;use warnings;use Carp;our$VERSION='3.39';sub new {bless {},shift}sub is_spinner {1}1;
TAP_PARSER_SCHEDULER_SPINNER
$fatpacked{"TAP/Parser/Source.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_SOURCE';
package TAP::Parser::Source;use strict;use warnings;use File::Basename qw(fileparse);use base 'TAP::Object';use constant BLK_SIZE=>512;our$VERSION='3.39';sub _initialize {my ($self)=@_;$self->meta({});$self->config({});return$self}sub raw {my$self=shift;return$self->{raw}unless @_;$self->{raw}=shift;return$self}sub meta {my$self=shift;return$self->{meta}unless @_;$self->{meta}=shift;return$self}sub has_meta {return scalar %{shift->meta}? 1 : 0}sub config {my$self=shift;return$self->{config}unless @_;$self->{config}=shift;return$self}sub merge {my$self=shift;return$self->{merge}unless @_;$self->{merge}=shift;return$self}sub switches {my$self=shift;return$self->{switches}unless @_;$self->{switches}=shift;return$self}sub test_args {my$self=shift;return$self->{test_args}unless @_;$self->{test_args}=shift;return$self}sub assemble_meta {my ($self)=@_;return$self->meta if$self->has_meta;my$meta=$self->meta;my$raw=$self->raw;$meta->{is_object}=UNIVERSAL::isa($raw,'UNIVERSAL')? 1 : 0;if ($meta->{is_object}){$meta->{class}=ref($raw)}else {my$ref=lc(ref($raw));$meta->{"is_$ref"}=1}if ($meta->{is_scalar}){my$source=$$raw;$meta->{length}=length($$raw);$meta->{has_newlines}=$$raw =~ /\n/ ? 1 : 0;if (!$meta->{has_newlines}and $meta->{length}< 1024){my$file={};$file->{exists}=-e $source ? 1 : 0;if ($file->{exists}){$meta->{file}=$file;$file->{stat}=[stat(_)];$file->{empty}=-z _ ? 1 : 0;$file->{size}=-s _;$file->{text}=-T _ ? 1 : 0;$file->{binary}=-B _ ? 1 : 0;$file->{read}=-r _ ? 1 : 0;$file->{write}=-w _ ? 1 : 0;$file->{execute}=-x _ ? 1 : 0;$file->{setuid}=-u _ ? 1 : 0;$file->{setgid}=-g _ ? 1 : 0;$file->{sticky}=-k _ ? 1 : 0;$meta->{is_file}=$file->{is_file}=-f _ ? 1 : 0;$meta->{is_dir}=$file->{is_dir}=-d _ ? 1 : 0;$meta->{is_symlink}=$file->{is_symlink}=-l $source ? 1 : 0;if ($file->{is_symlink}){$file->{lstat}=[lstat(_)]}($file->{basename},$file->{dir},$file->{ext})=map {defined $_ ? $_ : ''}fileparse($source,qr/\.[^.]*/);$file->{lc_ext}=lc($file->{ext});$file->{basename}.= $file->{ext}if$file->{ext};if (!$file->{is_dir}&& $file->{read}){eval {$file->{shebang}=$self->shebang($$raw)};if (my$e=$@){warn$e}}}}}elsif ($meta->{is_array}){$meta->{size}=$#$raw + 1}elsif ($meta->{is_hash}){}return$meta}{my%shebang_for;sub _read_shebang {my ($class,$file)=@_;open my$fh,'<',$file or die "Can't read $file: $!\n";my$got=read$fh,my ($buf),BLK_SIZE;defined$got or die "I/O error: $!\n";return $1 if$buf =~ /(.*)/;return}sub shebang {my ($class,$file)=@_;$shebang_for{$file}=$class->_read_shebang($file)unless exists$shebang_for{$file};return$shebang_for{$file}}}sub config_for {my ($self,$class)=@_;my ($abbrv_class)=($class =~ /(?:\:\:)?(\w+)$/);my$config=$self->config->{$abbrv_class}|| $self->config->{$class};return$config}1;
TAP_PARSER_SOURCE
$fatpacked{"TAP/Parser/SourceHandler.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_SOURCEHANDLER';
package TAP::Parser::SourceHandler;use strict;use warnings;use TAP::Parser::Iterator ();use base 'TAP::Object';our$VERSION='3.39';sub can_handle {my ($class,$args)=@_;$class->_croak("Abstract method 'can_handle' not implemented for $class!");return}sub make_iterator {my ($class,$args)=@_;$class->_croak("Abstract method 'make_iterator' not implemented for $class!");return}1;
TAP_PARSER_SOURCEHANDLER
$fatpacked{"TAP/Parser/SourceHandler/Executable.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_SOURCEHANDLER_EXECUTABLE';
package TAP::Parser::SourceHandler::Executable;use strict;use warnings;use TAP::Parser::IteratorFactory ();use TAP::Parser::Iterator::Process ();use base 'TAP::Parser::SourceHandler';TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);our$VERSION='3.39';sub can_handle {my ($class,$src)=@_;my$meta=$src->meta;if ($meta->{is_file}){my$file=$meta->{file};return 0.85 if$file->{execute}&& $file->{binary};return 0.8 if$file->{lc_ext}eq '.bat';return 0.25 if$file->{execute}}elsif ($meta->{is_hash}){return 0.9 if$src->raw->{exec}}return 0}sub make_iterator {my ($class,$source)=@_;my$meta=$source->meta;my@command;if ($meta->{is_hash}){@command=@{$source->raw->{exec}|| []}}elsif ($meta->{is_scalar}){@command=${$source->raw}}elsif ($meta->{is_array}){@command=@{$source->raw}}$class->_croak('No command found in $source->raw!')unless@command;$class->_autoflush(\*STDOUT);$class->_autoflush(\*STDERR);push@command,@{$source->test_args || []};return$class->iterator_class->new({command=>\@command,merge=>$source->merge })}use constant iterator_class=>'TAP::Parser::Iterator::Process';sub _autoflush {my ($class,$flushed)=@_;my$old_fh=select$flushed;$|=1;select$old_fh}1;
TAP_PARSER_SOURCEHANDLER_EXECUTABLE
$fatpacked{"TAP/Parser/SourceHandler/File.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_SOURCEHANDLER_FILE';
package TAP::Parser::SourceHandler::File;use strict;use warnings;use TAP::Parser::IteratorFactory ();use TAP::Parser::Iterator::Stream ();use base 'TAP::Parser::SourceHandler';TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);our$VERSION='3.39';sub can_handle {my ($class,$src)=@_;my$meta=$src->meta;my$config=$src->config_for($class);return 0 unless$meta->{is_file};my$file=$meta->{file};return 0.9 if$file->{lc_ext}eq '.tap';if (my$exts=$config->{extensions}){return 0.9 if grep {lc($_)eq $file->{lc_ext}}@$exts}return 0}sub make_iterator {my ($class,$source)=@_;$class->_croak('$source->raw must be a scalar ref')unless$source->meta->{is_scalar};my$file=${$source->raw};my$fh;open($fh,'<',$file)or $class->_croak("error opening TAP source file '$file': $!");return$class->iterator_class->new($fh)}use constant iterator_class=>'TAP::Parser::Iterator::Stream';1;
TAP_PARSER_SOURCEHANDLER_FILE
$fatpacked{"TAP/Parser/SourceHandler/Handle.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_SOURCEHANDLER_HANDLE';
package TAP::Parser::SourceHandler::Handle;use strict;use warnings;use TAP::Parser::IteratorFactory ();use TAP::Parser::Iterator::Stream ();use base 'TAP::Parser::SourceHandler';TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);our$VERSION='3.39';sub can_handle {my ($class,$src)=@_;my$meta=$src->meta;return 0.9 if$meta->{is_object}&& UNIVERSAL::isa($src->raw,'IO::Handle');return 0.8 if$meta->{is_glob};return 0}sub make_iterator {my ($class,$source)=@_;$class->_croak('$source->raw must be a glob ref or an IO::Handle')unless$source->meta->{is_glob}|| UNIVERSAL::isa($source->raw,'IO::Handle');return$class->iterator_class->new($source->raw)}use constant iterator_class=>'TAP::Parser::Iterator::Stream';1;
TAP_PARSER_SOURCEHANDLER_HANDLE
$fatpacked{"TAP/Parser/SourceHandler/Perl.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_SOURCEHANDLER_PERL';
package TAP::Parser::SourceHandler::Perl;use strict;use warnings;use Config;use constant IS_WIN32=>($^O =~ /^(MS)?Win32$/);use constant IS_VMS=>($^O eq 'VMS');use TAP::Parser::IteratorFactory ();use TAP::Parser::Iterator::Process ();use Text::ParseWords qw(shellwords);use base 'TAP::Parser::SourceHandler::Executable';TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);our$VERSION='3.39';sub can_handle {my ($class,$source)=@_;my$meta=$source->meta;return 0 unless$meta->{is_file};my$file=$meta->{file};if (my$shebang=$file->{shebang}){return 0.9 if$shebang =~ /^#!.*\bperl/;return 0.3}return 0.8 if$file->{lc_ext}eq '.t';return 0.9 if$file->{lc_ext}eq '.pl';return 0.75 if$file->{dir}=~ /^t\b/;return 0.25}sub _autoflush_stdhandles {my ($class)=@_;$class->_autoflush(\*STDOUT);$class->_autoflush(\*STDERR)}sub make_iterator {my ($class,$source)=@_;my$meta=$source->meta;my$perl_script=${$source->raw};$class->_croak("Cannot find ($perl_script)")unless$meta->{is_file};$class->_autoflush_stdhandles;my ($libs,$switches)=$class->_mangle_switches($class->_filter_libs($class->_switches($source)));$class->_run($source,$libs,$switches)}sub _has_taint_switch {my($class,$switches)=@_;my$has_taint=grep {$_ eq "-T" || $_ eq "-t"}@{$switches};return$has_taint ? 1 : 0}sub _mangle_switches {my ($class,$libs,$switches)=@_;if ($class->_has_taint_switch($switches)){my@perl5lib=defined$ENV{PERL5LIB}? split /$Config{path_sep}/,$ENV{PERL5LIB}: ();return ($libs,[@{$switches},$class->_libs2switches([@$libs,@perl5lib]),defined$ENV{PERL5OPT}? shellwords($ENV{PERL5OPT}): ()],)}return ($libs,$switches)}sub _filter_libs {my ($class,@switches)=@_;my$path_sep=$Config{path_sep};my$path_re=qr{$path_sep};my@libs;my@filtered_switches;for (@switches){if (!/$path_re/ && m/ ^ ['"]? -I ['"]? (.*?) ['"]? $ /x){push@libs,$1}else {push@filtered_switches,$_}}return \@libs,\@filtered_switches}sub _iterator_hooks {my ($class,$source,$libs,$switches)=@_;my$setup=sub {if (@{$libs}and!$class->_has_taint_switch($switches)){$ENV{PERL5LIB}=join($Config{path_sep},grep {defined}@{$libs},$ENV{PERL5LIB})}};my$previous=$ENV{PERL5LIB};my$teardown=sub {if (defined$previous){$ENV{PERL5LIB}=$previous}else {delete$ENV{PERL5LIB}}};return ($setup,$teardown)}sub _run {my ($class,$source,$libs,$switches)=@_;my@command=$class->_get_command_for_switches($source,$switches)or $class->_croak("No command found!");my ($setup,$teardown)=$class->_iterator_hooks($source,$libs,$switches);return$class->_create_iterator($source,\@command,$setup,$teardown)}sub _create_iterator {my ($class,$source,$command,$setup,$teardown)=@_;return TAP::Parser::Iterator::Process->new({command=>$command,merge=>$source->merge,setup=>$setup,teardown=>$teardown,})}sub _get_command_for_switches {my ($class,$source,$switches)=@_;my$file=${$source->raw};my@args=@{$source->test_args || []};my$command=$class->get_perl;my@command=($command,@{$switches},$file,@args);return@command}sub _libs2switches {my$class=shift;return map {"-I$_"}grep {$_}@{$_[0]}}sub get_taint {my ($class,$shebang)=@_;return unless defined$shebang && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;return $1}sub _switches {my ($class,$source)=@_;my$file=${$source->raw};my@switches=@{$source->switches || []};my$shebang=$source->meta->{file}->{shebang};return unless defined$shebang;my$taint=$class->get_taint($shebang);push@switches,"-$taint" if defined$taint;if (IS_VMS){for (@switches){$_=qq["$_"]}}return@switches}sub get_perl {my$class=shift;return$ENV{HARNESS_PERL}if defined$ENV{HARNESS_PERL};return qq["$^X"] if IS_WIN32 && ($^X =~ /[^\w\.\/\\]/);return $^X}1;
TAP_PARSER_SOURCEHANDLER_PERL
$fatpacked{"TAP/Parser/SourceHandler/RawTAP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_SOURCEHANDLER_RAWTAP';
package TAP::Parser::SourceHandler::RawTAP;use strict;use warnings;use TAP::Parser::IteratorFactory ();use TAP::Parser::Iterator::Array ();use base 'TAP::Parser::SourceHandler';TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);our$VERSION='3.39';sub can_handle {my ($class,$src)=@_;my$meta=$src->meta;return 0 if$meta->{file};if ($meta->{is_scalar}){return 0 unless$meta->{has_newlines};return 0.9 if ${$src->raw}=~ /\d\.\.\d/;return 0.7 if ${$src->raw}=~ /ok/;return 0.3}elsif ($meta->{is_array}){return 0.5}return 0}sub make_iterator {my ($class,$src)=@_;my$meta=$src->meta;my$tap_array;if ($meta->{is_scalar}){$tap_array=[split "\n"=>${$src->raw}]}elsif ($meta->{is_array}){$tap_array=$src->raw}$class->_croak('No raw TAP found in $source->raw')unless scalar$tap_array;return TAP::Parser::Iterator::Array->new($tap_array)}1;
TAP_PARSER_SOURCEHANDLER_RAWTAP
$fatpacked{"TAP/Parser/YAMLish/Reader.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_YAMLISH_READER';
package TAP::Parser::YAMLish::Reader;use strict;use warnings;use base 'TAP::Object';our$VERSION='3.39';my%UNESCAPES=(z=>"\x00",a=>"\x07",t=>"\x09",n=>"\x0a",v=>"\x0b",f=>"\x0c",r=>"\x0d",e=>"\x1b",'\\'=>'\\',);my$QQ_STRING=qr{ " (?:\\. | [^"])* " }x;my$HASH_LINE=qr{ ^ ($QQ_STRING|\S+) \s* : \s* (?: (.+?) \s* )? $ }x;my$IS_HASH_KEY=qr{ ^ [\w\'\"] }x;my$IS_END_YAML=qr{ ^ \.\.\. \s* $ }x;my$IS_QQ_STRING=qr{ ^ $QQ_STRING $ }x;sub read {my$self=shift;my$obj=shift;die "Must have a code reference to read input from" unless ref$obj eq 'CODE';$self->{reader}=$obj;$self->{capture}=[];$self->_next;return unless$self->{next};my$doc=$self->_read;my$dots=$self->_peek;die "Missing '...' at end of YAMLish" unless defined$dots and $dots =~ $IS_END_YAML;delete$self->{reader};delete$self->{next};return$doc}sub get_raw {join("\n",grep defined,@{shift->{capture}|| []})."\n"}sub _peek {my$self=shift;return$self->{next}unless wantarray;my$line=$self->{next};$line =~ /^ (\s*) (.*) $ /x;return ($2,length $1)}sub _next {my$self=shift;die "_next called with no reader" unless$self->{reader};my$line=$self->{reader}->();$self->{next}=$line;push @{$self->{capture}},$line}sub _read {my$self=shift;my$line=$self->_peek;if ($line =~ /^ --- (?: \s* (.+?)? \s* )? $/x){$self->_next;return$self->_read_scalar($1)if defined $1;my ($next,$indent)=$self->_peek;if ($next =~ /^ - /x){return$self->_read_array($indent)}elsif ($next =~ $IS_HASH_KEY){return$self->_read_hash($next,$indent)}elsif ($next =~ $IS_END_YAML){die "Premature end of YAMLish"}else {die "Unsupported YAMLish syntax: '$next'"}}else {die "YAMLish document header not found"}}sub _read_qq {my$self=shift;my$str=shift;unless ($str =~ s/^ " (.*?) " $/$1/x){die "Internal: not a quoted string"}$str =~ s/\\"/"/gx;$str =~ s/ \\ ( [tartan\\favez] | x([0-9a-fA-F]{2}) )
/ (length($1) > 1) ? pack("H2", $2) : $UNESCAPES{$1} /gex;return$str}sub _read_scalar {my$self=shift;my$string=shift;return undef if$string eq '~';return {}if$string eq '{}';return []if$string eq '[]';if ($string eq '>' || $string eq '|'){my ($line,$indent)=$self->_peek;die "Multi-line scalar content missing" unless defined$line;my@multiline=($line);while (1){$self->_next;my ($next,$ind)=$self->_peek;last if$ind < $indent;my$pad=$string eq '|' ? (' ' x ($ind - $indent)): '';push@multiline,$pad .$next}return join(($string eq '>' ? ' ' : "\n"),@multiline)."\n"}if ($string =~ /^ ' (.*) ' $/x){(my$rv=$1)=~ s/''/'/g;return$rv}if ($string =~ $IS_QQ_STRING){return$self->_read_qq($string)}if ($string =~ /^['"]/){die __PACKAGE__ ." does not support multi-line quoted scalars"}return$string}sub _read_nested {my$self=shift;my ($line,$indent)=$self->_peek;if ($line =~ /^ -/x){return$self->_read_array($indent)}elsif ($line =~ $IS_HASH_KEY){return$self->_read_hash($line,$indent)}else {die "Unsupported YAMLish syntax: '$line'"}}sub _read_array {my ($self,$limit)=@_;my$ar=[];while (1){my ($line,$indent)=$self->_peek;last if$indent < $limit ||!defined$line || $line =~ $IS_END_YAML;if ($indent > $limit){die "Array line over-indented"}if ($line =~ /^ (- \s+) \S+ \s* : (?: \s+ | $ ) /x){$indent += length $1;$line =~ s/-\s+//;push @$ar,$self->_read_hash($line,$indent)}elsif ($line =~ /^ - \s* (.+?) \s* $/x){die "Unexpected start of YAMLish" if$line =~ /^---/;$self->_next;push @$ar,$self->_read_scalar($1)}elsif ($line =~ /^ - \s* $/x){$self->_next;push @$ar,$self->_read_nested}elsif ($line =~ $IS_HASH_KEY){$self->_next;push @$ar,$self->_read_hash($line,$indent,)}else {die "Unsupported YAMLish syntax: '$line'"}}return$ar}sub _read_hash {my ($self,$line,$limit)=@_;my$indent;my$hash={};while (1){die "Badly formed hash line: '$line'" unless$line =~ $HASH_LINE;my ($key,$value)=($self->_read_scalar($1),$2);$self->_next;if (defined$value){$hash->{$key}=$self->_read_scalar($value)}else {$hash->{$key}=$self->_read_nested}($line,$indent)=$self->_peek;last if$indent < $limit ||!defined$line || $line =~ $IS_END_YAML}return$hash}1;
TAP_PARSER_YAMLISH_READER
$fatpacked{"TAP/Parser/YAMLish/Writer.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAP_PARSER_YAMLISH_WRITER';
package TAP::Parser::YAMLish::Writer;use strict;use warnings;use base 'TAP::Object';our$VERSION='3.39';my$ESCAPE_CHAR=qr{ [ \x00-\x1f \" ] }x;my$ESCAPE_KEY=qr{ (?: ^\W ) | $ESCAPE_CHAR }x;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);sub write {my$self=shift;die "Need something to write" unless @_;my$obj=shift;my$out=shift || \*STDOUT;die "Need a reference to something I can write to" unless ref$out;$self->{writer}=$self->_make_writer($out);$self->_write_obj('---',$obj);$self->_put('...');delete$self->{writer}}sub _make_writer {my$self=shift;my$out=shift;my$ref=ref$out;if ('CODE' eq $ref){return$out}elsif ('ARRAY' eq $ref){return sub {push @$out,shift}}elsif ('SCALAR' eq $ref){return sub {$$out .= shift()."\n"}}elsif ('GLOB' eq $ref || 'IO::Handle' eq $ref){return sub {print$out shift(),"\n"}}die "Can't write to $out"}sub _put {my$self=shift;$self->{writer}->(join '',@_)}sub _enc_scalar {my$self=shift;my$val=shift;my$rule=shift;return '~' unless defined$val;if ($val =~ /$rule/){$val =~ s/\\/\\\\/g;$val =~ s/"/\\"/g;$val =~ s/ ( [\x00-\x1f] ) / '\\' . $UNPRINTABLE[ ord($1) ] /gex;return qq{"$val"}}if (length($val)==0 or $val =~ /\s/){$val =~ s/'/''/;return "'$val'"}return$val}sub _write_obj {my$self=shift;my$prefix=shift;my$obj=shift;my$indent=shift || 0;if (my$ref=ref$obj){my$pad=' ' x $indent;if ('HASH' eq $ref){if (keys %$obj){$self->_put($prefix);for my$key (sort keys %$obj){my$value=$obj->{$key};$self->_write_obj($pad .$self->_enc_scalar($key,$ESCAPE_KEY).':',$value,$indent + 1)}}else {$self->_put($prefix,' {}')}}elsif ('ARRAY' eq $ref){if (@$obj){$self->_put($prefix);for my$value (@$obj){$self->_write_obj($pad .'-',$value,$indent + 1)}}else {$self->_put($prefix,' []')}}else {die "Don't know how to encode $ref"}}else {$self->_put($prefix,' ',$self->_enc_scalar($obj,$ESCAPE_CHAR))}}1;
TAP_PARSER_YAMLISH_WRITER
$fatpacked{"Test/Harness.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEST_HARNESS';
package Test::Harness;use 5.006;use strict;use warnings;use constant IS_WIN32=>($^O =~ /^(MS)?Win32$/);use constant IS_VMS=>($^O eq 'VMS');use TAP::Harness ();use TAP::Parser::Aggregator ();use TAP::Parser::Source ();use TAP::Parser::SourceHandler::Perl ();use Text::ParseWords qw(shellwords);use Config;use base 'Exporter';BEGIN {eval q{use Time::HiRes 'time'};our$has_time_hires=!$@}our$VERSION='3.39';*verbose=*Verbose;*switches=*Switches;*debug=*Debug;$ENV{HARNESS_ACTIVE}=1;$ENV{HARNESS_VERSION}=$VERSION;END {delete$ENV{HARNESS_ACTIVE};delete$ENV{HARNESS_VERSION}}our@EXPORT=qw(&runtests);our@EXPORT_OK=qw(&execute_tests $verbose $switches);our$Verbose=$ENV{HARNESS_VERBOSE}|| 0;our$Debug=$ENV{HARNESS_DEBUG}|| 0;our$Switches='-w';our$Columns=$ENV{HARNESS_COLUMNS}|| $ENV{COLUMNS}|| 80;$Columns--;our$Timer=$ENV{HARNESS_TIMER}|| 0;our$Color=$ENV{HARNESS_COLOR}|| 0;our$IgnoreExit=$ENV{HARNESS_IGNORE_EXIT}|| 0;sub _has_taint {my$test=shift;return TAP::Parser::SourceHandler::Perl->get_taint(TAP::Parser::Source->shebang($test))}sub _aggregate {my ($harness,$aggregate,@tests)=@_;local$ENV{HARNESS_OPTIONS};_apply_extra_INC($harness);_aggregate_tests($harness,$aggregate,@tests)}sub _apply_extra_INC {my$harness=shift;$harness->callback(parser_args=>sub {my ($args,$test)=@_;push @{$args->{switches}},map {"-I$_"}_filtered_inc()})}sub _aggregate_tests {my ($harness,$aggregate,@tests)=@_;$aggregate->start();$harness->aggregate_tests($aggregate,@tests);$aggregate->stop()}sub runtests {my@tests=@_;local ($\,$,);my$harness=_new_harness();my$aggregate=TAP::Parser::Aggregator->new();local$ENV{PERL_USE_UNSAFE_INC}=1 if not exists$ENV{PERL_USE_UNSAFE_INC};_aggregate($harness,$aggregate,@tests);$harness->formatter->summary($aggregate);my$total=$aggregate->total;my$passed=$aggregate->passed;my$failed=$aggregate->failed;my@parsers=$aggregate->parsers;my$num_bad=0;for my$parser (@parsers){$num_bad++ if$parser->has_problems}die(sprintf("Failed %d/%d test programs. %d/%d subtests failed.\n",$num_bad,scalar@parsers,$failed,$total))if$num_bad;return$total && $total==$passed}sub _canon {my@list=sort {$a <=> $b}@_;my@ranges=();my$count=scalar@list;my$pos=0;while ($pos < $count){my$end=$pos + 1;$end++ while$end < $count && $list[$end]<= $list[$end - 1 ]+ 1;push@ranges,($end==$pos + 1)? $list[$pos]: join('-',$list[$pos],$list[$end - 1 ]);$pos=$end}return join(' ',@ranges)}sub _new_harness {my$sub_args=shift || {};my (@lib,@switches);my@opt=map {shellwords($_)}grep {defined}$Switches,$ENV{HARNESS_PERL_SWITCHES};while (my$opt=shift@opt){if ($opt =~ /^ -I (.*) $ /x){push@lib,length($1)? $1 : shift@opt}else {push@switches,$opt}}push@lib,_filtered_inc()if IS_VMS;my$verbosity=($Verbose ? ($Verbose !~ /\d/)? 1 : $Verbose : 0);my$args={timer=>$Timer,directives=>our$Directives,lib=>\@lib,switches=>\@switches,color=>$Color,verbosity=>$verbosity,ignore_exit=>$IgnoreExit,};$args->{stdout}=$sub_args->{out}if exists$sub_args->{out};my$class=$ENV{HARNESS_SUBCLASS}|| 'TAP::Harness';if (defined(my$env_opt=$ENV{HARNESS_OPTIONS})){for my$opt (split /:/,$env_opt){if ($opt =~ /^j(\d*)$/){$args->{jobs}=$1 || 9}elsif ($opt eq 'c'){$args->{color}=1}elsif ($opt =~ m/^f(.*)$/){my$fmt=$1;$fmt =~ s/-/::/g;$args->{formatter_class}=$fmt}elsif ($opt =~ m/^a(.*)$/){my$archive=$1;$class="TAP::Harness::Archive";$args->{archive}=$archive}else {die "Unknown HARNESS_OPTIONS item: $opt\n"}}}return TAP::Harness->_construct($class,$args)}sub _filtered_inc {my@inc=grep {!ref}@INC;if (IS_VMS){@inc=grep!/perl_root/i,@inc}elsif (IS_WIN32){s/[\\\/]+$// for@inc}my@default_inc=_default_inc();my@new_inc;my%seen;for my$dir (@inc){next if$seen{$dir}++;if ($dir eq ($default_inc[0]|| '')){shift@default_inc}else {push@new_inc,$dir}shift@default_inc while@default_inc and $seen{$default_inc[0]}}return@new_inc}{my@inc;sub _default_inc {return@inc if@inc;local$ENV{PERL5LIB};local$ENV{PERLLIB};my$perl=$ENV{HARNESS_PERL}|| $^X;chomp(@inc=`"$perl" -e "print join qq[\\n], \@INC, q[]"`);return@inc}}sub _check_sequence {my@list=@_;my$prev;while (my$next=shift@list){return if defined$prev && $next <= $prev;$prev=$next}return 1}sub execute_tests {my%args=@_;my$harness=_new_harness(\%args);my$aggregate=TAP::Parser::Aggregator->new();my%tot=(bonus=>0,max=>0,ok=>0,bad=>0,good=>0,files=>0,tests=>0,sub_skipped=>0,todo=>0,skipped=>0,bench=>undef,);$harness->callback(made_parser=>sub {my$parser=shift;$parser->callback(plan=>sub {my$plan=shift;if ($plan->directive eq 'SKIP'){$tot{skipped}++}})});local$ENV{PERL_USE_UNSAFE_INC}=1 if not exists$ENV{PERL_USE_UNSAFE_INC};_aggregate($harness,$aggregate,@{$args{tests}});$tot{bench}=$aggregate->elapsed;my@tests=$aggregate->descriptions;$tot{files}=$tot{tests}=scalar@tests;my%failedtests=();my%todo_passed=();for my$test (@tests){my ($parser)=$aggregate->parsers($test);my@failed=$parser->failed;my$wstat=$parser->wait;my$estat=$parser->exit;my$planned=$parser->tests_planned;my@errors=$parser->parse_errors;my$passed=$parser->passed;my$actual_passed=$parser->actual_passed;my$ok_seq=_check_sequence($parser->actual_passed);$estat ||= '' unless$wstat;$wstat ||= '';$tot{max}+= ($planned || 0);$tot{bonus}+= $parser->todo_passed;$tot{ok}+= $passed > $actual_passed ? $passed : $actual_passed;$tot{sub_skipped}+= $parser->skipped;$tot{todo}+= $parser->todo;if (@failed || $estat || @errors){$tot{bad}++;my$huh_planned=$planned ? undef : '??';my$huh_errors=$ok_seq ? undef : '??';$failedtests{$test}={'canon'=>$huh_planned || $huh_errors || _canon(@failed)|| '??','estat'=>$estat,'failed'=>$huh_planned || $huh_errors || scalar@failed,'max'=>$huh_planned || $planned,'name'=>$test,'wstat'=>$wstat }}else {$tot{good}++}my@todo=$parser->todo_passed;if (@todo){$todo_passed{$test}={'canon'=>_canon(@todo),'estat'=>$estat,'failed'=>scalar@todo,'max'=>scalar$parser->todo,'name'=>$test,'wstat'=>$wstat }}}return (\%tot,\%failedtests,\%todo_passed)}1;
TEST_HARNESS
$fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TINY';
package Try::Tiny;use 5.006;our$VERSION='0.28';use strict;use warnings;use Exporter 5.57 'import';our@EXPORT=our@EXPORT_OK=qw(try catch finally);use Carp;$Carp::Internal{+__PACKAGE__}++;BEGIN {my$su=$INC{'Sub/Util.pm'}&& defined&Sub::Util::set_subname;my$sn=$INC{'Sub/Name.pm'}&& eval {Sub::Name->VERSION(0.08)};unless ($su || $sn){$su=eval {require Sub::Util}&& defined&Sub::Util::set_subname;unless ($su){$sn=eval {require Sub::Name;Sub::Name->VERSION(0.08)}}}*_subname=$su ? \&Sub::Util::set_subname : $sn ? \&Sub::Name::subname : sub {$_[1]};*_HAS_SUBNAME=($su || $sn)? sub(){1}: sub(){0}}my%_finally_guards;sub try (&;@) {my ($try,@code_refs)=@_;my$wantarray=wantarray;my ($catch,@finally)=();for my$code_ref (@code_refs){if (ref($code_ref)eq 'Try::Tiny::Catch'){croak 'A try() may not be followed by multiple catch() blocks' if$catch;$catch=${$code_ref}}elsif (ref($code_ref)eq 'Try::Tiny::Finally'){push@finally,${$code_ref}}else {croak('try() encountered an unexpected argument (' .(defined$code_ref ? $code_ref : 'undef').') - perhaps a missing semi-colon before or')}}my$caller=caller;_subname("${caller}::try {...} "=>$try)if _HAS_SUBNAME;local$_finally_guards{guards}=[map {Try::Tiny::ScopeGuard->_new($_)}@finally ];my$prev_error=$@;my (@ret,$error);my$failed=not eval {$@=$prev_error;if ($wantarray){@ret=$try->()}elsif (defined$wantarray){$ret[0]=$try->()}else {$try->()};return 1};$error=$@;$@=$prev_error;if ($failed){push @$_,$error for @{$_finally_guards{guards}};if ($catch){for ($error){return$catch->($error)}}return}else {return$wantarray ? @ret : $ret[0]}}sub catch (&;@) {my ($block,@rest)=@_;croak 'Useless bare catch()' unless wantarray;my$caller=caller;_subname("${caller}::catch {...} "=>$block)if _HAS_SUBNAME;return (bless(\$block,'Try::Tiny::Catch'),@rest,)}sub finally (&;@) {my ($block,@rest)=@_;croak 'Useless bare finally()' unless wantarray;my$caller=caller;_subname("${caller}::finally {...} "=>$block)if _HAS_SUBNAME;return (bless(\$block,'Try::Tiny::Finally'),@rest,)}{package Try::Tiny::ScopeGuard;use constant UNSTABLE_DOLLARAT=>("$]" < '5.013002')? 1 : 0;sub _new {shift;bless [@_ ]}sub DESTROY {my ($code,@args)=@{$_[0]};local $@ if UNSTABLE_DOLLARAT;eval {$code->(@args);1}or do {warn "Execution of finally() block $code resulted in an exception, which " .'*CAN NOT BE PROPAGATED* due to fundamental limitations of Perl. ' .'Your program will continue as if this event never took place. ' ."Original exception text follows:\n\n" .(defined $@ ? $@ : '$@ left undefined...')."\n" }}}__PACKAGE__
TRY_TINY
$fatpacked{"parent.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARENT';
package parent;use strict;use vars qw($VERSION);$VERSION='0.236';sub import {my$class=shift;my$inheritor=caller(0);if (@_ and $_[0]eq '-norequire'){shift @_}else {for (my@filename=@_){s{::|'}{/}g;require "$_.pm"}}{no strict 'refs';push @{"$inheritor\::ISA"},@_}};1;
PARENT
$fatpacked{"version.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION';
package version;use 5.006002;use strict;use warnings::register;if ($] >= 5.015){warnings::register_categories(qw/version/)}use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);$VERSION=0.9918;$CLASS='version';{local$SIG{'__DIE__'};eval "use version::vxs $VERSION";if ($@){eval "use version::vpp $VERSION";die "$@" if ($@);push@ISA,"version::vpp";local $^W;*version::qv=\&version::vpp::qv;*version::declare=\&version::vpp::declare;*version::_VERSION=\&version::vpp::_VERSION;*version::vcmp=\&version::vpp::vcmp;*version::new=\&version::vpp::new;*version::numify=\&version::vpp::numify;*version::normal=\&version::vpp::normal;if ($] >= 5.009000){no strict 'refs';*version::stringify=\&version::vpp::stringify;*{'version::(""'}=\&version::vpp::stringify;*{'version::(<=>'}=\&version::vpp::vcmp;*{'version::(cmp'}=\&version::vpp::vcmp;*version::parse=\&version::vpp::parse}}else {push@ISA,"version::vxs";local $^W;*version::declare=\&version::vxs::declare;*version::qv=\&version::vxs::qv;*version::_VERSION=\&version::vxs::_VERSION;*version::vcmp=\&version::vxs::VCMP;*version::new=\&version::vxs::new;*version::numify=\&version::vxs::numify;*version::normal=\&version::vxs::normal;if ($] >= 5.009000){no strict 'refs';*version::stringify=\&version::vxs::stringify;*{'version::(""'}=\&version::vxs::stringify;*{'version::(<=>'}=\&version::vxs::VCMP;*{'version::(cmp'}=\&version::vxs::VCMP;*version::parse=\&version::vxs::parse}}}require version::regex;*version::is_lax=\&version::regex::is_lax;*version::is_strict=\&version::regex::is_strict;*LAX=\$version::regex::LAX;*LAX_DECIMAL_VERSION=\$version::regex::LAX_DECIMAL_VERSION;*LAX_DOTTED_DECIMAL_VERSION=\$version::regex::LAX_DOTTED_DECIMAL_VERSION;*STRICT=\$version::regex::STRICT;*STRICT_DECIMAL_VERSION=\$version::regex::STRICT_DECIMAL_VERSION;*STRICT_DOTTED_DECIMAL_VERSION=\$version::regex::STRICT_DOTTED_DECIMAL_VERSION;sub import {no strict 'refs';my ($class)=shift;unless ($class eq $CLASS){local $^W;*{$class.'::declare'}=\&{$CLASS.'::declare'};*{$class.'::qv'}=\&{$CLASS.'::qv'}}my%args;if (@_){map {$args{$_}=1}@_}else {%args=(qv=>1,'UNIVERSAL::VERSION'=>1,)}my$callpkg=caller();if (exists($args{declare})){*{$callpkg.'::declare'}=sub {return$class->declare(shift)}unless defined(&{$callpkg.'::declare'})}if (exists($args{qv})){*{$callpkg.'::qv'}=sub {return$class->qv(shift)}unless defined(&{$callpkg.'::qv'})}if (exists($args{'UNIVERSAL::VERSION'})){local $^W;*UNIVERSAL::VERSION =\&{$CLASS.'::_VERSION'}}if (exists($args{'VERSION'})){*{$callpkg.'::VERSION'}=\&{$CLASS.'::_VERSION'}}if (exists($args{'is_strict'})){*{$callpkg.'::is_strict'}=\&{$CLASS.'::is_strict'}unless defined(&{$callpkg.'::is_strict'})}if (exists($args{'is_lax'})){*{$callpkg.'::is_lax'}=\&{$CLASS.'::is_lax'}unless defined(&{$callpkg.'::is_lax'})}}1;
VERSION
$fatpacked{"version/regex.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_REGEX';
package version::regex;use strict;use vars qw($VERSION $CLASS $STRICT $LAX $STRICT_DECIMAL_VERSION $STRICT_DOTTED_DECIMAL_VERSION $LAX_DECIMAL_VERSION $LAX_DOTTED_DECIMAL_VERSION);$VERSION=0.9918;my$FRACTION_PART=qr/\.[0-9]+/;my$STRICT_INTEGER_PART=qr/0|[1-9][0-9]*/;my$LAX_INTEGER_PART=qr/[0-9]+/;my$STRICT_DOTTED_DECIMAL_PART=qr/\.[0-9]{1,3}/;my$LAX_DOTTED_DECIMAL_PART=qr/\.[0-9]+/;my$LAX_ALPHA_PART=qr/_[0-9]+/;$STRICT_DECIMAL_VERSION=qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;$STRICT_DOTTED_DECIMAL_VERSION=qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;$STRICT=qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;$LAX_DECIMAL_VERSION=qr/ $LAX_INTEGER_PART (?: $FRACTION_PART | \. )? $LAX_ALPHA_PART?
|
$FRACTION_PART $LAX_ALPHA_PART?
/x;$LAX_DOTTED_DECIMAL_VERSION=qr/
v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )?
|
$LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART?
/x;$LAX=qr/ undef | $LAX_DOTTED_DECIMAL_VERSION | $LAX_DECIMAL_VERSION /x;sub is_strict {defined $_[0]&& $_[0]=~ qr/ \A $STRICT \z /x}sub is_lax {defined $_[0]&& $_[0]=~ qr/ \A $LAX \z /x}1;
VERSION_REGEX
$fatpacked{"version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_VPP';
package charstar;use overload ('""'=>\&thischar,'0+'=>\&thischar,'++'=>\&increment,'--'=>\&decrement,'+'=>\&plus,'-'=>\&minus,'*'=>\&multiply,'cmp'=>\&cmp,'<=>'=>\&spaceship,'bool'=>\&thischar,'='=>\&clone,);sub new {my ($self,$string)=@_;my$class=ref($self)|| $self;my$obj={string=>[split(//,$string)],current=>0,};return bless$obj,$class}sub thischar {my ($self)=@_;my$last=$#{$self->{string}};my$curr=$self->{current};if ($curr >= 0 && $curr <= $last){return$self->{string}->[$curr]}else {return ''}}sub increment {my ($self)=@_;$self->{current}++}sub decrement {my ($self)=@_;$self->{current}--}sub plus {my ($self,$offset)=@_;my$rself=$self->clone;$rself->{current}+= $offset;return$rself}sub minus {my ($self,$offset)=@_;my$rself=$self->clone;$rself->{current}-= $offset;return$rself}sub multiply {my ($left,$right,$swapped)=@_;my$char=$left->thischar();return$char * $right}sub spaceship {my ($left,$right,$swapped)=@_;unless (ref($right)){$right=$left->new($right)}return$left->{current}<=> $right->{current}}sub cmp {my ($left,$right,$swapped)=@_;unless (ref($right)){if (length($right)==1){return$left->thischar cmp $right}$right=$left->new($right)}return$left->currstr cmp $right->currstr}sub bool {my ($self)=@_;my$char=$self->thischar;return ($char ne '')}sub clone {my ($left,$right,$swapped)=@_;$right={string=>[@{$left->{string}}],current=>$left->{current},};return bless$right,ref($left)}sub currstr {my ($self,$s)=@_;my$curr=$self->{current};my$last=$#{$self->{string}};if (defined($s)&& $s->{current}< $last){$last=$s->{current}}my$string=join('',@{$self->{string}}[$curr..$last]);return$string}package version::vpp;use 5.006002;use strict;use warnings::register;use Config;use vars qw($VERSION $CLASS @ISA $LAX $STRICT $WARN_CATEGORY);$VERSION=0.9918;$CLASS='version::vpp';if ($] > 5.015){warnings::register_categories(qw/version/);$WARN_CATEGORY='version'}else {$WARN_CATEGORY='numeric'}require version::regex;*version::vpp::is_strict=\&version::regex::is_strict;*version::vpp::is_lax=\&version::regex::is_lax;*LAX=\$version::regex::LAX;*STRICT=\$version::regex::STRICT;use overload ('""'=>\&stringify,'0+'=>\&numify,'cmp'=>\&vcmp,'<=>'=>\&vcmp,'bool'=>\&vbool,'+'=>\&vnoop,'-'=>\&vnoop,'*'=>\&vnoop,'/'=>\&vnoop,'+='=>\&vnoop,'-='=>\&vnoop,'*='=>\&vnoop,'/='=>\&vnoop,'abs'=>\&vnoop,);sub import {no strict 'refs';my ($class)=shift;unless ($class eq $CLASS){local $^W;*{$class.'::declare'}=\&{$CLASS.'::declare'};*{$class.'::qv'}=\&{$CLASS.'::qv'}}my%args;if (@_){map {$args{$_}=1}@_}else {%args=(qv=>1,'UNIVERSAL::VERSION'=>1,)}my$callpkg=caller();if (exists($args{declare})){*{$callpkg.'::declare'}=sub {return$class->declare(shift)}unless defined(&{$callpkg.'::declare'})}if (exists($args{qv})){*{$callpkg.'::qv'}=sub {return$class->qv(shift)}unless defined(&{$callpkg.'::qv'})}if (exists($args{'UNIVERSAL::VERSION'})){no warnings qw/redefine/;*UNIVERSAL::VERSION =\&{$CLASS.'::_VERSION'}}if (exists($args{'VERSION'})){*{$callpkg.'::VERSION'}=\&{$CLASS.'::_VERSION'}}if (exists($args{'is_strict'})){*{$callpkg.'::is_strict'}=\&{$CLASS.'::is_strict'}unless defined(&{$callpkg.'::is_strict'})}if (exists($args{'is_lax'})){*{$callpkg.'::is_lax'}=\&{$CLASS.'::is_lax'}unless defined(&{$callpkg.'::is_lax'})}}my$VERSION_MAX=0x7FFFFFFF;use constant TRUE=>1;use constant FALSE=>0;sub isDIGIT {my ($char)=shift->thischar();return ($char =~ /\d/)}sub isALPHA {my ($char)=shift->thischar();return ($char =~ /[a-zA-Z]/)}sub isSPACE {my ($char)=shift->thischar();return ($char =~ /\s/)}sub BADVERSION {my ($s,$errstr,$error)=@_;if ($errstr){$$errstr=$error}return$s}sub prescan_version {my ($s,$strict,$errstr,$sqv,$ssaw_decimal,$swidth,$salpha)=@_;my$qv=defined$sqv ? $$sqv : FALSE;my$saw_decimal=defined$ssaw_decimal ? $$ssaw_decimal : 0;my$width=defined$swidth ? $$swidth : 3;my$alpha=defined$salpha ? $$salpha : FALSE;my$d=$s;if ($qv && isDIGIT($d)){goto dotted_decimal_version}if ($d eq 'v'){$d++;if (isDIGIT($d)){$qv=TRUE}else {return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}dotted_decimal_version: if ($strict && $d eq '0' && isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)")}while (isDIGIT($d)){$d++}if ($d eq '.'){$saw_decimal++;$d++}else {if ($strict){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}else {goto version_prescan_finish}}{my$i=0;my$j=0;while (isDIGIT($d)){$i++;while (isDIGIT($d)){$d++;$j++;if ($strict && $j > 3){return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)")}}if ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)")}$d++;$alpha=TRUE}elsif ($d eq '.'){if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)")}$saw_decimal++;$d++}elsif (!isDIGIT($d)){last}$j=0}if ($strict && $i < 2){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}}}else {my$j=0;if ($strict){if ($d eq '.'){return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)")}if ($d eq '0' && isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)")}}if ($d eq '-'){return BADVERSION($s,$errstr,"Invalid version format (negative version number)")}while (isDIGIT($d)){$d++}if ($d eq '.'){$saw_decimal++;$d++}elsif (!$d || $d eq ';' || isSPACE($d)|| $d eq '}'){if ($d==$s){return BADVERSION($s,$errstr,"Invalid version format (version required)")}goto version_prescan_finish}elsif ($d==$s){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}elsif ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}elsif (isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)")}else {return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)")}}elsif ($d){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}if ($d &&!isDIGIT($d)&& ($strict ||!($d eq ';' || isSPACE($d)|| $d eq '}'))){return BADVERSION($s,$errstr,"Invalid version format (fractional part required)")}while (isDIGIT($d)){$d++;$j++;if ($d eq '.' && isDIGIT($d-1)){if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)")}if ($strict){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')")}$d=$s;$qv=TRUE;goto dotted_decimal_version}if ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)")}if (!isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)")}$width=$j;$d++;$alpha=TRUE}}}version_prescan_finish: while (isSPACE($d)){$d++}if ($d &&!isDIGIT($d)&& (!($d eq ';' || $d eq '}'))){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}if ($saw_decimal > 1 && ($d-1)eq '.'){return BADVERSION($s,$errstr,"Invalid version format (trailing decimal)")}if (defined$sqv){$$sqv=$qv}if (defined$swidth){$$swidth=$width}if (defined$ssaw_decimal){$$ssaw_decimal=$saw_decimal}if (defined$salpha){$$salpha=$alpha}return$d}sub scan_version {my ($s,$rv,$qv)=@_;my$start;my$pos;my$last;my$errstr;my$saw_decimal=0;my$width=3;my$alpha=FALSE;my$vinf=FALSE;my@av;$s=new charstar$s;while (isSPACE($s)){$s++}$last=prescan_version($s,FALSE,\$errstr,\$qv,\$saw_decimal,\$width,\$alpha);if ($errstr){if ($s ne 'undef'){require Carp;Carp::croak($errstr)}}$start=$s;if ($s eq 'v'){$s++}$pos=$s;if ($qv){$$rv->{qv}=$qv}if ($alpha){$$rv->{alpha}=$alpha}if (!$qv && $width < 3){$$rv->{width}=$width}while (isDIGIT($pos)|| $pos eq '_'){$pos++}if (!isALPHA($pos)){my$rev;for (;;){$rev=0;{my$end=$pos;my$mult=1;my$orev;if (!$qv && $s > $start && $saw_decimal==1){$mult *= 100;while ($s < $end){next if$s eq '_';$orev=$rev;$rev += $s * $mult;$mult /= 10;if ((abs($orev)> abs($rev))|| (abs($rev)> $VERSION_MAX)){warn("Integer overflow in version %d",$VERSION_MAX);$s=$end - 1;$rev=$VERSION_MAX;$vinf=1}$s++;if ($s eq '_'){$s++}}}else {while (--$end >= $s){next if$end eq '_';$orev=$rev;$rev += $end * $mult;$mult *= 10;if ((abs($orev)> abs($rev))|| (abs($rev)> $VERSION_MAX)){warn("Integer overflow in version");$end=$s - 1;$rev=$VERSION_MAX;$vinf=1}}}}push@av,$rev;if ($vinf){$s=$last;last}elsif ($pos eq '.'){$s=++$pos}elsif ($pos eq '_' && isDIGIT($pos+1)){$s=++$pos}elsif ($pos eq ',' && isDIGIT($pos+1)){$s=++$pos}elsif (isDIGIT($pos)){$s=$pos}else {$s=$pos;last}if ($qv){while (isDIGIT($pos)|| $pos eq '_'){$pos++}}else {my$digits=0;while ((isDIGIT($pos)|| $pos eq '_')&& $digits < 3){if ($pos ne '_'){$digits++}$pos++}}}}if ($qv){my$len=$#av;$len=2 - $len;while ($len-- > 0){push@av,0}}if ($vinf){$$rv->{original}="v.Inf";$$rv->{vinf}=1}elsif ($s > $start){$$rv->{original}=$start->currstr($s);if ($qv && $saw_decimal==1 && $start ne 'v'){$$rv->{original}='v' .$$rv->{original}}}else {$$rv->{original}='0';push(@av,0)}$$rv->{version}=\@av;if ($s eq 'undef'){$s += 5}return$s}sub new {my$class=shift;unless (defined$class or $#_ > 1){require Carp;Carp::croak('Usage: version::new(class, version)')}my$self=bless ({},ref ($class)|| $class);my$qv=FALSE;if ($#_==1){$qv=TRUE}my$value=pop;if (ref($value)&& eval('$value->isa("version")')){$self->{version}=[@{$value->{version}}];$self->{qv}=1 if$value->{qv};$self->{alpha}=1 if$value->{alpha};$self->{original}=''.$value->{original};return$self}if (not defined$value or $value =~ /^undef$/){push @{$self->{version}},0;$self->{original}="0";return ($self)}if (ref($value)=~ m/ARRAY|HASH/){require Carp;Carp::croak("Invalid version format (non-numeric data)")}$value=_un_vstring($value);if ($Config{d_setlocale}){use POSIX qw/locale_h/;use if$Config{d_setlocale},'locale';my$currlocale=setlocale(LC_ALL);if (localeconv()->{decimal_point}eq ','){$value =~ tr/,/./}}if ($value =~ /\d+.?\d*e[-+]?\d+/){$value=sprintf("%.9f",$value);$value =~ s/(0+)$//}my$s=scan_version($value,\$self,$qv);if ($s){warn(sprintf "Version string '%s' contains invalid data; " ."ignoring: '%s'",$value,$s)}return ($self)}*parse=\&new;sub numify {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}my$alpha=$self->{alpha}|| "";my$len=$#{$self->{version}};my$digit=$self->{version}[0];my$string=sprintf("%d.",$digit);if ($alpha and warnings::enabled()){warnings::warn($WARN_CATEGORY,'alpha->numify() is lossy')}for (my$i=1 ;$i <= $len ;$i++ ){$digit=$self->{version}[$i];$string .= sprintf("%03d",$digit)}if ($len==0){$string .= sprintf("000")}return$string}sub normal {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}my$len=$#{$self->{version}};my$digit=$self->{version}[0];my$string=sprintf("v%d",$digit);for (my$i=1 ;$i <= $len ;$i++ ){$digit=$self->{version}[$i];$string .= sprintf(".%d",$digit)}if ($len <= 2){for ($len=2 - $len;$len!=0;$len-- ){$string .= sprintf(".%0d",0)}}return$string}sub stringify {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}return exists$self->{original}? $self->{original}: exists$self->{qv}? $self->normal : $self->numify}sub vcmp {my ($left,$right,$swap)=@_;my$class=ref($left);unless (UNIVERSAL::isa($right,$class)){$right=$class->new($right)}if ($swap){($left,$right)=($right,$left)}unless (_verify($left)){require Carp;Carp::croak("Invalid version object")}unless (_verify($right)){require Carp;Carp::croak("Invalid version format")}my$l=$#{$left->{version}};my$r=$#{$right->{version}};my$m=$l < $r ? $l : $r;my$lalpha=$left->is_alpha;my$ralpha=$right->is_alpha;my$retval=0;my$i=0;while ($i <= $m && $retval==0){$retval=$left->{version}[$i]<=> $right->{version}[$i];$i++}if ($retval==0 && $l!=$r){if ($l < $r){while ($i <= $r && $retval==0){if ($right->{version}[$i]!=0){$retval=-1}$i++}}else {while ($i <= $l && $retval==0){if ($left->{version}[$i]!=0){$retval=+1}$i++}}}return$retval}sub vbool {my ($self)=@_;return vcmp($self,$self->new("0"),1)}sub vnoop {require Carp;Carp::croak("operation not supported with version object")}sub is_alpha {my ($self)=@_;return (exists$self->{alpha})}sub qv {my$value=shift;my$class=$CLASS;if (@_){$class=ref($value)|| $value;$value=shift}$value=_un_vstring($value);$value='v'.$value unless$value =~ /(^v|\d+\.\d+\.\d)/;my$obj=$CLASS->new($value);return bless$obj,$class}*declare=\&qv;sub is_qv {my ($self)=@_;return (exists$self->{qv})}sub _verify {my ($self)=@_;if (ref($self)&& eval {exists$self->{version}}&& ref($self->{version})eq 'ARRAY'){return 1}else {return 0}}sub _is_non_alphanumeric {my$s=shift;$s=new charstar$s;while ($s){return 0 if isSPACE($s);return 1 unless (isALPHA($s)|| isDIGIT($s)|| $s =~ /[.-]/);$s++}return 0}sub _un_vstring {my$value=shift;if (length($value)>= 1 && $value !~ /[,._]/ && _is_non_alphanumeric($value)){my$tvalue;if ($] >= 5.008_001){$tvalue=_find_magic_vstring($value);$value=$tvalue if length$tvalue}elsif ($] >= 5.006_000){$tvalue=sprintf("v%vd",$value);if ($tvalue =~ /^v\d+(\.\d+)*$/){$value=$tvalue}}}return$value}sub _find_magic_vstring {my$value=shift;my$tvalue='';require B;my$sv=B::svref_2object(\$value);my$magic=ref($sv)eq 'B::PVMG' ? $sv->MAGIC : undef;while ($magic){if ($magic->TYPE eq 'V'){$tvalue=$magic->PTR;$tvalue =~ s/^v?(.+)$/v$1/;last}else {$magic=$magic->MOREMAGIC}}$tvalue =~ tr/_//d;return$tvalue}sub _VERSION {my ($obj,$req)=@_;my$class=ref($obj)|| $obj;no strict 'refs';if (exists$INC{"$class.pm"}and not %{"$class\::"}and $] >= 5.008){require Carp;Carp::croak("$class defines neither package nor VERSION" ."--version check failed")}my$version=eval "\$$class\::VERSION";if (defined$version){local $^W if $] <= 5.008;$version=version::vpp->new($version)}if (defined$req){unless (defined$version){require Carp;my$msg=$] < 5.006 ? "$class version $req required--this is only version " : "$class does not define \$$class\::VERSION" ."--version check failed";if ($ENV{VERSION_DEBUG}){Carp::confess($msg)}else {Carp::croak($msg)}}$req=version::vpp->new($req);if ($req > $version){require Carp;if ($req->is_qv){Carp::croak(sprintf ("%s version %s required--"."this is only version %s",$class,$req->normal,$version->normal))}else {Carp::croak(sprintf ("%s version %s required--"."this is only version %s",$class,$req->stringify,$version->stringify))}}}return defined$version ? $version->stringify : undef}1;
VERSION_VPP
$fatpacked{"version/vxs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_VXS';
package version::vxs;use v5.10;use strict;use vars qw(@ISA $VERSION $CLASS);$VERSION=0.9918;$CLASS='version::vxs';eval {require XSLoader;local $^W;XSLoader::load('version::vxs',$VERSION);1}or do {require DynaLoader;push@ISA,'DynaLoader';local $^W;bootstrap version::vxs$VERSION};1;
VERSION_VXS
s/^ //mg for values %fatpacked;
my $class = 'FatPacked::'.(0+\%fatpacked);
no strict 'refs';
*{"${class}::files"} = sub { keys %{$_[0]} };
if ($] < 5.008) {
*{"${class}::INC"} = sub {
if (my $fat = $_[0]{$_[1]}) {
my $pos = 0;
my $last = length $fat;
return (sub {
return 0 if $pos == $last;
my $next = (1 + index $fat, "\n", $pos) || $last;
$_ .= substr $fat, $pos, $next - $pos;
$pos = $next;
return 1;
});
}
};
}
else {
*{"${class}::INC"} = sub {
if (my $fat = $_[0]{$_[1]}) {
open my $fh, '<', \$fat
or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
return $fh;
}
return;
};
}
unshift @INC, bless \%fatpacked, $class;
} # END OF FATPACK CODE
#
# This is development version of the check_raid.pl plugin
# If you are running this file directly, you are doing it wrong
#
# See installation notes:
# https://github.com/glensc/nagios-plugin-check_raid#installing
#
use Monitoring::Plugin 0.37;
use App::Monitoring::Plugin::CheckRaid;
use App::Monitoring::Plugin::CheckRaid::Sudoers;
use App::Monitoring::Plugin::CheckRaid::Plugin;
use App::Monitoring::Plugin::CheckRaid::Utils;
use warnings;
use strict;
my $PROGNAME = 'check_raid';
my $VERSION = q/4.0.8-1-gba33c6a/;
my $URL = 'https://github.com/glensc/nagios-plugin-check_raid';
my $BUGS_URL = 'https://github.com/glensc/nagios-plugin-check_raid#reporting-bugs';
my $mp = Monitoring::Plugin->new(
usage =>
"Usage: %s [-h] [-V] [-S] [list of devices to ignore]",
version => $VERSION,
blurb => join($/,
"This plugin checks all RAID volumes (hardware and software) that can be identified",
"",
"Homepage: $URL",
"Reporting Bugs: $BUGS_URL",
),
plugin => $PROGNAME,
shortname => $PROGNAME,
);
$mp->add_arg(
spec => 'sudoers|S',
help => 'Setup sudo rules',
);
$mp->add_arg(
spec => 'warnonly|W',
help => 'Treat CRITICAL errors as WARNING',
);
$mp->add_arg(
spec => 'debug|d',
help => 'debug mode, or dry-run for sudoers',
);
$mp->add_arg(
spec => 'list_plugins|list-plugins|l',
help => 'Lists active plugins',
);
$mp->add_arg(
spec => 'plugin|p=s@',
help => 'Force the use of selected plugins, comma separated',
);
$mp->add_arg(
spec => 'plugin-option=s@',
help => "Specify extra option for specific plugin.\n" .
'
Plugin options (key=>value pairs) passed as "options" key to each plugin constructor.
The options are global, not plugin specific, but it\'s recommended to prefix option with plugin name.
The convention is to have PLUGIN_NAME-OPTION_NAME=OPTION_VALUE syntax to namespace each plugin option.
For example "--plugin-option=hp_msa-serial=/dev/ttyS2"
would define option "serial" for "hp_msa" plugin with value "/dev/ttyS2".
'
);
$mp->add_arg(
spec => 'noraid=s',
help => 'Return STATE if no RAID volumes are found. Defaults to UNKNOWN',
);
$mp->add_arg(
spec => 'resync=s',
help => 'Return STATE if RAID is in resync state. Defaults to WARNING',
);
$mp->add_arg(
spec => 'check=s',
help => 'Return STATE if RAID is in check state. Defaults to OK',
);
$mp->add_arg(
spec => 'cache-fail=s',
help => 'Set status as STATE if Write Cache is present but disabled. Defaults to WARNING',
);
$mp->add_arg(
spec => 'bbulearn=s',
help => 'Return STATE if Backup Battery Unit (BBU) learning cycle is in progress. Defaults to WARNING',
);
$mp->add_arg(
spec => 'bbu-monitoring',
help => 'Enable experimental monitoring of the BBU status',
);
$mp->getopts;
if (@ARGV) {
@App::Monitoring::Plugin::CheckRaid::Utils::ignore = @ARGV;
}
my (%ERRORS) = (OK => 0, WARNING => 1, CRITICAL => 2, UNKNOWN => 3);
my %plugin_options;
if ($mp->opts->warnonly) {
App::Monitoring::Plugin::CheckRaid::Plugin->set_critical_as_warning;
}
if ($mp->opts->get('bbu-monitoring')) {
$plugin_options{options}{bbu_monitoring} = 1;
}
# setup state flags
my %state_flags = (
'resync' => 'resync_status',
'check' => 'check_status',
'noraid' => 'noraid_status',
'bbulearn' => 'bbulearn_status',
'cache-fail' => 'cache_fail_status',
);
while (my($opt, $key) = each %state_flags) {
if (my $value = $mp->opts->get($opt)) {
unless (exists $ERRORS{$value}) {
print "Invalid value: '$value' for --$opt\n";
exit $ERRORS{UNKNOWN};
}
$plugin_options{options}{$key} = $ERRORS{$value};
}
}
# enable only specified plugins
if (my $plugins = $mp->opts->plugin) {
# split, as each value can contain commas
$plugin_options{enable_plugins} = [ map { split(/,/, $_) } @$plugins ];
}
if (my $opts = $mp->opts->get('plugin-option')) {
foreach my $o (@$opts) {
my($k, $v) = split(/=/, $o, 2);
$plugin_options{options}{$k} = $v;
}
}
my $mc = App::Monitoring::Plugin::CheckRaid->new(%plugin_options);
$App::Monitoring::Plugin::CheckRaid::Utils::debug = $mp->opts->debug;
if ($mp->opts->debug) {
print "$PROGNAME $VERSION\n";
print "Visit <$BUGS_URL> how to report bugs\n";
print "Please include output of **ALL** commands in bugreport\n\n";
}
if ($mp->opts->sudoers) {
my $res = sudoers($mp->opts->debug, $mc->active_plugins(1));
$mp->plugin_exit(OK, $res ? "sudoers updated" : "sudoers not updated");
}
my @plugins = $mc->active_plugins;
if (!@plugins) {
$mp->plugin_exit($plugin_options{options}{noraid_status}, "No active plugins (No RAID found)");
}
# print active plugins
if ($mp->opts->list_plugins) {
foreach my $p (@plugins) {
print $p->{name}, "\n";
}
my $count = @plugins;
warn "$count active plugins\n";
exit $ERRORS{OK};
}
my $message = '';
my $status = $ERRORS{OK};
# perform check of each active plugin
foreach my $plugin (@plugins) {
# skip if no check method (not standalone checker)
next unless $plugin->can('check');
# perform the check
$plugin->check;
my $pn = $plugin->{name};
# collect results
unless (defined $plugin->status) {
$status = $ERRORS{UNKNOWN} if $ERRORS{UNKNOWN} > $status;
$message .= '; ' if $message;
$message .= "$pn:[Plugin error]";
next;
}
if ($plugin->message or $plugin->{options}{noraid_status} == $ERRORS{UNKNOWN}) {
$status = $plugin->status if $plugin->status > $status;
} else {
$status = $plugin->{options}{noraid_status} if $plugin->{options}{noraid_status} > $status;
}
$message .= '; ' if $message;
$message .= "$pn:[".$plugin->message."]";
$message .= ' | ' . $plugin->perfdata if $plugin->perfdata;
$message .= "\n" . $plugin->longoutput if $plugin->longoutput;
}
if ($message) {
if ($status == $ERRORS{OK}) {
print "OK: ";
} elsif ($status == $ERRORS{WARNING}) {
print "WARNING: ";
} elsif ($status == $ERRORS{CRITICAL}) {
print "CRITICAL: ";
} else {
print "UNKNOWN: ";
}
print "$message\n";
} elsif ($plugin::options{noraid_status} != $ERRORS{UNKNOWN}) {
$status = $plugin::options{noraid_status};
print "No RAID configuration found\n";
} else {
$status = $ERRORS{UNKNOWN};
print "No RAID configuration found (tried: ", join(', ', @plugins), ")\n";
}
exit $status;