App-after
view release on metacpan or search on metacpan
# elsif ($i_to_o{$word}) {
# $singular =~ s/i$/o/;
# }
# if ($i_to_other{$word}) {
# $singular = $i_to_other{$word};
# }
# }
#
# }
# return $singular;
#}
#
#sub is_plural
#{
# my ($word) = @_;
# my $singular = to_singular ($word);
# my $is_plural;
# if ($singular ne $word) {
# $is_plural = 1;
# }
# elsif ($plural{$singular} && $plural{$singular} eq $singular) {
# $is_plural = 1;
# }
# else {
# $is_plural = 0;
# }
# return $is_plural;
#}
#
#1;
### Log/Any.pm ###
#use 5.008001;
#use strict;
#use warnings;
#
#package Log::Any;
#
#our $VERSION = '1.040';
#
#use Log::Any::Manager;
#use Log::Any::Adapter::Util qw(
# require_dynamic
# detection_aliases
# detection_methods
# log_level_aliases
# logging_aliases
# logging_and_detection_methods
# logging_methods
#);
#
#our $OverrideDefaultAdapterClass;
#our $OverrideDefaultProxyClass;
#
#{
# my $manager = Log::Any::Manager->new();
# sub _manager { return $manager }
#}
#
#sub import {
# my $class = shift;
# my $caller = caller();
#
# my @export_params = ( $caller, @_ );
# $class->_export_to_caller(@export_params);
#}
#
#sub _export_to_caller {
# my $class = shift;
# my $caller = shift;
#
# my $saw_log_param;
# my @params;
# while ( my $param = shift @_ ) {
# if ( $param eq '$log' ) {
# $saw_log_param = 1;
# next;
# }
# else {
# push @params, $param, shift @_;
# }
# }
#
# unless ( @params % 2 == 0 ) {
# require Carp;
# Carp::croak("Argument list not balanced: @params");
# }
#
# if ($saw_log_param) {
# no strict 'refs';
# my $proxy = $class->get_logger( category => $caller, @params );
# my $varname = "$caller\::log";
# *$varname = \$proxy;
# }
#}
#
#sub get_logger {
# my ( $class, %params ) = @_;
# no warnings 'once';
#
# my $proxy_class = $class->_get_proxy_class( delete $params{proxy_class} );
# my $category =
# defined $params{category} ? delete $params{'category'} : caller;
#
# if ( my $default = delete $params{'default_adapter'} ) {
# $class->_manager->set_default( $category, $default );
# }
#
# my $adapter = $class->_manager->get_adapter( $category );
#
# require_dynamic($proxy_class);
# return $proxy_class->new(
# %params, adapter => $adapter, category => $category,
# );
#}
#
#sub _get_proxy_class {
# my ( $self, $proxy_name ) = @_;
# return $Log::Any::OverrideDefaultProxyClass
# if $Log::Any::OverrideDefaultProxyClass;
# return "Log::Any::Proxy" unless $proxy_name;
# my $proxy_class = (
# substr( $proxy_name, 0, 1 ) eq '+'
# ? substr( $proxy_name, 1 )
# : "Log::Any::Proxy::$proxy_name"
# warn => 'warning',
# err => 'error',
# crit => 'critical',
# fatal => 'critical'
# );
# @logging_methods =
# qw(trace debug info notice warning error critical alert emergency);
# @logging_aliases = keys(%LOG_LEVEL_ALIASES);
# @detection_methods = map { "is_$_" } @logging_methods;
# @detection_aliases = map { "is_$_" } @logging_aliases;
# @logging_and_detection_methods = ( @logging_methods, @detection_methods );
#}
#
#
#sub logging_methods { @logging_methods }
#
#
#sub detection_methods { @detection_methods }
#
#
#sub logging_and_detection_methods { @logging_and_detection_methods }
#
#
#sub log_level_aliases { %LOG_LEVEL_ALIASES }
#
#
#sub logging_aliases { @logging_aliases }
#
#
#sub detection_aliases { @detection_aliases }
#
#
#sub numeric_level {
# my ($level) = @_;
# my $canonical =
# exists $LOG_LEVEL_ALIASES{$level} ? $LOG_LEVEL_ALIASES{$level} : $level;
# return $LOG_LEVELS{ uc($canonical) };
#}
#
#
#*dump_one_line = sub {
# require Data::Dumper;
#
# my $dumper = sub {
# my ($value) = @_;
#
# return Data::Dumper->new( [$value] )->Indent(0)->Sortkeys(1)->Quotekeys(0)
# ->Terse(1)->Useqq(1)->Dump();
# };
#
# my $string = $dumper->(@_);
# no warnings 'redefine';
# *dump_one_line = $dumper;
# return $string;
#};
#
#
#sub make_method {
# my ( $method, $code, $pkg ) = @_;
#
# $pkg ||= caller();
# no strict 'refs';
# *{ $pkg . "::$method" } = $code;
#}
#
#
#sub require_dynamic {
# my ($class) = @_;
#
# return 1 if $class->can('new');
#
# unless ( defined( eval "require $class; 1" ) )
# {
# die $@;
# }
#}
#
#
#sub read_file {
# my ($file) = @_;
#
# local $/ = undef;
# open( my $fh, '<:utf8', $file )
# or die "cannot open '$file': $!";
# my $contents = <$fh>;
# return $contents;
#}
#
#
#sub cmp_deeply {
# my ( $ref1, $ref2, $name ) = @_;
#
# my $tb = Test::Builder->new();
# $tb->is_eq( dump_one_line($ref1), dump_one_line($ref2), $name );
#}
#
#require Log::Any;
#
#1;
#
#
#
#__END__
#
### Log/Any/IfLOG.pm ###
#package Log::Any::IfLOG;
#
#our $DATE = '2015-08-17';
#our $VERSION = '0.07';
#
#our $DEBUG;
#our $ENABLE_LOG;
#
#my $log_singleton;
#sub __log_singleton {
# if (!$log_singleton) { $log_singleton = Object::Dumb->new }
# $log_singleton;
#}
#
#sub __log_enabled {
# if (defined $ENABLE_LOG) {
# return $ENABLE_LOG;
# } elsif ($INC{'Log/Any.pm'}) {
# return 1;
# } else {
# return
# $ENV{LOG} || $ENV{TRACE} || $ENV{DEBUG} ||
# $ENV{VERBOSE} || $ENV{QUIET} || $ENV{LOG_LEVEL};
# }
#}
#
#sub import {
# my $self = shift;
#
# my $caller = caller();
# if (__log_enabled()) {
# require Log::Any;
# Log::Any->_export_to_caller($caller, @_);
# } else {
# my $saw_log_param = grep { $_ eq '$log' } @_;
# if ($saw_log_param) {
# __log_singleton();
# *{"$caller\::log"} = \$log_singleton;
# }
# }
#}
#
#sub get_logger {
# if (__log_enabled()) {
# require Log::Any;
# my $class = shift;
# if ($class eq 'Log::Any::IfLOG') {
# Log::Any->get_logger(@_);
# } else {
# Log::Any::get_logger($class, @_);
# }
# } else {
# return __log_singleton();
# }
#}
#
#package
# Object::Dumb;
#sub new { my $o = ""; bless \$o, shift }
#sub AUTOLOAD { 0 }
#
#1;
#
#__END__
#
### Log/Any/Manager.pm ###
#use 5.008001;
#use strict;
#use warnings;
#
#package Log::Any::Manager;
#
#our $VERSION = '1.040';
#
#sub new {
# my $class = shift;
# my $self = {
# entries => [],
# category_cache => {},
# default_adapter => {},
# };
# bless $self, $class;
#
# return $self;
#}
#
#sub get_adapter {
# my ( $self, $category ) = @_;
#
# my $category_cache = $self->{category_cache};
# if ( !defined( $category_cache->{$category} ) ) {
# my $entry = $self->_choose_entry_for_category($category);
# my $adapter = $self->_new_adapter_for_entry( $entry, $category );
# }
#
# $nmeta;
#}
#
#sub normalize_function_metadata($;$) {
# my ($meta, $opts) = @_;
#
# $opts //= {};
#
# $opts->{allow_unknown_properties} //= 0;
# $opts->{normalize_sah_schemas} //= 1;
# $opts->{remove_internal_properties} //= 0;
#
# require Sah::Schema::rinci::function_meta;
# my $sch = $Sah::Schema::rinci::function_meta::schema;
# my $sch_proplist = $sch->[1]{_prop}
# or die "BUG: Rinci schema structure changed (1a)";
#
# _normalize($meta, 1.1, $opts, $sch_proplist, {}, '');
#}
#
#1;
#
#__END__
#
### Perinci/Sub/Util.pm ###
#package Perinci::Sub::Util;
#
#our $DATE = '2016-02-21';
#our $VERSION = '0.45';
#
#use 5.010001;
#use strict;
#use warnings;
#
#require Exporter;
#our @ISA = qw(Exporter);
#our @EXPORT_OK = qw(
# err
# caller
# warn_err
# die_err
# gen_modified_sub
# gen_curried_sub
# );
#
#our %SPEC;
#
#$SPEC{':package'} = {
# v => 1.1,
# summary => 'Helper when writing functions',
#};
#
#our $STACK_TRACE;
#our @_c;
#our $_i;
#sub err {
# require Scalar::Util;
#
# my @caller = CORE::caller(1);
# if (!@caller) {
# @caller = ("main", "-e", 1, "program");
# }
#
# my ($status, $msg, $meta, $prev);
#
# for (@_) {
# my $ref = ref($_);
# if ($ref eq 'ARRAY') { $prev = $_ }
# elsif ($ref eq 'HASH') { $meta = $_ }
# elsif (!$ref) {
# if (Scalar::Util::looks_like_number($_)) {
# $status = $_;
# } else {
# $msg = $_;
# }
# }
# }
#
# $status //= 500;
# $msg //= "$caller[3] failed";
# $meta //= {};
# $meta->{prev} //= $prev if $prev;
#
# if (!$meta->{logs}) {
#
# my $stack_trace;
# {
# no warnings;
# last unless $STACK_TRACE // $INC{"Carp/Always.pm"};
# last if $prev && ref($prev->[3]) eq 'HASH' &&
# ref($prev->[3]{logs}) eq 'ARRAY' &&
# ref($prev->[3]{logs}[0]) eq 'HASH' &&
# $prev->[3]{logs}[0]{stack_trace};
# $stack_trace = [];
# $_i = 1;
# while (1) {
# {
# package DB;
# @_c = CORE::caller($_i);
# if (@_c) {
# $_c[4] = [@DB::args];
# }
# }
# last unless @_c;
# push @$stack_trace, [@_c];
# $_i++;
# }
# }
# push @{ $meta->{logs} }, {
# type => 'create',
# time => time(),
# package => $caller[0],
# file => $caller[1],
# line => $caller[2],
# func => $caller[3],
# ( stack_trace => $stack_trace ) x !!$stack_trace,
# };
# }
#
# [$status, $msg, undef, $meta];
#}
#
#sub warn_err {
# require Carp;
#
# my $res = err(@_);
# Carp::carp("ERROR $res->[0]: $res->[1]");
#}
#
#sub die_err {
# require Carp;
#
# my $res = err(@_);
# Carp::croak("ERROR $res->[0]: $res->[1]");
#}
#
#sub caller {
# my $n0 = shift;
# my $n = $n0 // 0;
#
# my $pkg = $Perinci::Sub::Wrapper::default_wrapped_package //
# 'Perinci::Sub::Wrapped';
#
# my @r;
# my $i = 0;
# my $j = -1;
# while ($i <= $n+1) {
# $j++;
# @r = CORE::caller($j);
# last unless @r;
# if ($r[0] eq $pkg && $r[1] =~ /^\(eval /) {
# next;
# }
# $i++;
# }
#
# return unless @r;
# return defined($n0) ? @r : $r[0];
#}
#
#$SPEC{gen_modified_sub} = {
# v => 1.1,
# summary => 'Generate modified metadata (and subroutine) based on another',
# description => <<'_',
#
#Often you'll want to create another sub (and its metadata) based on another, but
#with some modifications, e.g. add/remove/rename some arguments, change summary,
#add/remove some properties, and so on.
#
#Instead of cloning the Rinci metadata and modify it manually yourself, this
#routine provides some shortcuts.
#
#You can specify base sub/metadata using `base_name` (string, subroutine name,
#either qualified or not) or `base_code` (coderef) + `base_meta` (hash).
#
#_
# args => {
# base_name => {
# summary => 'Subroutine name (either qualified or not)',
# schema => 'str*',
# description => <<'_',
#
#If not qualified with package name, will be searched in the caller's package.
#Rinci metadata will be searched in `%SPEC` package variable.
#
#Alternatively, you can also specify `base_code` and `base_meta`.
#
#_
# },
# base_code => {
# summary => 'Base subroutine code',
# schema => 'code*',
# description => <<'_',
#
#If you specify this, you'll also need to specify `base_meta`.
#
#Alternatively, you can specify `base_name` instead, to let this routine search
#the base subroutine from existing Perl package.
#
#_
# },
# base_meta => {
# summary => 'Base Rinci metadata',
# schema => 'hash*',
# },
# output_name => {
# summary => 'Where to install the modified sub',
# schema => 'str*',
# description => <<'_',
# summary => 'List of arguments to remove',
# schema => 'array*',
# },
# add_args => {
# summary => 'Arguments to add',
# schema => 'hash*',
# },
# replace_args => {
# summary => 'Arguments to add',
# schema => 'hash*',
# },
# rename_args => {
# summary => 'Arguments to rename',
# schema => 'hash*',
# },
# modify_args => {
# summary => 'Arguments to modify',
# description => <<'_',
#
#For each argument you can specify a coderef. The coderef will receive the
#argument ($arg_spec) and is expected to modify the argument specification.
#
#_
# schema => 'hash*',
# },
# modify_meta => {
# summary => 'Specify code to modify metadata',
# schema => 'code*',
# description => <<'_',
#
#Code will be called with arguments ($meta) where $meta is the cloned Rinci
#metadata.
#
#_
# },
# install_sub => {
# schema => 'bool',
# default => 1,
# },
# },
# result => {
# schema => ['hash*' => {
# keys => {
# code => ['code*'],
# meta => ['hash*'],
# },
# }],
# },
#};
#sub gen_modified_sub {
# require Function::Fallback::CoreOrPP;
#
# my %args = @_;
#
# my ($base_code, $base_meta);
# if ($args{base_name}) {
# my ($pkg, $leaf);
# if ($args{base_name} =~ /(.+)::(.+)/) {
# ($pkg, $leaf) = ($1, $2);
# } else {
# $pkg = CORE::caller();
# $leaf = $args{base_name};
# }
# no strict 'refs';
# $base_code = \&{"$pkg\::$leaf"};
# $base_meta = ${"$pkg\::SPEC"}{$leaf};
# die "Can't find Rinci metadata for $pkg\::$leaf" unless $base_meta;
# } elsif ($args{base_meta}) {
# $base_meta = $args{base_meta};
# $base_code = $args{base_code}
# or die "Please specify base_code";
# } else {
# die "Please specify base_name or base_code+base_meta";
# }
#
# my $output_meta = Function::Fallback::CoreOrPP::clone($base_meta);
# my $output_code = $args{output_code} // $base_code;
#
# for (qw/summary description/) {
# $output_meta->{$_} = $args{$_} if $args{$_};
# }
# if ($args{remove_args}) {
# delete $output_meta->{args}{$_} for @{ $args{remove_args} };
# }
# if ($args{add_args}) {
# for my $k (keys %{ $args{add_args} }) {
# my $v = $args{add_args}{$k};
# die "Can't add arg '$k' in mod sub: already exists"
# if $output_meta->{args}{$k};
# $output_meta->{args}{$k} = $v;
# }
# }
# if ($args{replace_args}) {
# for my $k (keys %{ $args{replace_args} }) {
# my $v = $args{replace_args}{$k};
# die "Can't replace arg '$k' in mod sub: doesn't exist"
# unless $output_meta->{args}{$k};
# $output_meta->{args}{$k} = $v;
# }
# }
# if ($args{rename_args}) {
# for my $old (keys %{ $args{rename_args} }) {
# my $new = $args{rename_args}{$old};
# my $as = $output_meta->{args}{$old};
# die "Can't rename arg '$old' in mod sub: doesn't exist" unless $as;
# die "Can't rename arg '$old'->'$new' in mod sub: ".
# "new name already exist" if $output_meta->{args}{$new};
# $output_meta->{args}{$new} = $as;
# delete $output_meta->{args}{$old};
# }
# }
# if ($args{modify_args}) {
# for (keys %{ $args{modify_args} }) {
# $args{modify_args}{$_}->($output_meta->{args}{$_});
# }
# }
# if ($args{modify_meta}) {
# $args{modify_meta}->($output_meta);
# }
#
# if ($args{output_name}) {
# my ($pkg, $leaf);
# if ($args{output_name} =~ /(.+)::(.+)/) {
# ($pkg, $leaf) = ($1, $2);
# } else {
# $pkg = CORE::caller();
# $leaf = $args{output_name};
# }
# no strict 'refs';
# no warnings 'redefine';
# *{"$pkg\::$leaf"} = $output_code if $args{install_sub} // 1;
# ${"$pkg\::SPEC"}{$leaf} = $output_meta;
# }
#
# [200, "OK", {code=>$output_code, meta=>$output_meta}];
#}
#
#$SPEC{gen_curried_sub} = {
# v => 1.1,
# summary => 'Generate curried subroutine (and its metadata)',
# description => <<'_',
#
#This is a more convenient helper than `gen_modified_sub` if you want to create a
#new subroutine that has some of its arguments preset (so they no longer need to
#be present in the new metadata).
#
#For more general needs of modifying a subroutine (e.g. add some arguments,
#modify some arguments, etc) use `gen_modified_sub`.
#
#_
# args => {
# base_name => {
# summary => 'Subroutine name (either qualified or not)',
# schema => 'str*',
# description => <<'_',
#
#If not qualified with package name, will be searched in the caller's package.
#Rinci metadata will be searched in `%SPEC` package variable.
#
#_
# req => 1,
# pos => 0,
# },
# set_args => {
# summary => 'Arguments to set',
# schema => 'hash*',
# },
# output_name => {
# summary => 'Where to install the modified sub',
# schema => 'str*',
# description => <<'_',
#
#Subroutine will be put in the specified name. If the name is not qualified with
#package name, will use caller's package.
#
#_
# req => 1,
# pos => 2,
# },
# },
# args_as => 'array',
# result_naked => 1,
#};
#sub gen_curried_sub {
# my ($base_name, $set_args, $output_name) = @_;
#
# my $caller = CORE::caller();
#
# my ($base_pkg, $base_leaf);
# if ($base_name =~ /(.+)::(.+)/) {
# ($base_pkg, $base_leaf) = ($1, $2);
# } else {
# $base_pkg = $caller;
# $base_leaf = $base_name;
# }
#
# my ($output_pkg, $output_leaf);
# if ($output_name =~ /(.+)::(.+)/) {
# ($output_pkg, $output_leaf) = ($1, $2);
# } else {
# $output_pkg = $caller;
# $output_leaf = $output_name;
# }
#
# my $base_sub = \&{"$base_pkg\::$base_leaf"};
#
# my $res = gen_modified_sub(
# base_name => "$base_pkg\::$base_leaf",
# output_name => "$output_pkg\::$output_leaf",
# output_code => sub {
# no strict 'refs';
# $base_sub->(@_, %$set_args);
# },
# remove_args => [keys %$set_args],
# install => 1,
# );
#
# die "Can't generate curried sub: $res->[0] - $res->[1]"
# unless $res->[0] == 200;
#
# 1;
#}
#
#1;
#
#__END__
#
### Perinci/Sub/Util/ResObj.pm ###
#package Perinci::Sub::Util::ResObj;
#
#our $DATE = '2016-02-21';
#our $VERSION = '0.45';
#
#use Carp;
#use overload
# q("") => sub {
# my $res = shift; "ERROR $err->[0]: $err->[1]\n" . Carp::longmess();
# };
#
#1;
#
#__END__
#
### Perinci/Sub/Util/Sort.pm ###
#package Perinci::Sub::Util::Sort;
#
#our $DATE = '2016-02-21';
( run in 0.773 second using v1.01-cache-2.11-cpan-5511b514fd6 )