Find file
Fetching contributors…
Cannot retrieve contributors at this time
executable file 4747 lines (3334 sloc) 146 KB
#!/usr/bin/env perl
# This chunk of stuff was generated by App::FatPacker. To find the original
# file's code, look for the end of this BEGIN block or the string 'FATPACK'
BEGIN {
my %fatpacked;
$fatpacked{"Fatal.pm"} = <<'FATAL';
package Fatal;
use 5.008; # 5.8.x needed for autodie
use Carp;
use strict;
use warnings;
use Tie::RefHash; # To cache subroutine refs
use Config;
use constant PERL510 => ( $] >= 5.010 );
use constant LEXICAL_TAG => q{:lexical};
use constant VOID_TAG => q{:void};
use constant INSIST_TAG => q{!};
use constant ERROR_NOARGS => 'Cannot use lexical %s with no arguments';
use constant ERROR_VOID_LEX => VOID_TAG.' cannot be used with lexical scope';
use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument';
use constant ERROR_NO_LEX => "no %s can only start with ".LEXICAL_TAG;
use constant ERROR_BADNAME => "Bad subroutine name for %s: %s";
use constant ERROR_NOTSUB => "%s is not a Perl subroutine";
use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine";
use constant ERROR_NOHINTS => "No user hints defined for %s";
use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal";
use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()";
use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system(). We only have version %f";
use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect};
use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect};
use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supported under Perl 5.8.x};
# Older versions of IPC::System::Simple don't support all the
# features we need.
use constant MIN_IPC_SYS_SIMPLE_VER => 0.12;
# All the Fatal/autodie modules share the same version number.
our $VERSION = '2.11';
our $Debug ||= 0;
# EWOULDBLOCK values for systems that don't supply their own.
# Even though this is defined with our, that's to help our
# test code. Please don't rely upon this variable existing in
# the future.
our %_EWOULDBLOCK = (
MSWin32 => 33,
);
# the linux parisc port has separate EAGAIN and EWOULDBLOCK,
# and the kernel returns EAGAIN
my $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0;
# We have some tags that can be passed in for use with import.
# These are all assumed to be CORE::
my %TAGS = (
':io' => [qw(:dbm :file :filesys :ipc :socket
read seek sysread syswrite sysseek )],
':dbm' => [qw(dbmopen dbmclose)],
':file' => [qw(open close flock sysopen fcntl fileno binmode
ioctl truncate chmod)],
':filesys' => [qw(opendir closedir chdir link unlink rename mkdir
symlink rmdir readlink umask)],
':ipc' => [qw(:msg :semaphore :shm pipe)],
':msg' => [qw(msgctl msgget msgrcv msgsnd)],
':threads' => [qw(fork)],
':semaphore'=>[qw(semctl semget semop)],
':shm' => [qw(shmctl shmget shmread)],
':system' => [qw(system exec)],
# Can we use qw(getpeername getsockname)? What do they do on failure?
# TODO - Can socket return false?
':socket' => [qw(accept bind connect getsockopt listen recv send
setsockopt shutdown socketpair)],
# Our defaults don't include system(), because it depends upon
# an optional module, and it breaks the exotic form.
#
# This *may* change in the future. I'd love IPC::System::Simple
# to be a dependency rather than a recommendation, and hence for
# system() to be autodying by default.
':default' => [qw(:io :threads)],
# Everything in v2.07 and brefore. This was :default less chmod.
':v207' => [qw(:threads :dbm :filesys :ipc :socket read seek sysread
syswrite sysseek open close flock sysopen fcntl fileno
binmode ioctl truncate)],
# Version specific tags. These allow someone to specify
# use autodie qw(:1.994) and know exactly what they'll get.
':1.994' => [qw(:v207)],
':1.995' => [qw(:v207)],
':1.996' => [qw(:v207)],
':1.997' => [qw(:v207)],
':1.998' => [qw(:v207)],
':1.999' => [qw(:v207)],
':1.999_01' => [qw(:v207)],
':2.00' => [qw(:v207)],
':2.01' => [qw(:v207)],
':2.02' => [qw(:v207)],
':2.03' => [qw(:v207)],
':2.04' => [qw(:v207)],
':2.05' => [qw(:v207)],
':2.06' => [qw(:v207)],
':2.06_01' => [qw(:v207)],
':2.07' => [qw(:v207)], # Last release without chmod
':2.08' => [qw(:default)],
':2.09' => [qw(:default)],
':2.10' => [qw(:default)],
':2.11' => [qw(:default)],
);
# chmod was only introduced in 2.07
$TAGS{':all'} = [ keys %TAGS ];
# This hash contains subroutines for which we should
# subroutine() // die() rather than subroutine() || die()
my %Use_defined_or;
# CORE::open returns undef on failure. It can legitimately return
# 0 on success, eg: open(my $fh, '-|') || exec(...);
@Use_defined_or{qw(
CORE::fork
CORE::recv
CORE::send
CORE::open
CORE::fileno
CORE::read
CORE::readlink
CORE::sysread
CORE::syswrite
CORE::sysseek
CORE::umask
)} = ();
# Cached_fatalised_sub caches the various versions of our
# fatalised subs as they're produced. This means we don't
# have to build our own replacement of CORE::open and friends
# for every single package that wants to use them.
my %Cached_fatalised_sub = ();
# Every time we're called with package scope, we record the subroutine
# (including package or CORE::) in %Package_Fatal. This allows us
# to detect illegal combinations of autodie and Fatal, and makes sure
# we don't accidently make a Fatal function autodying (which isn't
# very useful).
my %Package_Fatal = ();
# The first time we're called with a user-sub, we cache it here.
# In the case of a "no autodie ..." we put back the cached copy.
my %Original_user_sub = ();
# Is_fatalised_sub simply records a big map of fatalised subroutine
# refs. It means we can avoid repeating work, or fatalising something
# we've already processed.
my %Is_fatalised_sub = ();
tie %Is_fatalised_sub, 'Tie::RefHash';
# We use our package in a few hash-keys. Having it in a scalar is
# convenient. The "guard $PACKAGE" string is used as a key when
# setting up lexical guards.
my $PACKAGE = __PACKAGE__;
my $PACKAGE_GUARD = "guard $PACKAGE";
my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie'
# Here's where all the magic happens when someone write 'use Fatal'
# or 'use autodie'.
sub import {
my $class = shift(@_);
my @original_args = @_;
my $void = 0;
my $lexical = 0;
my $insist_hints = 0;
my ($pkg, $filename) = caller();
@_ or return; # 'use Fatal' is a no-op.
# If we see the :lexical flag, then _all_ arguments are
# changed lexically
if ($_[0] eq LEXICAL_TAG) {
$lexical = 1;
shift @_;
# If we see no arguments and :lexical, we assume they
# wanted ':default'.
if (@_ == 0) {
push(@_, ':default');
}
# Don't allow :lexical with :void, it's needlessly confusing.
if ( grep { $_ eq VOID_TAG } @_ ) {
croak(ERROR_VOID_LEX);
}
}
if ( grep { $_ eq LEXICAL_TAG } @_ ) {
# If we see the lexical tag as the non-first argument, complain.
croak(ERROR_LEX_FIRST);
}
my @fatalise_these = @_;
# Thiese subs will get unloaded at the end of lexical scope.
my %unload_later;
# This hash helps us track if we've alredy done work.
my %done_this;
# NB: we're using while/shift rather than foreach, since
# we'll be modifying the array as we walk through it.
while (my $func = shift @fatalise_these) {
if ($func eq VOID_TAG) {
# When we see :void, set the void flag.
$void = 1;
} elsif ($func eq INSIST_TAG) {
$insist_hints = 1;
} elsif (exists $TAGS{$func}) {
# When it's a tag, expand it.
push(@fatalise_these, @{ $TAGS{$func} });
} else {
# Otherwise, fatalise it.
# Check to see if there's an insist flag at the front.
# If so, remove it, and insist we have hints for this sub.
my $insist_this;
if ($func =~ s/^!//) {
$insist_this = 1;
}
# TODO: Even if we've already fatalised, we should
# check we've done it with hints (if $insist_hints).
# If we've already made something fatal this call,
# then don't do it twice.
next if $done_this{$func};
# We're going to make a subroutine fatalistic.
# However if we're being invoked with 'use Fatal qw(x)'
# and we've already been called with 'no autodie qw(x)'
# in the same scope, we consider this to be an error.
# Mixing Fatal and autodie effects was considered to be
# needlessly confusing on p5p.
my $sub = $func;
$sub = "${pkg}::$sub" unless $sub =~ /::/;
# If we're being called as Fatal, and we've previously
# had a 'no X' in scope for the subroutine, then complain
# bitterly.
if (! $lexical and $^H{$NO_PACKAGE}{$sub}) {
croak(sprintf(ERROR_FATAL_CONFLICT, $func, $func));
}
# We're not being used in a confusing way, so make
# the sub fatal. Note that _make_fatal returns the
# old (original) version of the sub, or undef for
# built-ins.
my $sub_ref = $class->_make_fatal(
$func, $pkg, $void, $lexical, $filename,
( $insist_this || $insist_hints )
);
$done_this{$func}++;
$Original_user_sub{$sub} ||= $sub_ref;
# If we're making lexical changes, we need to arrange
# for them to be cleaned at the end of our scope, so
# record them here.
$unload_later{$func} = $sub_ref if $lexical;
}
}
if ($lexical) {
# Dark magic to have autodie work under 5.8
# Copied from namespace::clean, that copied it from
# autobox, that found it on an ancient scroll written
# in blood.
# This magic bit causes %^H to be lexically scoped.
$^H |= 0x020000;
# Our package guard gets invoked when we leave our lexical
# scope.
push(@ { $^H{$PACKAGE_GUARD} }, autodie::Scope::Guard->new(sub {
$class->_install_subs($pkg, \%unload_later);
}));
# To allow others to determine when autodie was in scope,
# and with what arguments, we also set a %^H hint which
# is how we were called.
# This feature should be considered EXPERIMENTAL, and
# may change without notice. Please e-mail pjf@cpan.org
# if you're actually using it.
$^H{autodie} = "$PACKAGE @original_args";
}
return;
}
# The code here is originally lifted from namespace::clean,
# by Robert "phaylon" Sedlacek.
#
# It's been redesigned after feedback from ikegami on perlmonks.
# See http://perlmonks.org/?node_id=693338 . Ikegami rocks.
#
# Given a package, and hash of (subname => subref) pairs,
# we install the given subroutines into the package. If
# a subref is undef, the subroutine is removed. Otherwise
# it replaces any existing subs which were already there.
sub _install_subs {
my ($class, $pkg, $subs_to_reinstate) = @_;
my $pkg_sym = "${pkg}::";
while(my ($sub_name, $sub_ref) = each %$subs_to_reinstate) {
my $full_path = $pkg_sym.$sub_name;
# Copy symbols across to temp area.
no strict 'refs'; ## no critic
local *__tmp = *{ $full_path };
# Nuke the old glob.
{ no strict; delete $pkg_sym->{$sub_name}; } ## no critic
# Copy innocent bystanders back. Note that we lose
# formats; it seems that Perl versions up to 5.10.0
# have a bug which causes copying formats to end up in
# the scalar slot. Thanks to Ben Morrow for spotting this.
foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) {
next unless defined *__tmp{ $slot };
*{ $full_path } = *__tmp{ $slot };
}
# Put back the old sub (if there was one).
if ($sub_ref) {
no strict; ## no critic
*{ $pkg_sym . $sub_name } = $sub_ref;
}
}
return;
}
sub unimport {
my $class = shift;
# Calling "no Fatal" must start with ":lexical"
if ($_[0] ne LEXICAL_TAG) {
croak(sprintf(ERROR_NO_LEX,$class));
}
shift @_; # Remove :lexical
my $pkg = (caller)[0];
# If we've been called with arguments, then the developer
# has explicitly stated 'no autodie qw(blah)',
# in which case, we disable Fatalistic behaviour for 'blah'.
my @unimport_these = @_ ? @_ : ':all';
while (my $symbol = shift @unimport_these) {
if ($symbol =~ /^:/) {
# Looks like a tag! Expand it!
push(@unimport_these, @{ $TAGS{$symbol} });
next;
}
my $sub = $symbol;
$sub = "${pkg}::$sub" unless $sub =~ /::/;
# If 'blah' was already enabled with Fatal (which has package
# scope) then, this is considered an error.
if (exists $Package_Fatal{$sub}) {
croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol));
}
# Record 'no autodie qw($sub)' as being in effect.
# This is to catch conflicting semantics elsewhere
# (eg, mixing Fatal with no autodie)
$^H{$NO_PACKAGE}{$sub} = 1;
if (my $original_sub = $Original_user_sub{$sub}) {
# Hey, we've got an original one of these, put it back.
$class->_install_subs($pkg, { $symbol => $original_sub });
next;
}
# We don't have an original copy of the sub, on the assumption
# it's core (or doesn't exist), we'll just nuke it.
$class->_install_subs($pkg,{ $symbol => undef });
}
return;
}
# TODO - This is rather terribly inefficient right now.
# NB: Perl::Critic's dump-autodie-tag-contents depends upon this
# continuing to work.
{
my %tag_cache;
sub _expand_tag {
my ($class, $tag) = @_;
if (my $cached = $tag_cache{$tag}) {
return $cached;
}
if (not exists $TAGS{$tag}) {
croak "Invalid exception class $tag";
}
my @to_process = @{$TAGS{$tag}};
my @taglist = ();
while (my $item = shift @to_process) {
if ($item =~ /^:/) {
# Expand :tags
push(@to_process, @{$TAGS{$item}} );
}
else {
push(@taglist, "CORE::$item");
}
}
$tag_cache{$tag} = \@taglist;
return \@taglist;
}
}
# This code is from the original Fatal. It scares me.
# It is 100% compatible with the 5.10.0 Fatal module, right down
# to the scary 'XXXX' comment. ;)
sub fill_protos {
my $proto = shift;
my ($n, $isref, @out, @out1, $seen_semi) = -1;
while ($proto =~ /\S/) {
$n++;
push(@out1,[$n,@out]) if $seen_semi;
push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([_*\$&])//;
push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
$seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
die "Internal error: Unknown prototype letters: \"$proto\"";
}
push(@out1,[$n+1,@out]);
return @out1;
}
# This is a backwards compatible version of _write_invocation. It's
# recommended you don't use it.
sub write_invocation {
my ($core, $call, $name, $void, @args) = @_;
return Fatal->_write_invocation(
$core, $call, $name, $void,
0, # Lexical flag
undef, # Sub, unused in legacy mode
undef, # Subref, unused in legacy mode.
@args
);
}
# This version of _write_invocation is used internally. It's not
# recommended you call it from external code, as the interface WILL
# change in the future.
sub _write_invocation {
my ($class, $core, $call, $name, $void, $lexical, $sub, $sref, @argvs) = @_;
if (@argvs == 1) { # No optional arguments
my @argv = @{$argvs[0]};
shift @argv;
return $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
} else {
my $else = "\t";
my (@out, @argv, $n);
while (@argvs) {
@argv = @{shift @argvs};
$n = shift @argv;
my $condition = "\@_ == $n";
if (@argv and $argv[-1] =~ /#_/) {
# This argv ends with '@' in the prototype, so it matches
# any number of args >= the number of expressions in the
# argv.
$condition = "\@_ >= $n";
}
push @out, "${else}if ($condition) {\n";
$else = "\t} els";
push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
}
push @out, qq[
}
die "Internal error: $name(\@_): Do not expect to get ", scalar(\@_), " arguments";
];
return join '', @out;
}
}
# This is a slim interface to ensure backward compatibility with
# anyone doing very foolish things with old versions of Fatal.
sub one_invocation {
my ($core, $call, $name, $void, @argv) = @_;
return Fatal->_one_invocation(
$core, $call, $name, $void,
undef, # Sub. Unused in back-compat mode.
1, # Back-compat flag
undef, # Subref, unused in back-compat mode.
@argv
);
}
# This is the internal interface that generates code.
# NOTE: This interface WILL change in the future. Please do not
# call this subroutine directly.
# TODO: Whatever's calling this code has already looked up hints. Pass
# them in, rather than look them up a second time.
sub _one_invocation {
my ($class, $core, $call, $name, $void, $sub, $back_compat, $sref, @argv) = @_;
# If someone is calling us directly (a child class perhaps?) then
# they could try to mix void without enabling backwards
# compatibility. We just don't support this at all, so we gripe
# about it rather than doing something unwise.
if ($void and not $back_compat) {
Carp::confess("Internal error: :void mode not supported with $class");
}
# @argv only contains the results of the in-built prototype
# function, and is therefore safe to interpolate in the
# code generators below.
# TODO - The following clobbers context, but that's what the
# old Fatal did. Do we care?
if ($back_compat) {
# Use Fatal qw(system) will never be supported. It generated
# a compile-time error with legacy Fatal, and there's no reason
# to support it when autodie does a better job.
if ($call eq 'CORE::system') {
return q{
croak("UNIMPLEMENTED: use Fatal qw(system) not supported.");
};
}
local $" = ', ';
if ($void) {
return qq/return (defined wantarray)?$call(@argv):
$call(@argv) || Carp::croak("Can't $name(\@_)/ .
($core ? ': $!' : ', \$! is \"$!\"') . '")'
} else {
return qq{return $call(@argv) || Carp::croak("Can't $name(\@_)} .
($core ? ': $!' : ', \$! is \"$!\"') . '")';
}
}
# The name of our original function is:
# $call if the function is CORE
# $sub if our function is non-CORE
# The reason for this is that $call is what we're actualling
# calling. For our core functions, this is always
# CORE::something. However for user-defined subs, we're about to
# replace whatever it is that we're calling; as such, we actually
# calling a subroutine ref.
my $human_sub_name = $core ? $call : $sub;
# Should we be testing to see if our result is defined, or
# just true?
my $use_defined_or;
my $hints; # All user-sub hints, including list hints.
if ( $core ) {
# Core hints are built into autodie.
$use_defined_or = exists ( $Use_defined_or{$call} );
}
else {
# User sub hints are looked up using autodie::hints,
# since users may wish to add their own hints.
require autodie::hints;
$hints = autodie::hints->get_hints_for( $sref );
# We'll look up the sub's fullname. This means we
# get better reports of where it came from in our
# error messages, rather than what imported it.
$human_sub_name = autodie::hints->sub_fullname( $sref );
}
# Checks for special core subs.
if ($call eq 'CORE::system') {
# Leverage IPC::System::Simple if we're making an autodying
# system.
local $" = ", ";
# We need to stash $@ into $E, rather than using
# local $@ for the whole sub. If we don't then
# any exceptions from internal errors in autodie/Fatal
# will mysteriously disappear before propogating
# upwards.
return qq{
my \$retval;
my \$E;
{
local \$@;
eval {
\$retval = IPC::System::Simple::system(@argv);
};
\$E = \$@;
}
if (\$E) {
# TODO - This can't be overridden in child
# classes!
die autodie::exception::system->new(
function => q{CORE::system}, args => [ @argv ],
message => "\$E", errno => \$!,
);
}
return \$retval;
};
}
local $" = ', ';
# If we're going to throw an exception, here's the code to use.
my $die = qq{
die $class->throw(
function => q{$human_sub_name}, args => [ @argv ],
pragma => q{$class}, errno => \$!,
context => \$context, return => \$retval,
eval_error => \$@
)
};
if ($call eq 'CORE::flock') {
# flock needs special treatment. When it fails with
# LOCK_UN and EWOULDBLOCK, then it's not really fatal, it just
# means we couldn't get the lock right now.
require POSIX; # For POSIX::EWOULDBLOCK
local $@; # Don't blat anyone else's $@.
# Ensure that our vendor supports EWOULDBLOCK. If they
# don't (eg, Windows), then we use known values for its
# equivalent on other systems.
my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); }
|| $_EWOULDBLOCK{$^O}
|| _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system.");
my $EAGAIN = $EWOULDBLOCK;
if ($try_EAGAIN) {
$EAGAIN = eval { POSIX::EAGAIN(); }
|| _autocroak("Internal error - can't overload flock - EAGAIN not defined on this system.");
}
require Fcntl; # For Fcntl::LOCK_NB
return qq{
my \$context = wantarray() ? "list" : "scalar";
# Try to flock. If successful, return it immediately.
my \$retval = $call(@argv);
return \$retval if \$retval;
# If we failed, but we're using LOCK_NB and
# returned EWOULDBLOCK, it's not a real error.
if (\$_[1] & Fcntl::LOCK_NB() and
(\$! == $EWOULDBLOCK or
($try_EAGAIN and \$! == $EAGAIN ))) {
return \$retval;
}
# Otherwise, we failed. Die noisily.
$die;
};
}
# AFAIK everything that can be given an unopned filehandle
# will fail if it tries to use it, so we don't really need
# the 'unopened' warning class here. Especially since they
# then report the wrong line number.
# Other warnings are disabled because they produce excessive
# complaints from smart-match hints under 5.10.1.
my $code = qq[
no warnings qw(unopened uninitialized numeric);
if (wantarray) {
my \@results = $call(@argv);
my \$retval = \\\@results;
my \$context = "list";
];
if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) {
# NB: Subroutine hints are passed as a full list.
# This differs from the 5.10.0 smart-match behaviour,
# but means that context unaware subroutines can use
# the same hints in both list and scalar context.
$code .= qq{
if ( \$hints->{list}->(\@results) ) { $die };
};
}
elsif ( PERL510 and $hints ) {
$code .= qq{
if ( \@results ~~ \$hints->{list} ) { $die };
};
}
elsif ( $hints ) {
croak sprintf(ERROR_58_HINTS, 'list', $sub);
}
else {
$code .= qq{
# An empty list, or a single undef is failure
if (! \@results or (\@results == 1 and ! defined \$results[0])) {
$die;
}
}
}
# Tidy up the end of our wantarray call.
$code .= qq[
return \@results;
}
];
# Otherwise, we're in scalar context.
# We're never in a void context, since we have to look
# at the result.
$code .= qq{
my \$retval = $call(@argv);
my \$context = "scalar";
};
if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) {
# We always call code refs directly, since that always
# works in 5.8.x, and always works in 5.10.1
return $code .= qq{
if ( \$hints->{scalar}->(\$retval) ) { $die };
return \$retval;
};
}
elsif (PERL510 and $hints) {
return $code . qq{
if ( \$retval ~~ \$hints->{scalar} ) { $die };
return \$retval;
};
}
elsif ( $hints ) {
croak sprintf(ERROR_58_HINTS, 'scalar', $sub);
}
return $code .
( $use_defined_or ? qq{
$die if not defined \$retval;
return \$retval;
} : qq{
return \$retval || $die;
} ) ;
}
# This returns the old copy of the sub, so we can
# put it back at end of scope.
# TODO : Check to make sure prototypes are restored correctly.
# TODO: Taking a huge list of arguments is awful. Rewriting to
# take a hash would be lovely.
# TODO - BACKCOMPAT - This is not yet compatible with 5.10.0
sub _make_fatal {
my($class, $sub, $pkg, $void, $lexical, $filename, $insist) = @_;
my($name, $code, $sref, $real_proto, $proto, $core, $call, $hints);
my $ini = $sub;
$sub = "${pkg}::$sub" unless $sub =~ /::/;
# Figure if we're using lexical or package semantics and
# twiddle the appropriate bits.
if (not $lexical) {
$Package_Fatal{$sub} = 1;
}
# TODO - We *should* be able to do skipping, since we know when
# we've lexicalised / unlexicalised a subroutine.
$name = $sub;
$name =~ s/.*::// or $name =~ s/^&//;
warn "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/;
if (defined(&$sub)) { # user subroutine
# NOTE: Previously we would localise $@ at this point, so
# the following calls to eval {} wouldn't interfere with anything
# that's already in $@. Unfortunately, it would also stop
# any of our croaks from triggering(!), which is even worse.
# This could be something that we've fatalised that
# was in core.
if ( $Package_Fatal{$sub} and do { local $@; eval { prototype "CORE::$name" } } ) {
# Something we previously made Fatal that was core.
# This is safe to replace with an autodying to core
# version.
$core = 1;
$call = "CORE::$name";
$proto = prototype $call;
# We return our $sref from this subroutine later
# on, indicating this subroutine should be placed
# back when we're finished.
$sref = \&$sub;
} else {
# If this is something we've already fatalised or played with,
# then look-up the name of the original sub for the rest of
# our processing.
$sub = $Is_fatalised_sub{\&$sub} || $sub;
# A regular user sub, or a user sub wrapping a
# core sub.
$sref = \&$sub;
$proto = prototype $sref;
$call = '&$sref';
require autodie::hints;
$hints = autodie::hints->get_hints_for( $sref );
# If we've insisted on hints, but don't have them, then
# bail out!
if ($insist and not $hints) {
croak(sprintf(ERROR_NOHINTS, $name));
}
# Otherwise, use the default hints if we don't have
# any.
$hints ||= autodie::hints::DEFAULT_HINTS();
}
} elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) {
# Stray user subroutine
croak(sprintf(ERROR_NOTSUB,$sub));
} elsif ($name eq 'system') {
# If we're fatalising system, then we need to load
# helper code.
# The business with $E is to avoid clobbering our caller's
# $@, and to avoid $@ being localised when we croak.
my $E;
{
local $@;
eval {
require IPC::System::Simple; # Only load it if we need it.
require autodie::exception::system;
};
$E = $@;
}
if ($E) { croak ERROR_NO_IPC_SYS_SIMPLE; }
# Make sure we're using a recent version of ISS that actually
# support fatalised system.
if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) {
croak sprintf(
ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER,
$IPC::System::Simple::VERSION
);
}
$call = 'CORE::system';
$name = 'system';
$core = 1;
} elsif ($name eq 'exec') {
# Exec doesn't have a prototype. We don't care. This
# breaks the exotic form with lexical scope, and gives
# the regular form a "do or die" beaviour as expected.
$call = 'CORE::exec';
$name = 'exec';
$core = 1;
} else { # CORE subroutine
my $E;
{
local $@;
$proto = eval { prototype "CORE::$name" };
$E = $@;
}
croak(sprintf(ERROR_NOT_BUILT,$name)) if $E;
croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto;
$core = 1;
$call = "CORE::$name";
}
if (defined $proto) {
$real_proto = " ($proto)";
} else {
$real_proto = '';
$proto = '@';
}
my $true_name = $core ? $call : $sub;
# TODO: This caching works, but I don't like using $void and
# $lexical as keys. In particular, I suspect our code may end up
# wrapping already wrapped code when autodie and Fatal are used
# together.
# NB: We must use '$sub' (the name plus package) and not
# just '$name' (the short name) here. Failing to do so
# results code that's in the wrong package, and hence has
# access to the wrong package filehandles.
if (my $subref = $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical}) {
$class->_install_subs($pkg, { $name => $subref });
return $sref;
}
$code = qq[
sub$real_proto {
local(\$", \$!) = (', ', 0); # TODO - Why do we do this?
];
# Don't have perl whine if exec fails, since we'll be handling
# the exception now.
$code .= "no warnings qw(exec);\n" if $call eq "CORE::exec";
my @protos = fill_protos($proto);
$code .= $class->_write_invocation($core, $call, $name, $void, $lexical, $sub, $sref, @protos);
$code .= "}\n";
warn $code if $Debug;
# I thought that changing package was a monumental waste of
# time for CORE subs, since they'll always be the same. However
# that's not the case, since they may refer to package-based
# filehandles (eg, with open).
#
# There is potential to more aggressively cache core subs
# that we know will never want to interact with package variables
# and filehandles.
{
no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ...
my $E;
{
local $@;
$code = eval("package $pkg; require Carp; $code"); ## no critic
$E = $@;
}
if (not $code) {
croak("Internal error in autodie/Fatal processing $true_name: $E");
}
}
# Now we need to wrap our fatalised sub inside an itty bitty
# closure, which can detect if we've leaked into another file.
# Luckily, we only need to do this for lexical (autodie)
# subs. Fatal subs can leak all they want, it's considered
# a "feature" (or at least backwards compatible).
# TODO: Cache our leak guards!
# TODO: This is pretty hairy code. A lot more tests would
# be really nice for this.
my $leak_guard;
if ($lexical) {
$leak_guard = qq<
package $pkg;
sub$real_proto {
# If we're inside a string eval, we can end up with a
# whacky filename. The following code allows autodie
# to propagate correctly into string evals.
my \$caller_level = 0;
my \$caller;
while ( (\$caller = (caller \$caller_level)[1]) =~ m{^\\(eval \\d+\\)\$} ) {
# If our filename is actually an eval, and we
# reach it, then go to our autodying code immediatately.
goto &\$code if (\$caller eq \$filename);
\$caller_level++;
}
# We're now out of the eval stack.
# If we're called from the correct file, then use the
# autodying code.
goto &\$code if ((caller \$caller_level)[1] eq \$filename);
# Oh bother, we've leaked into another file. Call the
# original code. Note that \$sref may actually be a
# reference to a Fatalised version of a core built-in.
# That's okay, because Fatal *always* leaks between files.
goto &\$sref if \$sref;
>;
# If we're here, it must have been a core subroutine called.
# Warning: The following code may disturb some viewers.
# TODO: It should be possible to combine this with
# write_invocation().
foreach my $proto (@protos) {
local $" = ", "; # So @args is formatted correctly.
my ($count, @args) = @$proto;
$leak_guard .= qq<
if (\@_ == $count) {
return $call(@args);
}
>;
}
$leak_guard .= qq< Carp::croak("Internal error in Fatal/autodie. Leak-guard failure"); } >;
# warn "$leak_guard\n";
my $E;
{
local $@;
$leak_guard = eval $leak_guard; ## no critic
$E = $@;
}
die "Internal error in $class: Leak-guard installation failure: $E" if $E;
}
my $installed_sub = $leak_guard || $code;
$class->_install_subs($pkg, { $name => $installed_sub });
$Cached_fatalised_sub{$class}{$sub}{$void}{$lexical} = $installed_sub;
# Cache that we've now overriddent this sub. If we get called
# again, we may need to find that find subroutine again (eg, for hints).
$Is_fatalised_sub{$installed_sub} = $sref;
return $sref;
}
# This subroutine exists primarily so that child classes can override
# it to point to their own exception class. Doing this is significantly
# less complex than overriding throw()
sub exception_class { return "autodie::exception" };
{
my %exception_class_for;
my %class_loaded;
sub throw {
my ($class, @args) = @_;
# Find our exception class if we need it.
my $exception_class =
$exception_class_for{$class} ||= $class->exception_class;
if (not $class_loaded{$exception_class}) {
if ($exception_class =~ /[^\w:']/) {
confess "Bad exception class '$exception_class'.\nThe '$class->exception_class' method wants to use $exception_class\nfor exceptions, but it contains characters which are not word-characters or colons.";
}
# Alas, Perl does turn barewords into modules unless they're
# actually barewords. As such, we're left doing a string eval
# to make sure we load our file correctly.
my $E;
{
local $@; # We can't clobber $@, it's wrong!
my $pm_file = $exception_class . ".pm";
$pm_file =~ s{ (?: :: | ' ) }{/}gx;
eval { require $pm_file };
$E = $@; # Save $E despite ending our local.
}
# We need quotes around $@ to make sure it's stringified
# while still in scope. Without them, we run the risk of
# $@ having been cleared by us exiting the local() block.
confess "Failed to load '$exception_class'.\nThis may be a typo in the '$class->exception_class' method,\nor the '$exception_class' module may not exist.\n\n $E" if $E;
$class_loaded{$exception_class}++;
}
return $exception_class->new(@args);
}
}
# For some reason, dying while replacing our subs doesn't
# kill our calling program. It simply stops the loading of
# autodie and keeps going with everything else. The _autocroak
# sub allows us to die with a vegence. It should *only* ever be
# used for serious internal errors, since the results of it can't
# be captured.
sub _autocroak {
warn Carp::longmess(@_);
exit(255); # Ugh!
}
package autodie::Scope::Guard;
# This code schedules the cleanup of subroutines at the end of
# scope. It's directly inspired by chocolateboy's excellent
# Scope::Guard module.
sub new {
my ($class, $handler) = @_;
return bless $handler, $class;
}
sub DESTROY {
my ($self) = @_;
$self->();
}
1;
__END__
=head1 NAME
Fatal - Replace functions with equivalents which succeed or die
=head1 SYNOPSIS
use Fatal qw(open close);
open(my $fh, "<", $filename); # No need to check errors!
use File::Copy qw(move);
use Fatal qw(move);
move($file1, $file2); # No need to check errors!
sub juggle { . . . }
Fatal->import('juggle');
=head1 BEST PRACTICE
B<Fatal has been obsoleted by the new L<autodie> pragma.> Please use
L<autodie> in preference to C<Fatal>. L<autodie> supports lexical scoping,
throws real exception objects, and provides much nicer error messages.
The use of C<:void> with Fatal is discouraged.
=head1 DESCRIPTION
C<Fatal> provides a way to conveniently replace
functions which normally return a false value when they fail with
equivalents which raise exceptions if they are not successful. This
lets you use these functions without having to test their return
values explicitly on each call. Exceptions can be caught using
C<eval{}>. See L<perlfunc> and L<perlvar> for details.
The do-or-die equivalents are set up simply by calling Fatal's
C<import> routine, passing it the names of the functions to be
replaced. You may wrap both user-defined functions and overridable
CORE operators (except C<exec>, C<system>, C<print>, or any other
built-in that cannot be expressed via prototypes) in this way.
If the symbol C<:void> appears in the import list, then functions
named later in that import list raise an exception only when
these are called in void context--that is, when their return
values are ignored. For example
use Fatal qw/:void open close/;
# properly checked, so no exception raised on error
if (not open(my $fh, '<', '/bogotic') {
warn "Can't open /bogotic: $!";
}
# not checked, so error raises an exception
close FH;
The use of C<:void> is discouraged, as it can result in exceptions
not being thrown if you I<accidentally> call a method without
void context. Use L<autodie> instead if you need to be able to
disable autodying/Fatal behaviour for a small block of code.
=head1 DIAGNOSTICS
=over 4
=item Bad subroutine name for Fatal: %s
You've called C<Fatal> with an argument that doesn't look like
a subroutine name, nor a switch that this version of Fatal
understands.
=item %s is not a Perl subroutine
You've asked C<Fatal> to try and replace a subroutine which does not
exist, or has not yet been defined.
=item %s is neither a builtin, nor a Perl subroutine
You've asked C<Fatal> to replace a subroutine, but it's not a Perl
built-in, and C<Fatal> couldn't find it as a regular subroutine.
It either doesn't exist or has not yet been defined.
=item Cannot make the non-overridable %s fatal
You've tried to use C<Fatal> on a Perl built-in that can't be
overridden, such as C<print> or C<system>, which means that
C<Fatal> can't help you, although some other modules might.
See the L</"SEE ALSO"> section of this documentation.
=item Internal error: %s
You've found a bug in C<Fatal>. Please report it using
the C<perlbug> command.
=back
=head1 BUGS
C<Fatal> clobbers the context in which a function is called and always
makes it a scalar context, except when the C<:void> tag is used.
This problem does not exist in L<autodie>.
"Used only once" warnings can be generated when C<autodie> or C<Fatal>
is used with package filehandles (eg, C<FILE>). It's strongly recommended
you use scalar filehandles instead.
=head1 AUTHOR
Original module by Lionel Cons (CERN).
Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>.
L<autodie> support, bugfixes, extended diagnostics, C<system>
support, and major overhauling by Paul Fenwick <pjf@perltraining.com.au>
=head1 LICENSE
This module is free software, you may distribute it under the
same terms as Perl itself.
=head1 SEE ALSO
L<autodie> for a nicer way to use lexical Fatal.
L<IPC::System::Simple> for a similar idea for calls to C<system()>
and backticks.
=cut
FATAL
$fatpacked{"Lingua/JA/Regular/Unicode.pm"} = <<'LINGUA_JA_REGULAR_UNICODE';
package Lingua::JA::Regular::Unicode;
use strict;
use warnings;
use utf8;
use 5.008001; # dankogai-san says "tr/// on 5.8.0 is buggy!"
our $VERSION = '0.09';
use Exporter 'import';
our @EXPORT = qw/ hiragana2katakana alnum_z2h alnum_h2z space_z2h katakana2hiragana katakana_h2z katakana_z2h space_h2z/;
# regexp is generated by tools/createmap.pl
my %katakana_h2z_map = (
"\x{FF8E}\x{FF9F}" => "\x{30DD}",
"\x{FF7E}\x{FF9E}" => "\x{30BC}",
"\x{FF73}\x{FF9E}" => "\x{30F4}",
"\x{FF8B}\x{FF9F}" => "\x{30D4}",
"\x{FF8E}\x{FF9E}" => "\x{30DC}",
"\x{FF78}\x{FF9E}" => "\x{30B0}",
"\x{FF8D}\x{FF9F}" => "\x{30DA}",
"\x{FF8B}\x{FF9E}" => "\x{30D3}",
"\x{FF8A}\x{FF9F}" => "\x{30D1}",
"\x{FF8C}\x{FF9E}" => "\x{30D6}",
"\x{FF8D}\x{FF9E}" => "\x{30D9}",
"\x{FF82}\x{FF9E}" => "\x{30C5}",
"\x{FF7A}\x{FF9E}" => "\x{30B4}",
"\x{FF77}\x{FF9E}" => "\x{30AE}",
"\x{FF7C}\x{FF9E}" => "\x{30B8}",
"\x{FF7B}\x{FF9E}" => "\x{30B6}",
"\x{FF83}\x{FF9E}" => "\x{30C7}",
"\x{FF84}\x{FF9E}" => "\x{30C9}",
"\x{FF8A}\x{FF9E}" => "\x{30D0}",
"\x{FF80}\x{FF9E}" => "\x{30C0}",
"\x{FF8C}\x{FF9F}" => "\x{30D7}",
"\x{FF76}\x{FF9E}" => "\x{30AC}",
"\x{FF81}\x{FF9E}" => "\x{30C2}",
"\x{FF7D}\x{FF9E}" => "\x{30BA}",
"\x{FF7F}\x{FF9E}" => "\x{30BE}",
"\x{FF79}\x{FF9E}" => "\x{30B2}"
);
my %katakana_z2h_map = (
"\x{30B6}" => "\x{FF7B}\x{FF9E}",
"\x{30D1}" => "\x{FF8A}\x{FF9F}",
"\x{30C7}" => "\x{FF83}\x{FF9E}",
"\x{30D4}" => "\x{FF8B}\x{FF9F}",
"\x{30BE}" => "\x{FF7F}\x{FF9E}",
"\x{30BC}" => "\x{FF7E}\x{FF9E}",
"\x{30AE}" => "\x{FF77}\x{FF9E}",
"\x{30D6}" => "\x{FF8C}\x{FF9E}",
"\x{30C0}" => "\x{FF80}\x{FF9E}",
"\x{30DA}" => "\x{FF8D}\x{FF9F}",
"\x{30D0}" => "\x{FF8A}\x{FF9E}",
"\x{30D3}" => "\x{FF8B}\x{FF9E}",
"\x{30C5}" => "\x{FF82}\x{FF9E}",
"\x{30F4}" => "\x{FF73}\x{FF9E}",
"\x{30B0}" => "\x{FF78}\x{FF9E}",
"\x{30B8}" => "\x{FF7C}\x{FF9E}",
"\x{30B4}" => "\x{FF7A}\x{FF9E}",
"\x{30D7}" => "\x{FF8C}\x{FF9F}",
"\x{30D9}" => "\x{FF8D}\x{FF9E}",
"\x{30C2}" => "\x{FF81}\x{FF9E}",
"\x{30BA}" => "\x{FF7D}\x{FF9E}",
"\x{30DD}" => "\x{FF8E}\x{FF9F}",
"\x{30DC}" => "\x{FF8E}\x{FF9E}",
"\x{30B2}" => "\x{FF79}\x{FF9E}",
"\x{30AC}" => "\x{FF76}\x{FF9E}",
"\x{30C9}" => "\x{FF84}\x{FF9E}"
);
sub alnum_z2h {
local $_ = shift;
tr/\x{FF07}\x{FF3B}\x{FF56}\x{FF4F}\x{FF0C}\x{FF5E}\x{FF14}\x{FF43}\x{FF19}\x{FF26}\x{FF55}\x{FF3F}\x{FF2D}\x{FF27}\x{FF34}\x{FF37}\x{FF30}\x{FF51}\x{FFE3}\x{FF60}\x{FF36}\x{FF49}\x{FF29}\x{FF52}\x{FF1A}\x{FF3A}\x{FF38}\x{FF3D}\x{FF4C}\x{FF1E}\x{FF5D}\x{FFE6}\x{FF01}\x{FF5C}\x{FF58}\x{FF16}\x{FF05}\x{FF54}\x{FF3E}\x{FF18}\x{FF45}\x{FF24}\x{FF2B}\x{FF15}\x{FF4A}\x{FF0D}\x{FFE0}\x{FF48}\x{FF11}\x{FF5B}\x{FF35}\x{FF12}\x{FF2E}\x{FF28}\x{FF06}\x{FF10}\x{FF03}\x{FF2F}\x{FF4E}\x{FFE2}\x{FF20}\x{FF5F}\x{FF46}\x{FF13}\x{FF31}\x{FF41}\x{FF50}\x{FF2A}\x{FFE5}\x{FF1F}\x{FF21}\x{FF57}\x{FF3C}\x{FF04}\x{FF02}\x{FF22}\x{FF4D}\x{FF23}\x{FF17}\x{FF1B}\x{FFE4}\x{FF1D}\x{FF59}\x{FF0B}\x{FF47}\x{FF39}\x{FF32}\x{FF42}\x{FF2C}\x{FF4B}\x{FF09}\x{FF33}\x{FF40}\x{FF25}\x{FF08}\x{FFE1}\x{FF0A}\x{FF0E}\x{FF5A}\x{FF53}\x{FF0F}\x{FF1C}\x{FF44}/\x{0027}\x{005B}\x{0076}\x{006F}\x{002C}\x{007E}\x{0034}\x{0063}\x{0039}\x{0046}\x{0075}\x{005F}\x{004D}\x{0047}\x{0054}\x{0057}\x{0050}\x{0071}\x{00AF}\x{2986}\x{0056}\x{0069}\x{0049}\x{0072}\x{003A}\x{005A}\x{0058}\x{005D}\x{006C}\x{003E}\x{007D}\x{20A9}\x{0021}\x{007C}\x{0078}\x{0036}\x{0025}\x{0074}\x{005E}\x{0038}\x{0065}\x{0044}\x{004B}\x{0035}\x{006A}\x{002D}\x{00A2}\x{0068}\x{0031}\x{007B}\x{0055}\x{0032}\x{004E}\x{0048}\x{0026}\x{0030}\x{0023}\x{004F}\x{006E}\x{00AC}\x{0040}\x{2985}\x{0066}\x{0033}\x{0051}\x{0061}\x{0070}\x{004A}\x{00A5}\x{003F}\x{0041}\x{0077}\x{005C}\x{0024}\x{0022}\x{0042}\x{006D}\x{0043}\x{0037}\x{003B}\x{00A6}\x{003D}\x{0079}\x{002B}\x{0067}\x{0059}\x{0052}\x{0062}\x{004C}\x{006B}\x{0029}\x{0053}\x{0060}\x{0045}\x{0028}\x{00A3}\x{002A}\x{002E}\x{007A}\x{0073}\x{002F}\x{003C}\x{0064}/;
$_;
}
sub alnum_h2z {
local $_ = shift;
tr/\x{0027}\x{005B}\x{0076}\x{006F}\x{002C}\x{007E}\x{0034}\x{0063}\x{0039}\x{0046}\x{0075}\x{005F}\x{004D}\x{0047}\x{0054}\x{0057}\x{0050}\x{0071}\x{00AF}\x{2986}\x{0056}\x{0069}\x{0049}\x{0072}\x{003A}\x{005A}\x{0058}\x{005D}\x{006C}\x{003E}\x{007D}\x{20A9}\x{0021}\x{007C}\x{0078}\x{0036}\x{0025}\x{0074}\x{005E}\x{0038}\x{0065}\x{0044}\x{004B}\x{0035}\x{006A}\x{002D}\x{00A2}\x{0068}\x{0031}\x{007B}\x{0055}\x{0032}\x{004E}\x{0048}\x{0026}\x{0030}\x{0023}\x{004F}\x{006E}\x{00AC}\x{0040}\x{2985}\x{0066}\x{0033}\x{0051}\x{0061}\x{0070}\x{004A}\x{00A5}\x{003F}\x{0041}\x{0077}\x{005C}\x{0024}\x{0022}\x{0042}\x{006D}\x{0043}\x{0037}\x{003B}\x{00A6}\x{003D}\x{0079}\x{002B}\x{0067}\x{0059}\x{0052}\x{0062}\x{004C}\x{006B}\x{0029}\x{0053}\x{0060}\x{0045}\x{0028}\x{00A3}\x{002A}\x{002E}\x{007A}\x{0073}\x{002F}\x{003C}\x{0064}/\x{FF07}\x{FF3B}\x{FF56}\x{FF4F}\x{FF0C}\x{FF5E}\x{FF14}\x{FF43}\x{FF19}\x{FF26}\x{FF55}\x{FF3F}\x{FF2D}\x{FF27}\x{FF34}\x{FF37}\x{FF30}\x{FF51}\x{FFE3}\x{FF60}\x{FF36}\x{FF49}\x{FF29}\x{FF52}\x{FF1A}\x{FF3A}\x{FF38}\x{FF3D}\x{FF4C}\x{FF1E}\x{FF5D}\x{FFE6}\x{FF01}\x{FF5C}\x{FF58}\x{FF16}\x{FF05}\x{FF54}\x{FF3E}\x{FF18}\x{FF45}\x{FF24}\x{FF2B}\x{FF15}\x{FF4A}\x{FF0D}\x{FFE0}\x{FF48}\x{FF11}\x{FF5B}\x{FF35}\x{FF12}\x{FF2E}\x{FF28}\x{FF06}\x{FF10}\x{FF03}\x{FF2F}\x{FF4E}\x{FFE2}\x{FF20}\x{FF5F}\x{FF46}\x{FF13}\x{FF31}\x{FF41}\x{FF50}\x{FF2A}\x{FFE5}\x{FF1F}\x{FF21}\x{FF57}\x{FF3C}\x{FF04}\x{FF02}\x{FF22}\x{FF4D}\x{FF23}\x{FF17}\x{FF1B}\x{FFE4}\x{FF1D}\x{FF59}\x{FF0B}\x{FF47}\x{FF39}\x{FF32}\x{FF42}\x{FF2C}\x{FF4B}\x{FF09}\x{FF33}\x{FF40}\x{FF25}\x{FF08}\x{FFE1}\x{FF0A}\x{FF0E}\x{FF5A}\x{FF53}\x{FF0F}\x{FF1C}\x{FF44}/;
$_;
}
sub hiragana2katakana {
local $_ = shift;
tr/\x{3077}\x{3094}\x{306B}\x{3080}\x{3066}\x{3044}\x{3067}\x{3079}\x{309E}\x{3090}\x{3075}\x{3068}\x{304A}\x{308A}\x{3052}\x{305D}\x{3065}\x{3088}\x{306F}\x{3064}\x{3056}\x{3057}\x{3083}\x{306E}\x{3063}\x{306D}\x{3072}\x{3043}\x{305F}\x{3087}\x{3051}\x{307E}\x{308C}\x{3073}\x{3084}\x{304C}\x{307D}\x{306C}\x{307A}\x{304F}\x{305E}\x{3071}\x{3054}\x{3092}\x{3078}\x{305A}\x{304B}\x{3074}\x{3085}\x{308E}\x{3042}\x{304D}\x{3096}\x{3047}\x{3069}\x{3060}\x{308D}\x{3082}\x{3048}\x{308F}\x{3093}\x{3076}\x{305C}\x{3081}\x{306A}\x{3061}\x{3070}\x{3062}\x{308B}\x{3059}\x{3041}\x{3095}\x{307C}\x{3089}\x{3049}\x{309D}\x{3050}\x{307B}\x{3055}\x{3091}\x{304E}\x{307F}\x{305B}\x{3058}\x{3053}\x{3045}\x{3086}\x{3046}/\x{30D7}\x{30F4}\x{30CB}\x{30E0}\x{30C6}\x{30A4}\x{30C7}\x{30D9}\x{30FE}\x{30F0}\x{30D5}\x{30C8}\x{30AA}\x{30EA}\x{30B2}\x{30BD}\x{30C5}\x{30E8}\x{30CF}\x{30C4}\x{30B6}\x{30B7}\x{30E3}\x{30CE}\x{30C3}\x{30CD}\x{30D2}\x{30A3}\x{30BF}\x{30E7}\x{30B1}\x{30DE}\x{30EC}\x{30D3}\x{30E4}\x{30AC}\x{30DD}\x{30CC}\x{30DA}\x{30AF}\x{30BE}\x{30D1}\x{30B4}\x{30F2}\x{30D8}\x{30BA}\x{30AB}\x{30D4}\x{30E5}\x{30EE}\x{30A2}\x{30AD}\x{30F6}\x{30A7}\x{30C9}\x{30C0}\x{30ED}\x{30E2}\x{30A8}\x{30EF}\x{30F3}\x{30D6}\x{30BC}\x{30E1}\x{30CA}\x{30C1}\x{30D0}\x{30C2}\x{30EB}\x{30B9}\x{30A1}\x{30F5}\x{30DC}\x{30E9}\x{30A9}\x{30FD}\x{30B0}\x{30DB}\x{30B5}\x{30F1}\x{30AE}\x{30DF}\x{30BB}\x{30B8}\x{30B3}\x{30A5}\x{30E6}\x{30A6}/;
$_;
}
sub katakana2hiragana {
local $_ = shift;
tr/\x{FF98}\x{30DC}\x{30BA}\x{30B7}\x{FF77}\x{FF6D}\x{FF99}\x{FF88}\x{30B0}\x{30CD}\x{30AD}\x{FF6A}\x{30F1}\x{30C6}\x{FF78}\x{30CB}\x{FF84}\x{FF9B}\x{30C9}\x{30A7}\x{30B3}\x{30FD}\x{FF81}\x{30AC}\x{FF8D}\x{30C8}\x{FF69}\x{30C0}\x{30E4}\x{30EC}\x{FF86}\x{30C1}\x{30BD}\x{30CE}\x{FF7F}\x{FF7B}\x{30D1}\x{30E8}\x{FF67}\x{FF89}\x{FF8A}\x{30B4}\x{30B2}\x{FF6B}\x{30EE}\x{30E2}\x{30F0}\x{30EB}\x{30F2}\x{30E0}\x{FF71}\x{FF83}\x{30BC}\x{30DD}\x{30D5}\x{30CF}\x{30E3}\x{30B5}\x{30C3}\x{30E9}\x{FF8F}\x{30A2}\x{30A3}\x{30E7}\x{FF73}\x{FF75}\x{30AA}\x{30AF}\x{30E1}\x{FF95}\x{30A5}\x{30C2}\x{30AE}\x{FF92}\x{30A6}\x{FF85}\x{30B9}\x{FF7D}\x{FF97}\x{FF7E}\x{30B6}\x{30D6}\x{FF8C}\x{30D8}\x{FF7A}\x{FF76}\x{30DA}\x{30AB}\x{FF72}\x{30FE}\x{30A8}\x{FF9C}\x{30F4}\x{30F3}\x{FF80}\x{FF6C}\x{FF8E}\x{FF6E}\x{FF96}\x{30C4}\x{30BE}\x{30D0}\x{30D7}\x{FF93}\x{30BB}\x{FF91}\x{FF79}\x{30EA}\x{30C7}\x{FF90}\x{30DF}\x{30DB}\x{30B1}\x{30A4}\x{30D2}\x{FF6F}\x{30E6}\x{FF82}\x{30DE}\x{30F5}\x{30BF}\x{FF9A}\x{30D4}\x{30B8}\x{FF7C}\x{FF87}\x{30D3}\x{30C5}\x{30CC}\x{FF68}\x{FF9D}\x{FF74}\x{30A1}\x{30A9}\x{30F6}\x{30CA}\x{FF66}\x{30E5}\x{FF94}\x{30ED}\x{FF8B}\x{30D9}\x{30EF}/\x{308A}\x{307C}\x{305A}\x{3057}\x{304D}\x{3085}\x{308B}\x{306D}\x{3050}\x{306D}\x{304D}\x{3047}\x{3091}\x{3066}\x{304F}\x{306B}\x{3068}\x{308D}\x{3069}\x{3047}\x{3053}\x{309D}\x{3061}\x{304C}\x{3078}\x{3068}\x{3045}\x{3060}\x{3084}\x{308C}\x{306B}\x{3061}\x{305D}\x{306E}\x{305D}\x{3055}\x{3071}\x{3088}\x{3041}\x{306E}\x{306F}\x{3054}\x{3052}\x{3049}\x{308E}\x{3082}\x{3090}\x{308B}\x{3092}\x{3080}\x{3042}\x{3066}\x{305C}\x{307D}\x{3075}\x{306F}\x{3083}\x{3055}\x{3063}\x{3089}\x{307E}\x{3042}\x{3043}\x{3087}\x{3046}\x{304A}\x{304A}\x{304F}\x{3081}\x{3086}\x{3045}\x{3062}\x{304E}\x{3081}\x{3046}\x{306A}\x{3059}\x{3059}\x{3089}\x{305B}\x{3056}\x{3076}\x{3075}\x{3078}\x{3053}\x{304B}\x{307A}\x{304B}\x{3044}\x{309E}\x{3048}\x{308F}\x{3094}\x{3093}\x{305F}\x{3083}\x{307B}\x{3087}\x{3088}\x{3064}\x{305E}\x{3070}\x{3077}\x{3082}\x{305B}\x{3080}\x{3051}\x{308A}\x{3067}\x{307F}\x{307F}\x{307B}\x{3051}\x{3044}\x{3072}\x{3063}\x{3086}\x{3064}\x{307E}\x{3095}\x{305F}\x{308C}\x{3074}\x{3058}\x{3057}\x{306C}\x{3073}\x{3065}\x{306C}\x{3043}\x{3093}\x{3048}\x{3041}\x{3049}\x{3096}\x{306A}\x{3092}\x{3085}\x{3084}\x{308D}\x{3072}\x{3079}\x{308F}/;
$_;
}
sub space_z2h {
local $_ = shift;
tr/\x{3000}/\x{0020}/; # convert \N{IDEOGRAPHIC SPACE} to \N{SPACE}
$_;
}
sub space_h2z {
local $_ = shift;
tr/\x{0020}/\x{3000}/; # convert \N{SPACE} to \N{IDEOGRAPHIC SPACE}
$_;
}
sub katakana_h2z {
local $_ = shift;
# dakuten
s/(\x{FF7E}\x{FF9E}|\x{FF84}\x{FF9E}|\x{FF80}\x{FF9E}|\x{FF76}\x{FF9E}|\x{FF8B}\x{FF9E}|\x{FF7D}\x{FF9E}|\x{FF8B}\x{FF9F}|\x{FF73}\x{FF9E}|\x{FF79}\x{FF9E}|\x{FF7B}\x{FF9E}|\x{FF8D}\x{FF9F}|\x{FF8A}\x{FF9F}|\x{FF8A}\x{FF9E}|\x{FF83}\x{FF9E}|\x{FF7A}\x{FF9E}|\x{FF8C}\x{FF9F}|\x{FF8D}\x{FF9E}|\x{FF82}\x{FF9E}|\x{FF8E}\x{FF9F}|\x{FF8C}\x{FF9E}|\x{FF77}\x{FF9E}|\x{FF81}\x{FF9E}|\x{FF7C}\x{FF9E}|\x{FF78}\x{FF9E}|\x{FF8E}\x{FF9E}|\x{FF7F}\x{FF9E})/$katakana_h2z_map{$1}/ge;
# normal
tr/\x{FF6C}\x{FF97}\x{FF7E}\x{FF8F}\x{FF83}\x{FF6A}\x{FF8E}\x{FF8B}\x{FF61}\x{FF67}\x{FF7C}\x{FF88}\x{FF80}\x{FF8C}\x{FF77}\x{FF93}\x{FF92}\x{FF9B}\x{FF86}\x{FF95}\x{FF69}\x{FF87}\x{FF6E}\x{FF94}\x{FF7A}\x{FF68}\x{FF8D}\x{FF6F}\x{FF9C}\x{FF72}\x{FF79}\x{FF85}\x{FF64}\x{FF62}\x{FF9A}\x{FF74}\x{FF9F}\x{FF71}\x{FF7F}\x{FF82}\x{FF9E}\x{FF66}\x{FF70}\x{FF9D}\x{FF73}\x{FF7D}\x{FF98}\x{FF76}\x{FF63}\x{FF91}\x{FF6B}\x{FF99}\x{FF6D}\x{FF96}\x{FF8A}\x{FF89}\x{FF78}\x{FF65}\x{FF75}\x{FF7B}\x{FF84}\x{FF90}\x{FF81}/\x{30E3}\x{30E9}\x{30BB}\x{30DE}\x{30C6}\x{30A7}\x{30DB}\x{30D2}\x{3002}\x{30A1}\x{30B7}\x{30CD}\x{30BF}\x{30D5}\x{30AD}\x{30E2}\x{30E1}\x{30ED}\x{30CB}\x{30E6}\x{30A5}\x{30CC}\x{30E7}\x{30E4}\x{30B3}\x{30A3}\x{30D8}\x{30C3}\x{30EF}\x{30A4}\x{30B1}\x{30CA}\x{3001}\x{300C}\x{30EC}\x{30A8}\x{309C}\x{30A2}\x{30BD}\x{30C4}\x{309B}\x{30F2}\x{30FC}\x{30F3}\x{30A6}\x{30B9}\x{30EA}\x{30AB}\x{300D}\x{30E0}\x{30A9}\x{30EB}\x{30E5}\x{30E8}\x{30CF}\x{30CE}\x{30AF}\x{30FB}\x{30AA}\x{30B5}\x{30C8}\x{30DF}\x{30C1}/;
$_;
}
sub katakana_z2h {
local $_ = shift;
# dakuten
s/([\x{30BC}\x{30C9}\x{30C0}\x{30AC}\x{30D3}\x{30BA}\x{30D4}\x{30F4}\x{30B2}\x{30B6}\x{30DA}\x{30D1}\x{30D0}\x{30C7}\x{30B4}\x{30D7}\x{30D9}\x{30C5}\x{30DD}\x{30D6}\x{30AE}\x{30C2}\x{30B8}\x{30B0}\x{30DC}\x{30BE}])/$katakana_z2h_map{$1}/ge;
# normal
tr/\x{30E3}\x{30E9}\x{30BB}\x{30DE}\x{30C6}\x{30A7}\x{30DB}\x{30D2}\x{3002}\x{30A1}\x{30B7}\x{30CD}\x{30BF}\x{30D5}\x{30AD}\x{30E2}\x{30E1}\x{30ED}\x{30CB}\x{30E6}\x{30A5}\x{30CC}\x{30E7}\x{30E4}\x{30B3}\x{30A3}\x{30D8}\x{30C3}\x{30EF}\x{30A4}\x{30B1}\x{30CA}\x{3001}\x{300C}\x{30EC}\x{30A8}\x{309C}\x{30A2}\x{30BD}\x{30C4}\x{309B}\x{30F2}\x{30FC}\x{30F3}\x{30A6}\x{30B9}\x{30EA}\x{30AB}\x{300D}\x{30E0}\x{30A9}\x{30EB}\x{30E5}\x{30E8}\x{30CF}\x{30CE}\x{30AF}\x{30FB}\x{30AA}\x{30B5}\x{30C8}\x{30DF}\x{30C1}/\x{FF6C}\x{FF97}\x{FF7E}\x{FF8F}\x{FF83}\x{FF6A}\x{FF8E}\x{FF8B}\x{FF61}\x{FF67}\x{FF7C}\x{FF88}\x{FF80}\x{FF8C}\x{FF77}\x{FF93}\x{FF92}\x{FF9B}\x{FF86}\x{FF95}\x{FF69}\x{FF87}\x{FF6E}\x{FF94}\x{FF7A}\x{FF68}\x{FF8D}\x{FF6F}\x{FF9C}\x{FF72}\x{FF79}\x{FF85}\x{FF64}\x{FF62}\x{FF9A}\x{FF74}\x{FF9F}\x{FF71}\x{FF7F}\x{FF82}\x{FF9E}\x{FF66}\x{FF70}\x{FF9D}\x{FF73}\x{FF7D}\x{FF98}\x{FF76}\x{FF63}\x{FF91}\x{FF6B}\x{FF99}\x{FF6D}\x{FF96}\x{FF8A}\x{FF89}\x{FF78}\x{FF65}\x{FF75}\x{FF7B}\x{FF84}\x{FF90}\x{FF81}/;
$_;
}
1;
__END__
=encoding utf8
=head1 NAME
Lingua::JA::Regular::Unicode - convert japanese chars.
=head1 SYNOPSIS
use Lingua::JA::Regular::Unicode qw/alnum_z2h hiragana2katakana space_z2h/;
alnum_z2h("A1"); # => "A1"
hiragana2katakana("ほげ"); # => "ホゲ"
space_z2h("\x{0300}"); # => 半角スペース
=head1 DESCRIPTION
Lingua::JA::Regular::Unicode is regularizer.
=over 4
=item alnum_z2h
convert alphabet and numbers ZENKAKU to HANKAKU.
=item alnum_h2z
convert alphabet and numbers HANKAKU to ZENKAKU.
=item space_z2h
convert spaces ZENKAKU to HANKAKU.
=item space_h2z
convert spaces HANKAKU to ZENKAKU.
=item katakana_z2h
convert katakanas ZENKAKU to HANKAKU.
=item katakana_h2z
convert katakanas HANKAKU to ZENKAKU.
=item katakana2hiragana
convert KATAKANA to HIRAGANA.
This method ignores following chars:
KATAKANA LETTER VA
KATAKANA LETTER SMALL RE
KATAKANA LETTER SMALL HU
KATAKANA LETTER SMALL HI
KATAKANA LETTER SMALL HE
KATAKANA DIGRAPH KOTO
KATAKANA LETTER SMALL SU
KATAKANA LETTER SMALL HO
KATAKANA LETTER SMALL SI
KATAKANA LETTER SMALL RI
KATAKANA LETTER VE
KATAKANA LETTER SMALL TO
KATAKANA LETTER SMALL KU
KATAKANA LETTER VO
KATAKANA LETTER SMALL RO
KATAKANA LETTER SMALL RA
KATAKANA LETTER SMALL MU
KATAKANA LETTER SMALL HA
KATAKANA LETTER VI
KATAKANA LETTER SMALL RU
KATAKANA LETTER SMALL NU
KATAKANA MIDDLE DOT
HALFWIDTH KATAKANA SEMI-VOICED SOUND MARK
HALFWIDTH KATAKANA VOICED SOUND MARK
HALFWIDTH KATAKANA MIDDLE DOT
=item hiragana2katakana
convert HIRAGANA to KATAKANA.
This method ignores following chars:
HIRAGANA DIGRAPH YORI
=back
=head1 AUTHOR
Tokuhiro Matsuno E<lt>tokuhirom AAJKLFJEF@ GMAIL COME<gt>
=head1 THANKS To
takefumi kimura - the author of L<Lingua::JA::Regular>
dankogai
=head1 SEE ALSO
L<Lingua::JA::Regular>
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
LINGUA_JA_REGULAR_UNICODE
$fatpacked{"Parse/JapanesePostalCode.pm"} = <<'PARSE_JAPANESEPOSTALCODE';
package Parse::JapanesePostalCode;
use strict;
use warnings;
use utf8;
our $VERSION = '0.01';
use Parse::JapanesePostalCode::Row;
sub new {
my($class, %opts) = @_;
my $self = bless {
format => 'ken',
katakana_h2z => 1,
alnum_z2h => 1,
%opts,
current_build_town => '',
current_build_town_kana => '',
}, $class;
if ( ! $self->{fh} && $self->{file} && -f $self->{file}) {
open $self->{fh}, '<:encoding(cp932)', $self->{file};
}
$self;
}
sub fetch_obj {
my($self, ) = @_;
my $row = $self->get_line;
return unless $row;
my @names = Parse::JapanesePostalCode::Row->columns;
my %columns;
@columns{@names} = @{ $row };
Parse::JapanesePostalCode::Row->new(
build_town => $self->{current_build_town},
build_town_kana => $self->{current_build_town_kana},
katakana_h2z => $self->{katakana_h2z},
alnum_z2h => $self->{alnum_z2h},
%columns,
);
}
sub _get_line {
my($self, ) = @_;
my $fh = $self->{fh};
my $line = <$fh>;
return unless $line;
$line =~ s/\r\n$//;
# easy csv parser for KEN_ALL.csv
my @row = map {
my $data = $_;
$data =~ s/^"//;
$data =~ s/"$//;
$data;
} split ',', $line;
\@row;
}
sub get_line {
my($self, ) = @_;
my $row = $self->_get_line;
return unless $row;
if ($row->[8] =~ /(.+[^)]$/) {
while (1) {
my $tmp = $self->_get_line;
return unless $tmp;
$row->[5] .= $tmp->[5];
$row->[8] .= $tmp->[8];
last if $row->[8] =~ /\)$/;
}
}
my $town = $row->[8];
if ($town =~ /^(.+)(次のビルを除く)$/) {
$self->{current_build_town} = $1;
($self->{current_build_town_kana}) = $row->[5] =~ /^(.+)\(/;
} elsif ($row->[2] eq '4530002' && $town =~ /^名駅\(/) {
$self->{current_build_town} = '名駅';
$self->{current_build_town_kana} = 'メイエキ';
} else {
my $current_build_town = $self->{current_build_town};
unless ($town =~ /^$current_build_town.+(.+階.*)$/) {
$self->{current_build_town} = '';
$self->{current_build_town_kana} = '';
}
}
$row;
}
1;
__END__
=encoding utf8
=head1 NAME
Parse::JapanesePostalCode - PostalCode Parser for 日本郵政
=head1 SYNOPSIS
use Parse::JapanesePostalCode;
my $parser = Parse::JapanesePostalCode->new( file => 'KEN_ALL.csv' );
while (my $obj = $parser->fetch_obj) {
my @list = map { $_ ? $_ : () } ($obj->zip, $obj->pref, $obj->district, $obj->city, $obj->ward, $obj->town);
if ($obj->has_subtown) {
push @list, join '/', @{ $obj->subtown };
}
if ($obj->build) {
my $str = $obj->build;
$str .= $obj->floor . 'F' if $obj->floor;
push @list, $str;
}
}
=head1 DESCRIPTION
Parse::JapanesePostalCode is a feel good parser to parse to Postal Code files that are provided by Japan Post.
Parse::JapanesePostalCode は、日本郵政が提供している郵便番号ファイルを良い感じにパースしてくれるパーサです。
=head1 METHODS
=head2 new
create to parser instance.
read from file path.
my $parser = Parse::JapanesePostalCode->new(
file => 'foo/bar/KEN_ALL.csv',
);
read from file handle.
my $parser = Parse::JapanesePostalCode->new(
fh => $ken_all_fh,
);
ignore katakana_h2z.
my $parser = Parse::JapanesePostalCode->new(
file => 'foo/bar/KEN_ALL.csv',
katakana_h2z => 0,
);
ignore alnum_z2h.
my $parser = Parse::JapanesePostalCode->new(
file => 'foo/bar/KEN_ALL.csv',
alnum_z2h => 0,
);
=head2 get_line
get one line from KEN_ALL.csv.
while (my $line = $parser->get_line) {
say $line;
}
1行読み込みます。もし
07543,"97906","9790622","フクシマケン","フタバグントミオカマチ","ケガヤ(マエカワハラ232-244、311、312、337-862バンチ","福島県","双葉郡富岡町","毛萱(前川原232〜244、311、312、337〜862番地",1,1,0,0,0,0
07543,"97906","9790622","フクシマケン","フタバグントミオカマチ","トウキョウデンリョクフクシマダイ2ゲンシリョクハツデンショコウナイ)","福島県","双葉郡富岡町","〔東京電力福島第二原子力発電所構内〕)",1,1,0,0,0,0
のように複数行に分割されていたら、良い感じに行をマージした結果を返します。
=head2 fetch_obj
get one line object from KEN_ALL.csv.
while (my $obj = $parser->fetch_obj) {
say $obj->zip;
}
get_line で取得した行を、 L<Parse::JapanesePostalCode::Row> でオブジェクト化したオブジェクトを返します。
=head1 AUTHOR
Kazuhiro Osawa E<lt>yappo {at} shibuya {dot} plE<gt>
=head1 SEE ALSO
L<Parse::JapanesePostalCode::Row>,
L<http://www.post.japanpost.jp/zipcode/download.html>
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
PARSE_JAPANESEPOSTALCODE
$fatpacked{"Parse/JapanesePostalCode/Row.pm"} = <<'PARSE_JAPANESEPOSTALCODE_ROW';
package Parse::JapanesePostalCode::Row;
use strict;
use warnings;
use utf8;
use Lingua::JA::Regular::Unicode qw/ katakana_h2z /;
sub alnum_z2h {
my $str = shift;
$str = Lingua::JA::Regular::Unicode::alnum_z2h($str);
$str =~ tr/~−/〜-/;
$str;
}
my @COLUMNS = qw/
region_id old_zip zip
pref_kana region_kana town_kana pref region town
is_multi_zip has_koaza_banchi has_chome is_multi_town
update_status update_reason
/;
my @METHODS = (@COLUMNS, qw/
district district_kana city city_kana ward ward_kana
subtown_kana subtown
build build_kana floor
/);
for my $name (@METHODS) {
my $sub = sub { $_[0]->{columns}{$name} };
no strict 'refs';
*{$name} = $sub;
}
sub columns { @COLUMNS }
sub has_subtown { !! $_[0]->subtown }
sub new {
my($class, %opts) = @_;
my $columns = {};
for my $column (@COLUMNS) {
$columns->{$column} = delete $opts{$column} if defined $opts{$column};
}
my $self = bless {
katakana_h2z => 1,
alnum_z2h => 1,
build_town => '',
build_town_kana => '',
%opts,
columns => $columns,
}, $class;
$self->fix_region;
$self->fix_town;
$self->fix_build;
$self->fix_subtown unless $self->build;
$self->fix_kana_alnum;
$self;
}
sub fix_region {
my $self = shift;
my $columns = $self->{columns};
$columns->{district} = undef;
$columns->{district_kana} = undef;
$columns->{city} = undef;
$columns->{city_kana} = undef;
$columns->{ward} = undef;
$columns->{ward_kana} = undef;
# district
my($district, $town_village) = $self->region =~ /^(.+?郡)(.+[町村])$/;
if ($district && $town_village) {
my($district_kana, $town_village_kana) = $self->region_kana =~ /^((?:キタグンマ|.+?)グン)(.+)$/;
$columns->{district} = $district;
$columns->{district_kana} = $district_kana;
$columns->{city} = $town_village;
$columns->{city_kana} = $town_village_kana;
} else {
my($city, $ward) = $self->region =~ /^(.+市)(.+区)$/;
if ($city && $ward) {
my($city_kana, $ward_kana) = $self->region_kana =~ /^((?:ヒロシマ|キタキュウシュウ|.+?)シ)(.+)$/;
$columns->{city} = $city;
$columns->{city_kana} = $city_kana;
$columns->{ward} = $ward;
$columns->{ward_kana} = $ward_kana;
} elsif ($self->region =~ /区$/) {
$columns->{ward} = $self->region;
$columns->{ward_kana} = $self->region_kana;
} else {
$columns->{city} = $self->region;
$columns->{city_kana} = $self->region_kana;
}
}
}
sub fix_town {
my $self = shift;
my $columns = $self->{columns};
if ($columns->{town} eq '以下に掲載がない場合') {
$columns->{town_kana} = undef;
$columns->{town} = undef;
} elsif ($columns->{town} =~ /^(.+)の次に番地がくる場合/) {
my $name = $1;
if ($columns->{city} eq $name || $columns->{city} =~ /郡\Q$name\E$/) {
$columns->{town_kana} = undef;
$columns->{town} = undef;
}
} elsif ($columns->{town} =~ s/(その他)$//) {
$columns->{town_kana} =~ s/\(ソノタ\)$//;
} elsif ($columns->{town} =~ /^(.+[町村])一円$/) {
my $name = $1;
if ($columns->{city} eq $name) {
$columns->{town_kana} = undef;
$columns->{town} = undef;
}
}
$columns->{town} =~ s/[〜~]/〜/g if $columns->{town};
}
sub fix_subtown {
my $self = shift;
my $columns = $self->{columns};
return unless $columns->{town};
my @subtown;
my @subtown_kana;
# chome
if ($columns->{town} =~ s/(([\d〜、]+)丁目)$//) {
my $num = alnum_z2h($1);
my @nums = map {
if (/^(\d+)〜(\d+)$/) {
($1..$2);
} else {
$_
}
} map { alnum_z2h($_) } split /、/, $1;
@subtown = map { $_ . '丁目' } @nums;
@subtown_kana = map { $_ . 'チョウメ' } @nums;
$columns->{town_kana} =~ s/\([\d\-、]+チョウメ\)$//;
}
# chiwari
elsif ($columns->{town} =~ /^[^\(]+地割/) {
my($prefix, $koaza) = $columns->{town} =~ /^(.+\d+地割)(?:((.+)))?$/;
my($prefix_kana, $koaza_kana) = $columns->{town_kana} =~ /^(.+\d+チワリ)(?:\((.+)\))?$/;
my($aza, $chiwari) = $prefix =~ /^(.+?)第?(\d+地割.*)$/;
my($aza_kana, $chiwari_kana) = $prefix_kana =~ /^(.+?)(?:ダイ)?(\d+チワリ.*)$/;
if ($chiwari =~ /〜/) {
my @tmp = map {
if (/\d+地割$/) {
my $str = $_;
$str =~ s/^\Q$aza\E//;
$str =~ s/^第//;
"第$str";
} else {
$_;
}
} split /〜/, $chiwari;
$chiwari = join '〜', @tmp;
}
if ($chiwari_kana =~ /-/) {
my @tmp = map {
if (/\d+チワリ$/) {
my $str = $_;
$str =~ s/^\Q$aza_kana\E//;
$str =~ s/^ダイ//;
"ダイ$str";
} else {
$_;
}
} split /-/, $chiwari_kana;
$chiwari_kana = join '-', @tmp;
}
@subtown = map {
if (/\d+地割$/) {
my $str = $_;
$str =~ s/^\Q$aza\E//;
$str =~ s/^第//;
"第$str";
} else {
$_;
}
} split /、/, $chiwari;
@subtown_kana = map {
if (/\d+チワリ$/) {
my $str = $_;
$str =~ s/^\Q$aza_kana\E//;
$str =~ s/^ダイ//;
"ダイ$str";
} else {
$_;
}
} split /、/, $chiwari_kana;
if ($koaza) {
@subtown = map {
my $str = $_;
map {
"$str $_";
} split /、/, $koaza;
} @subtown;
}
if ($koaza_kana) {
@subtown_kana = map {
my $str = $_;
map {
"$str $_";
} split /、/, $koaza_kana;
} @subtown_kana;
}
$columns->{town} = $aza;
$columns->{town_kana} = $aza_kana;
}
# other
elsif ($columns->{town} =~ s/((.+?))$//) {
my $town = $1;
$town =~ s{「([^\」]+)」}{
my $str = $1;
$str =~ s/、/_____COMMNA_____/g;
"「${str}」";
}ge;
@subtown = map {
my $str = $_;
$str =~ s/_____COMMNA_____/、/g;
$str;
} split /、/, $town;
$columns->{town_kana} =~ s/\((.+?)\)$//;
my $kana = $1;
$kana =~ s{<([^>]+)>}{
my $str = $1;
$str =~ s/、/_____COMMNA_____/g;
"<${str}>";
}ge;
@subtown_kana = map {
my $str = $_;
$str =~ s/_____COMMNA_____/,/g;
$str;
} split /、/, $kana;
}
$columns->{subtown} = \@subtown if @subtown;
$columns->{subtown_kana} = \@subtown_kana if @subtown_kana;
}
sub fix_build {
my $self = shift;
my $columns = $self->{columns};
unless ($self->{build_town}) {
unless ($columns->{town} && $columns->{town} =~ /(.+?階.*?)$/) {
return;
}
}
my $build_town = $self->{build_town};
my $build_town_kana = $self->{build_town_kana};
$columns->{town} =~ s/(高層棟)//;
$columns->{town_kana} =~ s/\(コウソウトウ\)//;
if ($columns->{town} =~ s/(次のビルを除く)$//) {
$columns->{town_kana} =~ s/\(ツギノビルヲノゾク\)$//;
} elsif ($columns->{town} =~ /^\Q$build_town\E(.+)((.+))$/) {
my $floor = $2;
$columns->{build} = $1;
if ($floor =~ /(\d+)階/) {
$columns->{floor} = alnum_z2h($1);
}
$columns->{town_kana} =~ /^\Q$build_town_kana\E(.+)\(.+$/;
$columns->{build_kana} = $1;
$columns->{town} = $build_town;
$columns->{town_kana} = $build_town_kana;
}
}
sub fix_kana_alnum {
my $self = shift;
return unless$self->{katakana_h2z} || $self->{alnum_z2h};
for my $name (qw/ pref_kana region_kana district_kana city_kana ward_kana town_kana build_kana pref region district city ward town build /) {
next unless defined $self->{columns}{$name};
$self->{columns}{$name} = katakana_h2z($self->{columns}{$name}) if $self->{katakana_h2z};
$self->{columns}{$name} = alnum_z2h($self->{columns}{$name}) if $self->{alnum_z2h};
}
if ($self->has_subtown) {
for my $i (0..(scalar(@{ $self->subtown }) - 1)) {
$self->subtown->[$i] = katakana_h2z($self->subtown->[$i]) if $self->{katakana_h2z};
$self->subtown->[$i] = alnum_z2h($self->subtown->[$i]) if $self->{alnum_z2h};
}
for my $i (0..(scalar(@{ $self->subtown_kana }) - 1)) {
$self->subtown_kana->[$i] = katakana_h2z($self->subtown_kana->[$i]) if $self->{katakana_h2z};
$self->subtown_kana->[$i] = alnum_z2h($self->subtown_kana->[$i]) if $self->{alnum_z2h};
}
}
}
1;
__END__
=encoding utf8
=head1 NAME
Parse::JapanesePostalCode::Row - Object of Japanese PostalCode
=head1 METHODS
=head2 new
instance method.
=head2 region_id
全国地方公共団体コード(JIS X0401、X0402) を返します。
=head2 old_zip
(旧)郵便番号(5桁) を返します。
=head2 zip
郵便番号(7桁) を返します。
=head2 pref
都道府県名 を返します。
=head2 region
市区町村名 を返します。町村の場合には郡を含み、政令指定都市の場合には区を含みます。
=head2 district
region から、郡名を抜き出した物を返します。なければ undef が返ります。
=head2 city
region から、市名を抜き出した物を返します。なければ undef が返ります。
=head2 ward
region から、区名を抜き出した物を返します。なければ undef が返ります。
=head2 town
町域名 を返します。小字、丁目、番地,号、ビル名等は含まれません。基本的に大字と同等の町域名が入ります。
実質町域を指定していない物では undef が返ります。
=head2 build
ビル名が入ります。なければ undef が返ります。
=head2 floor
ビルの階が入ります。地階、不明階やビルでない場合には undef が返ります。
=head2 has_subtown
小字、丁目、番地,号がある場合には真が返ります。
=head2 subtown
小字、丁目、番地,号等が ARRAY ref で返ります。
=head2 pref
都道府県名 を返します。
=head2 region_kana
カタカナが返ります。
=head2 district_kana
カタカナが返ります。
=head2 city_kana
カタカナが返ります。
=head2 ward_kana
カタカナが返ります。
=head2 town_kana
カタカナが返ります。
=head2 build_kana
カタカナが返ります。
=head2 subtown_kana
カタカナが返ります。
=head2 is_multi_zip
一町域が二以上の郵便番号で表される場合の表示 が返ります。
=head2 has_koaza_banchi
小字毎に番地が起番されている町域の表示 が返ります。
=head2 has_chome
丁目を有する町域の場合の表示 が返ります。
=head2 is_multi_town
一つの郵便番号で二以上の町域を表す場合の表示 が返ります。
=head2 update_status
更新の表示 が返ります。
=head2 update_reason
変更理由 が返ります。
=head1 AUTHOR
Kazuhiro Osawa E<lt>yappo {at} shibuya {dot} plE<gt>
=head1 SEE ALSO
L<Parse::JapanesePostalCode>,
L<http://www.post.japanpost.jp/zipcode/download.html>
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
PARSE_JAPANESEPOSTALCODE_ROW
$fatpacked{"autodie.pm"} = <<'AUTODIE';
package autodie;
use 5.008;
use strict;
use warnings;
use Fatal ();
our @ISA = qw(Fatal);
our $VERSION;
BEGIN {
$VERSION = '2.11';
}
use constant ERROR_WRONG_FATAL => q{
Incorrect version of Fatal.pm loaded by autodie.
The autodie pragma uses an updated version of Fatal to do its
heavy lifting. We seem to have loaded Fatal version %s, which is
probably the version that came with your version of Perl. However
autodie needs version %s, which would have come bundled with
autodie.
You may be able to solve this problem by adding the following
line of code to your main program, before any use of Fatal or
autodie.
use lib "%s";
};
# We have to check we've got the right version of Fatal before we
# try to compile the rest of our code, lest we use a constant
# that doesn't exist.
BEGIN {
# If we have the wrong Fatal, then we've probably loaded the system
# one, not our own. Complain, and give a useful hint. ;)
if ($Fatal::VERSION ne $VERSION) {
my $autodie_path = $INC{'autodie.pm'};
$autodie_path =~ s/autodie\.pm//;
require Carp;
Carp::croak sprintf(
ERROR_WRONG_FATAL, $Fatal::VERSION, $VERSION, $autodie_path
);
}
}
# When passing args to Fatal we want to keep the first arg
# (our package) in place. Hence the splice.
sub import {
splice(@_,1,0,Fatal::LEXICAL_TAG);
goto &Fatal::import;
}
sub unimport {
splice(@_,1,0,Fatal::LEXICAL_TAG);
goto &Fatal::unimport;
}
1;
__END__
=head1 NAME
autodie - Replace functions with ones that succeed or die with lexical scope
=head1 SYNOPSIS
use autodie; # Recommended: implies 'use autodie qw(:default)'
use autodie qw(:all); # Recommended more: defaults and system/exec.
use autodie qw(open close); # open/close succeed or die
open(my $fh, "<", $filename); # No need to check!
{
no autodie qw(open); # open failures won't die
open(my $fh, "<", $filename); # Could fail silently!
no autodie; # disable all autodies
}
=head1 DESCRIPTION
bIlujDI' yIchegh()Qo'; yIHegh()!
It is better to die() than to return() in failure.
-- Klingon programming proverb.
The C<autodie> pragma provides a convenient way to replace functions
that normally return false on failure with equivalents that throw
an exception on failure.
The C<autodie> pragma has I<lexical scope>, meaning that functions
and subroutines altered with C<autodie> will only change their behaviour
until the end of the enclosing block, file, or C<eval>.
If C<system> is specified as an argument to C<autodie>, then it
uses L<IPC::System::Simple> to do the heavy lifting. See the
description of that module for more information.
=head1 EXCEPTIONS
Exceptions produced by the C<autodie> pragma are members of the
L<autodie::exception> class. The preferred way to work with
these exceptions under Perl 5.10 is as follows:
use feature qw(switch);
eval {
use autodie;
open(my $fh, '<', $some_file);
my @records = <$fh>;
# Do things with @records...
close($fh);
};
given ($@) {
when (undef) { say "No error"; }
when ('open') { say "Error from open"; }
when (':io') { say "Non-open, IO error."; }
when (':all') { say "All other autodie errors." }
default { say "Not an autodie error at all." }
}
Under Perl 5.8, the C<given/when> structure is not available, so the
following structure may be used:
eval {
use autodie;
open(my $fh, '<', $some_file);
my @records = <$fh>;
# Do things with @records...
close($fh);
};
if ($@ and $@->isa('autodie::exception')) {
if ($@->matches('open')) { print "Error from open\n"; }
if ($@->matches(':io' )) { print "Non-open, IO error."; }
} elsif ($@) {
# A non-autodie exception.
}
See L<autodie::exception> for further information on interrogating
exceptions.
=head1 CATEGORIES
Autodie uses a simple set of categories to group together similar
built-ins. Requesting a category type (starting with a colon) will
enable autodie for all built-ins beneath that category. For example,
requesting C<:file> will enable autodie for C<close>, C<fcntl>,
C<fileno>, C<open> and C<sysopen>.
The categories are currently:
:all
:default
:io
read
seek
sysread
sysseek
syswrite
:dbm
dbmclose
dbmopen
:file
binmode
close
fcntl
fileno
flock
ioctl
open
sysopen
truncate
:filesys
chdir
closedir
opendir
link
mkdir
readlink
rename
rmdir
symlink
unlink
:ipc
pipe
:msg
msgctl
msgget
msgrcv
msgsnd
:semaphore
semctl
semget
semop
:shm
shmctl
shmget
shmread
:socket
accept
bind
connect
getsockopt
listen
recv
send
setsockopt
shutdown
socketpair
:threads
fork
:system
system
exec
Note that while the above category system is presently a strict
hierarchy, this should not be assumed.
A plain C<use autodie> implies C<use autodie qw(:default)>. Note that
C<system> and C<exec> are not enabled by default. C<system> requires
the optional L<IPC::System::Simple> module to be installed, and enabling
C<system> or C<exec> will invalidate their exotic forms. See L</BUGS>
below for more details.
The syntax:
use autodie qw(:1.994);
allows the C<:default> list from a particular version to be used. This
provides the convenience of using the default methods, but the surety
that no behavorial changes will occur if the C<autodie> module is
upgraded.
C<autodie> can be enabled for all of Perl's built-ins, including
C<system> and C<exec> with:
use autodie qw(:all);
=head1 FUNCTION SPECIFIC NOTES
=head2 flock
It is not considered an error for C<flock> to return false if it fails
due to an C<EWOULDBLOCK> (or equivalent) condition. This means one can
still use the common convention of testing the return value of
C<flock> when called with the C<LOCK_NB> option:
use autodie;
if ( flock($fh, LOCK_EX | LOCK_NB) ) {
# We have a lock
}
Autodying C<flock> will generate an exception if C<flock> returns
false with any other error.
=head2 system/exec
The C<system> built-in is considered to have failed in the following
circumstances:
=over 4
=item *
The command does not start.
=item *
The command is killed by a signal.
=item *
The command returns a non-zero exit value (but see below).
=back
On success, the autodying form of C<system> returns the I<exit value>
rather than the contents of C<$?>.
Additional allowable exit values can be supplied as an optional first
argument to autodying C<system>:
system( [ 0, 1, 2 ], $cmd, @args); # 0,1,2 are good exit values
C<autodie> uses the L<IPC::System::Simple> module to change C<system>.
See its documentation for further information.
Applying C<autodie> to C<system> or C<exec> causes the exotic
forms C<system { $cmd } @args > or C<exec { $cmd } @args>
to be considered a syntax error until the end of the lexical scope.
If you really need to use the exotic form, you can call C<CORE::system>
or C<CORE::exec> instead, or use C<no autodie qw(system exec)> before
calling the exotic form.
=head1 GOTCHAS
Functions called in list context are assumed to have failed if they
return an empty list, or a list consisting only of a single undef
element.
=head1 DIAGNOSTICS
=over 4
=item :void cannot be used with lexical scope
The C<:void> option is supported in L<Fatal>, but not
C<autodie>. To workaround this, C<autodie> may be explicitly disabled until
the end of the current block with C<no autodie>.
To disable autodie for only a single function (eg, open)
use C<no autodie qw(open)>.
C<autodie> performs no checking of called context to determine whether to throw
an exception; the explicitness of error handling with C<autodie> is a deliberate
feature.
=item No user hints defined for %s
You've insisted on hints for user-subroutines, either by pre-pending
a C<!> to the subroutine name itself, or earlier in the list of arguments
to C<autodie>. However the subroutine in question does not have
any hints available.
=back
See also L<Fatal/DIAGNOSTICS>.
=head1 BUGS
"Used only once" warnings can be generated when C<autodie> or C<Fatal>
is used with package filehandles (eg, C<FILE>). Scalar filehandles are
strongly recommended instead.
When using C<autodie> or C<Fatal> with user subroutines, the
declaration of those subroutines must appear before the first use of
C<Fatal> or C<autodie>, or have been exported from a module.
Attempting to use C<Fatal> or C<autodie> on other user subroutines will
result in a compile-time error.
Due to a bug in Perl, C<autodie> may "lose" any format which has the
same name as an autodying built-in or function.
C<autodie> may not work correctly if used inside a file with a
name that looks like a string eval, such as F<eval (3)>.
=head2 autodie and string eval
Due to the current implementation of C<autodie>, unexpected results
may be seen when used near or with the string version of eval.
I<None of these bugs exist when using block eval>.
Under Perl 5.8 only, C<autodie> I<does not> propagate into string C<eval>
statements, although it can be explicitly enabled inside a string
C<eval>.
Under Perl 5.10 only, using a string eval when C<autodie> is in
effect can cause the autodie behaviour to leak into the surrounding
scope. This can be worked around by using a C<no autodie> at the
end of the scope to explicitly remove autodie's effects, or by
avoiding the use of string eval.
I<None of these bugs exist when using block eval>. The use of
C<autodie> with block eval is considered good practice.
=head2 REPORTING BUGS
Please report bugs via the CPAN Request Tracker at
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie>.
=head1 FEEDBACK
If you find this module useful, please consider rating it on the
CPAN Ratings service at
L<http://cpanratings.perl.org/rate?distribution=autodie> .
The module author loves to hear how C<autodie> has made your life
better (or worse). Feedback can be sent to
E<lt>pjf@perltraining.com.auE<gt>.
=head1 AUTHOR
Copyright 2008-2009, Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
=head1 LICENSE
This module is free software. You may distribute it under the
same terms as Perl itself.
=head1 SEE ALSO
L<Fatal>, L<autodie::exception>, L<autodie::hints>, L<IPC::System::Simple>
I<Perl tips, autodie> at
L<http://perltraining.com.au/tips/2008-08-20.html>
=head1 ACKNOWLEDGEMENTS
Mark Reed and Roland Giersig -- Klingon translators.
See the F<AUTHORS> file for full credits. The latest version of this
file can be found at
L<http://github.com/pfenwick/autodie/tree/master/AUTHORS> .
=cut
AUTODIE
$fatpacked{"autodie/exception.pm"} = <<'AUTODIE_EXCEPTION';
package autodie::exception;
use 5.008;
use strict;
use warnings;
use Carp qw(croak);
our $DEBUG = 0;
use overload
q{""} => "stringify"
;
# Overload smart-match only if we're using 5.10
use if ($] >= 5.010), overload => '~~' => "matches";
our $VERSION = '2.11';
my $PACKAGE = __PACKAGE__; # Useful to have a scalar for hash keys.
=head1 NAME
autodie::exception - Exceptions from autodying functions.
=head1 SYNOPSIS
eval {
use autodie;
open(my $fh, '<', 'some_file.txt');
...
};
if (my $E = $@) {
say "Ooops! ",$E->caller," had problems: $@";
}
=head1 DESCRIPTION
When an L<autodie> enabled function fails, it generates an
C<autodie::exception> object. This can be interrogated to
determine further information about the error that occurred.
This document is broken into two sections; those methods that
are most useful to the end-developer, and those methods for
anyone wishing to subclass or get very familiar with
C<autodie::exception>.
=head2 Common Methods
These methods are intended to be used in the everyday dealing
of exceptions.
The following assume that the error has been copied into
a separate scalar:
if ($E = $@) {
...
}
This is not required, but is recommended in case any code
is called which may reset or alter C<$@>.
=cut
=head3 args
my $array_ref = $E->args;
Provides a reference to the arguments passed to the subroutine
that died.
=cut
sub args { return $_[0]->{$PACKAGE}{args}; }
=head3 function
my $sub = $E->function;
The subroutine (including package) that threw the exception.
=cut
sub function { return $_[0]->{$PACKAGE}{function}; }
=head3 file
my $file = $E->file;
The file in which the error occurred (eg, C<myscript.pl> or
C<MyTest.pm>).
=cut
sub file { return $_[0]->{$PACKAGE}{file}; }
=head3 package
my $package = $E->package;
The package from which the exceptional subroutine was called.
=cut
sub package { return $_[0]->{$PACKAGE}{package}; }
=head3 caller
my $caller = $E->caller;
The subroutine that I<called> the exceptional code.
=cut
sub caller { return $_[0]->{$PACKAGE}{caller}; }
=head3 line
my $line = $E->line;
The line in C<< $E->file >> where the exceptional code was called.
=cut
sub line { return $_[0]->{$PACKAGE}{line}; }
=head3 context
my $context = $E->context;
The context in which the subroutine was called. This can be
'list', 'scalar', or undefined (unknown). It will never be 'void', as
C<autodie> always captures the return value in one way or another.
=cut
sub context { return $_[0]->{$PACKAGE}{context} }
=head3 return
my $return_value = $E->return;
The value(s) returned by the failed subroutine. When the subroutine
was called in a list context, this will always be a reference to an
array containing the results. When the subroutine was called in
a scalar context, this will be the actual scalar returned.
=cut
sub return { return $_[0]->{$PACKAGE}{return} }
=head3 errno
my $errno = $E->errno;
The value of C<$!> at the time when the exception occurred.
B<NOTE>: This method will leave the main C<autodie::exception> class
and become part of a role in the future. You should only call
C<errno> for exceptions where C<$!> would reasonably have been
set on failure.
=cut
# TODO: Make errno part of a role. It doesn't make sense for
# everything.
sub errno { return $_[0]->{$PACKAGE}{errno}; }
=head3 eval_error
my $old_eval_error = $E->eval_error;
The contents of C<$@> immediately after autodie triggered an
exception. This may be useful when dealing with modules such
as L<Text::Balanced> that set (but do not throw) C<$@> on error.
=cut
sub eval_error { return $_[0]->{$PACKAGE}{eval_error}; }
=head3 matches
if ( $e->matches('open') ) { ... }
if ( $e ~~ 'open' ) { ... }
C<matches> is used to determine whether a
given exception matches a particular role. On Perl 5.10,
using smart-match (C<~~>) with an C<autodie::exception> object
will use C<matches> underneath.
An exception is considered to match a string if:
=over 4
=item *
For a string not starting with a colon, the string exactly matches the
package and subroutine that threw the exception. For example,
C<MyModule::log>. If the string does not contain a package name,
C<CORE::> is assumed.
=item *
For a string that does start with a colon, if the subroutine
throwing the exception I<does> that behaviour. For example, the
C<CORE::open> subroutine does C<:file>, C<:io> and C<:all>.
See L<autodie/CATEGORIES> for futher information.
=back
=cut
{
my (%cache);
sub matches {
my ($this, $that) = @_;
# TODO - Handle references
croak "UNIMPLEMENTED" if ref $that;
my $sub = $this->function;
if ($DEBUG) {
my $sub2 = $this->function;
warn "Smart-matching $that against $sub / $sub2\n";
}
# Direct subname match.
return 1 if $that eq $sub;
return 1 if $that !~ /:/ and "CORE::$that" eq $sub;
return 0 if $that !~ /^:/;
# Cached match / check tags.
require Fatal;
if (exists $cache{$sub}{$that}) {
return $cache{$sub}{$that};
}
# This rather awful looking line checks to see if our sub is in the
# list of expanded tags, caches it, and returns the result.
return $cache{$sub}{$that} = grep { $_ eq $sub } @{ $this->_expand_tag($that) };
}
}
# This exists primarily so that child classes can override or
# augment it if they wish.
sub _expand_tag {
my ($this, @args) = @_;
return Fatal->_expand_tag(@args);
}
=head2 Advanced methods
The following methods, while usable from anywhere, are primarily
intended for developers wishing to subclass C<autodie::exception>,
write code that registers custom error messages, or otherwise
work closely with the C<autodie::exception> model.
=cut
# The table below records customer formatters.
# TODO - Should this be a package var instead?
# TODO - Should these be in a completely different file, or
# perhaps loaded on demand? Most formatters will never
# get used in most programs.
my %formatter_of = (
'CORE::close' => \&_format_close,
'CORE::open' => \&_format_open,
'CORE::dbmopen' => \&_format_dbmopen,
'CORE::flock' => \&_format_flock,
);
# TODO: Our tests only check LOCK_EX | LOCK_NB is properly
# formatted. Try other combinations and ensure they work
# correctly.
sub _format_flock {
my ($this) = @_;
require Fcntl;
my $filehandle = $this->args->[0];
my $raw_mode = $this->args->[1];
my $mode_type;
my $lock_unlock;
if ($raw_mode & Fcntl::LOCK_EX() ) {
$lock_unlock = "lock";
$mode_type = "for exclusive access";
}
elsif ($raw_mode & Fcntl::LOCK_SH() ) {
$lock_unlock = "lock";
$mode_type = "for shared access";
}
elsif ($raw_mode & Fcntl::LOCK_UN() ) {
$lock_unlock = "unlock";
$mode_type = "";
}
else {
# I've got no idea what they're trying to do.
$lock_unlock = "lock";
$mode_type = "with mode $raw_mode";
}
my $cooked_filehandle;
if ($filehandle and not ref $filehandle) {
# A package filehandle with a name!
$cooked_filehandle = " $filehandle";
}
else {
# Otherwise we have a scalar filehandle.
$cooked_filehandle = '';
}
local $! = $this->errno;
return "Can't $lock_unlock filehandle$cooked_filehandle $mode_type: $!";
}
# Default formatter for CORE::dbmopen
sub _format_dbmopen {
my ($this) = @_;
my @args = @{$this->args};
# TODO: Presently, $args flattens out the (usually empty) hash
# which is passed as the first argument to dbmopen. This is
# a bug in our args handling code (taking a reference to it would
# be better), but for the moment we'll just examine the end of
# our arguments list for message formatting.
my $mode = $args[-1];
my $file = $args[-2];
# If we have a mask, then display it in octal, not decimal.
# We don't do this if it already looks octalish, or doesn't
# look like a number.
if ($mode =~ /^[^\D0]\d+$/) {
$mode = sprintf("0%lo", $mode);
};
local $! = $this->errno;
return "Can't dbmopen(%hash, '$file', $mode): '$!'";
}
# Default formatter for CORE::close
sub _format_close {
my ($this) = @_;
my $close_arg = $this->args->[0];
local $! = $this->errno;
# If we've got an old-style filehandle, mention it.
if ($close_arg and not ref $close_arg) {
return "Can't close filehandle '$close_arg': '$!'";
}
# TODO - This will probably produce an ugly error. Test and fix.
return "Can't close($close_arg) filehandle: '$!'";
}
# Default formatter for CORE::open
use constant _FORMAT_OPEN => "Can't open '%s' for %s: '%s'";
sub _format_open_with_mode {
my ($this, $mode, $file, $error) = @_;
my $wordy_mode;
if ($mode eq '<') { $wordy_mode = 'reading'; }
elsif ($mode eq '>') { $wordy_mode = 'writing'; }
elsif ($mode eq '>>') { $wordy_mode = 'appending'; }
return sprintf _FORMAT_OPEN, $file, $wordy_mode, $error if $wordy_mode;
Carp::confess("Internal autodie::exception error: Don't know how to format mode '$mode'.");
}
sub _format_open {
my ($this) = @_;
my @open_args = @{$this->args};
# Use the default formatter for single-arg and many-arg open
if (@open_args <= 1 or @open_args >= 4) {
return $this->format_default;
}
# For two arg open, we have to extract the mode
if (@open_args == 2) {
my ($fh, $file) = @open_args;
if (ref($fh) eq "GLOB") {
$fh = '$fh';
}
my ($mode) = $file =~ m{
^\s* # Spaces before mode
(
(?> # Non-backtracking subexp.
< # Reading
|>>? # Writing/appending
)
)
[^&] # Not an ampersand (which means a dup)
}x;
if (not $mode) {
# Maybe it's a 2-arg open without any mode at all?
# Detect the most simple case for this, where our
# file consists only of word characters.
if ( $file =~ m{^\s*\w+\s*$} ) {
$mode = '<'
}
else {
# Otherwise, we've got no idea what's going on.
# Use the default.
return $this->format_default;
}
}
# Localising $! means perl make make it a pretty error for us.
local $! = $this->errno;
return $this->_format_open_with_mode($mode, $file, $!);
}
# Here we must be using three arg open.
my $file = $open_args[2];
local $! = $this->errno;
my $mode = $open_args[1];
local $@;
my $msg = eval { $this->_format_open_with_mode($mode, $file, $!); };
return $msg if $msg;
# Default message (for pipes and odd things)
return "Can't open '$file' with mode '$open_args[1]': '$!'";
}
=head3 register
autodie::exception->register( 'CORE::open' => \&mysub );
The C<register> method allows for the registration of a message
handler for a given subroutine. The full subroutine name including
the package should be used.
Registered message handlers will receive the C<autodie::exception>
object as the first parameter.
=cut
sub register {
my ($class, $symbol, $handler) = @_;
croak "Incorrect call to autodie::register" if @_ != 3;
$formatter_of{$symbol} = $handler;
}
=head3 add_file_and_line
say "Problem occurred",$@->add_file_and_line;
Returns the string C< at %s line %d>, where C<%s> is replaced with
the filename, and C<%d> is replaced with the line number.
Primarily intended for use by format handlers.
=cut
# Simply produces the file and line number; intended to be added
# to the end of error messages.
sub add_file_and_line {
my ($this) = @_;
return sprintf(" at %s line %d\n", $this->file, $this->line);
}
=head3 stringify
say "The error was: ",$@->stringify;
Formats the error as a human readable string. Usually there's no
reason to call this directly, as it is used automatically if an
C<autodie::exception> object is ever used as a string.
Child classes can override this method to change how they're
stringified.
=cut
sub stringify {
my ($this) = @_;
my $call = $this->function;
if ($DEBUG) {
my $dying_pkg = $this->package;
my $sub = $this->function;
my $caller = $this->caller;
warn "Stringifing exception for $dying_pkg :: $sub / $caller / $call\n";
}
# TODO - This isn't using inheritance. Should it?
if ( my $sub = $formatter_of{$call} ) {
return $sub->($this) . $this->add_file_and_line;
}
return $this->format_default . $this->add_file_and_line;
}
=head3 format_default
my $error_string = $E->format_default;
This produces the default error string for the given exception,
I<without using any registered message handlers>. It is primarily
intended to be called from a message handler when they have
been passed an exception they don't want to format.
Child classes can override this method to change how default
messages are formatted.
=cut
# TODO: This produces ugly errors. Is there any way we can
# dig around to find the actual variable names? I know perl 5.10
# does some dark and terrible magicks to find them for undef warnings.
sub format_default {
my ($this) = @_;
my $call = $this->function;
local $! = $this->errno;
# TODO: This is probably a good idea for CORE, is it
# a good idea for other subs?
# Trim package name off dying sub for error messages.
$call =~ s/.*:://;
# Walk through all our arguments, and...
#
# * Replace undef with the word 'undef'
# * Replace globs with the string '$fh'
# * Quote all other args.
my @args = @{ $this->args() };
foreach my $arg (@args) {
if (not defined($arg)) { $arg = 'undef' }
elsif (ref($arg) eq "GLOB") { $arg = '$fh' }
else { $arg = qq{'$arg'} }
}
# Format our beautiful error.
return "Can't $call(". join(q{, }, @args) . "): $!" ;
# TODO - Handle user-defined errors from hash.
# TODO - Handle default error messages.
}
=head3 new
my $error = autodie::exception->new(
args => \@_,
function => "CORE::open",
errno => $!,
context => 'scalar',
return => undef,
);
Creates a new C<autodie::exception> object. Normally called
directly from an autodying function. The C<function> argument
is required, its the function we were trying to call that
generated the exception. The C<args> parameter is optional.
The C<errno> value is optional. In versions of C<autodie::exception>
1.99 and earlier the code would try to automatically use the
current value of C<$!>, but this was unreliable and is no longer
supported.
Atrributes such as package, file, and caller are determined
automatically, and cannot be specified.
=cut
sub new {
my ($class, @args) = @_;
my $this = {};
bless($this,$class);
# I'd love to use EVERY here, but it causes our code to die
# because it wants to stringify our objects before they're
# initialised, causing everything to explode.
$this->_init(@args);
return $this;
}
sub _init {
my ($this, %args) = @_;
# Capturing errno here is not necessarily reliable.
my $original_errno = $!;
our $init_called = 1;
my $class = ref $this;
# We're going to walk up our call stack, looking for the
# first thing that doesn't look like our exception
# code, autodie/Fatal, or some whacky eval.
my ($package, $file, $line, $sub);
my $depth = 0;
while (1) {
$depth++;
($package, $file, $line, $sub) = CORE::caller($depth);
# Skip up the call stack until we find something outside
# of the Fatal/autodie/eval space.
next if $package->isa('Fatal');
next if $package->isa($class);
next if $package->isa(__PACKAGE__);
next if $file =~ /^\(eval\s\d+\)$/;
last;
}
# We now have everything correct, *except* for our subroutine
# name. If it's __ANON__ or (eval), then we need to keep on
# digging deeper into our stack to find the real name. However we
# don't update our other information, since that will be correct
# for our current exception.
my $first_guess_subroutine = $sub;
while (defined $sub and $sub =~ /^\(eval\)$|::__ANON__$/) {
$depth++;
$sub = (CORE::caller($depth))[3];
}
# If we end up falling out the bottom of our stack, then our
# __ANON__ guess is the best we can get. This includes situations
# where we were called from the top level of a program.
if (not defined $sub) {
$sub = $first_guess_subroutine;
}
$this->{$PACKAGE}{package} = $package;
$this->{$PACKAGE}{file} = $file;
$this->{$PACKAGE}{line} = $line;
$this->{$PACKAGE}{caller} = $sub;
$this->{$PACKAGE}{package} = $package;
$this->{$PACKAGE}{errno} = $args{errno} || 0;
$this->{$PACKAGE}{context} = $args{context};
$this->{$PACKAGE}{return} = $args{return};
$this->{$PACKAGE}{eval_error} = $args{eval_error};
$this->{$PACKAGE}{args} = $args{args} || [];
$this->{$PACKAGE}{function}= $args{function} or
croak("$class->new() called without function arg");
return $this;
}
1;
__END__
=head1 SEE ALSO
L<autodie>, L<autodie::exception::system>
=head1 LICENSE
Copyright (C)2008 Paul Fenwick
This is free software. You may modify and/or redistribute this
code under the same terms as Perl 5.10 itself, or, at your option,
any later version of Perl 5.
=head1 AUTHOR
Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
AUTODIE_EXCEPTION
$fatpacked{"autodie/exception/system.pm"} = <<'AUTODIE_EXCEPTION_SYSTEM';
package autodie::exception::system;
use 5.008;
use strict;
use warnings;
use base 'autodie::exception';
use Carp qw(croak);
our $VERSION = '2.11';
my $PACKAGE = __PACKAGE__;
=head1 NAME
autodie::exception::system - Exceptions from autodying system().
=head1 SYNOPSIS
eval {
use autodie qw(system);
system($cmd, @args);
};
if (my $E = $@) {
say "Ooops! ",$E->caller," had problems: $@";
}
=head1 DESCRIPTION
This is a L<autodie::exception> class for failures from the
C<system> command.
Presently there is no way to interrogate an C<autodie::exception::system>
object for the command, exit status, and other information you'd expect
such an object to hold. The interface will be expanded to accommodate
this in the future.
=cut
sub _init {
my ($this, %args) = @_;
$this->{$PACKAGE}{message} = $args{message}
|| croak "'message' arg not supplied to autodie::exception::system->new";
return $this->SUPER::_init(%args);
}
=head2 stringify
When stringified, C<autodie::exception::system> objects currently
use the message generated by L<IPC::System::Simple>.
=cut
sub stringify {
my ($this) = @_;
return $this->{$PACKAGE}{message} . $this->add_file_and_line;
}
1;
__END__
=head1 LICENSE
Copyright (C)2008 Paul Fenwick
This is free software. You may modify and/or redistribute this
code under the same terms as Perl 5.10 itself, or, at your option,
any later version of Perl 5.
=head1 AUTHOR
Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
AUTODIE_EXCEPTION_SYSTEM
$fatpacked{"autodie/hints.pm"} = <<'AUTODIE_HINTS';
package autodie::hints;
use strict;
use warnings;
use constant PERL58 => ( $] < 5.009 );
our $VERSION = '2.11';
=head1 NAME
autodie::hints - Provide hints about user subroutines to autodie
=head1 SYNOPSIS
package Your::Module;
our %DOES = ( 'autodie::hints::provider' => 1 );
sub AUTODIE_HINTS {
return {
foo => { scalar => HINTS, list => SOME_HINTS },
bar => { scalar => HINTS, list => MORE_HINTS },
}
}
# Later, in your main program...
use Your::Module qw(foo bar);
use autodie qw(:default foo bar);
foo(); # succeeds or dies based on scalar hints
# Alternatively, hints can be set on subroutines we've
# imported.
use autodie::hints;
use Some::Module qw(think_positive);
BEGIN {
autodie::hints->set_hints_for(
\&think_positive,
{
fail => sub { $_[0] <= 0 }
}
)
}
use autodie qw(think_positive);
think_positive(...); # Returns positive or dies.
=head1 DESCRIPTION
=head2 Introduction
The L<autodie> pragma is very smart when it comes to working with
Perl's built-in functions. The behaviour for these functions are
fixed, and C<autodie> knows exactly how they try to signal failure.
But what about user-defined subroutines from modules? If you use
C<autodie> on a user-defined subroutine then it assumes the following
behaviour to demonstrate failure:
=over
=item *
A false value, in scalar context
=item *
An empty list, in list context
=item *
A list containing a single undef, in list context
=back
All other return values (including the list of the single zero, and the
list containing a single empty string) are considered successful. However,
real-world code isn't always that easy. Perhaps the code you're working
with returns a string containing the word "FAIL" upon failure, or a
two element list containing C<(undef, "human error message")>. To make
autodie work with these sorts of subroutines, we have
the I<hinting interface>.
The hinting interface allows I<hints> to be provided to C<autodie>
on how it should detect failure from user-defined subroutines. While
these I<can> be provided by the end-user of C<autodie>, they are ideally
written into the module itself, or into a helper module or sub-class
of C<autodie> itself.
=head2 What are hints?
A I<hint> is a subroutine or value that is checked against the
return value of an autodying subroutine. If the match returns true,
C<autodie> considers the subroutine to have failed.
If the hint provided is a subroutine, then C<autodie> will pass
the complete return value to that subroutine. If the hint is
any other value, then C<autodie> will smart-match against the
value provided. In Perl 5.8.x there is no smart-match operator, and as such
only subroutine hints are supported in these versions.
Hints can be provided for both scalar and list contexts. Note
that an autodying subroutine will never see a void context, as
C<autodie> always needs to capture the return value for examination.
Autodying subroutines called in void context act as if they're called
in a scalar context, but their return value is discarded after it
has been checked.
=head2 Example hints
Hints may consist of scalars, array references, regular expressions and
subroutine references. You can specify different hints for how
failure should be identified in scalar and list contexts.
These examples apply for use in the C<AUTODIE_HINTS> subroutine and when
calling C<autodie::hints->set_hints_for()>.
The most common context-specific hints are:
# Scalar failures always return undef:
{ scalar => undef }
# Scalar failures return any false value [default expectation]:
{ scalar => sub { ! $_[0] } }
# Scalar failures always return zero explicitly:
{ scalar => '0' }
# List failures always return an empty list:
{ list => [] }
# List failures return () or (undef) [default expectation]:
{ list => sub { ! @_ || @_ == 1 && !defined $_[0] } }
# List failures return () or a single false value:
{ list => sub { ! @_ || @_ == 1 && !$_[0] } }
# List failures return (undef, "some string")
{ list => sub { @_ == 2 && !defined $_[0] } }
# Unsuccessful foo() returns 'FAIL' or '_FAIL' in scalar context,
# returns (-1) in list context...
autodie::hints->set_hints_for(
\&foo,
{
scalar => qr/^ _? FAIL $/xms,
list => [-1],
}
);
# Unsuccessful foo() returns 0 in all contexts...
autodie::hints->set_hints_for(
\&foo,
{
scalar => 0,
list => [0],
}
);
This "in all contexts" construction is very common, and can be
abbreviated, using the 'fail' key. This sets both the C<scalar>
and C<list> hints to the same value:
# Unsuccessful foo() returns 0 in all contexts...
autodie::hints->set_hints_for(
\&foo,
{
fail => sub { @_ == 1 and defined $_[0] and $_[0] == 0 }
}
);
# Unsuccessful think_positive() returns negative number on failure...
autodie::hints->set_hints_for(
\&think_positive,
{
fail => sub { $_[0] < 0 }
}
);
# Unsuccessful my_system() returns non-zero on failure...
autodie::hints->set_hints_for(
\&my_system,
{
fail => sub { $_[0] != 0 }
}
);
=head1 Manually setting hints from within your program
If you are using a module which returns something special on failure, then
you can manually create hints for each of the desired subroutines. Once
the hints are specified, they are available for all files and modules loaded
thereafter, thus you can move this work into a module and it will still
work.
use Some::Module qw(foo bar);
use autodie::hints;
autodie::hints->set_hints_for(
\&foo,
{
scalar => SCALAR_HINT,
list => LIST_HINT,
}
);
autodie::hints->set_hints_for(
\&bar,
{ fail => SOME_HINT, }
);
It is possible to pass either a subroutine reference (recommended) or a fully
qualified subroutine name as the first argument. This means you can set hints
on modules that I<might> get loaded:
use autodie::hints;
autodie::hints->set_hints_for(
'Some::Module:bar', { fail => SCALAR_HINT, }
);
This technique is most useful when you have a project that uses a
lot of third-party modules. You can define all your possible hints
in one-place. This can even be in a sub-class of autodie. For
example:
package my::autodie;
use parent qw(autodie);
use autodie::hints;
autodie::hints->set_hints_for(...);
1;
You can now C<use my::autodie>, which will work just like the standard
C<autodie>, but is now aware of any hints that you've set.
=head1 Adding hints to your module
C<autodie> provides a passive interface to allow you to declare hints for
your module. These hints will be found and used by C<autodie> if it
is loaded, but otherwise have no effect (or dependencies) without autodie.
To set these, your module needs to declare that it I<does> the
C<autodie::hints::provider> role. This can be done by writing your
own C<DOES> method, using a system such as C<Class::DOES> to handle
the heavy-lifting for you, or declaring a C<%DOES> package variable
with a C<autodie::hints::provider> key and a corresponding true value.
Note that checking for a C<%DOES> hash is an C<autodie>-only
short-cut. Other modules do not use this mechanism for checking
roles, although you can use the C<Class::DOES> module from the
CPAN to allow it.
In addition, you must define a C<AUTODIE_HINTS> subroutine that returns
a hash-reference containing the hints for your subroutines:
package Your::Module;
# We can use the Class::DOES from the CPAN to declare adherence
# to a role.
use Class::DOES 'autodie::hints::provider' => 1;
# Alternatively, we can declare the role in %DOES. Note that
# this is an autodie specific optimisation, although Class::DOES
# can be used to promote this to a true role declaration.
our %DOES = ( 'autodie::hints::provider' => 1 );
# Finally, we must define the hints themselves.
sub AUTODIE_HINTS {
return {
foo => { scalar => HINTS, list => SOME_HINTS },
bar => { scalar => HINTS, list => MORE_HINTS },
baz => { fail => HINTS },
}
}
This allows your code to set hints without relying on C<autodie> and
C<autodie::hints> being loaded, or even installed. In this way your
code can do the right thing when C<autodie> is installed, but does not
need to depend upon it to function.
=head1 Insisting on hints
When a user-defined subroutine is wrapped by C<autodie>, it will
use hints if they are available, and otherwise reverts to the
I<default behaviour> described in the introduction of this document.
This can be problematic if we expect a hint to exist, but (for
whatever reason) it has not been loaded.
We can ask autodie to I<insist> that a hint be used by prefixing
an exclamation mark to the start of the subroutine name. A lone
exclamation mark indicates that I<all> subroutines after it must
have hints declared.
# foo() and bar() must have their hints defined
use autodie qw( !foo !bar baz );
# Everything must have hints (recommended).
use autodie qw( ! foo bar baz );
# bar() and baz() must have their hints defined
use autodie qw( foo ! bar baz );
# Enable autodie for all of Perl's supported built-ins,
# as well as for foo(), bar() and baz(). Everything must
# have hints.
use autodie qw( ! :all foo bar baz );
If hints are not available for the specified subroutines, this will cause a
compile-time error. Insisting on hints for Perl's built-in functions
(eg, C<open> and C<close>) is always successful.
Insisting on hints is I<strongly> recommended.
=cut
# TODO: implement regular expression hints
use constant UNDEF_ONLY => sub { not defined $_[0] };
use constant EMPTY_OR_UNDEF => sub {
! @_ or
@_==1 && !defined $_[0]
};
use constant EMPTY_ONLY => sub { @_ == 0 };
use constant EMPTY_OR_FALSE => sub {
! @_ or
@_==1 && !$_[0]
};
use constant SINGLE_TRUE => sub { @_ == 1 and not $_[0] };
use constant DEFAULT_HINTS => {
scalar => UNDEF_ONLY,
list => EMPTY_OR_UNDEF,
};
use constant HINTS_PROVIDER => 'autodie::hints::provider';
use base qw(Exporter);
our $DEBUG = 0;
# Only ( undef ) is a strange but possible situation for very
# badly written code. It's not supported yet.
my %Hints = (
'File::Copy::copy' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
'File::Copy::move' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
'File::Copy::cp' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
'File::Copy::mv' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
);
# Start by using Sub::Identify if it exists on this system.
eval { require Sub::Identify; Sub::Identify->import('get_code_info'); };
# If it doesn't exist, we'll define our own. This code is directly
# taken from Rafael Garcia's Sub::Identify 0.04, used under the same
# license as Perl itself.
if ($@) {
require B;
no warnings 'once';
*get_code_info = sub ($) {
my ($coderef) = @_;
ref $coderef or return;
my $cv = B::svref_2object($coderef);
$cv->isa('B::CV') or return;
# bail out if GV is undefined
$cv->GV->isa('B::SPECIAL') and return;
return ($cv->GV->STASH->NAME, $cv->GV->NAME);
};
}
sub sub_fullname {
return join( '::', get_code_info( $_[1] ) );
}
my %Hints_loaded = ();
sub load_hints {
my ($class, $sub) = @_;
my ($package) = ( $sub =~ /(.*)::/ );
if (not defined $package) {
require Carp;
Carp::croak(
"Internal error in autodie::hints::load_hints - no package found.
");
}
# Do nothing if we've already tried to load hints for
# this package.
return if $Hints_loaded{$package}++;
my $hints_available = 0;
{
no strict 'refs'; ## no critic
if ($package->can('DOES') and $package->DOES(HINTS_PROVIDER) ) {
$hints_available = 1;
}
elsif ( PERL58 and $package->isa(HINTS_PROVIDER) ) {
$hints_available = 1;
}
elsif ( ${"${package}::DOES"}{HINTS_PROVIDER.""} ) {
$hints_available = 1;
}
}
return if not $hints_available;
my %package_hints = %{ $package->AUTODIE_HINTS };
foreach my $sub (keys %package_hints) {
my $hint = $package_hints{$sub};
# Ensure we have a package name.
$sub = "${package}::$sub" if $sub !~ /::/;
# TODO - Currently we don't check for conflicts, should we?
$Hints{$sub} = $hint;
$class->normalise_hints(\%Hints, $sub);
}
return;
}
sub normalise_hints {
my ($class, $hints, $sub) = @_;
if ( exists $hints->{$sub}->{fail} ) {
if ( exists $hints->{$sub}->{scalar} or
exists $hints->{$sub}->{list}
) {
# TODO: Turn into a proper diagnostic.
require Carp;
local $Carp::CarpLevel = 1;
Carp::croak("fail hints cannot be provided with either scalar or list hints for $sub");
}
# Set our scalar and list hints.
$hints->{$sub}->{scalar} =
$hints->{$sub}->{list} = delete $hints->{$sub}->{fail};
return;
}
# Check to make sure all our hints exist.
foreach my $hint (qw(scalar list)) {
if ( not exists $hints->{$sub}->{$hint} ) {
# TODO: Turn into a proper diagnostic.
require Carp;
local $Carp::CarpLevel = 1;
Carp::croak("$hint hint missing for $sub");
}
}
return;
}
sub get_hints_for {
my ($class, $sub) = @_;
my $subname = $class->sub_fullname( $sub );
# If we have hints loaded for a sub, then return them.
if ( exists $Hints{ $subname } ) {
return $Hints{ $subname };
}
# If not, we try to load them...
$class->load_hints( $subname );
# ...and try again!
if ( exists $Hints{ $subname } ) {
return $Hints{ $subname };
}
# It's the caller's responsibility to use defaults if desired.
# This allows on autodie to insist on hints if needed.
return;
}
sub set_hints_for {
my ($class, $sub, $hints) = @_;
if (ref $sub) {
$sub = $class->sub_fullname( $sub );
require Carp;
$sub or Carp::croak("Attempts to set_hints_for unidentifiable subroutine");
}
if ($DEBUG) {
warn "autodie::hints: Setting $sub to hints: $hints\n";
}
$Hints{ $sub } = $hints;
$class->normalise_hints(\%Hints, $sub);
return;
}
1;
__END__
=head1 Diagnostics
=over 4
=item Attempts to set_hints_for unidentifiable subroutine
You've called C<< autodie::hints->set_hints_for() >> using a subroutine
reference, but that reference could not be resolved back to a
subroutine name. It may be an anonymous subroutine (which can't
be made autodying), or may lack a name for other reasons.
If you receive this error with a subroutine that has a real name,
then you may have found a bug in autodie. See L<autodie/BUGS>
for how to report this.
=item fail hints cannot be provided with either scalar or list hints for %s
When defining hints, you can either supply both C<list> and
C<scalar> keywords, I<or> you can provide a single C<fail> keyword.
You can't mix and match them.
=item %s hint missing for %s
You've provided either a C<scalar> hint without supplying
a C<list> hint, or vice-versa. You I<must> supply both C<scalar>
and C<list> hints, I<or> a single C<fail> hint.
=back
=head1 ACKNOWLEDGEMENTS
=over
=item *
Dr Damian Conway for suggesting the hinting interface and providing the
example usage.
=item *
Jacinta Richardson for translating much of my ideas into this
documentation.
=back
=head1 AUTHOR
Copyright 2009, Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
=head1 LICENSE
This module is free software. You may distribute it under the
same terms as Perl itself.
=head1 SEE ALSO
L<autodie>, L<Class::DOES>
=cut
AUTODIE_HINTS
$fatpacked{"x86_64-linux/List/Util.pm"} = <<'X86_64-LINUX_LIST_UTIL';
# List::Util.pm
#
# Copyright (c) 1997-2009 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# This module is normally only loaded if the XS module is not available
package List::Util;
use strict;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle);
our $VERSION = "1.25";
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
require XSLoader;