App-Genpass-ID
view release on metacpan or search on metacpan
script/_genpass-id view on Meta::CPAN
#my $sub1 = sub {1};
#my $default_null_routines;
#
#sub install_routines {
# my ($target, $target_arg, $routines) = @_;
#
# if ($target eq 'package') {
# for my $r (@$routines) {
# my ($code, $name, $lnum, $type) = @$r;
# next unless $type =~ /_sub\z/;
# *{"$target_arg\::$name"} = $code;
# }
# } elsif ($target eq 'object') {
# my $pkg = ref $target_arg;
# for my $r (@$routines) {
# my ($code, $name, $lnum, $type) = @$r;
# next unless $type =~ /_method\z/;
# *{"$pkg\::$name"} = $code;
# }
# } elsif ($target eq 'hash') {
# for my $r (@$routines) {
# my ($code, $name, $lnum, $type) = @$r;
# next unless $type =~ /_sub\z/;
# $target_arg->{$name} = $code;
# }
# }
#}
#
#sub add_target {
# my ($target, $target_arg, $args, $replace) = @_;
# $replace = 1 unless defined $replace;
#
# if ($target eq 'package') {
# unless ($replace) { return if $Package_Targets{$target_arg} }
# $Package_Targets{$target_arg} = $args;
# } elsif ($target eq 'object') {
# my ($addr) = "$target_arg" =~ $re_addr;
# unless ($replace) { return if $Object_Targets{$addr} }
# $Object_Targets{$addr} = [$target_arg, $args];
# } elsif ($target eq 'hash') {
# my ($addr) = "$target_arg" =~ $re_addr;
# unless ($replace) { return if $Hash_Targets{$addr} }
# $Hash_Targets{$addr} = [$target_arg, $args];
# }
#}
#
#sub _set_default_null_routines {
# $default_null_routines ||= [
# (map {(
# [$sub0, "log_$_", $Levels{$_}, 'log_sub'],
# [$Levels{$_} > $Current_Level ? $sub0 : $sub1, "log_is_$_", $Levels{$_}, 'is_sub'],
# [$sub0, $_, $Levels{$_}, 'log_method'],
# [$Levels{$_} > $Current_Level ? $sub0 : $sub1, "is_$_", $Levels{$_}, 'is_method'],
# )} keys %Levels),
# ];
#}
#
#sub get_logger {
# my ($package, %args) = @_;
#
# my $caller = caller(0);
# $args{category} = $caller if !defined($args{category});
# my $obj = []; $obj =~ $re_addr;
# my $pkg = "Log::ger::Obj$1"; bless $obj, $pkg;
# add_target(object => $obj, \%args);
# if (keys %Global_Hooks) {
# require Log::ger::Heavy;
# init_target(object => $obj, \%args);
# } else {
# _set_default_null_routines();
# install_routines(object => $obj, $default_null_routines);
# }
# $obj;
#}
#
#sub import {
# my ($package, %args) = @_;
#
# my $caller = caller(0);
# $args{category} = $caller if !defined($args{category});
# add_target(package => $caller, \%args);
# if (keys %Global_Hooks) {
# require Log::ger::Heavy;
# init_target(package => $caller, \%args);
# } else {
# _set_default_null_routines();
# install_routines(package => $caller, $default_null_routines);
# }
#}
#
#1;
#
#__END__
#
### Log/ger/Format.pm ###
#package Log::ger::Format;
#
#our $DATE = '2017-08-03';
#our $VERSION = '0.023';
#
#use parent qw(Log::ger::Plugin);
#
#sub _import_sets_for_current_package { 1 }
#
#1;
#
#__END__
#
### Log/ger/Format/None.pm ###
#package Log::ger::Format::None;
#
#our $DATE = '2017-08-03';
#our $VERSION = '0.023';
#
#sub get_hooks {
# return {
# create_formatter => [
# __PACKAGE__, 50,
# sub {
# [sub {shift}];
# }],
# };
#}
#
#1;
#
#__END__
#
### Log/ger/Heavy.pm ###
#package Log::ger::Heavy;
#
#our $DATE = '2017-08-03';
#our $VERSION = '0.023';
#
#
#package
# Log::ger;
#
#
script/_genpass-id view on Meta::CPAN
# return {
# create_log_routine => [
# __PACKAGE__, 50,
# sub {
# my %args = @_;
# my $level = $args{level};
# my $logger = sub {
# my $msg = $_[1];
# if ($formatter) {
# $msg = $formatter->($msg);
# }
# ${ $conf{string} } .= $msg;
# ${ $conf{string} } .= "\n"
# unless !$append_newline || $msg =~ /\R\z/;
# };
# [$logger];
# }],
# };
#}
#
#1;
#
#__END__
#
### Log/ger/Plugin.pm ###
#package Log::ger::Plugin;
#
#our $DATE = '2017-08-03';
#our $VERSION = '0.023';
#
#use strict;
#use warnings;
#
#use Log::ger::Util;
#
#sub set {
# my $pkg = shift;
#
# my %args;
# if (ref $_[0] eq 'HASH') {
# %args = %{shift()};
# } else {
# %args = (name => shift, conf => {@_});
# }
#
# $args{prefix} ||= $pkg . '::';
# $args{replace_package_regex} = $pkg->_replace_package_regex;
# Log::ger::Util::set_plugin(%args);
#}
#
#sub set_for_current_package {
# my $pkg = shift;
#
# my %args;
# if (ref $_[0] eq 'HASH') {
# %args = %{shift()};
# } else {
# %args = (name => shift, conf => {@_});
# }
#
# my $caller = caller(0);
# $args{target} = 'package';
# $args{target_arg} = $caller;
#
# set($pkg, \%args);
#}
#
#sub _import_sets_for_current_package { 0 }
#
#sub _replace_package_regex { undef }
#
#sub import {
# if (@_ > 1) {
# if ($_[0]->_import_sets_for_current_package) {
# goto &set_for_current_package;
# } else {
# goto &set;
# }
# }
#}
#
#1;
#
#__END__
#
### Log/ger/Plugin/MultilevelLog.pm ###
#package Log::ger::Plugin::MultilevelLog;
#
#our $DATE = '2017-08-03';
#our $VERSION = '0.023';
#
#use strict;
#use warnings;
#
#use Log::ger::Util;
#
#sub get_hooks {
# my %conf = @_;
#
# return {
# create_routine_names => [
# __PACKAGE__, 50,
# sub {
# return [{
# logml_subs => [[$conf{sub_name} || 'log', undef]],
# logml_methods => [[$conf{method_name} || 'log', undef]],
# }];
# },
# ],
# };
#}
#
#1;
#
#__END__
#
### Log/ger/Util.pm ###
#package Log::ger::Util;
#
#our $DATE = '2017-08-03';
#our $VERSION = '0.023';
script/_genpass-id view on Meta::CPAN
# }
#
# $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 = '2017-01-31';
#our $VERSION = '0.46';
#
#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 => <<'_',
script/_genpass-id view on Meta::CPAN
# 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/Args.pm ###
#package Perinci::Sub::Util::Args;
#
#our $DATE = '2017-01-31';
#our $VERSION = '0.46';
#
#use 5.010001;
#use strict 'subs', 'vars';
#use warnings;
#
#use Exporter qw(import);
#our @EXPORT_OK = qw(
# args_by_tag
# argnames_by_tag
# func_args_by_tag
# func_argnames_by_tag
# call_with_its_args
#);
#
#sub args_by_tag {
# my ($meta, $args, $tag) = @_;
#
# my @res;
# my $args_prop = $meta->{args} or return ();
# my $neg = $tag =~ s/\A!//;
# for my $argname (keys %$args_prop) {
# my $argspec = $args_prop->{$argname};
# if ($neg) {
# next unless !$argspec->{tags} ||
# !(grep {$_ eq $tag} @{$argspec->{tags}});
# } else {
# next unless $argspec->{tags} &&
# grep {$_ eq $tag} @{$argspec->{tags}};
# }
# push @res, $argname, $args->{$argname}
# if exists $args->{$argname};
# }
# @res;
#}
#
#sub argnames_by_tag {
# my ($meta, $tag) = @_;
#
# my @res;
# my $args_prop = $meta->{args} or return ();
# my $neg = 1 if $tag =~ s/\A!//;
# for my $argname (keys %$args_prop) {
# my $argspec = $args_prop->{$argname};
# if ($neg) {
# next unless !$argspec->{tags} ||
# !(grep {$_ eq $tag} @{$argspec->{tags}});
# } else {
# next unless $argspec->{tags} &&
# grep {$_ eq $tag} @{$argspec->{tags}};
# }
# push @res, $argname;
# }
# sort @res;
#}
#
#sub _find_meta {
# my $caller = shift;
# my $func_name = shift;
#
# if ($func_name =~ /(.+)::(.+)/) {
# return ${"$1::SPEC"}{$2};
# } else {
# return ${"$caller->[0]::SPEC"}{$func_name};
# }
#}
#
#sub func_args_by_tag {
# my ($func_name, $args, $tag) = @_;
# my $meta = _find_meta([caller(1)], $func_name)
# or die "Can't find Rinci function metadata for $func_name";
# args_by_tag($meta, $args, $tag);
#}
#
#sub func_argnames_by_tag {
# my ($func_name, $tag) = @_;
# my $meta = _find_meta([caller(1)], $func_name)
# or die "Can't find Rinci function metadata for $func_name";
# argnames_by_tag($meta, $tag);
#}
#
#sub call_with_its_args {
# my ($func_name, $args) = @_;
#
# my ($meta, $func);
# if ($func_name =~ /(.+)::(.+)/) {
# defined &{$func_name}
# or die "Function $func_name not defined";
# $func = \&{$func_name};
# $meta = ${"$1::SPEC"}{$2};
# } else {
# my @caller = caller(1);
# my $fullname = "$caller[0]::$func_name";
# defined &{$fullname}
# or die "Function $fullname not defined";
# $func = \&{$fullname};
# $meta = ${"$caller[0]::SPEC"}{$func_name};
# }
# $meta or die "Can't find Rinci function metadata for $func_name";
#
# my @args;
# if ($meta->{args}) {
# for my $argname (keys %{ $meta->{args} }) {
# push @args, $argname, $args->{$argname}
# if exists $args->{$argname};
# }
# }
# $func->(@args);
#}
#
#1;
#
#__END__
#
### Perinci/Sub/Util/ResObj.pm ###
#package Perinci::Sub::Util::ResObj;
#
#our $DATE = '2017-01-31';
#our $VERSION = '0.46';
#
#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 = '2017-01-31';
#our $VERSION = '0.46';
#
#use 5.010;
#use strict;
#use warnings;
#
#require Exporter;
#our @ISA = qw(Exporter);
#our @EXPORT_OK = qw(
# sort_args
# );
#
#our %SPEC;
#
#sub sort_args {
# my $args = shift;
# sort {
# (($args->{$a}{pos} // 9999) <=> ($args->{$b}{pos} // 9999)) ||
( run in 2.335 seconds using v1.01-cache-2.11-cpan-75ffa21a3d4 )