#!/usr/bin/env perl
BEGIN {
local ($x, @ARGV, $/) = ('# __MOBUNDLE_INCLUSION__', __FILE__);
eval($mobundle = (<> =~ m{(^$x.*^$x)}ms)[0]);
}
use 5.010;
my $VERSION = "0.740";
my %config = get_options(
['loglevel|log=s', default => 'INFO'],
['abstract|A=s', environment => 'TG_ABSTRACT', required => 1],
['author|a=s', environment => 'TG_AUTHOR', required => 1],
['email|e=s', environment => 'TG_EMAIL', required => 1],
['name|n=s', environment => 'TG_NAME', required => 1],
['output|o=s', environment => 'TG_OUTPUT'],
['year|y=s', environment => 'TG_YEAR',
default => 1900 + (localtime)[5]],
);
$config{output} //= $config{name};
$config{modules_bundle} = $main::mobundle;
pipeline(
['Renderer::with_template_perlish', template => template()],
['Writer::to_files', filename => $config{output}],
{tap => 'sink'},
)->({structured => \%config});
my $mode = ((stat $config{output})[2] | 0111) & (~umask());
chmod $mode, $config{output};
sub get_options {
my %config;
my @options = qw< usage! help! man! version! >;
my (%fallback_for, @required);
for my $option (@_) {
if (ref $option) {
my ($spec, %opts) = @$option;
push @options, $spec;
my ($name) = split /\|/, $spec, 2;
if (exists $opts{default}) {
$config{$name} = $opts{default};
}
if (exists $opts{environment}) {
$config{$name} = $ENV{$opts{environment}}
if defined $ENV{$opts{environment}};
}
if (exists $opts{fallback}) {
$fallback_for{$name} = $opts{fallback};
}
if (exists $opts{required}) {
push @required, $name;
}
}
else {
push @options, $option;
}
}
GetOptions(\%config, @options)
or pod2usage(-verbose => 99, -sections => 'USAGE');
pod2usage(message => "$0 $VERSION", -verbose => 99,
-sections => ' ') if $config{version};
pod2usage(-verbose => 99, -sections => 'USAGE') if $config{usage};
pod2usage(-verbose => 99, -sections => 'USAGE|EXAMPLES|OPTIONS')
if $config{help};
pod2usage(-verbose => 2) if $config{man};
while (my ($key, $value) = each %fallback_for) {
next if exists $config{$key};
$config{$key} = $value;
}
my @missing = grep { ! exists $config{$_} } @required;
pod2usage(message => "missing options @missing",
-verbose => 99, -sections => 'USAGE')
if @missing;
return %config if wantarray();
return \%config;
}
BEGIN {
my %file_for = (
'Log/Log4perl/Tiny.pm' => <<'END_OF_FILE',
package Log::Log4perl::Tiny;
use strict;
use warnings;
{ our $VERSION = '1.4.0'; }
use Carp;
use POSIX ();
our ($TRACE, $DEBUG, $INFO, $WARN, $ERROR, $FATAL, $OFF, $DEAD);
my ($_instance, %name_of, %format_for, %id_for);
my $LOGDIE_MESSAGE_ON_STDERR = 1;
sub import {
my ($exporter, @list) = @_;
my ($caller, $file, $line) = caller();
no strict 'refs';
if (grep { $_ eq ':full_or_fake' } @list) {
@list = grep { $_ ne ':full_or_fake' } @list;
my $sue = 'use Log::Log4perl (@list)';
eval "
package $caller;
$sue;
1;
" and return;
unshift @list, ':fake';
} ## end if (grep { $_ eq ':full_or_fake'...})
my (%done, $level_set);
ITEM:
for my $item (@list) {
next ITEM if $done{$item};
$done{$item} = 1;
if ($item =~ /^[a-zA-Z]/mxs) {
*{$caller . '::' . $item} = \&{$exporter . '::' . $item};
}
elsif ($item eq ':levels') {
for my $level (qw( TRACE DEBUG INFO WARN ERROR FATAL OFF DEAD )) {
*{$caller . '::' . $level} = \${$exporter . '::' . $level};
}
}
elsif ($item eq ':subs') {
push @list, qw(
ALWAYS TRACE DEBUG INFO WARN ERROR FATAL
LOGWARN LOGDIE LOGEXIT LOGCARP LOGCLUCK LOGCROAK LOGCONFESS
get_logger
);
} ## end elsif ($item eq ':subs')
elsif ($item =~ /\A : (mimic | mask | fake) \z/mxs) {
# module name as a string below to trick Module::ScanDeps
if (!'Log::Log4perl'->can('easy_init')) {
$INC{'Log/Log4perl.pm'} = __FILE__;
*Log::Log4perl::import = sub { };
*Log::Log4perl::easy_init = sub {
my ($pack, $conf) = @_;
if (ref $conf) {
$_instance = __PACKAGE__->new($conf);
$_instance->level($conf->{level})
if exists $conf->{level};
$_instance->format($conf->{format})
if exists $conf->{format};
$_instance->format($conf->{layout})
if exists $conf->{layout};
} ## end if (ref $conf)
elsif (defined $conf) {
$_instance->level($conf);
}
};
} ## end if (!'Log::Log4perl'->...)
} ## end elsif ($item =~ /\A : (mimic | mask | fake) \z/mxs)
elsif ($item eq ':easy') {
push @list, qw( :levels :subs :fake );
}
elsif (lc($item) eq ':dead_if_first') {
get_logger()->_set_level_if_first($DEAD);
$level_set = 1;
}
elsif (lc($item) eq ':no_extra_logdie_message') {
$LOGDIE_MESSAGE_ON_STDERR = 0;
}
} ## end ITEM: for my $item (@list)
if (!$level_set) {
my $logger = get_logger();
$logger->_set_level_if_first($INFO);
$logger->level($logger->level());
}
return;
} ## end sub import
sub new {
my $package = shift;
my %args = ref($_[0]) ? %{$_[0]} : @_;
$args{format} = $args{layout} if exists $args{layout};
my $channels_input = [fh => \*STDERR];
if (exists $args{channels}) {
$channels_input = $args{channels};
}
else {
for my $key (qw< file_append file_create file_insecure file fh >) {
next unless exists $args{$key};
$channels_input = [$key => $args{$key}];
last;
}
} ## end else [ if (exists $args{channels...})]
my $channels = build_channels($channels_input);
$channels = $channels->[0] if @$channels == 1; # remove outer shell
my $self = bless {
fh => $channels,
level => $INFO,
}, $package;
for my $accessor (qw( level fh format )) {
next unless defined $args{$accessor};
$self->$accessor($args{$accessor});
}
$self->format('[%d] [%5p] %m%n') unless exists $self->{format};
if (exists $args{loglocal}) {
my $local = $args{loglocal};
$self->loglocal($_, $local->{$_}) for keys %$local;
}
return $self;
} ## end sub new
sub build_channels {
my @pairs = (@_ && ref($_[0])) ? @{$_[0]} : @_;
my @channels;
while (@pairs) {
my ($key, $value) = splice @pairs, 0, 2;
# some initial validation
croak "build_channels(): undefined key in list"
unless defined $key;
croak "build_channels(): undefined value for key $key"
unless defined $value;
# analyze the key-value pair and set the channel accordingly
my ($channel, $set_autoflush);
if ($key =~ m{\A(?: fh | sub | code | channel )\z}mxs) {
$channel = $value;
}
elsif ($key eq 'file_append') {
open $channel, '>>', $value
or croak "open('$value') for appending: $!";
$set_autoflush = 1;
}
elsif ($key eq 'file_create') {
open $channel, '>', $value
or croak "open('$value') for creating: $!";
$set_autoflush = 1;
}
elsif ($key =~ m{\A file (?: _insecure )? \z}mxs) {
open $channel, $value
or croak "open('$value'): $!";
$set_autoflush = 1;
}
else {
croak "unsupported channel key '$key'";
}
# autoflush new filehandle if applicable
if ($set_autoflush) {
my $previous = select($channel);
$|++;
select($previous);
}
# record the channel, on to the next
push @channels, $channel;
} ## end while (@pairs)
return \@channels;
} ## end sub build_channels
sub get_logger { return $_instance ||= __PACKAGE__->new(); }
sub LOGLEVEL { return get_logger()->level(@_); }
sub LEVELID_FOR {
my $level = shift;
return $id_for{$level} if exists $id_for{$level};
return;
} ## end sub LEVELID_FOR
sub LEVELNAME_FOR {
my $id = shift;
return $name_of{$id} if exists $name_of{$id};
return $id if exists $id_for{$id};
return;
} ## end sub LEVELNAME_FOR
sub loglocal {
my $self = shift;
my $key = shift;
my $retval = delete $self->{loglocal}{$key};
$self->{loglocal}{$key} = shift if @_;
return $retval;
} ## end sub loglocal
sub LOGLOCAL { return get_logger->loglocal(@_) }
sub format {
my $self = shift;
if (@_) {
$self->{format} = shift;
$self->{args} = \my @args;
my $replace = sub {
if (defined $_[2]) { # op with options
my ($num, $opts, $op) = @_[0 .. 2];
push @args, [$op, $opts];
return "%$num$format_for{$op}[0]";
}
if (defined $_[4]) { # op without options
my ($num, $op) = @_[3, 4];
push @args, [$op];
return "%$num$format_for{$op}[0]";
}
# not an op
my $char = ((!defined($_[5])) || ($_[5] eq '%')) ? '' : $_[5];
return '%%' . $char; # keep the percent AND the char, if any
};
# transform into real format
my ($with_options, $standalone) = ('', '');
for my $key (keys %format_for) {
my $type = $format_for{$key}[2] || '';
$with_options .= $key if $type;
$standalone .= $key if $type ne 'required';
}
# quotemeta or land on impossible character class if empty
$_ = length($_) ? quotemeta($_) : '^\\w\\W'
for ($with_options, $standalone);
$self->{format} =~ s<
% # format marker
(?:
(?: # something with options
( -? \d* (?:\.\d+)? ) # number
( (?:\{ .*? \}) ) # options
([$with_options]) # specifier
)
| (?:
( -? \d* (?:\.\d+)? ) # number
([$standalone]) # specifier
)
| (.) # just any char
| \z # just the end of it!
)
>
{
$replace->($1, $2, $3, $4, $5, $6);
}gsmex;
} ## end if (@_)
return $self->{format};
} ## end sub format
*layout = \&format;
sub emit_log {
my ($self, $message) = @_;
my $fh = $self->{fh};
for my $channel ((ref($fh) eq 'ARRAY') ? (@$fh) : ($fh)) {
(ref($channel) eq 'CODE')
? $channel->($message, $self)
: print {$channel} $message;
}
return;
} ## end sub emit_log
sub log {
my $self = shift;
return if $self->{level} == $DEAD;
my $level = shift;
return if $level > $self->{level};
my %data_for = (
level => $level,
message => \@_,
(exists($self->{loglocal}) ? (loglocal => $self->{loglocal}) : ()),
);
my $message = sprintf $self->{format},
map { $format_for{$_->[0]}[1]->(\%data_for, @$_); } @{$self->{args}};
return $self->emit_log($message);
} ## end sub log
sub ALWAYS { return $_instance->log($OFF, @_); }
sub _exit {
my $self = shift || $_instance;
exit $self->{logexit_code} if defined $self->{logexit_code};
exit $Log::Log4perl::LOGEXIT_CODE
if defined $Log::Log4perl::LOGEXIT_CODE;
exit 1;
} ## end sub _exit
sub logwarn {
my $self = shift;
$self->warn(@_);
# default warning when nothing is passed to warn
push @_, "Warning: something's wrong" unless @_;
# add 'at <file> line <line>' unless argument ends in "\n";
my (undef, $file, $line) = caller(1);
push @_, sprintf " at %s line %d.\n", $file, $line
if substr($_[-1], -1, 1) ne "\n";
# go for it!
CORE::warn(@_) if $LOGDIE_MESSAGE_ON_STDERR;
} ## end sub logwarn
sub logdie {
my $self = shift;
$self->fatal(@_);
# default die message when nothing is passed to die
push @_, "Died" unless @_;
# add 'at <file> line <line>' unless argument ends in "\n";
my (undef, $file, $line) = caller(1);
push @_, sprintf " at %s line %d.\n", $file, $line
if substr($_[-1], -1, 1) ne "\n";
# go for it!
CORE::die(@_) if $LOGDIE_MESSAGE_ON_STDERR;
$self->_exit();
} ## end sub logdie
sub logexit {
my $self = shift;
$self->fatal(@_);
$self->_exit();
}
sub logcarp {
my $self = shift;
require Carp;
$Carp::Internal{$_} = 1 for __PACKAGE__;
if ($self->is_warn()) { # avoid unless we're allowed to emit
my $message = Carp::shortmess(@_);
$self->warn($_) for split m{\n}mxs, $message;
}
if ($LOGDIE_MESSAGE_ON_STDERR) {
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
Carp::carp(@_);
}
return;
} ## end sub logcarp
sub logcluck {
my $self = shift;
require Carp;
$Carp::Internal{$_} = 1 for __PACKAGE__;
if ($self->is_warn()) { # avoid unless we're allowed to emit
my $message = Carp::longmess(@_);
$self->warn($_) for split m{\n}mxs, $message;
}
if ($LOGDIE_MESSAGE_ON_STDERR) {
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
Carp::cluck(@_);
}
return;
} ## end sub logcluck
sub logcroak {
my $self = shift;
require Carp;
$Carp::Internal{$_} = 1 for __PACKAGE__;
if ($self->is_fatal()) { # avoid unless we're allowed to emit
my $message = Carp::shortmess(@_);
$self->fatal($_) for split m{\n}mxs, $message;
}
if ($LOGDIE_MESSAGE_ON_STDERR) {
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
Carp::croak(@_);
}
$self->_exit();
} ## end sub logcroak
sub logconfess {
my $self = shift;
require Carp;
$Carp::Internal{$_} = 1 for __PACKAGE__;
if ($self->is_fatal()) { # avoid unless we're allowed to emit
my $message = Carp::longmess(@_);
$self->fatal($_) for split m{\n}mxs, $message;
}
if ($LOGDIE_MESSAGE_ON_STDERR) {
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
Carp::confess(@_);
}
$self->_exit();
} ## end sub logconfess
sub level {
my $self = shift;
$self = $_instance unless ref $self;
if (@_) {
my $level = shift;
return unless exists $id_for{$level};
$self->{level} = $id_for{$level};
$self->{_count}++;
} ## end if (@_)
return $self->{level};
} ## end sub level
sub _set_level_if_first {
my ($self, $level) = @_;
if (!$self->{_count}) {
$self->level($level);
delete $self->{_count};
}
return;
} ## end sub _set_level_if_first
BEGIN {
# Time tracking's start time. Used to be tied to $^T but Log::Log4perl
# does differently and uses Time::HiRes if available
my $has_time_hires;
my $gtod = sub { return (time(), 0) };
eval {
require Time::HiRes;
$has_time_hires = 1;
$gtod = \&Time::HiRes::gettimeofday;
};
my $start_time = [$gtod->()];
# For supporting %R
my $last_log = $start_time;
# Timezones are... differently supported somewhere
my $strftime_has_tz_offset =
POSIX::strftime('%z', localtime()) =~ m<\A [-+] \d{4} \z>mxs;
if (! $strftime_has_tz_offset) {
require Time::Local;
}
{ # alias to the one in Log::Log4perl, for easier switching towards that
no strict 'refs';
*caller_depth = *Log::Log4perl::caller_depth;
}
our $caller_depth;
$caller_depth ||= 0;
# %format_for idea from Log::Tiny by J. M. Adler
%format_for = ( # specifiers according to Log::Log4perl
c => [s => sub { 'main' }],
C => [
s => sub {
my ($internal_package) = caller 0;
my $i = 1;
my $package;
while ($i <= 4) {
($package) = caller $i;
return '*undef*' unless defined $package;
last if $package ne $internal_package;
++$i;
} ## end while ($i <= 4)
return '*undef' if $i > 4;
($package) = caller($i += $caller_depth) if $caller_depth;
return $package;
},
],
d => [
s => sub {
my ($epoch) = @{shift->{tod} ||= [$gtod->()]};
return POSIX::strftime('%Y/%m/%d %H:%M:%S', localtime($epoch));
},
],
D => [
s => sub {
my ($data, $op, $options) = @_;
$options = '{}' unless defined $options;
$options = substr $options, 1, length($options) - 2;
my %flag_for = map { $_ => 1 } split /\s*,\s*/, lc($options);
my ($s, $u) = @{$data->{tod} ||= [$gtod->()]};
$u = substr "000000$u", -6, 6; # padding left with 0
return POSIX::strftime("%Y-%m-%d %H:%M:%S.$u+0000", gmtime $s)
if $flag_for{utc};
my @localtime = localtime $s;
return POSIX::strftime("%Y-%m-%d %H:%M:%S.$u%z", @localtime)
if $strftime_has_tz_offset;
my $sign = '+';
my $offset = Time::Local::timegm(@localtime) - $s;
($sign, $offset) = ('-', -$offset) if $offset < 0;
my $z = sprintf '%s%02d%02d',
$sign, # sign
int($offset / 3600), # hours
(int($offset / 60) % 60); # minutes
return POSIX::strftime("%Y-%m-%d %H:%M:%S.$u$z", @localtime);
},
'optional'
],
e => [
s => sub {
my ($data, $op, $options) = @_;
$data->{tod} ||= [$gtod->()]; # guarantee consistency here
my $local = $data->{loglocal} or return '';
my $key = substr $options, 1, length($options) - 2;
return '' unless exists $local->{$key};
my $target = $local->{$key};
return '' unless defined $target;
my $reft = ref $target or return $target;
return '' unless $reft eq 'CODE';
return $target->($data, $op, $options);
},
'required',
],
F => [
s => sub {
my ($internal_package) = caller 0;
my $i = 1;
my ($package, $file);
while ($i <= 4) {
($package, $file) = caller $i;
return '*undef*' unless defined $package;
last if $package ne $internal_package;
++$i;
} ## end while ($i <= 4)
return '*undef' if $i > 4;
(undef, $file) = caller($i += $caller_depth) if $caller_depth;
return $file;
},
],
H => [
s => sub {
eval { require Sys::Hostname; Sys::Hostname::hostname() }
|| '';
},
],
l => [
s => sub {
my ($internal_package) = caller 0;
my $i = 1;
my ($package, $filename, $line);
while ($i <= 4) {
($package, $filename, $line) = caller $i;
return '*undef*' unless defined $package;
last if $package ne $internal_package;
++$i;
} ## end while ($i <= 4)
return '*undef' if $i > 4;
(undef, $filename, $line) = caller($i += $caller_depth)
if $caller_depth;
my (undef, undef, undef, $subroutine) = caller($i + 1);
$subroutine = "main::" unless defined $subroutine;
return sprintf '%s %s (%d)', $subroutine, $filename, $line;
},
],
L => [
d => sub {
my ($internal_package) = caller 0;
my $i = 1;
my ($package, $line);
while ($i <= 4) {
($package, undef, $line) = caller $i;
return -1 unless defined $package;
last if $package ne $internal_package;
++$i;
} ## end while ($i <= 4)
return -1 if $i > 4;
(undef, undef, $line) = caller($i += $caller_depth)
if $caller_depth;
return $line;
},
],
m => [
s => sub {
join(
(defined $, ? $, : ''),
map { ref($_) eq 'CODE' ? $_->() : $_; } @{shift->{message}}
);
},
],
M => [
s => sub {
my ($internal_package) = caller 0;
my $i = 1;
while ($i <= 4) {
my ($package) = caller $i;
return '*undef*' unless defined $package;
last if $package ne $internal_package;
++$i;
} ## end while ($i <= 4)
return '*undef' if $i > 4;
$i += $caller_depth if $caller_depth;
my (undef, undef, undef, $subroutine) = caller($i + 1);
$subroutine = "main::" unless defined $subroutine;
return $subroutine;
},
],
n => [s => sub { "\n" },],
p => [s => sub { $name_of{shift->{level}} },],
P => [d => sub { $$ },],
r => [
d => sub {
my ($s, $u) = @{shift->{tod} ||= [$gtod->()]};
$s -= $start_time->[0];
my $m = int(($u - $start_time->[1]) / 1000);
($s, $m) = ($s - 1, $m + 1000) if $m < 0;
return $m + 1000 * $s;
},
],
R => [
d => sub {
my ($sx, $ux) = @{shift->{tod} ||= [$gtod->()]};
my $s = $sx - $last_log->[0];
my $m = int(($ux - $last_log->[1]) / 1000);
($s, $m) = ($s - 1, $m + 1000) if $m < 0;
$last_log = [$sx, $ux];
return $m + 1000 * $s;
},
],
T => [
s => sub {
my ($internal_package) = caller 0;
my $level = 1;
while ($level <= 4) {
my ($package) = caller $level;
return '*undef*' unless defined $package;
last if $package ne $internal_package;
++$level;
} ## end while ($level <= 4)
return '*undef' if $level > 4;
# usage of Carp::longmess() and substitutions is mostly copied
# from Log::Log4perl for better alignment and easier
# transition to the "bigger" module
local $Carp::CarpLevel =
$Carp::CarpLevel + $level + $caller_depth;
chomp(my $longmess = Carp::longmess());
$longmess =~ s{(?:\A\s*at.*?\n|^\s*)}{}mxsg;
$longmess =~ s{\n}{, }g;
return $longmess;
},
],
);
# From now on we're going to play with GLOBs...
no strict 'refs';
for my $name (qw( FATAL ERROR WARN INFO DEBUG TRACE )) {
# create the ->level methods
*{__PACKAGE__ . '::' . lc($name)} = sub {
my $self = shift;
return $self->log($$name, @_);
};
# create ->is_level and ->isLevelEnabled methods as well
*{__PACKAGE__ . '::is' . ucfirst(lc($name)) . 'Enabled'} =
*{__PACKAGE__ . '::is_' . lc($name)} = sub {
return 0 if $_[0]->{level} == $DEAD || $$name > $_[0]->{level};
return 1;
};
} ## end for my $name (qw( FATAL ERROR WARN INFO DEBUG TRACE ))
for my $name (
qw(
FATAL ERROR WARN INFO DEBUG TRACE
LOGWARN LOGDIE LOGEXIT
LOGCARP LOGCLUCK LOGCROAK LOGCONFESS
)
)
{
*{__PACKAGE__ . '::' . $name} = sub {
$_instance->can(lc $name)->($_instance, @_);
};
} ## end for my $name (qw( FATAL ERROR WARN INFO DEBUG TRACE...))
for my $accessor (qw( fh logexit_code )) {
*{__PACKAGE__ . '::' . $accessor} = sub {
my $self = shift;
$self = $_instance unless ref $self;
$self->{$accessor} = shift if @_;
return $self->{$accessor};
};
} ## end for my $accessor (qw( fh logexit_code ))
my $index = -1;
for my $name (qw( DEAD OFF FATAL ERROR WARN INFO DEBUG TRACE )) {
$name_of{$$name = $index} = $name;
$id_for{$name} = $index;
$id_for{$index} = $index;
++$index;
} ## end for my $name (qw( DEAD OFF FATAL ERROR WARN INFO DEBUG TRACE ))
get_logger(); # initialises $_instance;
} ## end BEGIN
1; # Magic true value required at end of module
END_OF_FILE
'Mo.pm' => <<'END_OF_FILE',
package Mo;
$VERSION=0.39;
no warnings;my$M=__PACKAGE__.'::';*{$M.Object::new}=sub{my$c=shift;my$s=bless{@_},$c;my%n=%{$c.::.':E'};map{$s->{$_}=$n{$_}->()if!exists$s->{$_}}keys%n;$s};*{$M.import}=sub{import warnings;$^H|=1538;my($P,%e,%o)=caller.'::';shift;eval"no Mo::$_",&{$M.$_.::e}($P,\%e,\%o,\@_)for@_;return if$e{M};%e=(extends,sub{eval"no $_[0]()";@{$P.ISA}=$_[0]},has,sub{my$n=shift;my$m=sub{$#_?$_[0]{$n}=$_[1]:$_[0]{$n}};@_=(default,@_)if!($#_%2);$m=$o{$_}->($m,$n,@_)for sort keys%o;*{$P.$n}=$m},%e,);*{$P.$_}=$e{$_}for keys%e;@{$P.ISA}=$M.Object};
END_OF_FILE
'Mo/default.pm' => <<'END_OF_FILE',
package Mo::default;my$M="Mo::";
$VERSION=0.39;
*{$M.'default::e'}=sub{my($P,$e,$o)=@_;$o->{default}=sub{my($m,$n,%a)=@_;exists$a{default}or return$m;my($d,$r)=$a{default};my$g='HASH'eq($r=ref$d)?sub{+{%$d}}:'ARRAY'eq$r?sub{[@$d]}:'CODE'eq$r?$d:sub{$d};my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=$g and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$g->(@_):$m->(@_)}}};
END_OF_FILE
'Template/Perlish.pm' => <<'END_OF_FILE',
package Template::Perlish;
# vim: ts=3 sts=3 sw=3 et ai :
use 5.008_000;
use warnings;
use strict;
use Carp;
use English qw( -no_match_vars );
use constant ERROR_CONTEXT => 3;
{ our $VERSION = '1.56'; }
use Scalar::Util qw< blessed reftype >;
# Function-oriented interface
sub import {
my ($package, @list) = @_;
for my $sub (@list) {
croak "subroutine '$sub' not exportable"
unless grep { $sub eq $_ } qw< crumble render traverse >;
my $caller = caller();
no strict 'refs'; ## no critic (ProhibitNoStrict)
local $SIG{__WARN__} = \&Carp::carp;
*{$caller . q<::> . $sub} = \&{$package . q<::> . $sub};
} ## end for my $sub (@list)
return;
} ## end sub import
sub render {
my ($template, @rest) = @_;
my ($variables, %params);
if (@rest) {
$variables = ref($rest[0]) ? shift(@rest) : {splice @rest, 0};
%params = %{shift @rest} if @rest;
}
return __PACKAGE__->new(%params)->process($template, $variables);
} ## end sub render
# Object-oriented interface
{
my (%preset_for, %inhibits_defaults);
BEGIN {
%preset_for = (
'default' => {
method_over_key => 0,
start => '[%',
stdout => 1,
stop => '%]',
strict_blessed => 0,
traverse_methods => 0,
utf8 => 1,
},
'1.52' => {
method_over_key => 1,
stdout => 0,
traverse_methods => 1,
},
);
# some defaults are inhibited by the presence of certain input
# parameters. These parameters can still be put externally, though.
%inhibits_defaults = (
binmode => [qw< utf8 >],
);
}
sub new {
my $package = shift;
my %external;
if (@_ == 1) {
%external = %{$_[0]};
}
elsif (scalar(@_) % 2 == 0) {
while (@_) {
my ($key, $value) = splice @_, 0, 2;
if ($key eq '-preset') {
croak "invalid preset $value in new()"
unless exists $preset_for{$value};
%external = (%external, %{$preset_for{$value}});
}
else {
$external{$key} = $value;
}
}
}
else {
croak 'invalid number of input arguments for constructor';
}
# compute defaults, removing inhibitions
my %defaults =(%{$preset_for{'default'}}, variables => {});
for my $inhibitor (keys %inhibits_defaults) {
next unless exists $external{$inhibitor};
delete $defaults{$_} for @{$inhibits_defaults{$inhibitor}};
}
return bless {%defaults, %external}, $package;
} ## end sub new
}
sub process {
my ($self, $template, $vars) = @_;
return $self->evaluate($self->compile($template), $vars);
}
sub evaluate {
my ($self, $compiled, $vars) = @_;
$self->_compile_sub($compiled)
unless exists $compiled->{sub};
return $compiled->{sub}->($vars);
} ## end sub evaluate
sub compile { ## no critic (RequireArgUnpacking)
my ($self, undef, %args) = @_;
my $outcome = $self->_compile_code_text($_[1]);
return $outcome if $args{no_check};
return $self->_compile_sub($outcome);
} ## end sub compile
sub compile_as_sub { ## no critic (RequireArgUnpacking)
my $self = shift;
return $self->compile($_[0])->{'sub'};
}
sub _compile_code_text {
my ($self, $template) = @_;
my $starter = $self->{start};
my $stopper = $self->{stop};
my $compiled = "# line 1 'input'\n";
$compiled .= "use utf8;\n\n" if $self->{utf8};
$compiled .= "P('');\n\n";
my $pos = 0;
my $line_no = 1;
while ($pos < length $template) {
# Find starter and emit all previous text as simple text
my $start = index $template, $starter, $pos;
last if $start < 0;
my $chunk = substr $template, $pos, $start - $pos;
$compiled .= _simple_text($chunk)
if $start > $pos;
# Update scanning variables. The line counter is advanced for
# the chunk but not yet for the $starter, so that error reporting
# for unmatched $starter will point to the correct line
$pos = $start + length $starter;
$line_no += ($chunk =~ tr/\n//);
# Grab code
my $stop = index $template, $stopper, $pos;
if ($stop < 0) { # no matching $stopper, bummer!
my $section = _extract_section({template => $template}, $line_no);
croak "unclosed starter '$starter' at line $line_no\n$section";
}
my $code = substr $template, $pos, $stop - $pos;
# Now I can advance the line count considering the $starter too
$line_no += ($starter =~ tr/\n//);
if (length $code) {
if (my $path = crumble($code)) {
$compiled .= _variable($path);
}
elsif (my ($scalar) =
$code =~ m{\A\s* (\$ [[:alpha:]_]\w*) \s*\z}mxs)
{
$compiled .=
"\nP($scalar); ### straight scalar\n\n";
} ## end elsif (my ($scalar) = $code...)
elsif (substr($code, 0, 1) eq q<=>) {
$compiled .= "\n# line $line_no 'template<3,$line_no>'\n"
. _expression(substr $code, 1);
}
else {
$compiled .=
"\n# line $line_no 'template<0,$line_no>'\n" . $code;
}
} ## end if (length $code)
# Update scanning variables
$pos = $stop + length $stopper;
$line_no += (($code . $stopper) =~ tr/\n//);
} ## end while ($pos < length $template)
# put last part of input string as simple text
$compiled .= _simple_text(substr($template, $pos || 0));
return {
template => $template,
code_text => $compiled,
};
} ## end sub _compile_code_text
# The following function is long and complex because it deals with many
# different cases. It is kept as-is to avoid too many calls to other
# subroutines; for this reason, it's reasonably commented.
sub traverse { ## no critic (RequireArgUnpacking,ProhibitExcessComplexity)
## no critic (ProhibitDoubleSigils)
my $iref = ref($_[0]);
my $ref_wanted = ($iref eq 'SCALAR') || ($iref eq 'REF');
my $ref_to_value = $ref_wanted ? shift : \shift;
# early detection of options, remove them from args list
my $opts = (@_ && (ref($_[-1]) eq 'HASH')) ? pop(@_) : {};
# if there's not $path provided, just don't bother going on. Actually,
# no $path means just return root, undefined path is always "not
# present" though.
return ($ref_wanted ? $ref_to_value : $$ref_to_value) unless @_;
my $path_input = shift;
return ($ref_wanted ? undef : '') unless defined $path_input;
my $crumbs;
if (ref $path_input) {
$crumbs = $path_input;
}
else {
return ($ref_wanted ? $ref_to_value : $$ref_to_value)
if defined($path_input) && !length($path_input);
$crumbs = crumble($path_input);
}
return ($ref_wanted ? undef : '') unless defined $crumbs;
# go down the rabbit hole
my $use_method = $opts->{traverse_methods} || 0;
my ($strict_blessed, $method_pre) = (0, 0);
if ($use_method) {
$strict_blessed = $opts->{strict_blessed} || 0;
$method_pre = (! $strict_blessed && $opts->{method_over_key}) || 0;
}
for my $crumb (@$crumbs) {
# $key is what we will look into $$ref_to_value. We don't use
# $crumb directly as we might change $key in the loop, and we
# don't want to spoil $crumbs
my $key = $crumb;
# $ref tells me how to look down into $$ref_to_value, i.e. as
# an ARRAY or a HASH... or object
my $ref = reftype $$ref_to_value;
# if $ref is not true, we hit a wall. How we proceed depends on
# whether we were asked to auto-vivify or not.
if (!$ref) {
return '' unless $ref_wanted; # don't bother going on
# auto-vivification requested! $key will tell us how to
# proceed further, hopefully
$ref = ref $key;
} ## end if (!$ref)
# if $key is a reference, it will tell us what's expected now
if (my $key_ref = ref $key) {
# if $key_ref is not the same as $ref there is a mismatch
# between what's available ($ref) and what' expected ($key_ref)
return($ref_wanted ? undef : '') if $key_ref ne $ref;
# OK, data and expectations agree. Get the "real" key
if ($key_ref eq 'ARRAY') {
$key = $crumb->[0]; # it's an array, key is (only) element
}
elsif ($key_ref eq 'HASH') {
($key) = keys %$crumb; # hash... key is (only) key
}
} ## end if (my $key_ref = ref ...)
# if $ref is still not true at this point, we're doing
# auto-vivification and we have a plain key. Some guessing
# will be needed! Plain non-negative integers resolve to ARRAY,
# otherwise we'll consider $key as a HASH key
$ref ||= ($key =~ m{\A (?: 0 | [1-9]\d*) \z}mxs) ? 'ARRAY' : 'HASH';
# time to actually do the next step
my $is_blessed = blessed $$ref_to_value;
my $method = $is_blessed && $$ref_to_value->can($key);
if ($is_blessed && $strict_blessed) {
return($ref_wanted ? undef : '') unless $method;
$ref_to_value = \($$ref_to_value->$method());
}
elsif ($method && $method_pre) {
$ref_to_value = \($$ref_to_value->$method());
}
elsif (($ref eq 'HASH') && exists($$ref_to_value->{$key})) {
$ref_to_value = \($$ref_to_value->{$key});
}
elsif (($ref eq 'ARRAY') && exists($$ref_to_value->[$key])) {
$ref_to_value = \($$ref_to_value->[$key]);
}
elsif ($method && $use_method) {
$ref_to_value = \($$ref_to_value->$method());
}
# autovivification goes here eventually
elsif ($ref eq 'HASH') {
$ref_to_value = \($$ref_to_value->{$key});
}
elsif ($ref eq 'ARRAY') {
$ref_to_value = \($$ref_to_value->[$key]);
}
else { # don't know what to do with other references!
return $ref_wanted ? undef : '';
}
} ## end for my $crumb (@$crumbs)
# normalize output, substitute undef with '' unless $ref_wanted
return
$ref_wanted ? $ref_to_value
: defined($$ref_to_value) ? $$ref_to_value
: '';
## use critic
} ## end sub traverse
sub V { return '' }
sub A { return }
sub H { return }
sub HK { return }
sub HV { return }
sub _compile_sub {
my ($self, $outcome) = @_;
my @warnings;
{
my $utf8 = $self->{utf8} ? 1 : 0;
my $stdout = $self->{stdout} ? 1 : 0;
local $SIG{__WARN__} = sub { push @warnings, @_ };
my @code;
push @code, <<'END_OF_CODE';
sub {
my %variables = %{$self->{variables}};
my $V = \%variables; # generic kid, as before by default
{
my $vars = shift || {};
if (ref($vars) eq 'HASH') { # old case
%variables = (%variables, %$vars);
}
else {
$V = $vars;
%variables = (HASH => { %variables }, REF => $V);
}
}
my $buffer = ''; # output variable
my $OFH;
END_OF_CODE
my $handle = '$OFH';
if ($stdout) {
$handle = 'STDOUT';
push @code, <<'END_OF_CODE';
local *STDOUT;
open STDOUT, '>', \$buffer or croak "open(): $OS_ERROR";
$OFH = select(STDOUT);
END_OF_CODE
}
else {
push @code, <<'END_OF_CODE';
open $OFH, '>', \$buffer or croak "open(): $OS_ERROR";
END_OF_CODE
}
push @code, "binmode $handle, ':encoding(utf8)';\n"
if $utf8;
push @code, "binmode $handle, '$self->{binmode}';\n"
if defined $self->{binmode};
push @code, <<'END_OF_CODE';
no warnings 'redefine';
local *V = sub {
my $path = scalar(@_) ? shift : [];
my $input = scalar(@_) ? shift : $V;
return traverse($input, $path, $self);
};
local *A = sub {
my $path = scalar(@_) ? shift : [];
my $input = scalar(@_) ? shift : $V;
return @{traverse($input, $path, $self) || []};
};
local *H = sub {
my $path = scalar(@_) ? shift : [];
my $input = scalar(@_) ? shift : $V;
return %{traverse($input, $path, $self) || {}};
};
local *HK = sub {
my $path = scalar(@_) ? shift : [];
my $input = scalar(@_) ? shift : $V;
return keys %{traverse($input, $path, $self) || {}};
};
local *HV = sub {
my $path = scalar(@_) ? shift : [];
my $input = scalar(@_) ? shift : $V;
return values %{traverse($input, $path, $self) || {}};
};
END_OF_CODE
push @code, <<"END_OF_CODE";
local *P = sub { return print $handle \@_; };
use warnings 'redefine';
END_OF_CODE
push @code, <<'END_OF_CODE';
{ # double closure to free "my" variables
my ($buffer, $OFH); # hide external ones
END_OF_CODE
# the real code! one additional scope indentation to ensure we
# can "my" variables again
push @code,
"{\n", # this enclusure allows using "my" again
$outcome->{code_text},
"}\n}\n\n";
push @code, "select(\$OFH);\n" if $stdout;
push @code, "close $handle;\n\n";
if ($utf8) {
push @code, <<'END_OF_CODE';
require Encode;
$buffer = Encode::decode(utf8 => $buffer);
END_OF_CODE
}
push @code, "return \$buffer;\n}\n";
my $code = join '', @code;
#print {*STDOUT} $code, "\n\n\n\n\n"; exit 0;
$outcome->{sub} = eval $code; ## no critic (ProhibitStringyEval)
return $outcome if $outcome->{sub};
}
my $error = $EVAL_ERROR;
my ($offset, $starter, $line_no) =
$error =~ m{at[ ]'template<(\d+),(\d+)>'[ ]line[ ](\d+)}mxs;
$line_no -= $offset;
s{at[ ]'template<\d+,\d+>'[ ]line[ ](\d+)}
{'at line ' . ($1 - $offset)}egmxs
for @warnings, $error;
if ($line_no == $starter) {
s{,[ ]near[ ]"[#][ ]line.*?\n\s+}{, near "}gmxs
for @warnings, $error;
}
my $section = _extract_section($outcome, $line_no);
$error = join '', @warnings, $error, "\n", $section;
croak $error;
} ## end sub _compile_sub
sub _extract_section {
my ($hash, $line_no) = @_;
$line_no--; # for proper comparison with 0-based array
my $start = $line_no - ERROR_CONTEXT;
my $end = $line_no + ERROR_CONTEXT;
my @lines = split /\n/mxs, $hash->{template};
$start = 0 if $start < 0;
$end = $#lines if $end > $#lines;
my $n_chars = length($end + 1);
return join '', map {
sprintf "%s%${n_chars}d| %s\n",
(($_ == $line_no) ? '>>' : ' '), ($_ + 1), $lines[$_];
} $start .. $end;
} ## end sub _extract_section
sub _simple_text {
my $text = shift;
return "P('$text');\n\n" if $text !~ /[\n'\\]/mxs;
$text =~ s/^/ /gmxs; # indent, trick taken from diff -u
return <<"END_OF_CHUNK";
### Verbatim text
P(do {
my \$text = <<'END_OF_INDENTED_TEXT';
$text
END_OF_INDENTED_TEXT
\$text =~ s/^ //gms; # de-indent
substr \$text, -1, 1, ''; # get rid of added newline
\$text;
});
END_OF_CHUNK
} ## end sub _simple_text
sub crumble {
my ($input) = @_;
return unless defined $input;
$input =~ s{\A\s+|\s+\z}{}gmxs;
return [] unless length $input;
my $sq = qr{(?mxs: ' [^']* ' )}mxs;
my $dq = qr{(?mxs: " (?:[^\\"] | \\.)* " )}mxs;
my $ud = qr{(?mxs: \w+ )}mxs;
my $chunk = qr{(?mxs: $sq | $dq | $ud)+}mxs;
# save and reset current pos() on $input
my $prepos = pos($input);
pos($input) = undef;
my @path;
## no critic (RegularExpressions::ProhibitCaptureWithoutTest)
push @path, $1 while $input =~ m{\G [.]? ($chunk) }cgmxs;
## use critic
# save and restore pos() on $input
my $postpos = pos($input);
pos($input) = $prepos;
return unless defined $postpos;
return if $postpos != length($input);
# cleanup @path components
for my $part (@path) {
my @subparts;
while ((pos($part) || 0) < length($part)) {
if ($part =~ m{\G ($sq) }cgmxs) {
push @subparts, substr $1, 1, length($1) - 2;
}
elsif ($part =~ m{\G ($dq) }cgmxs) {
my $subpart = substr $1, 1, length($1) - 2;
$subpart =~ s{\\(.)}{$1}gmxs;
push @subparts, $subpart;
}
elsif ($part =~ m{\G ($ud) }cgmxs) {
push @subparts, $1;
}
else { # shouldn't happen ever
return;
}
} ## end while ((pos($part) || 0) ...)
$part = join '', @subparts;
} ## end for my $part (@path)
return \@path;
} ## end sub crumble
sub _variable {
my $path = shift;
my $DQ = q<">; # double quotes
$path = join ', ', map { $DQ . quotemeta($_) . $DQ } @{$path};
return <<"END_OF_CHUNK";
### Variable from the stash (\$V)
P(V([$path]));
END_OF_CHUNK
} ## end sub _variable
sub _expression {
my $expression = shift;
return <<"END_OF_CHUNK";
# Expression to be evaluated and printed out
{
my \$value = do {{
$expression
}};
P(\$value) if defined \$value;
}
END_OF_CHUNK
} ## end sub _expression
1;
END_OF_FILE
'Try/Tiny.pm' => <<'END_OF_FILE',
package Try::Tiny; # git description: v0.23-3-g5ee27f1
use 5.006;
# ABSTRACT: minimal try/catch with proper preservation of $@
our $VERSION = '0.24';
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};
}
# Need to prototype as @ not $$ because of the way Perl evaluates the prototype.
# Keeping it at $$ means you only ever get 1 sub because we need to eval in a list
# context & not a scalar one
sub try (&;@) {
my ( $try, @code_refs ) = @_;
# we need to save this here, the eval block will be in scalar context due
# to $failed
my $wantarray = wantarray;
# work around perl bug by explicitly initializing these, due to the likelyhood
# this will be used in global destruction (perl rt#119311)
my ( $catch, @finally ) = ();
# find labeled blocks in the argument list.
# catch and finally tag the blocks by blessing a scalar reference to them.
foreach 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'
);
}
}
# FIXME consider using local $SIG{__DIE__} to accumulate all errors. It's
# not perfect, but we could provide a list of additional errors for
# $catch->();
# name the blocks if we have Sub::Name installed
my $caller = caller;
_subname("${caller}::try {...} " => $try)
if _HAS_SUBNAME;
# save the value of $@ so we can set $@ back to it in the beginning of the eval
# and restore $@ after the eval finishes
my $prev_error = $@;
my ( @ret, $error );
# failed will be true if the eval dies, because 1 will not be returned
# from the eval body
my $failed = not eval {
$@ = $prev_error;
# evaluate the try block in the correct context
if ( $wantarray ) {
@ret = $try->();
} elsif ( defined $wantarray ) {
$ret[0] = $try->();
} else {
$try->();
};
return 1; # properly set $failed to false
};
# preserve the current error and reset the original value of $@
$error = $@;
$@ = $prev_error;
# set up a scope guard to invoke the finally block at the end
my @guards =
map { Try::Tiny::ScopeGuard->_new($_, $failed ? $error : ()) }
@finally;
# at this point $failed contains a true value if the eval died, even if some
# destructor overwrote $@ as the eval was unwinding.
if ( $failed ) {
# if we got an error, invoke the catch block.
if ( $catch ) {
# This works like given($error), but is backwards compatible and
# sets $_ in the dynamic scope for the body of C<$catch>
for ($error) {
return $catch->($error);
}
# in case when() was used without an explicit return, the C<for>
# loop will be aborted and there's no useful return value
}
return;
} else {
# no failure, $@ is back to what it was, everything is fine
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 # hide from PAUSE
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__
__END__
=pod
=encoding UTF-8
=head1 NAME
Try::Tiny - minimal try/catch with proper preservation of $@
=head1 VERSION
version 0.24
=head1 SYNOPSIS
You can use Try::Tiny's C<try> and C<catch> to expect and handle exceptional
conditions, avoiding quirks in Perl and common mistakes:
# handle errors with a catch handler
try {
die "foo";
} catch {
warn "caught error: $_"; # not $@
};
You can also use it like a standalone C<eval> to catch and ignore any error
conditions. Obviously, this is an extreme measure not to be undertaken
lightly:
# just silence errors
try {
die "foo";
};
=head1 DESCRIPTION
This module provides bare bones C<try>/C<catch>/C<finally> statements that are designed to
minimize common mistakes with eval blocks, and NOTHING else.
This is unlike L<TryCatch> which provides a nice syntax and avoids adding
another call stack layer, and supports calling C<return> from the C<try> block to
return from the parent subroutine. These extra features come at a cost of a few
dependencies, namely L<Devel::Declare> and L<Scope::Upper> which are
occasionally problematic, and the additional catch filtering uses L<Moose>
type constraints which may not be desirable either.
The main focus of this module is to provide simple and reliable error handling
for those having a hard time installing L<TryCatch>, but who still want to
write correct C<eval> blocks without 5 lines of boilerplate each time.
It's designed to work as correctly as possible in light of the various
pathological edge cases (see L</BACKGROUND>) and to be compatible with any style
of error values (simple strings, references, objects, overloaded objects, etc).
If the C<try> block dies, it returns the value of the last statement executed in
the C<catch> block, if there is one. Otherwise, it returns C<undef> in scalar
context or the empty list in list context. The following examples all
assign C<"bar"> to C<$x>:
my $x = try { die "foo" } catch { "bar" };
my $x = try { die "foo" } || "bar";
my $x = (try { die "foo" }) // "bar";
my $x = eval { die "foo" } || "bar";
You can add C<finally> blocks, yielding the following:
my $x;
try { die 'foo' } finally { $x = 'bar' };
try { die 'foo' } catch { warn "Got a die: $_" } finally { $x = 'bar' };
C<finally> blocks are always executed making them suitable for cleanup code
which cannot be handled using local. You can add as many C<finally> blocks to a
given C<try> block as you like.
Note that adding a C<finally> block without a preceding C<catch> block
suppresses any errors. This behaviour is consistent with using a standalone
C<eval>, but it is not consistent with C<try>/C<finally> patterns found in
other programming languages, such as Java, Python, Javascript or C#. If you
learnt the C<try>/C<finally> pattern from one of these languages, watch out for
this.
=head1 EXPORTS
All functions are exported by default using L<Exporter>.
If you need to rename the C<try>, C<catch> or C<finally> keyword consider using
L<Sub::Import> to get L<Sub::Exporter>'s flexibility.
=over 4
=item try (&;@)
Takes one mandatory C<try> subroutine, an optional C<catch> subroutine and C<finally>
subroutine.
The mandatory subroutine is evaluated in the context of an C<eval> block.
If no error occurred the value from the first block is returned, preserving
list/scalar context.
If there was an error and the second subroutine was given it will be invoked
with the error in C<$_> (localized) and as that block's first and only
argument.
C<$@> does B<not> contain the error. Inside the C<catch> block it has the same
value it had before the C<try> block was executed.
Note that the error may be false, but if that happens the C<catch> block will
still be invoked.
Once all execution is finished then the C<finally> block, if given, will execute.
=item catch (&;@)
Intended to be used in the second argument position of C<try>.
Returns a reference to the subroutine it was given but blessed as
C<Try::Tiny::Catch> which allows try to decode correctly what to do
with this code reference.
catch { ... }
Inside the C<catch> block the caught error is stored in C<$_>, while previous
value of C<$@> is still available for use. This value may or may not be
meaningful depending on what happened before the C<try>, but it might be a good
idea to preserve it in an error stack.
For code that captures C<$@> when throwing new errors (i.e.
L<Class::Throwable>), you'll need to do:
local $@ = $_;
=item finally (&;@)
try { ... }
catch { ... }
finally { ... };
Or
try { ... }
finally { ... };
Or even
try { ... }
finally { ... }
catch { ... };
Intended to be the second or third element of C<try>. C<finally> blocks are always
executed in the event of a successful C<try> or if C<catch> is run. This allows
you to locate cleanup code which cannot be done via C<local()> e.g. closing a file
handle.
When invoked, the C<finally> block is passed the error that was caught. If no
error was caught, it is passed nothing. (Note that the C<finally> block does not
localize C<$_> with the error, since unlike in a C<catch> block, there is no way
to know if C<$_ == undef> implies that there were no errors.) In other words,
the following code does just what you would expect:
try {
die_sometimes();
} catch {
# ...code run in case of error
} finally {
if (@_) {
print "The try block died with: @_\n";
} else {
print "The try block ran without error.\n";
}
};
B<You must always do your own error handling in the C<finally> block>. C<Try::Tiny> will
not do anything about handling possible errors coming from code located in these
blocks.
Furthermore B<exceptions in C<finally> blocks are not trappable and are unable
to influence the execution of your program>. This is due to limitation of
C<DESTROY>-based scope guards, which C<finally> is implemented on top of. This
may change in a future version of Try::Tiny.
In the same way C<catch()> blesses the code reference this subroutine does the same
except it bless them as C<Try::Tiny::Finally>.
=back
=head1 BACKGROUND
There are a number of issues with C<eval>.
=head2 Clobbering $@
When you run an C<eval> block and it succeeds, C<$@> will be cleared, potentially
clobbering an error that is currently being caught.
This causes action at a distance, clearing previous errors your caller may have
not yet handled.
C<$@> must be properly localized before invoking C<eval> in order to avoid this
issue.
More specifically, C<$@> is clobbered at the beginning of the C<eval>, which
also makes it impossible to capture the previous error before you die (for
instance when making exception objects with error stacks).
For this reason C<try> will actually set C<$@> to its previous value (the one
available before entering the C<try> block) in the beginning of the C<eval>
block.
=head2 Localizing $@ silently masks errors
Inside an C<eval> block, C<die> behaves sort of like:
sub die {
$@ = $_[0];
return_undef_from_eval();
}
This means that if you were polite and localized C<$@> you can't die in that
scope, or your error will be discarded (printing "Something's wrong" instead).
The workaround is very ugly:
my $error = do {
local $@;
eval { ... };
$@;
};
...
die $error;
=head2 $@ might not be a true value
This code is wrong:
if ( $@ ) {
...
}
because due to the previous caveats it may have been unset.
C<$@> could also be an overloaded error object that evaluates to false, but
that's asking for trouble anyway.
The classic failure mode is:
sub Object::DESTROY {
eval { ... }
}
eval {
my $obj = Object->new;
die "foo";
};
if ( $@ ) {
}
In this case since C<Object::DESTROY> is not localizing C<$@> but still uses
C<eval>, it will set C<$@> to C<"">.
The destructor is called when the stack is unwound, after C<die> sets C<$@> to
C<"foo at Foo.pm line 42\n">, so by the time C<if ( $@ )> is evaluated it has
been cleared by C<eval> in the destructor.
The workaround for this is even uglier than the previous ones. Even though we
can't save the value of C<$@> from code that doesn't localize, we can at least
be sure the C<eval> was aborted due to an error:
my $failed = not eval {
...
return 1;
};
This is because an C<eval> that caught a C<die> will always return a false
value.
=head1 SHINY SYNTAX
Using Perl 5.10 you can use L<perlsyn/"Switch statements">.
=for stopwords topicalizer
The C<catch> block is invoked in a topicalizer context (like a C<given> block),
but note that you can't return a useful value from C<catch> using the C<when>
blocks without an explicit C<return>.
This is somewhat similar to Perl 6's C<CATCH> blocks. You can use it to
concisely match errors:
try {
require Foo;
} catch {
when (/^Can't locate .*?\.pm in \@INC/) { } # ignore
default { die $_ }
};
=head1 CAVEATS
=over 4
=item *
C<@_> is not available within the C<try> block, so you need to copy your
argument list. In case you want to work with argument values directly via C<@_>
aliasing (i.e. allow C<$_[1] = "foo">), you need to pass C<@_> by reference:
sub foo {
my ( $self, @args ) = @_;
try { $self->bar(@args) }
}
or
sub bar_in_place {
my $self = shift;
my $args = \@_;
try { $_ = $self->bar($_) for @$args }
}
=item *
C<return> returns from the C<try> block, not from the parent sub (note that
this is also how C<eval> works, but not how L<TryCatch> works):
sub parent_sub {
try {
die;
}
catch {
return;
};
say "this text WILL be displayed, even though an exception is thrown";
}
Instead, you should capture the return value:
sub parent_sub {
my $success = try {
die;
1;
};
return unless $success;
say "This text WILL NEVER appear!";
}
# OR
sub parent_sub_with_catch {
my $success = try {
die;
1;
}
catch {
# do something with $_
return undef; #see note
};
return unless $success;
say "This text WILL NEVER appear!";
}
Note that if you have a C<catch> block, it must return C<undef> for this to work,
since if a C<catch> block exists, its return value is returned in place of C<undef>
when an exception is thrown.
=item *
C<try> introduces another caller stack frame. L<Sub::Uplevel> is not used. L<Carp>
will not report this when using full stack traces, though, because
C<%Carp::Internal> is used. This lack of magic is considered a feature.
=for stopwords unhygienically
=item *
The value of C<$_> in the C<catch> block is not guaranteed to be the value of
the exception thrown (C<$@>) in the C<try> block. There is no safe way to
ensure this, since C<eval> may be used unhygienically in destructors. The only
guarantee is that the C<catch> will be called if an exception is thrown.
=item *
The return value of the C<catch> block is not ignored, so if testing the result
of the expression for truth on success, be sure to return a false value from
the C<catch> block:
my $obj = try {
MightFail->new;
} catch {
...
return; # avoid returning a true value;
};
return unless $obj;
=item *
C<$SIG{__DIE__}> is still in effect.
Though it can be argued that C<$SIG{__DIE__}> should be disabled inside of
C<eval> blocks, since it isn't people have grown to rely on it. Therefore in
the interests of compatibility, C<try> does not disable C<$SIG{__DIE__}> for
the scope of the error throwing code.
=item *
Lexical C<$_> may override the one set by C<catch>.
For example Perl 5.10's C<given> form uses a lexical C<$_>, creating some
confusing behavior:
given ($foo) {
when (...) {
try {
...
} catch {
warn $_; # will print $foo, not the error
warn $_[0]; # instead, get the error like this
}
}
}
Note that this behavior was changed once again in L<Perl5 version 18
However, since the entirety of lexical C<$_> is now L<considered experimental
is unclear whether the new version 18 behavior is final.
=back
=head1 SEE ALSO
=over 4
=item L<TryCatch>
Much more feature complete, more convenient semantics, but at the cost of
implementation complexity.
=item L<autodie>
Automatic error throwing for builtin functions and more. Also designed to
work well with C<given>/C<when>.
=item L<Throwable>
A lightweight role for rolling your own exception classes.
=item L<Error>
Exception object implementation with a C<try> statement. Does not localize
C<$@>.
=item L<Exception::Class::TryCatch>
Provides a C<catch> statement, but properly calling C<eval> is your
responsibility.
The C<try> keyword pushes C<$@> onto an error stack, avoiding some of the
issues with C<$@>, but you still need to localize to prevent clobbering.
=back
=head1 LIGHTNING TALK
I gave a lightning talk about this module, you can see the slides (Firefox
only):
Or read the source:
=head1 VERSION CONTROL
=head1 SUPPORT
(or L<bug-Try-Tiny@rt.cpan.org|mailto:bug-Try-Tiny@rt.cpan.org>).
=head1 AUTHORS
=over 4
=item *
ืืืื ืงืื'ืื (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Jesse Luehrs <doy@tozt.net>
=back
=head1 CONTRIBUTORS
=for stopwords Karen Etheridge Peter Rabbitson Ricardo Signes Mark Fowler Graham Knop Dagfinn Ilmari Mannsรฅker Paul Howarth Rudolf Leermakers anaxagoras awalker chromatic Alex cm-perl Andrew Yates David Lowe Glenn Hans Dieter Pearcey Jonathan Yu Marc Mims Stosberg
=over 4
=item *
Karen Etheridge <ether@cpan.org>
=item *
Peter Rabbitson <ribasushi@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=item *
Mark Fowler <mark@twoshortplanks.com>
=item *
Graham Knop <haarg@haarg.org>
=item *
Dagfinn Ilmari Mannsรฅker <ilmari@ilmari.org>
=item *
Paul Howarth <paul@city-fan.org>
=item *
Rudolf Leermakers <rudolf@hatsuseno.org>
=item *
anaxagoras <walkeraj@gmail.com>
=item *
awalker <awalker@sourcefire.com>
=item *
chromatic <chromatic@wgz.org>
=item *
Alex <alex@koban.(none)>
=item *
cm-perl <cm-perl@users.noreply.github.com>
=item *
Andrew Yates <ayates@haddock.local>
=item *
David Lowe <davidl@lokku.com>
=item *
Glenn Fowler <cebjyre@cpan.org>
=item *
Hans Dieter Pearcey <hdp@weftsoar.net>
=item *
Jonathan Yu <JAWNSY@cpan.org>
=item *
Marc Mims <marc@questright.com>
=item *
Mark Stosberg <mark@stosberg.com>
=back
=head1 COPYRIGHT AND LICENCE
This software is Copyright (c) 2009 by ืืืื ืงืื'ืื (Yuval Kogman).
This is free software, licensed under:
The MIT (X11) License
=cut
END_OF_FILE
'Data/Tubes.pm' => <<'END_OF_FILE',
package Data::Tubes;
# vim: ts=3 sts=3 sw=3 et ai :
use strict;
use warnings;
use English qw< -no_match_vars >;
our $VERSION = '0.740';
our $API_VERSION = $VERSION;
use Exporter ();
our @ISA = qw< Exporter >;
use Log::Log4perl::Tiny qw< :easy :dead_if_first LOGLEVEL >;
use Data::Tubes::Util qw<
args_array_with_options
load_sub
normalize_args
pump
resolve_module
tube
>;
our @EXPORT_OK = (
qw<
drain
pipeline
summon
tube
>
);
our %EXPORT_TAGS = (all => \@EXPORT_OK,);
sub _drain_0_734 {
my $tube = shift;
my @outcome = $tube->(@_);
return unless scalar @outcome;
return $outcome[0] if scalar(@outcome) == 1;
return pump($outcome[1]) if $outcome[0] eq 'iterator';
my $wa = wantarray();
return if !defined($wa);
return $outcome[1] unless $wa;
return @{$outcome[1]};
} ## end sub _drain_0_734
sub drain {
goto \&_drain_0_734 if $API_VERSION le '0.734';
my $tube = shift;
my @outcome = $tube->(@_);
my $retval;
if (scalar(@outcome) < 2) { # one single record inside
$retval = \@outcome;
}
elsif ($outcome[0] eq 'iterator') {
$retval = [pump($outcome[1])];
}
elsif ($outcome[0] eq 'records') {
$retval = $outcome[1];
}
else {
LOGDIE "invalid tube output";
}
my $wa = wantarray();
return unless defined $wa;
return $retval unless $wa;
return @$retval;
} ## end sub drain
sub import {
my $package = shift;
my @filtered;
while (@_) {
my $item = shift;
if (lc($item) eq '-api') {
LOGDIE "no API version provided for parameter -api"
unless @_;
$API_VERSION = shift;
}
else {
push @filtered, $item;
}
} ## end while (@_)
$package->export_to_level(1, $package, @filtered);
} ## end sub import
sub pipeline {
my ($tubes, $args) = args_array_with_options(@_, {name => 'sequence'});
my $tap = delete $args->{tap};
if (defined $tap) {
$tap = sub {
my $iterator = shift;
while (my @items = $iterator->()) { }
return;
}
if $tap eq 'sink';
$tap = sub {
my $iterator = shift;
my @records;
while (my @items = $iterator->()) { push @records, @items; }
return unless @records;
return $records[0] if @records == 1;
return (records => \@records);
}
if $tap eq 'bucket';
$tap = sub {
my ($record) = $_[0]->();
return $record;
}
if $tap eq 'first';
$tap = sub {
my $iterator = shift;
my @records;
while (my @items = $iterator->()) { push @records, @items; }
return unless @records;
return \@records;
}
if $tap eq 'array';
} ## end if (defined $tap)
if ((!defined($tap)) && (defined($args->{pump}))) {
my $pump = delete $args->{pump};
$tap = sub {
my $iterator = shift;
while (my ($record) = $iterator->()) {
$pump->($record);
}
return;
}
} ## end if ((!defined($tap)) &&...)
LOGDIE 'invalid tap or pump'
if $tap && ref($tap) ne 'CODE';
my $sequence = tube('^Data::Tubes::Plugin::Plumbing::sequence',
%$args, tubes => $tubes);
return $sequence unless $tap;
return sub {
my (undef, $iterator) = $sequence->(@_) or return;
return $tap->($iterator);
};
} ## end sub pipeline
sub summon { # sort-of import
my ($imports, $args) = args_array_with_options(
@_,
{
prefix => 'Data::Tubes::Plugin',
package => (caller(0))[0],
}
);
my $prefix = $args->{prefix};
my $cpack = $args->{package};
for my $r (@_) {
my @parts;
if (ref($r) eq 'ARRAY') {
@parts = $r;
}
else {
my ($pack, $name) = $r =~ m{\A(.*)::(\w+)\z}mxs;
@parts = [$pack, $name];
}
for my $part (@parts) {
my ($pack, @names) = @$part;
$pack = resolve_module($pack, $prefix);
(my $fpack = "$pack.pm") =~ s{::}{/}gmxs;
require $fpack;
for my $name (@names) {
my $sub = $pack->can($name)
or LOGDIE "package '$pack' has no '$name' inside";
no strict 'refs';
*{$cpack . '::' . $name} = $sub;
} ## end for my $name (@names)
} ## end for my $part (@parts)
} ## end for my $r (@_)
} ## end sub summon
1;
__END__
END_OF_FILE
'Data/Tubes/Util.pm' => <<'END_OF_FILE',
package Data::Tubes::Util;
# vim: ts=3 sts=3 sw=3 et ai :
use strict;
use warnings;
use English qw< -no_match_vars >;
use Exporter 'import';
our $VERSION = '0.740';
use Log::Log4perl::Tiny qw< :easy :dead_if_first >;
our @EXPORT_OK = qw<
args_array_with_options
assert_all_different
generalized_hashy
load_module
load_sub
metadata
normalize_args
normalize_filename
pump
read_file
read_file_maybe
resolve_module
shorter_sub_names
sprintffy
test_all_equal
traverse
trim
tube
unzip
>;
sub _load_module {
my $module = shift;
(my $packfile = $module . '.pm') =~ s{::}{/}gmxs;
require $packfile;
return $module;
} ## end sub _load_module
sub args_array_with_options {
my %defaults = %{pop @_};
%defaults = (%defaults, %{pop @_})
if @_ && (ref($_[-1]) eq 'HASH');
return ([@_], \%defaults);
} ## end sub args_array_with_options
sub assert_all_different {
my $keys = (@_ && ref($_[0])) ? $_[0] : \@_;
my %flag_for;
for my $key (@$keys) {
die {message => $key} if $flag_for{$key}++;
}
return 1;
} ## end sub assert_all_different
sub _compile_capture {
my %h = @_;
use feature 'state';
state $quoted = qr{(?mxs:
(?: "(?: [^\\"]+ | \\. )*") # double quotes
| (?: '[^']*') # single quotes
)};
my ($key, $value, $kvs, $cs) =
@h{qw< key value key_value_separator chunks_separator>};
if (!defined($key)) {
my $admitted = $h{key_admitted};
$admitted = qr{[\Q$admitted\E]} unless ref $admitted;
$key = qr{(?mxs: $quoted | (?:(?:$admitted | \\.)+?))};
}
if (!defined($value)) {
my $admitted = $h{value_admitted};
$admitted = qr{[\Q$admitted\E]} unless ref $admitted;
$value = qr{(?mxs: $quoted | (?:(?:$admitted | \\.)+?))};
}
my $close = qr{(?<close>$h{close})};
return qr{(?mxs:
(?: (?<key> $key) $kvs)? # optional key with kv-separator
(?<value> $value) # a value, for sure
(?: $close | $cs $close?) # close or chunk separator next
)};
} ## end sub _compile_capture
sub generalized_hashy {
use feature 'state';
state $admitted_default = qr{[^\\'":=\s,;\|/]};
state $kvdecoder = sub {
my $kv = shift;
my $first = substr $kv, 0, 1;
$kv = substr $kv, 1, length($kv) - 2
if ($first eq q{'}) || ($first eq q{"});
$kv =~ s{\\(.)}{$1}gmxs unless $first eq q{'};
return $kv;
};
state $default_handler_for = {
open => qr{(?mxs: \s* )},
key_value_separator => qr{(?mxs: \s* [:=] \s*)},
chunks_separator => qr{(?mxs: \s* [\s,;\|/] \s*)},
close => qr{(?mxs: \s*\z)},
key_admitted => $admitted_default,
value_admitted => $admitted_default,
key_decoder => $kvdecoder,
value_decoder => $kvdecoder,
key_duplicate => sub {
my ($h, $k, $v) = @_;
$h->{$k} = [$h->{$k}] unless ref $h->{$k};
push @{$h->{$k}}, $v;
},
};
my $args = normalize_args(@_, [$default_handler_for, 'text']);
$args->{key_default} = delete $args->{default_key}
if exists $args->{default_key};
my $text = $args->{text};
my %h = (%$default_handler_for, %$args);
my $capture = $h{capture} ||= _compile_capture(%h);
my %retval = (capture => $capture);
return {%retval, failure => 'undefined input'} unless defined $text;
my $len = length $text;
pos($text) = my $startpos = $args->{pos} || 0;
%retval = (%retval, pos => $startpos, res => ($len - $startpos));
# let's check open first, no need to define anything otherwise
$text =~ m{\G$h{open}}gmxs or return {%retval, failure => 'no opening'};
my ($dkey, $dupkey, $kdec, $vdec) =
@h{qw< key_default key_duplicate key_decoder value_decoder >};
my ($closed, %hash);
while (!$closed && pos($text) < length($text)) {
my $pos = pos($text);
$text =~ m{\G$capture}gcmxs
or return {
%retval,
failure => "failed match at $pos",
failpos => $pos
};
my $key =
exists($+{key}) ? ($kdec ? $kdec->($+{key}) : $+{key})
: defined($dkey) ? (ref($dkey) ? $dkey->() : $dkey)
: undef;
return {
%retval,
failure => 'stand-alone value, no default key set',
failpos => $pos
}
unless defined $key;
my $value = $vdec ? $vdec->($+{value}) : $+{value};
if (!exists $hash{$key}) {
$hash{$key} = $value;
}
elsif ($dupkey) {
$dupkey->(\%hash, $key, $value);
}
else {
return {
%retval,
failure => "duplicate key $key",
failpos => $pos
};
} ## end else [ if (!exists $hash{$key...})]
$closed = exists $+{close};
} ## end while (!$closed && pos($text...))
return {%retval, failure => 'no closure found'} unless $closed;
my $pos = pos $text;
return {
%retval,
pos => $pos,
res => ($len - $pos),
hash => \%hash,
};
} ## end sub generalized_hashy
sub load_module {
return _load_module(resolve_module(@_));
} ## end sub load_module
sub load_sub {
my ($locator, $prefix) = @_;
my ($module, $sub) =
ref($locator) ? @$locator : $locator =~ m{\A(.*)::(\w+)\z}mxs;
$module = resolve_module($module, $prefix);
# optimistic first
return $module->can($sub) // _load_module($module)->can($sub);
} ## end sub load_sub
sub metadata {
my $input = shift;
my %args = normalize_args(
@_,
{
chunks_separator => ' ',
key_value_separator => '=',
default_key => '',
}
);
# split data into chunks, un-escape on the fly
my $separator = $args{chunks_separator};
my $qs = quotemeta($separator);
my $regexp = qr/((?:\\.|[^\\$qs])+)(?:$qs+)?/;
my @chunks = map { s{\\(.)}{$1}g; $_ } $input =~ m{$regexp}gc;
# ensure we consumed the whole $input
die {message =>
"invalid metadata (separator: '$separator', input: [$input])\n"
}
if pos($input) < length($input);
$separator = $args{key_value_separator};
return {
map {
my ($k, $v) = _split_pair($_, $separator);
defined($v) ? ($k, $v) : ($args{default_key} => $k);
} @chunks
};
} ## end sub metadata
sub normalize_args {
my $defaults = pop(@_);
my %retval;
if (ref($defaults) eq 'ARRAY') {
($defaults, my $key) = @$defaults;
$retval{$key} = shift(@_)
if (scalar(@_) % 2) && (ref($_[0]) ne 'HASH');
}
%retval = (
%$defaults, # defaults go first
%retval, # anything already present goes next
((@_ && ref($_[0]) eq 'HASH') ? %{$_[0]} : @_), # then... the rest
);
return %retval if wantarray();
return \%retval;
} ## end sub normalize_args
sub normalize_filename {
my ($filename, $default_handle) = @_;
return unless defined $filename;
return $filename if ref($filename) eq 'GLOB';
return $filename if ref($filename) eq 'SCALAR';
return $default_handle if $filename eq '-';
return $filename if $filename =~ s{\Afile:}{}mxs;
if (my ($handlename) = $filename =~ m{\Ahandle:(?:std)?(.*)\z}imxs) {
$handlename = lc $handlename;
return \*STDOUT if $handlename eq 'out';
return \*STDIN if $handlename eq 'err';
return \*STDERR if $handlename eq 'in';
LOGDIE "normalize_filename: invalid filename '$filename', "
. "use 'file:$filename' if name is correct";
} ## end if (my ($handlename) =...)
return $filename;
} ## end sub normalize_filename
sub pump {
my ($iterator, $sink) = @_;
if ($sink) {
while (my @items = $iterator->()) {
$sink->(@items);
}
return;
}
my $wa = wantarray();
if (! defined $wa) {
while (my @items = $iterator->()) {}
return;
}
my @records;
while (my @items = $iterator->()) {
push @records, @items;
}
return $wa ? @records : \@records;
}
sub read_file {
my %args = normalize_args(
@_,
[
{binmode => ':encoding(UTF-8)'},
'filename', # default key for "straight" unnamed parameter
]
);
defined(my $filename = normalize_filename($args{filename}, \*STDIN))
or LOGDIE 'read_file(): undefined filename';
my $fh;
if (ref($filename) eq 'GLOB') {
$fh = $filename;
}
else {
open $fh, '<', $filename
or LOGDIE "read_file() for <$args{filename}>: open(): $OS_ERROR";
}
if (defined $args{binmode}) {
binmode $fh, $args{binmode}
or LOGDIE "read_file(): binmode()"
. " for $args{filename} failed: $OS_ERROR";
}
local $INPUT_RECORD_SEPARATOR;
return <$fh>;
} ## end sub read_file
sub read_file_maybe {
my $x = shift;
return read_file(@$x) if ref($x) eq 'ARRAY';
return $x;
}
sub resolve_module {
my ($module, $prefix) = @_;
# Force a first character transforming from new interface if after 0.734
if ($Data::Tubes::API_VERSION gt '0.734') {
$module = '+' . $module unless $module =~ s{^[+^]}{!}mxs;
}
my ($first) = substr $module, 0, 1;
return substr $module, 1 if $first eq '!';
$prefix //= 'Data::Tubes::Plugin';
if ($first eq '+') {
$module = substr $module, 1;
}
elsif ($module =~ m{::}mxs) {
$prefix = undef;
}
return $module unless defined $prefix;
return $prefix . '::' . $module;
}
sub shorter_sub_names {
my $stash = shift(@_) . '::';
no strict 'refs';
# isolate all subs
my %sub_for =
map { *{$stash . $_}{CODE} ? ($_ => *{$stash . $_}{CODE}) : (); }
keys %$stash;
# iterate through inputs, work only on isolated subs and don't
# consider shortened ones
for my $prefix (@_) {
while (my ($name, $sub) = each %sub_for) {
next if index($name, $prefix) < 0;
my $shortname = substr $name, length($prefix);
*{$stash . $shortname} = $sub;
}
} ## end for my $prefix (@_)
return;
} ## end sub shorter_sub_names
sub _split_pair {
my ($input, $separator) = @_;
my $qs = quotemeta($separator);
my $regexp = qr{(?mxs:\A((?:\\.|[^\\$qs])+)$qs(.*)\z)};
my ($first, $second) = $input =~ m{$regexp};
($first, $second) = ($input, undef) unless defined($first);
$first =~ s{\\(.)}{$1}gmxs; # unescape metadata
return ($first, $second);
} ## end sub _split_pair
sub sprintffy {
my ($template, $substitutions) = @_;
my $len = length $template;
pos($template) = 0; # initialize
my @chunks;
QUEST:
while (pos($template) < $len) {
$template =~ m{\G (.*?) (% | \z)}mxscg;
my ($plain, $term) = ($1, $2);
my $pos = pos($template);
push @chunks, $plain;
last unless $term; # got a percent, have to continue
CANDIDATE:
for my $candidate ([qr{%} => '%'], @$substitutions) {
my ($regex, $value) = @$candidate;
$template =~ m{\G$regex}cg or next CANDIDATE;
$value = $value->() if ref($value) eq 'CODE';
push @chunks, $value;
next QUEST;
} ## end CANDIDATE: for my $candidate ([qr{%}...])
# didn't find a matchin thing... time to complain
die {message => "invalid sprintffy template '$template'"};
} ## end QUEST: while (pos($template) < $len)
return join '', @chunks;
} ## end sub sprintffy
sub test_all_equal {
my $reference = shift;
for my $candidate (@_) {
return if $candidate ne $reference;
}
return 1;
} ## end sub test_all_equal
sub traverse {
my ($data, @keys) = @_;
for my $key (@keys) {
if (ref($data) eq 'HASH') {
$data = $data->{$key};
}
elsif (ref($data) eq 'ARRAY') {
$data = $data->[$key];
}
else {
return undef;
}
return undef unless defined $data;
} ## end for my $key (@keys)
return $data;
} ## end sub traverse
sub trim {
s{\A\s+|\s+\z}{}gmxs for @_;
}
sub tube {
my $opts = {};
$opts = shift(@_) if (@_ && ref($_[0]) eq 'HASH');
my @prefix = exists($opts->{prefix}) ? ($opts->{prefix}) : ();
my $locator = shift;
return load_sub($locator, @prefix)->(@_);
}
sub unzip {
my $items = (@_ && ref($_[0])) ? $_[0] : \@_;
my $n_items = scalar @$items;
my (@evens, @odds);
my $i = 0;
while ($i < $n_items) {
push @evens, $items->[$i++];
push @odds, $items->[$i++] if $i < $n_items;
}
return (\@evens, \@odds);
} ## end sub unzip
1;
END_OF_FILE
'Data/Tubes/Util/Cache.pm' => <<'END_OF_FILE',
package Data::Tubes::Util::Cache;
use strict;
use warnings;
use English qw< -no_match_vars >;
use 5.010;
our $VERSION = '0.740';
use File::Path qw< mkpath >;
use File::Spec::Functions qw< splitpath catpath >;
use Storable qw< nstore retrieve >;
use Log::Log4perl::Tiny qw< :easy :dead_if_first >;
use Mo qw< default >;
has repository => (default => sub { return {} });
has __filenames => (default => sub { return undef });
has max_items => (default => 0);
sub _path {
my ($dir, $filename) = @_;
my ($v, $d) = splitpath($dir, 'no-file');
return catpath($v, $d, $filename);
}
sub get {
my ($self, $key) = @_;
my $repo = $self->repository();
if (ref($repo) eq 'HASH') {
return unless exists $repo->{$key};
return $repo->{$key};
}
my $path = _path($repo, $key);
return retrieve($path) if -r $path;
return;
} ## end sub get
sub _filenames {
my $self = shift;
if (my $retval = $self->__filenames()) {
return $retval;
}
my $repo = $self->repository();
my ($v, $d) = splitpath($repo, 'no-file');
opendir my $dh, $repo or return;
my @filenames = map { catpath($v, $d, $_) } readdir $dh;
closedir $dh;
$self->__filenames(\@filenames);
return \@filenames;
}
sub purge {
my $self = shift;
my $max = $self->max_items() or return;
my $repo = $self->repository();
if (ref($repo) eq 'HASH') {
my $n = scalar keys %$repo;
delete $repo->{(keys %$repo)[0]} while $n-- > $max;
return;
}
my $filenames = $self->_filenames() or return;
while (@$filenames > $max) {
my $filename = shift @$filenames;
unlink $filename;
}
return;
} ## end sub purge
sub set {
my ($self, $key, $data) = @_;
my $repo = $self->repository();
return $repo->{$key} = $data if ref($repo) eq 'HASH';
eval {
mkpath($repo) unless -d $repo;
nstore($data, _path($repo, $key));
1;
} or LOGWARN $EVAL_ERROR;
return $data;
}
END_OF_FILE
'Data/Tubes/Util/Output.pm' => <<'END_OF_FILE',
package Data::Tubes::Util::Output;
use strict;
use warnings;
use English qw< -no_match_vars >;
use 5.010;
use File::Path qw< make_path >;
use File::Basename qw< dirname >;
our $VERSION = '0.740';
use Log::Log4perl::Tiny qw< :easy :dead_if_first >;
use Mo qw< default >;
has binmode => (default => ':raw');
has footer => ();
has header => ();
has interlude => ();
has output => (default => \*STDOUT);
has policy => (default => undef);
has track => (
default => sub {
return {
files => 0,
records => 0,
chars_file => 0,
chars_total => 0,
};
}
);
sub open {
my ($self, $hint) = @_;
# reset some tracking parameters
my $track = $self->track();
$track->{files}++;
$track->{records} = 0;
$track->{chars_file} = 0;
# get new filehandle
my ($fh, $fh_releaser) =
@{$track}{qw< current_fh current_fh_releaser>} = $self->get_fh($hint);
# do header handling
$self->_print($fh, $self->header(), $track);
return $fh;
} ## end sub open
sub __open_file {
my ($filename, $binmode) = @_;
# ensure its directory exists
make_path(dirname($filename), {error => \my $errors});
if (@$errors) {
my ($error) = values %{$errors->[0]};
LOGCONFESS "make_path() for '$filename': $error";
}
# can open the file, at last
CORE::open my $fh, '>', $filename
or LOGCONFESS "open('$filename'): $OS_ERROR";
binmode $fh, $binmode;
return $fh;
} ## end sub __open_file
sub get_fh {
my ($self, $handle) = @_;
$handle //= $self->output();
# define a default releaser, but not for GLOBs as they have their own
# life outside of here
my $releaser = ref($handle) eq 'GLOB' ? undef : sub {
CORE::close $_[0] or LOGCONFESS "close(): $OS_ERROR";
return undef;
};
# if $handle is a factory, treat it as such
if (ref($handle) eq 'CODE') {
my @items = $handle->($self);
$handle = shift @items;
# override the $releaser if and only if the factory instructed to
# do so. Otherwise, the default one will be kept.
$releaser = shift @items if @items;
} ## end if (ref($handle) eq 'CODE')
# now, we either have a filehandle, or a filename
return ($handle, $releaser) if ref($handle) eq 'GLOB';
return (__open_file($handle, $self->binmode()), $releaser);
} ## end sub get_fh
sub release_fh {
my ($self, $fh) = @_;
my $track = $self->track();
if (my $releaser = delete $track->{current_fh_releaser}) {
$releaser->($fh);
}
delete $track->{current_fh};
return undef;
} ## end sub release_fh
sub close {
my ($self, $fh, $track) = @_;
# do footer handling
$self->_print($fh, $self->footer(), $track);
# call close, prepare $fh for other possible records
return $self->release_fh($fh);
} ## end sub close
sub just_close {
my $self = shift;
my $track = $self->track();
my $fh = $track->{current_fh} or return;
$self->close($fh, $track);
return;
} ## end sub just_close
sub print {
my $self = shift;
my $iterator = ref($_[0]) && $_[0];
my $checker = $self->checker();
my $track = $self->track();
my $fh = $track->{current_fh};
my $interlude = $self->interlude();
while ('necessary') {
my $record = $iterator ? $iterator->() : shift(@_);
last unless defined $record;
# get filehandle if needed
$fh ||= $self->open();
# print interlude if we have previous records, increase count
$self->_print($fh, $interlude, $track)
if $track->{records};
# print record
$self->_print($fh, $record, $track);
# increment number of records, for next print
$track->{records}++;
# do checks if activated
$fh = $self->close($fh, $track)
if $checker && (!$checker->($self));
} ## end while ('necessary')
return;
} ## end sub print
sub _print {
my ($self, $fh, $data, $track) = @_;
return unless defined $data;
$data = $data->($self) if ref $data;
# do print data
ref($fh) or LOGCONFESS("$fh is not a reference");
print {$fh} $data or LOGCONFESS "print(): $OS_ERROR";
# update trackers
my $new_chars = length($data);
$track->{chars_file} += $new_chars;
$track->{chars_total} += $new_chars;
return $new_chars;
} ## end sub _print
sub default_check {
my $self = shift;
my $policy = $self->policy()
or return 1; # no policy, always fine
my $track = $self->track();
if (my $mr = $policy->{records_threshold}) {
return 0 if $track->{records} >= $mr;
}
if (my $cpf = $policy->{characters_threshold}) {
return 0 if $track->{chars_file} >= $cpf;
}
return 1;
} ## end sub default_check
sub checker {
my $self = shift;
# allow for overriding tout-court
if (my $method = $self->can('check')) {
return $method; # will eventually be called in the right way
}
# if no policy is set, there's no reason to do checks
my $policy = $self->policy() or return;
# at this point, let's use the default_check, whatever it is
return $self->can('default_check');
} ## end sub checker
sub DESTROY { shift->just_close() }
sub writer {
my $package = shift;
my $self = $package->new(@_);
return sub { return $self->print(@_) };
}
1;
END_OF_FILE
'Data/Tubes/Plugin/Source.pm' => <<'END_OF_FILE',
package Data::Tubes::Plugin::Source;
# vim: ts=3 sts=3 sw=3 et ai :
use strict;
use warnings;
use English qw< -no_match_vars >;
use Log::Log4perl::Tiny qw< :easy :dead_if_first LOGLEVEL >;
our $VERSION = '0.740';
use Data::Tubes::Util
qw< normalize_args normalize_filename args_array_with_options >;
use Data::Tubes::Plugin::Util qw< identify log_helper >;
my %global_defaults = (
input => 'source',
output => 'raw',
);
sub iterate_array {
my %args = normalize_args(@_,
[{name => 'array iterator', array => []}, 'array']);
identify(\%args);
my $logger = log_helper(\%args);
my $global_array = $args{array};
LOGDIE 'undefined global array, omit or pass empty one instead'
unless defined $global_array;
my $n_global = @$global_array;
return sub {
my $local_array = shift || [];
my $n_local = @$local_array;
my $i = 0;
return (
iterator => sub {
return if $i >= $n_global + $n_local;
my $element =
($i < $n_global)
? $global_array->[$i++]
: $local_array->[($i++) - $n_global];
$logger->($element, \%args) if $logger;
return $element;
},
);
};
} ## end sub iterate_array
sub open_file {
my %args = normalize_args(
@_,
[
{
binmode => ':encoding(UTF-8)',
output => 'source',
name => 'open file',
},
'binmode'
],
);
identify(\%args);
# valid "output" sub-fields must be defined and at least one char long
# otherwise output will be ignored
my $binmode = $args{binmode};
my $output = $args{output};
my $input = $args{input};
my $has_input = defined($input) && length($input);
return sub {
my ($record, $file) =
$has_input ? ($_[0], $_[0]{$input}) : ({}, $_[0]);
$file = normalize_filename($file);
if (ref($file) eq 'GLOB') {
my $is_stdin = fileno($file) == fileno(\*STDIN);
my $name = $is_stdin ? 'STDIN' : "$file";
$record->{$output} = {
fh => $file,
input => $file,
type => 'handle',
name => "handle\:$name",
};
} ## end if (ref($file) eq 'GLOB')
else {
open my $fh, '<', $file
or die "open('$file'): $OS_ERROR";
binmode $fh, $binmode;
my $type = (ref($file) eq 'SCALAR') ? 'scalar' : 'file';
$record->{$output} = {
fh => $fh,
input => $file,
type => $type,
name => "$type\:$file",
};
} ## end else [ if (ref($file) eq 'GLOB')]
return $record;
};
} ## end sub open_file
sub iterate_files {
my ($files, $args) = args_array_with_options(
@_,
{ # these are the default options
name => 'files',
# options specific for sub-tubes
iterate_array_args => {},
open_file_args => {},
logger_args => {
target => sub {
my $record = shift;
return 'reading from ' . $record->{source}{name},;
},
},
}
);
identify($args);
use Data::Tubes::Plugin::Plumbing;
return Data::Tubes::Plugin::Plumbing::sequence(
tubes => [
iterate_array(
%{$args->{iterate_array_args}}, array => $files,
),
open_file(%{$args->{open_file_args}}),
Data::Tubes::Plugin::Plumbing::logger(%{$args->{logger_args}}),
]
);
} ## end sub iterate_files
1;
END_OF_FILE
'Data/Tubes/Plugin/Util.pm' => <<'END_OF_FILE',
package Data::Tubes::Plugin::Util;
# vim: ts=3 sts=3 sw=3 et ai :
use strict;
use warnings;
use English qw< -no_match_vars >;
use Data::Dumper;
our $VERSION = '0.740';
use Template::Perlish;
use Log::Log4perl::Tiny qw< :easy :dead_if_first get_logger >;
use Data::Tubes::Util qw< normalize_args read_file tube >;
use Exporter qw< import >;
our @EXPORT_OK = qw< identify log_helper read_file tubify >;
sub identify {
my ($args, $opts) = @_;
$args //= {};
$opts //= $args->{identification} // {};
my $name = $args->{name};
$name = '*unknown*' unless defined $name;
my @caller_fields = qw<
package
filename
line
subroutine
hasargs
wantarray
evaltext
is_require
hints
bitmask
hintsh
>;
my %caller;
if (exists $opts->{caller}) {
@caller{@caller_fields} = @{$opts->{caller}};
}
else {
my $level = $opts->{level};
$level = 1 unless defined $level;
@caller{@caller_fields} = caller($level);
}
my $message = $opts->{message};
$message = 'building [% name %] as [% subroutine %]'
unless defined $message;
my $tp = Template::Perlish->new(%{$opts->{tp_opts} || {}});
$message = $tp->process(
$message,
{
%caller,
name => $name,
args => $args,
opts => $opts,
}
);
my $loglevel = $opts->{loglevel};
$loglevel = $DEBUG unless defined $loglevel;
get_logger->log($loglevel, $message);
return;
} ## end sub identify
sub log_helper {
my ($args, $opts) = @_;
$opts //= $args->{logger};
return unless $opts;
return $opts if ref($opts) eq 'CODE';
# generate one
my $name = $args->{name};
$name = '*unknown*' unless defined $name;
my $message = $opts->{message};
$message = '==> [% args.name %]' unless defined $message;
my $tp = Template::Perlish->new(%{$opts->{tp_opts} || {}});
$message = $tp->compile($message);
my $logger = get_logger();
my $loglevel = $opts->{loglevel};
$loglevel = $DEBUG unless defined $loglevel;
return sub {
my $level = $logger->level();
return if $level < $loglevel;
my $record = shift;
my $rendered =
$tp->evaluate($message,
{record => $record, args => $args, opts => $opts});
$logger->log($loglevel, $rendered);
};
} ## end sub log_helper
sub tubify {
my $opts = {};
$opts = shift(@_) if (@_ && ref($_[0]) eq 'HASH');
map {
my $ref = ref $_;
($ref eq 'CODE')
? $_
: tube($opts, ($ref eq 'ARRAY') ? @$_ : $_)
} grep { $_ } @_;
} ## end sub tubify
1;
END_OF_FILE
'Data/Tubes/Plugin/Reader.pm' => <<'END_OF_FILE',
package Data::Tubes::Plugin::Reader;
use strict;
use warnings;
use English qw< -no_match_vars >;
our $VERSION = '0.740';
use Log::Log4perl::Tiny qw< :easy :dead_if_first LOGLEVEL >;
use Data::Tubes::Util qw< normalize_args shorter_sub_names >;
use Data::Tubes::Plugin::Util qw< identify >;
my %global_defaults = (
input => 'source',
output => 'raw',
);
sub read_by_line {
return read_by_separator(
normalize_args(
@_,
{
name => 'read_by_line',
identification => {caller => [caller(0)]},
}
),
separator => "\n",
);
} ## end sub read_by_line
sub read_by_paragraph {
return read_by_separator(
normalize_args(
@_,
{
name => 'read_by_paragraph',
identification => {caller => [caller(0)]},
}
),
separator => '',
);
} ## end sub read_by_paragraph
sub read_by_record_reader {
my %args = normalize_args(
@_,
[
{
%global_defaults,
emit_eof => 0,
name => 'read_by_record_reader',
identification => {caller => [caller(0)]},
},
'record_reader'
],
);
identify(\%args);
my $name = $args{name};
my $record_reader = $args{record_reader};
LOGDIE "$name undefined record_reader" unless defined $record_reader;
LOGDIE "$name record_reader MUST be a sub reference"
unless ref($record_reader) eq 'CODE';
my $emit_eof = $args{emit_eof};
my $input = $args{input};
my $has_input = defined($input) && length($input);
my $output = $args{output};
return sub {
my $record = shift;
my $source = $has_input ? $record->{$input} : $record;
my $fh = $source->{fh};
return (
iterator => sub {
my $read = $record_reader->($fh);
my $retval = {%$record, $output => $read};
return $retval if defined $read;
if ($emit_eof) {
$emit_eof = 0;
return $retval;
}
return;
},
);
};
} ## end sub read_by_record_reader
sub read_by_separator {
my %args = normalize_args(
@_,
[
{
name => 'read_by_separator',
chomp => 1,
identification => {caller => [caller(0)]},
},
'separator'
]
);
my $separator = $args{separator};
my $chomp = $args{chomp};
return read_by_record_reader(
%args,
record_reader => sub {
my $fh = shift;
local $INPUT_RECORD_SEPARATOR = $separator;
my $retval = <$fh>;
chomp($retval) if defined($retval) && $chomp;
return $retval;
},
);
} ## end sub read_by_separator
shorter_sub_names(__PACKAGE__, 'read_');
1;
END_OF_FILE
'Data/Tubes/Plugin/Parser.pm' => <<'END_OF_FILE',
package Data::Tubes::Plugin::Parser;
use strict;
use warnings;
use English qw< -no_match_vars >;
use Data::Dumper;
our $VERSION = '0.740';
use Log::Log4perl::Tiny qw< :easy :dead_if_first >;
use Data::Tubes::Util qw<
assert_all_different
generalized_hashy
metadata
normalize_args
shorter_sub_names
test_all_equal
trim
unzip
>;
use Data::Tubes::Plugin::Util qw< identify >;
my %global_defaults = (
input => 'raw',
output => 'structured',
);
sub parse_by_format {
my %args = normalize_args(@_,
[{%global_defaults, name => 'parse by format'}, 'format']);
identify(\%args);
my $format = $args{format};
LOGDIE "parser of type 'format' needs a definition"
unless defined $format;
my @items = split m{(\W+)}, $format;
return parse_single(key => $items[0]) if @items == 1;
my ($keys, $separators) = unzip(\@items);
# all keys MUST be different, otherwise some fields are just trumping
# on each other
eval { assert_all_different($keys); }
or LOGDIE "'format' parser [$format] "
. "has duplicate key $EVAL_ERROR->{message}";
my $value = $args{value} //= ['whatever'];
$value = [$value] unless ref $value;
my $multiple =
(ref($value) ne 'ARRAY')
|| (scalar(@$value) > 1)
|| ($value->[0] ne 'whatever');
return parse_by_separators(
%args,
keys => $keys,
separators => $separators
) if $multiple || !test_all_equal(@$separators);
# a simple split will do if all separators are the same
return parse_by_split(
%args,
keys => $keys,
separator => $separators->[0]
);
} ## end sub parse_by_format
sub parse_by_regex {
my %args =
normalize_args(@_,
[{%global_defaults, name => 'parse by regex'}, 'regex']);
identify(\%args);
my $name = $args{name};
my $regex = $args{regex};
LOGDIE "parse_by_regex needs a regex"
unless defined $regex;
$regex = qr{$regex};
my $input = $args{input};
my $output = $args{output};
return sub {
my $record = shift;
$record->{$input} =~ m{$regex}
or die {
message => "'$name': invalid record, regex is $regex",
input => $input,
record => $record,
};
my $retval = {%+};
$record->{$output} = $retval;
return $record;
};
} ## end sub parse_by_regex
sub _resolve_separator {
my ($separator, $args) = @_;
return unless defined $separator;
$separator = $separator->($args) if ref($separator) eq 'CODE';
my $ref = ref $separator;
return $separator if $ref eq 'Regexp';
LOGCROAK "$args->{name}: unknown separator type $ref" if $ref;
$separator = quotemeta $separator;
return qr{(?-i:$separator)};
} ## end sub _resolve_separator
sub _resolve_value {
my ($value, $args) = @_;
$value //= 'whatever';
$value = $value->($args) if ref($value) eq 'CODE';
my $ref = ref $value;
($value, $ref) = ([$value], 'ARRAY') if (!$ref) || ($ref eq 'Regexp');
LOGCROAK "$args->{name}: unknown value type $ref" if $ref ne 'ARRAY';
my (%flag_for, @regexps);
for my $part (@$value) {
my $ref = ref $part;
if ($ref eq 'Regexp') {
push @regexps, $part;
}
elsif (
$part =~ m{\A(?:
(?:single|double)[-_]quoted
| escaped
| whatever
)\z}mxs
)
{
$part =~ s{-}{_}mxs;
$flag_for{$part} = 1;
} ## end elsif ($part =~ m{\A(?: )})
elsif ($part eq 'quoted') {
$flag_for{single_quoted} = 1;
$flag_for{double_quoted} = 1;
}
elsif ($part eq 'specials') {
$flag_for{single_quoted} = 1;
$flag_for{double_quoted} = 1;
$flag_for{escaped} = 1;
}
elsif ($ref) {
LOGCROAK "$args->{name}: unknown part of type $ref";
}
else {
LOGCROAK "$args->{name}: unknown part $part";
}
} ## end for my $part (@$value)
my @escape;
if ($flag_for{single_quoted}) {
push @escape, q{'};
unshift @regexps, q{(?mxs: '[^']*' )};
}
if ($flag_for{double_quoted}) {
push @escape, q{"};
unshift @regexps, q{(?mxs: "(?: [^\\"] | \\\\.)*" )};
}
if ($flag_for{escaped}) {
push @escape, '\\';
my $escape = quotemeta join '', @escape;
push @regexps, qq{(?mxs-i: (?: [^$escape] | \\\\.)*?)};
}
if ($flag_for{whatever}) {
push @regexps, qq{(?mxs:.*?)};
}
my $regex = '(' . join('|', @regexps) . ')';
return ($regex, \%flag_for);
} ## end sub _resolve_value
sub _resolve_decode {
my $args = shift;
my $name = $args->{name};
my $escape = $args->{escaped};
my $squote = $args->{single_quoted};
my $dquote = $args->{double_quoted};
my $vdecode = $args->{decode};
my $decode = $args->{decode_values};
if ($vdecode) {
$decode ||= sub {
my $values = shift;
for my $value (@$values) {
$value = $vdecode->($value);
}
return $values;
}
} ## end if ($vdecode)
elsif ($escape || $squote || $dquote) {
$decode ||= sub {
my $values = shift;
for my $i (0 .. $#$values) {
my $value = $values->[$i];
my $len = length $value or next;
my $first = substr $value, 0, 1;
if ($dquote && $first eq q{"}) {
die {message => "'$name': invalid record, "
. "unterminated double quote at field $i (0-based)"
}
unless $len > 1 && substr($value, -1, 1) eq q{"};
$values->[$i] = substr $value, 1, $len - 2; # unquote
$values->[$i] =~ s{\\(.)}{$1}gmxs; # unescape
} ## end if ($dquote && $first ...)
elsif ($squote && $first eq q{'}) {
die {message => "'$name': invalid record, "
. "unterminated single quote at field $i (0-based)",
}
unless $len > 1 && substr($value, -1, 1) eq q{'};
$values->[$i] = substr $value, 1, $len - 2; # unquote
} ## end elsif ($squote && $first ...)
elsif ($escape) {
$values->[$i] =~ s{\\(.)}{$1}gmxs; # unescape
}
} ## end for my $i (0 .. $#$values)
return $values;
}
} ## end elsif ($escape || $squote...)
return $decode;
} ## end sub _resolve_decode
sub parse_by_separators {
my %args = normalize_args(@_,
[{%global_defaults, name => 'parse by separators'}, 'separators']);
identify(\%args);
my $name = $args{name};
my $separators = $args{separators};
LOGDIE "parse_by_separators needs separators"
unless defined $separators;
$separators = [map { _resolve_separator($_, \%args) } @$separators];
my $keys = $args{keys};
my ($delta, $n_keys);
if (defined $keys) {
$n_keys = scalar @$keys;
$delta = $n_keys - scalar(@$separators);
LOGDIE "parse_by_separators 0 <= #keys - #separators <= 1"
if ($delta < 0) || ($delta > 1);
} ## end if (defined $keys)
else {
$keys = [0 .. scalar(@$separators)];
$n_keys = 0; # don't bother
$delta = 1;
}
my ($value_regex, $flag_for) = _resolve_value($args{value}, \%args);
my @items;
for my $i (0 .. $#$keys) {
push @items, $value_regex;
push @items, $separators->[$i] if $i <= $#$separators;
}
# if not a separator, the last item becomes a catchall
$items[-1] = '(.*)' if $delta > 0;
# ready to generate the regexp. We bind the end to \z anyway because
# the last element might be a separator
my $format = join '', '(?:\\A', @items, '\\z)';
my $regex = qr{$format};
DEBUG "$name: regex will be: $regex";
# this sub will use the regexp above, do checking and return captured
# values in a hash with @keys
my $input = $args{input};
my $output = $args{output};
my $trim = $args{trim};
my $decode = _resolve_decode({%args, %$flag_for});
return sub {
my $record = shift;
my @values = $record->{$input} =~ m{$regex}
or die {
message => 'invalid record',
record => $record,
regex => $regex
};
trim(@values) if $trim;
if ($decode) {
eval { @values = @{$decode->(\@values)}; 1 } or do {
my $e = $@;
$e = {message => $e} unless ref $e;
$e = {%$e, record => $record} if ref($e) eq 'HASH';
die $e;
};
} ## end if ($decode)
if ($n_keys) {
my $n_values = scalar @values;
die {
message => "'$name': invalid record, expected $n_keys, "
. "got $n_values only",
values => \@values,
record => $record
}
if $n_values < $n_keys;
$record->{$output} = \my %retval;
@retval{@$keys} = @values;
} ## end if ($n_keys)
else {
$record->{$output} = \@values;
}
return $record;
};
} ## end sub parse_by_separators
sub parse_by_split {
my %args =
normalize_args(@_,
[{%global_defaults, name => 'parse by split'}, 'separator']);
identify(\%args);
my $separator = _resolve_separator($args{separator}, \%args);
my $name = $args{name};
my $keys = $args{keys};
my $n_keys = defined($keys) ? scalar(@$keys) : 0;
my $input = $args{input};
my $output = $args{output};
my $allow_missing = $args{allow_missing} || 0;
my $trim = $args{trim};
return sub {
my $record = shift;
my @values = split(/$separator/, $record->{$input}, $n_keys);
trim(@values) if $trim;
my $n_values = @values;
die {
message => "'$name': invalid record, expected $n_keys items, "
. "got $n_values",
input => $input,
record => $record,
}
if $n_values + $allow_missing < $n_keys;
$record->{$output} = \my %retval;
@retval{@$keys} = @values;
return $record;
}
if $n_keys;
return sub {
my $record = shift;
my @retval = split /$separator/, $record->{$input};
trim(@retval) if $trim;
$record->{$output} = \@retval;
return $record;
};
} ## end sub parse_by_split
sub parse_by_value_separator {
my %args = normalize_args(
@_,
[
{%global_defaults, name => 'parse by value and separator'},
'separator'
]
);
identify(\%args);
my $name = $args{name};
my $separator = _resolve_separator($args{separator}, \%args);
LOGCROAK "$name: argument separator is mandatory"
unless defined $separator;
my ($value, $flag_for) = _resolve_value($args{value}, \%args);
my $decode = _resolve_decode({%args, %$flag_for});
my $keys = $args{keys};
my $n_keys = defined($keys) ? scalar(@$keys) : 0;
my $input = $args{input};
my $output = $args{output};
my $allow_missing = $args{allow_missing} || 0;
my $allow_surplus = $args{allow_surplus} || 0;
my $trim = $args{trim};
my $go_global = $^V lt v5.18.0;
return sub {
my $record = shift;
my @values;
if ($go_global) {
local our @global_values = ();
my $collector = qr/(?{push @global_values, $^N})/;
$record->{$input} =~ m/
\A (?: $value $separator $collector )*
$value \z $collector
/gmxs
or die {
message => 'invalid record',
separator => $separator,
value => $value,
record => $record,
};
@values = @global_values;
}
else {
$record->{$input} =~ m/
\A (?: $value $separator (?{push @values, $^N}) )*
$value \z (?{push @values, $^N})
/gmxs
or die {
message => 'invalid record',
separator => $separator,
value => $value,
record => $record,
};
}
trim(@values) if $trim;
if ($decode) {
eval { @values = @{$decode->(\@values)}; 1 } or do {
my $e = $EVAL_ERROR;
$e = {message => $e} unless ref $e;
$e = {%$e, record => $record} if ref($e) eq 'HASH';
die $e;
};
} ## end if ($decode)
if ($n_keys) {
my $n_values = @values;
die {
message => "'$name': invalid record, expected $n_keys items, "
. "got $n_values",
input => $input,
record => $record,
}
if ($n_values + $allow_missing < $n_keys)
|| ($n_values - $allow_surplus > $n_keys);
$record->{$output} = \my %retval;
@retval{@$keys} = @values;
} ## end if ($n_keys)
else {
$record->{$output} = \@values;
}
return $record;
};
} ## end sub parse_by_value_separator
sub parse_ghashy {
my %args = normalize_args(@_,
{%global_defaults, default_key => '', name => 'parse ghashy'});
identify(\%args);
my %defaults = %{$args{defaults} || {}};
my $input = $args{input};
my $output = $args{output};
# pre-compile capture thing from generalized_hashy
$args{capture} = generalized_hashy(%args, text => undef)->{capture};
return sub {
my $record = shift;
my $outcome = generalized_hashy(%args, text => $record->{$input});
die {
input => $input,
message => $outcome->{failure},
outcome => $outcome,
record => $record,
}
unless exists $outcome->{hash};
$record->{$output} = {%defaults, %{$outcome->{hash}}};
return $record;
};
} ## end sub parse_ghashy
sub parse_hashy {
my %args = normalize_args(
@_,
{
%global_defaults,
chunks_separator => ' ',
default_key => '',
key_value_separator => '=',
name => 'parse hashy',
}
);
identify(\%args);
my %defaults = %{$args{defaults} || {}};
my $input = $args{input};
my $output = $args{output};
return sub {
my $record = shift;
my $parsed = metadata($record->{$input}, %args);
$record->{$output} = {%defaults, %$parsed};
return $record;
};
} ## end sub parse_hashy
sub parse_single {
my %args = normalize_args(
@_,
{
key => 'key',
%global_defaults,
}
);
identify(\%args);
my $key = $args{key};
my $has_key = defined($key) && length($key);
my $input = $args{input};
my $output = $args{output};
return sub {
my $record = shift;
$record->{$output} =
$has_key ? {$key => $record->{$input}} : $record->{$input};
return $record;
}
} ## end sub parse_single
shorter_sub_names(__PACKAGE__, 'parse_');
1;
END_OF_FILE
'Data/Tubes/Plugin/Writer.pm' => <<'END_OF_FILE',
package Data::Tubes::Plugin::Writer;
# vim: ts=3 sts=3 sw=3 et ai :
use strict;
use warnings;
use English qw< -no_match_vars >;
use POSIX qw< strftime >;
our $VERSION = '0.740';
use Log::Log4perl::Tiny qw< :easy :dead_if_first LOGLEVEL >;
use Template::Perlish;
use Data::Tubes::Util
qw< normalize_args read_file_maybe shorter_sub_names sprintffy >;
use Data::Tubes::Plugin::Util qw< identify log_helper >;
use Data::Tubes::Plugin::Plumbing;
my %global_defaults = (input => 'rendered',);
sub _filenames_generator {
my $template = shift;
my $n = 0; # counter, used in closures inside $substitutions
my $substitutions = [
[qr{(\d*)n} => sub { return sprintf "%${1}d", $n; }],
[qr{Y} => sub { return strftime('%Y', localtime()); }],
[qr{m} => sub { return strftime('%m', localtime()); }],
[qr{d} => sub { return strftime('%d', localtime()); }],
[qr{H} => sub { return strftime('%H', localtime()); }],
[qr{M} => sub { return strftime('%M', localtime()); }],
[qr{S} => sub { return strftime('%S', localtime()); }],
[qr{z} => sub { return strftime('%z', localtime()); }],
[qr{D} => sub { return strftime('%Y%m%d', localtime()); }],
[qr{T} => sub { return strftime('%H%M%S%z', localtime()); }],
[qr{t} => sub { return strftime('%Y%m%dT%H%M%S%z', localtime()); }],
];
# see if the template depends on the counter
my $expanded = sprintffy($template, $substitutions);
return sub {
my $retval = sprintffy($template, $substitutions);
++$n;
return $retval;
}
if ($expanded ne $template); # it does!
# then, by default, revert to poor's man expansion of name...
return sub {
my $retval = $n ? "${template}_$n" : $template;
++$n;
return $retval;
};
} ## end sub _filenames_generator
sub dispatch_to_files {
my %args = normalize_args(
@_,
[
{
%global_defaults,
name => 'write dispatcher',
binmode => ':encoding(UTF-8)'
},
'filename'
],
);
identify(\%args);
my $name = delete $args{name}; # so that it can be overridden
if (defined(my $filename = delete $args{filename})) {
my $ref = ref $filename;
if (!$ref) {
$args{filename_template} //= $filename;
}
elsif ($ref eq 'CODE') {
$args{filename_factory} //= $filename;
}
else {
LOGDIE "argument filename has invalid type $ref";
}
} ## end if (defined(my $filename...))
my $factory = delete $args{filename_factory};
if (!defined($factory) && defined($args{filename_template})) {
my $tp = Template::Perlish->new(%{$args{tp_opts} || {}});
my $template = $tp->compile($args{filename_template});
$factory = sub {
my ($key, $record) = @_;
return $tp->evaluate($template, {key => $key, record => $record});
};
} ## end if (!defined($factory)...)
$args{factory} //= sub {
my $filename = $factory->(@_);
return write_to_files(%args, filename => $filename);
};
return Data::Tubes::Plugin::Plumbing::dispatch(%args);
} ## end sub dispatch_to_files
sub write_to_files {
my %args = normalize_args(
@_,
[
{
%global_defaults,
name => 'write to file',
binmode => ':encoding(UTF-8)',
filename => \*STDOUT,
},
'filename'
],
);
identify(\%args);
my $name = $args{name};
LOGDIE "$name: need a filename" unless defined $args{filename};
LOGDIE "$name: need an input" unless defined $args{input};
my $output = $args{filename};
$output = _filenames_generator($output) unless ref($output);
my %oha =
map { ($_ => $args{$_}) }
grep { defined $args{$_} } qw< binmode policy >;
for my $marker (qw< footer header interlude >) {
$oha{$marker} = read_file_maybe($args{$marker})
if defined $args{$marker};
}
require Data::Tubes::Util::Output;
my $output_handler =
Data::Tubes::Util::Output->new(%oha, output => $output,);
my $input = $args{input};
return sub {
my $record = shift;
$output_handler->print($record->{$input});
return $record; # relaunch for further processing
};
} ## end sub write_to_files
shorter_sub_names(__PACKAGE__, 'write_');
1;
END_OF_FILE
'Data/Tubes/Plugin/Plumbing.pm' => <<'END_OF_FILE',
package Data::Tubes::Plugin::Plumbing;
# vim: ts=3 sts=3 sw=3 et ai :
use strict;
use warnings;
use English qw< -no_match_vars >;
use Data::Dumper;
use Scalar::Util qw< blessed >;
our $VERSION = '0.740';
use Log::Log4perl::Tiny
qw< :easy :dead_if_first get_logger LOGLEVEL LEVELID_FOR >;
use Data::Tubes::Util qw<
args_array_with_options
load_module
load_sub
pump
normalize_args
traverse
>;
use Data::Tubes::Plugin::Util qw< identify log_helper tubify >;
sub alternatives {
my ($tubes, $args) =
args_array_with_options(@_, {name => 'alternatives'});
identify($args);
my $name = $args->{name};
my @tubes = tubify($args, @$tubes);
return sub {
my $record = shift;
for my $tube (@tubes) {
if (my @retval = $tube->($record)) {
return @retval;
}
}
return;
};
} ## end sub alternatives
sub _get_selector {
my $args = shift;
my $selector = $args->{selector};
if (!defined($selector) && defined($args->{key})) {
my $key = $args->{key};
my $ref = ref $key;
$selector =
($ref eq 'CODE')
? $key
: sub { return traverse($_[0], $ref ? @$key : $key); };
} ## end if (!defined($selector...))
LOGDIE "$args->{name}: required dispatch key or selector"
if (! defined $selector) && (! $args->{missing_ok});
return $selector;
} ## end sub _get_selector
sub cache {
my %args = normalize_args(@_, [{name => 'cache'}, 'tube']);
identify(\%args);
my $name = $args{name};
# the cached tube
my ($tube) = tubify(\%args, $args{tube});
LOGCROAK "$name: no tube to cache" unless defined $tube;
# the cache! We will use something compatible with CHI
my $cache = $args{cache} // {};
$cache = ['^Data::Tubes::Util::Cache', repository => $cache]
if ref($cache) eq 'HASH';
if (!blessed($cache)) {
my ($x, @args) = ref($cache) ? @$cache : $cache;
$cache = ref($x) ? $x->(@args) : load_module($x)->new(@args);
}
my @get_options = $args{get_options} ? @{$args{get_options}} : ();
my @set_options = $args{set_options} ? @{$args{set_options}} : ();
# what allows me to look in the cache?
my $selector = _get_selector({%args, missing_ok => 1});
LOGCROAK "missing key or selector, but output is set"
if (! defined $selector) && defined($args{output});
# cleaning trigger, if any
my $cleaner = $args{cleaner};
$cleaner = $cache->can($cleaner) if defined($cleaner) && !ref($cleaner);
# cloning facility, if needed
my $merger = $args{merger};
$merger = load_sub($merger) if defined($merger) && !ref($merger);
my $output = $args{output};
return sub {
my $record = shift;
my $key = $selector ? $selector->($record) : $record;
my $data = $cache->get($key, @get_options);
if (!$data) { # MUST be an array reference at this point
my @oc = $tube->($record);
if (scalar(@oc) == 2) {
my $rcs = ($oc[0] eq 'records') ? $oc[1] : pump($oc[1]);
$rcs = [map { $_->{$output} } @$rcs] if defined($output);
$data = [records => $rcs];
}
elsif (scalar @oc) {
$data = defined($output) ? [$oc[0]{$output}] : \@oc;
}
else {
$data = \@oc;
}
$cache->set($key, $data, @set_options);
$cleaner->($cache) if $cleaner;
} ## end if (!$data)
return unless scalar @$data;
if (scalar(@$data) == 1) { # single record
return $merger->($record, $output, $data->[0]) if $merger;
return $data->[0] unless $output;
$record->{$output} = $data->[0];
return $record;
} ## end if (scalar(@$data) == ...)
# array of records here
my $aref = $data->[1];
my $records =
$merger
? [map { $merger->($record, $output, $_) } @$aref]
: $output ? [
map {
{ %$record, $output => $_ }
} @$aref
]
: $aref;
return (records => $records);
};
} ## end sub cache
sub dispatch {
my %args = normalize_args(@_,
{default => undef, name => 'dispatch', loglevel => $INFO});
identify(\%args);
my $name = $args{name};
my $selector = _get_selector(\%args);
my $factory = $args{factory};
if (!defined($factory)) {
$factory = sub {
my ($key, $record) = @_;
die {
message => "$name: unhandled selection key '$key'",
record => $record,
};
};
} ## end if (!defined($factory))
my %predefined_for = %{$args{handlers} || {}};
my %handler_for;
my $default = $args{default};
return sub {
my $record = shift;
# get a key into the cache
my $key = $selector->($record) // $default;
die {
message => "$name: selector key is undefined",
record => $record,
}
unless defined $key;
$handler_for{$key} //= exists $predefined_for{$key}
? (tubify($predefined_for{$key}))[0]
: (tubify(\%args, $factory->($key, $record)))[0];
return $handler_for{$key}->($record);
};
} ## end sub dispatch
sub fallback {
# we lose syntax sugar but allow for Try::Catch to remain optional
eval { require Try::Catch; }
or LOGCONFESS 'Data::Tubes::Plugin::Plumbing::fallback '
. 'needs Try::Catch, please install';
my ($tubes, $args) = args_array_with_options(@_, {name => 'fallback'});
identify($args);
my $name = $args->{name};
my @tubes = tubify($args, @$tubes);
my $catch = $args->{catch};
return sub {
my $record = shift;
for my $tube (@tubes) {
my (@retval, $do_fallback);
Try::Catch::try(
sub {
@retval = $tube->($record);
},
Try::Catch::catch(
sub {
$catch->($_, $record) if $catch;
$do_fallback = 1;
}
)
);
return @retval unless $do_fallback;
} ## end for my $tube (@tubes)
return;
};
} ## end sub fallback
sub logger {
my %args = normalize_args(@_, {name => 'log pipe', loglevel => $INFO});
identify(\%args);
my $loglevel = LEVELID_FOR($args{loglevel});
my $mangler = $args{target};
if (!defined $mangler) {
$mangler = sub { return shift; }
}
elsif (ref($mangler) ne 'CODE') {
my @keys = ref($mangler) ? @$mangler : ($mangler);
$mangler = sub {
my $record = shift;
return traverse($record, @keys);
};
} ## end elsif (ref($mangler) ne 'CODE')
my $logger = get_logger();
return sub {
my $record = shift;
$logger->log($loglevel, $mangler->($record));
return $record;
};
} ## end sub logger
sub pipeline {
my ($tubes, $args) = args_array_with_options(@_, {name => 'pipeline'});
return sequence(%$args, tubes => $tubes);
}
sub sequence {
my %args =
normalize_args(@_, [{name => 'sequence', tubes => []}, 'tubes']);
identify(\%args);
# cope with an empty list of tubes - equivalent to an "id" function but
# always returning an iterator for consistency
my $tubes = $args{tubes} || [];
return sub {
my @record = shift;
return (
iterator => sub {
return unless @record;
return shift @record;
}
);
}
unless @$tubes;
# auto-generate tubes if you get definitions
my @tubes = tubify(\%args, @$tubes);
my $gate = $args{gate} // undef;
my $logger = log_helper(\%args);
my $name = $args{name};
return sub {
my $record = shift;
$logger->($record, \%args) if $logger;
my @stack = ({record => $record});
my $iterator = sub {
STEP:
while (@stack) {
my $pos = $#stack;
my $f = $stack[$pos];
my @record =
exists($f->{record}) ? delete $f->{record}
: exists($f->{iterator}) ? $f->{iterator}->()
: @{$f->{records} || []} ? shift @{$f->{records}}
: ();
if (!@record) { # no more at this level...
my $n = @stack;
TRACE "$name: level $n backtracking, no more records";
pop @stack;
next STEP;
} ## end if (!@record)
my $record = $record[0];
return $record if @stack > @tubes; # output cache
# cut the sequence early if the gate function says so
return $record if $gate && ! $gate->($record);
# something must be done...
my @outcome = $tubes[$pos]->($record)
or next STEP;
unshift @outcome, 'record' if @outcome == 1;
push @stack, {@outcome}; # and go to next level
} ## end STEP: while (@stack)
return; # end of output, empty list
};
return (iterator => $iterator);
};
} ## end sub sequence
1;
END_OF_FILE
'Data/Tubes/Plugin/Validator.pm' => <<'END_OF_FILE',
package Data::Tubes::Plugin::Validator;
use strict;
use warnings;
use English qw< -no_match_vars >;
our $VERSION = '0.740';
use Log::Log4perl::Tiny qw< :easy :dead_if_first >;
use Data::Tubes::Util
qw< args_array_with_options normalize_args shorter_sub_names >;
use Data::Tubes::Plugin::Util qw< identify >;
my %global_defaults = (input => 'structured',);
sub validate_admit {
my ($validators, $args) = args_array_with_options(
@_,
{
input => 'raw',
name => 'validate with acceptance regexp',
}
);
identify($args);
my $name = $args->{name};
my $input = $args->{input};
my $refuse = $args->{refuse};
return sub {
my $record = shift;
my $target = defined($input) ? $record->{$input} : $record;
for my $validator (@$validators) {
my $outcome =
(ref($validator) eq 'CODE')
? $validator->($target)
: ($target =~ m{$validator});
return unless ($outcome xor $refuse);
} ## end for my $validator (@$validators)
return $record;
};
} ## end sub validate_admit
sub validate_refuse {
my ($validators, $args) = args_array_with_options(
@_,
{
input => 'raw',
name => 'validate with rejection regexp',
}
);
$args->{refuse} = 1;
return validate_admit(@$validators, $args);
} ## end sub validate_refuse
sub validate_refuse_comment {
my $args = normalize_args(@_, {name => 'validate reject comment line'});
identify($args);
return validate_refuse(qr{(?mxs:\A \s* \#)}, $args);
}
sub validate_refuse_comment_or_empty {
my $args = normalize_args(@_,
{name => 'validate reject comment or non-spaces-only line'});
identify($args);
return validate_refuse(qr{(?mxs:\A \s* (?: \# | \z ))}, $args);
} ## end sub validate_refuse_comment_or_empty
sub validate_refuse_empty {
my $args = normalize_args(@_,
{name => 'validate reject empty (non-spaces only) string'});
identify($args);
return validate_refuse(qr{(?mxs:\A \s* \z)}, $args);
} ## end sub validate_refuse_empty
sub validate_thoroughly {
my ($validators, $args) = args_array_with_options(
@_,
{
%global_defaults,
name => 'validate with subs',
output => 'validation',
keep_positives => 0,
keep_empty => 0,
wrapper => undef,
}
);
identify($args);
my $name = $args->{name};
my $wrapper = $args->{wrapper};
if ($wrapper && $wrapper eq 'try') {
eval { require Try::Catch; }
or LOGCONFESS 'Validator::validate_with_subs '
. 'needs Try::Catch, please install';
$wrapper = sub {
my ($validator, @params) = @_;
return Try::Catch::try(
sub { $validator->(@params); },
Try::Catch::catch(sub { return (0, $_); }),
);
};
} ## end if ($wrapper && $wrapper...)
my $input = $args->{input};
my $output = $args->{output};
my $keep_positives = $args->{keep_positives};
my $keep_empty = $args->{keep_empty};
return sub {
my $record = shift;
my $target = defined($input) ? $record->{$input} : $record;
my @outcomes;
for my $i (0 .. $#$validators) {
my ($name, $validator, @params) =
(ref($validators->[$i]) eq 'ARRAY')
? @{$validators->[$i]}
: ("validator-$i", $validators->[$i]);
my @outcome =
$wrapper
? $wrapper->($validator, $target, $record, $args, @params)
: (ref($validator) eq 'CODE')
? $validator->($target, $record, $args, @params)
: (
$target =~ m{$validator}
? (1)
: (0, regex => "$validator")
);
push @outcome, 0 unless @outcome;
push @outcomes, [$name, @outcome]
if !$outcome[0] || $keep_positives;
} ## end for my $i (0 .. $#$validators)
$record->{$output} = undef;
$record->{$output} = \@outcomes if @outcomes || $keep_empty;
return $record;
};
} ## end sub validate_with_subs
*validate_with_subs = \&validate_thoroughly;
shorter_sub_names(__PACKAGE__, 'validate_');
1;
END_OF_FILE
'Data/Tubes/Plugin/Renderer.pm' => <<'END_OF_FILE',
package Data::Tubes::Plugin::Renderer;
use strict;
use warnings;
use English qw< -no_match_vars >;
our $VERSION = '0.740';
use Log::Log4perl::Tiny qw< :easy :dead_if_first >;
use Data::Tubes::Util qw< normalize_args shorter_sub_names >;
use Data::Tubes::Util qw< read_file_maybe >;
my %global_defaults = (
input => 'structured',
output => 'rendered',
);
sub _resolve_template {
my $args = shift;
my $template = read_file_maybe($args->{template});
$template = read_file_maybe($template->($args))
if ref($template) eq 'CODE';
LOGDIE 'undefined template' unless defined $template;
$template = $args->{template_perlish}->compile($template)
unless ref $template;
return $template if ref($template) eq 'HASH';
LOGDIE 'invalid template of type ' . ref($template);
} ## end sub _resolve_template
sub _create_tp {
my $args = shift;
require Template::Perlish;
return Template::Perlish->new(
map { $_ => $args->{$_} }
grep { defined $args->{$_} } qw< start stop variables >
);
} ## end sub _create_tp
sub _rwtp_ntp_nt {
my $args = shift;
my $input = $args->{input};
my $output = $args->{output};
my $tp = $args->{template_perlish};
my $template = _resolve_template($args) // LOGDIE 'undefined template';
return sub {
my $record = shift;
$record->{$output} =
$tp->evaluate($template, $record->{$input} // {});
return $record;
};
} ## end sub _rwtp_ntp_nt
sub _rwtp_ntp_t {
my $args = shift;
my $itf = $args->{template_input};
my $input = $args->{input};
my $output = $args->{output};
my $tp = $args->{template_perlish};
my $ctmpl =
defined($args->{template}) ? _resolve_template($args) : undef;
return sub {
my $record = shift;
my $template =
defined($record->{$itf})
? _resolve_template(
{
template_perlish => $tp,
template => $record->{$itf}
}
)
: ($ctmpl
// die {message => 'undefined template', record => $record});
$record->{$output} =
$tp->evaluate($template, $record->{$input} // {});
return $record;
};
} ## end sub _rwtp_ntp_t
sub _rwtp_tp_nt {
my $args = shift;
my $itpf = $args->{template_perlish_input};
my $input = $args->{input};
my $output = $args->{output};
my $ctp = $args->{template_perlish};
my $ctmpl = $args->{template} // LOGDIE 'undefined template';
my $pctmpl = _resolve_template($args) if defined $ctmpl;
return sub {
my $record = shift;
my $tp = $record->{$itpf} // $ctp;
my $template =
defined($record->{$itpf})
? _resolve_template({template_perlish => $tp, template => $ctmpl})
: $pctmpl;
$record->{$output} =
$tp->evaluate($template, $record->{$input} // {});
return $record;
};
} ## end sub _rwtp_tp_nt
sub _rwtp_tp_t {
my $args = shift;
my $itpf = $args->{template_perlish_input};
my $itf = $args->{template_input};
my $input = $args->{input};
my $output = $args->{output};
my $ctp = $args->{template_perlish};
my $ctmpl = $args->{template};
my $pctmpl = defined($ctmpl) ? _resolve_template($args) : undef;
return sub {
my $record = shift;
my $tp = $record->{$itpf} // $ctp;
my $template =
defined($record->{$itf}) ? _resolve_template(
{
template_perlish => $tp,
template => $record->{$itf}
}
)
: (!defined($ctmpl))
? die({message => 'undefined template', record => $record})
: defined($record->{$itpf})
? _resolve_template({template_perlish => $tp, template => $ctmpl})
: $pctmpl;
$record->{$output} =
$tp->evaluate($template, $record->{$input} // {});
return $record;
};
} ## end sub _rwtp_tp_t
sub render_with_template_perlish {
my %args = normalize_args(
@_,
[
{
%global_defaults,
start => '[%',
stop => '%]',
variables => {},
name => 'render with Template::Perlish',
},
'template'
]
);
my $name = $args{name};
$args{template_perlish} //= _create_tp(\%args);
my $tpi = defined $args{template_perlish_input};
my $ti = defined $args{template_input};
return
($tpi && $ti) ? _rwtp_tp_t(\%args)
: $tpi ? _rwtp_tp_nt(\%args)
: $ti ? _rwtp_ntp_t(\%args)
: _rwtp_ntp_nt(\%args);
} ## end sub render_with_template_perlish
shorter_sub_names(__PACKAGE__, 'render_');
1;
END_OF_FILE
);
unshift @INC, sub {
my ($me, $packfile) = @_;
return unless exists $file_for{$packfile};
(my $text = $file_for{$packfile}) =~ s/^\ //gmxs;
chop($text);
open my $fh, '<', \$text or die "open(): $!\n";
return $fh;
}
unless $main::LOADED++;
}
sub template {
my $template = <<'END_OF_TEMPLATE';
#!/usr/bin/env perl
# vim: sts=3 ts=3 sw=3 et ai :
### LEAVE THIS INITIAL SECTION AS-IS ##################################
BEGIN {
local ($x, @ARGV, $/) = ('# __MOBUNDLE_INCLUSION__', __FILE__);
eval((<> =~ m{(^$x.*^$x)}ms)[0]);
}
use strict;
use warnings;
use Pod::Usage qw< pod2usage >;
use Getopt::Long qw< :config gnu_getopt >;
use Data::Tubes qw< pipeline summon >;
### YOU CAN START CHANGING THINGS FROM HERE ON #########################
########################################################################
# __SECTION__
#
# Preamble
#
########################################################################
my $VERSION = '0.0.1';
use Log::Log4perl::Tiny qw< :easy LOGLEVEL :no_extra_logdie_message >;
use Template::Perlish qw< render >;
use Try::Tiny;
########################################################################
# __SECTION__
#
# Command Line Handling
#
########################################################################
my %config = get_options(
['loglevel|log=s', default => 'INFO'], # leave it or remove it
# start putting your options here
'foo|f=s',
['bar|b=s', default => 'default value for bar'],
['baz|B=i', required => 0, environment => 'MYAPP_BAZ'],
);
# Remove following line if you remove 'loglevel' in options above
LOGLEVEL($config{loglevel});
########################################################################
# __SECTION__
#
# Business Logic
#
########################################################################
# this is just an example to get you started, works with an input file
# like this:
#
# Flavio,44,salad
# FooBar,23,kiwi
my $template = <<'END_OF_TEMPLATE';
[[%%]% name %] is [[%%]% age %] and likes [[%%]% food %].
-----------------------------------------------------------
END_OF_TEMPLATE
pipeline(
'Source::iterate_files',
# Choose a reader
#
'Reader::by_line',
#
#'Reader::by_paragraph',
#
#['Reader::by_separator', separator => "\n---\n"],
# Choose a parser
#
#['Parser::hashy',
# chunks_separator => ';',
# key_value_separator => ':',
# default_key => 'name'],
#
['Parser::by_format', format => 'name,age,food'],
#
#['Parser::by_regex',
# regex => qr{(?mxs:\A(?<name>.*?),(?<age>\d+),(^<food>.*))}],
# There's little choiche for a renderer initially...
['Renderer::with_template_perlish', template => $template],
# Choose a writer
['Writer::to_files', filename => \*STDOUT],
#
#['Writer::to_files',
# filename => '[% name %]-output-%02d.txt',
# header => "-- here comes the data:\n",
# interlude => "-- end of record, start of next record --\n",
# footer => "-- end of data\n",
# binmode => ':encoding(UTF-8)',
# policy => {records_threshold => 100}],
#
#['Writer::dispatch_to_files',
# filename_factory => sub {...},
# filename_template => '[% name %]-{{ key }}-output-%02d.txt',
# tp_opts => {start => '{{', stop => '}}'},
{tap => 'sink'},
)->([@ARGV]);
########################################################################
# __SECTION__
#
# Embedded Modules
#
# You should not need to fiddle any more with code beyond this point.
# Be sure to get your POD right though!
#
########################################################################
# Ancillary scaffolding here
sub get_options {
my %config;
my @options = qw< usage! help! man! version! >;
my (%fallback_for, @required);
for my $option (@_) {
if (ref $option) {
my ($spec, %opts) = @$option;
push @options, $spec;
my ($name) = split /\|/, $spec, 2;
if (exists $opts{default}) {
$config{$name} = $opts{default};
}
if (exists $opts{environment}) {
$config{$name} = $ENV{$opts{environment}}
if defined $ENV{$opts{environment}};
}
if (exists $opts{fallback}) {
$fallback_for{$name} = $opts{fallback};
}
if (exists $opts{required}) {
push @required, $name;
}
} ## end if (ref $option)
else {
push @options, $option;
}
} ## end for my $option (@_)
GetOptions(\%config, @options)
or pod2usage(-verbose => 99, -sections => 'USAGE');
pod2usage(message => "$0 $VERSION", -verbose => 99,
-sections => ' ') if $config{version};
pod2usage(-verbose => 99, -sections => 'USAGE') if $config{usage};
pod2usage(-verbose => 99, -sections => 'USAGE|EXAMPLES|OPTIONS')
if $config{help};
pod2usage(-verbose => 2) if $config{man};
while (my ($key, $value) = each %fallback_for) {
next if exists $config{$key};
$config{$key} = $value;
}
my @missing = grep { ! exists $config{$_} } @required;
pod2usage(message => "missing options @missing",
-verbose => 99, -sections => 'USAGE')
if @missing;
return %config if wantarray();
return \%config;
} ## end sub get_options
[% modules_bundle %]
__END__
########################################################################
# __SECTION__
#
# POD
#
########################################################################
=pod
=encoding utf8
=head1 NAME
[% name %] - [% abstract %]
=head1 USAGE
[% name %] [--usage] [--help] [--man] [--version]
[% name %]
=head1 EXAMPLES
shell$ [% name %]
=for author, to fill in
Put a few examples of how to use your program
=head1 DESCRIPTION
=for author, to fill in
Put a thorough description of your program
=head1 OPTIONS
=for author, to fill in
Description of all command-line options
=over
=item --help
print a somewhat more verbose help, showing usage, this description of
the options and some examples from the synopsis.
=item --man
print out the full documentation for the script.
=item --usage
print a concise usage line and exit.
=item --version
print the version of the script.
=back
=head1 DIAGNOSTICS
=for author, to fill in
List and describe all warnings/error messages
=over
=item C<< Error message here, perhaps with %s placeholders >>
[Error description...]
=item C<< Another error message here >>
[Error description...]
[You get the idea...]
=back
=head1 CONFIGURATION AND ENVIRONMENT
=for author, to fill in
Explain any configuration that can be used by the program, via some
file or via environment variables.
[% name %] requires no configuration files or environment variables.
=head1 BUGS AND LIMITATIONS
=for author, to fill in
List any known bugs and limitations of your program
No bugs have been reported.
=head1 AUTHOR
[% author %] <[% email %]>
=head1 LICENCE AND COPYRIGHT
Copyright (c) [% year %], [% author %] <[% email %]>
=for author, to fill in
Put your licensing terms here, leaving the terms for the embedded
modules. If you're fine with the Artistic License 2.0, you can find
them in the two paragraphs below, delete them if you want to use
something different.
This program is free software. You can redistribute it and/or
modify it under the terms of the Artistic License 2.0.
This program is distributed in the hope that it will be useful,
but without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
This program embeds all modules from distribution Data::Tubes, that is
Copyright (C) 2016 by Flavio Poletti and licensed under the Artistic
details.
This program embeds Log::Log4perl::Tiny, that is Copyright (C) 2010-2016
by Flavio Poletti and licensed under the Artistic License 2.0. See
This program embeds Template::Perlish, that is Copyright (C) 2008-2016
by Flavio Poletti and licensed under the Artistic License 2.0. See
This program embeds Try::Tiny, that is Copyright (c) 2009 by ืืืื ืงืื'ืื
(Yuval Kogman) and licensed under The MIT (X11) License. See
=cut
END_OF_TEMPLATE
$template =~ s{^\ }{}gmxs;
$template =~ s{\n\z}{}mxs;
return $template;
}
__END__
Hide Show 409 lines of Pod