App-reposdb
view release on metacpan or search on metacpan
script/_reposdb-inline view on Meta::CPAN
# if (!$cd->{clone_func}) {
# $cd->{clone_func} = 'Clone::PP::clone';
# }
# {
# last unless $cd->{clone_func} =~ /(.+)::(.+)/;
# $cd->{modules}{$1} //= 0;
# }
#
# my (@code, @stmts_ary, @stmts_hash, @stmts_main);
#
# my $n = 0;
# my $add_stmt = sub {
# my $which = shift;
# if ($which eq 'if' || $which eq 'new_if') {
# my ($cond0, $act0) = @_;
# for ([\@stmts_ary, '$e', 'ary'],
# [\@stmts_hash, '$h->{$k}', 'hash'],
# [\@stmts_main, '$_', 'main']) {
# my $act = $act0 ; $act =~ s/\Q{{var}}\E/$_->[1]/g;
# my $cond = $cond0; $cond =~ s/\Q{{var}}\E/$_->[1]/g;
# if ($opts->{'!debug'}) { unless (@{ $_->[0] }) { push @{ $_->[0] }, ' print "DEBUG:'.$_->[2].' cleaner: val=", Data::Dmp::dmp_ellipsis('.$_->[1].'), ", ref=$ref\n"; '."\n" } }
# push @{ $_->[0] }, " ".($n && $which ne 'new_if' ? "els":"")."if ($cond) { $act }\n";
# }
# $n++;
# } else {
# my ($stmt0) = @_;
# for ([\@stmts_ary, '$e', 'ary'],
# [\@stmts_hash, '$h->{$k}', 'hash'],
# [\@stmts_main, '$_', 'main']) {
# my $stmt = $stmt0; $stmt =~ s/\Q{{var}}\E/$_->[1]/g;
# push @{ $_->[0] }, " $stmt;\n";
# }
# }
# };
# my $add_if = sub {
# $add_stmt->('if', @_);
# };
# my $add_new_if = sub {
# $add_stmt->('new_if', @_);
# };
# my $add_if_ref = sub {
# my ($ref, $act0) = @_;
# $add_if->("\$ref eq '$ref'", $act0);
# };
# my $add_new_if_ref = sub {
# my ($ref, $act0) = @_;
# $add_new_if->("\$ref eq '$ref'", $act0);
# };
#
# # catch circular references
# my $circ = $opts->{-circular};
# if ($circ) {
# my $meth = "command_$circ->[0]";
# die "Can't handle command $circ->[0] for option '-circular'" unless $self->can($meth);
# my @args = @$circ; shift @args;
# my $act = $self->$meth($cd, \@args);
# if ($opts->{'!debug'}) { $add_stmt->('stmt', 'print "DEBUG: main cleaner: ref=$ref, " . {{var}} . "\n"'); }
# $add_new_if->('$ref && $refs{ {{var}} }++', $act);
# }
#
# # catch object of specified classes (e.g. DateTime, etc)
# for my $on (grep {/\A\w*(::\w+)*\z/} sort keys %$opts) {
# my $o = $opts->{$on};
# next unless $o;
# my $meth = "command_$o->[0]";
# die "Can't handle command $o->[0] for option '$on'" unless $self->can($meth);
# my @args = @$o; shift @args;
# my $act = $self->$meth($cd, \@args);
# $add_if_ref->($on, $act);
# }
#
# # catch general object not caught by previous
# for my $p ([-obj => 'Scalar::Util::blessed({{var}})']) {
# my $o = $opts->{$p->[0]};
# next unless $o;
# my $meth = "command_$o->[0]";
# die "Can't handle command $o->[0] for option '$p->[0]'" unless $self->can($meth);
# my @args = @$o; shift @args;
# $add_if->($p->[1], $self->$meth($cd, \@args));
# }
#
# # recurse array and hash
# if ($opts->{'!recurse_obj'}) {
# $add_stmt->('stmt', 'my $reftype=Scalar::Util::reftype({{var}})//""');
# $add_new_if->('$reftype eq "ARRAY"', '$process_array->({{var}})');
# $add_if->('$reftype eq "HASH"' , '$process_hash->({{var}})');
# } else {
# $add_new_if_ref->("ARRAY", '$process_array->({{var}})');
# $add_if_ref->("HASH" , '$process_hash->({{var}})');
# }
#
# # lastly, catch any reference left
# for my $p ([-ref => '$ref']) {
# my $o = $opts->{$p->[0]};
# next unless $o;
# my $meth = "command_$o->[0]";
# die "Can't handle command $o->[0] for option '$p->[0]'" unless $self->can($meth);
# my @args = @$o; shift @args;
# $add_if->($p->[1], $self->$meth($cd, \@args));
# }
#
# push @code, 'sub {'."\n";
#
# for (sort keys %{$cd->{subs}}) {
# push @code, "state \$sub_$_ = sub { ".$cd->{subs}{$_}." };\n";
# }
#
# push @code, 'my $data = shift;'."\n";
# push @code, 'state %refs;'."\n" if $circ;
# push @code, 'state $ctr_circ;'."\n" if $circ;
# push @code, 'state $process_array;'."\n";
# push @code, 'state $process_hash;'."\n";
# push @code, (
# 'if (!$process_array) { $process_array = sub { my $a = shift; for my $e (@$a) { ',
# 'my $ref=ref($e);'."\n",
# join("", @stmts_ary).'} } }'."\n"
# );
# push @code, (
# 'if (!$process_hash) { $process_hash = sub { my $h = shift; for my $k (keys %$h) { ',
# 'my $ref=ref($h->{$k});'."\n",
# join("", @stmts_hash).'} } }'."\n"
script/_reposdb-inline view on Meta::CPAN
# push @code, (
# 'for ($data) { ',
# 'my $ref=ref($_);'."\n",
# join("", @stmts_main).'}'."\n"
# );
# push @code, 'print "DEBUG: main cleaner: result: ", Data::Dmp::dmp_ellipsis($data), "\n";'."\n" if $opts->{'!debug'};
# push @code, '$data'."\n";
# push @code, '}'."\n";
#
# my $code = join("", @code).";";
#
# if ($ENV{LOG_CLEANSER_CODE} && log_is_trace()) {
# require String::LineNumber;
# log_trace("Cleanser code:\n%s",
# $ENV{LINENUM} // 1 ?
# String::LineNumber::linenum($code) : $code);
# }
#
# $cd->{src} = $code;
#
# $cd;
#}
#
#sub clean_in_place {
# my ($self, $data) = @_;
#
# $self->{_code}->($data);
#}
#
#sub clone_and_clean {
# no strict 'refs';
#
# my ($self, $data) = @_;
# my $clone = &{$self->{_cd}{clone_func}}($data);
# $self->clean_in_place($clone);
#}
#
#1;
## ABSTRACT: Clean data structure
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Data::Clean - Clean data structure
#
#=head1 VERSION
#
#This document describes version 0.507 of Data::Clean (from Perl distribution Data-Clean), released on 2020-04-07.
#
#=head1 SYNOPSIS
#
# use Data::Clean;
#
# my $cleanser = Data::Clean->new(
# # specify how to deal with specific classes
# 'DateTime' => [call_method => 'epoch'], # replace object with its epoch
# 'Time::Moment' => [call_method => 'epoch'], # replace object with its epoch
# 'Regexp' => ['stringify'], # replace $obj with "$obj"
#
# # specify how to deal with all scalar refs
# SCALAR => ['deref_scalar'], # replace \1 with 1
#
# # specify how to deal with circular reference
# -circular => ['clone'],
#
# # specify how to deal with all other kinds of objects
# -obj => ['unbless'],
#
# # recurse into object
# #'!recurse_obj'=> 1,
#
# # generate cleaner with debugging messages
# #'!debug' => 1,
# );
#
# # to get cleansed data
# my $cleansed_data = $cleanser->clone_and_clean($data);
#
# # to replace original data with cleansed one
# $cleanser->clean_in_place($data);
#
#=head1 DESCRIPTION
#
#This class can be used to process a data structure by replacing some forms of
#data items with other forms. One of the main uses is to clean "unsafe" data,
#e.g. clean a data structure so it can be encoded to JSON (see
#L<Data::Clean::ForJSON>, which is a thin wrapper over this class).
#
#As can be seen from the example, you specify a list of transformations to be
#done, and then this class will generate an appropriate Perl code to do the
#cleansing. This class is faster than the other ways of processing, e.g.
#L<Data::Rmap> (see L<Bencher::Scenarios::DataCleansing> for some benchmarks).
#
#=for Pod::Coverage ^(command_.+)$
#
#=head1 METHODS
#
#=head2 new(%opts) => $obj
#
#Create a new instance.
#
#Options specify what to do with certain category of data. Option keys are either
#reference types (like C<HASH>, C<ARRAY>, C<SCALAR>) or class names (like
#C<Foo::Bar>), or C<-obj> (to match all kinds of objects, a.k.a. blessed
#references), C<-circular> (to match circular references), C<-ref> (to refer to
#any kind of references, used to process references not handled by other
#options). Option values are arrayrefs, the first element of the array is command
#name, to specify what to do with the reference/class. The rest are command
#arguments.
#
#Note that arrayrefs and hashrefs are always walked into, so it's not trapped by
#C<-ref>.
#
#Default for C<%opts>: C<< -ref => 'stringify' >>.
#
#Option keys that start with C<!> are special:
#
#=over
#
#=item * !recurse_obj (bool)
#
#Can be set to true to to recurse into objects if they are hash- or array-based.
#By default objects are not recursed into. Note that if you enable this option,
#object options (like C<Foo::Bar> or C<-obj>) won't work for hash- and
#array-based objects because they will be recursed instead.
#
#=item * !clone_func (str)
#
#Set fully qualified name of clone function to use. The default is to use
#C<Clone::PP::clone>.
#
#The clone module (all but the last part of the C<!clone_func> value) will
#automatically be loaded using C<require()>.
#
#=item * !debug (bool)
#
#If set to true, will generate code to print debugging messages. For debugging
#only.
#
#=back
#
#Available commands:
#
#=over 4
#
#=item * ['stringify']
#
#This will stringify a reference like C<{}> to something like C<HASH(0x135f998)>.
#
#=item * ['replace_with_ref']
#
#This will replace a reference like C<{}> with C<HASH>.
#
#=item * ['replace_with_str', STR]
#
#This will replace a reference like C<{}> with I<STR>.
#
#=item * ['call_method' => STR]
#
#This will call a method named I<STR> and use its return as the replacement. For
#example: C<< DateTime->from_epoch(epoch=>1000) >> when processed with C<<
#[call_method => 'epoch'] >> will become 1000.
#
#=item * ['call_func', STR]
#
#This will call a function named I<STR> with value as argument and use its return
#as the replacement.
#
#=item * ['one_or_zero']
#
#This will perform C<< $val ? 1:0 >>.
#
#=item * ['deref_scalar_one_or_zero']
#
#This will perform C<< ${$val} ? 1:0 >>.
#
#=item * ['deref_scalar']
#
#This will replace a scalar reference like \1 with 1.
#
#=item * ['unbless']
#
#This will perform unblessing using L<Function::Fallback::CoreOrPP::unbless()>.
#Should be done only for objects (C<-obj>).
#
#=item * ['die']
#
#Die. Only for testing.
#
#=item * ['code', STR]
#
#This will replace with I<STR> treated as Perl code.
#
#=item * ['clone', INT]
#
#This command is useful if you have circular references and want to expand/copy
#them. For example:
#
# my $def_opts = { opt1 => 'default', opt2 => 0 };
# my $users = { alice => $def_opts, bob => $def_opts, charlie => $def_opts };
#
#C<$users> contains three references to the same data structure. With the default
#behaviour of C<< -circular => [replace_with_str => 'CIRCULAR'] >> the cleaned
#data structure will be:
#
# { alice => { opt1 => 'default', opt2 => 0 },
# bob => 'CIRCULAR',
# charlie => 'CIRCULAR' }
#
#But with C<< -circular => ['clone'] >> option, the data structure will be
#cleaned to become (the C<$def_opts> is cloned):
#
# { alice => { opt1 => 'default', opt2 => 0 },
# bob => { opt1 => 'default', opt2 => 0 },
# charlie => { opt1 => 'default', opt2 => 0 }, }
#
#The command argument specifies the number of references to clone as a limit (the
#default is 50), since a cyclical structure can lead to infinite cloning. Above
#this limit, the circular references will be replaced with a string
#C<"CIRCULAR">. For example:
#
script/_reposdb-inline view on Meta::CPAN
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Data-Clean>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Data-Clean>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Clean>
#
#When submitting a bug or request, please include a test-file or a
#patch to an existing test-file that illustrates the bug or desired
#feature.
#
#=head1 SEE ALSO
#
#Related modules: L<Data::Rmap>, L<Hash::Sanitize>, L<Data::Walk>.
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2020, 2019, 2018, 2017, 2016 by perlancar@cpan.org.
#
#This is free software; you can redistribute it and/or modify it under
#the same terms as the Perl 5 programming language system itself.
#
#=cut
### Data/Clean/ForJSON.pm ###
#package Data::Clean::ForJSON;
#
#our $DATE = '2019-11-26'; # DATE
#our $VERSION = '0.395'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#
#use parent qw(Data::Clean);
#use vars qw($creating_singleton);
#
#use Exporter qw(import);
#our @EXPORT_OK = qw(
# clean_json_in_place
# clone_and_clean_json
# );
#
#sub new {
# my ($class, %opts) = @_;
#
# if (!%opts && !$creating_singleton) {
# warn "You are creating a new ".__PACKAGE__." object without customizing options. ".
# "You probably want to call get_cleanser() yet to get a singleton instead?";
# }
#
# $opts{DateTime} //= [call_method => 'epoch'];
# $opts{'Time::Moment'} //= [call_method => 'epoch'];
# $opts{'Math::BigInt'} //= [call_method => 'bstr'];
# $opts{Regexp} //= ['stringify'];
# $opts{version} //= ['stringify'];
#
# $opts{SCALAR} //= ['deref_scalar'];
# $opts{-ref} //= ['replace_with_ref'];
# $opts{-circular} //= ['clone'];
# $opts{-obj} //= ['unbless'];
#
# $opts{'!recurse_obj'} //= 1;
# $class->SUPER::new(%opts);
#}
#
#sub get_cleanser {
# my $class = shift;
# local $creating_singleton = 1;
# state $singleton = $class->new;
# $singleton;
#}
#
#sub clean_json_in_place {
# __PACKAGE__->get_cleanser->clean_in_place(@_);
#}
#
#sub clone_and_clean_json {
# __PACKAGE__->get_cleanser->clone_and_clean(@_);
#}
#
#1;
## ABSTRACT: Clean data so it is safe to output to JSON
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Data::Clean::ForJSON - Clean data so it is safe to output to JSON
#
#=head1 VERSION
#
#This document describes version 0.395 of Data::Clean::ForJSON (from Perl distribution Data-Clean-ForJSON), released on 2019-11-26.
#
#=head1 SYNOPSIS
#
# use Data::Clean::ForJSON;
# my $cleanser = Data::Clean::ForJSON->get_cleanser;
# my $data = { code=>sub {}, re=>qr/abc/i };
#
# my $cleaned;
#
# # modifies data in-place
# $cleaned = $cleanser->clean_in_place($data);
#
# # ditto, but deep clone first, return
# $cleaned = $cleanser->clone_and_clean($data);
#
# # now output it
# use JSON;
# print encode_json($cleaned); # prints '{"code":"CODE","re":"(?^i:abc)"}'
#
#Functional shortcuts:
#
# use Data::Clean::ForJSON qw(clean_json_in_place clone_and_clean_json);
#
# # equivalent to Data::Clean::ForJSON->get_cleanser->clean_in_place($data)
# clean_json_in_place($data);
#
# # equivalent to Data::Clean::ForJSON->get_cleanser->clone_and_clean($data)
# $cleaned = clone_and_clean_json($data);
#
#=head1 DESCRIPTION
#
#This class cleans data from anything that might be problematic when encoding to
#JSON. This includes coderefs, globs, and so on. Here's what it will do by
#default:
#
#=over
#
#=item * Change DateTime and Time::Moment object to its epoch value
#
#=item * Change Regexp and version object to its string value
#
#=item * Change scalar references (e.g. \1) to its scalar value (e.g. 1)
#
#=item * Change other references (non-hash, non-array) to its ref() value (e.g. "GLOB", "CODE")
#
#=item * Clone circular references
#
#With a default limit of 1, meaning that if a reference is first seen again for
#the first time, it will be cloned. But if it is seen again for the second time,
#it will be replaced with "CIRCULAR".
#
#To change the default limit, customize your cleanser object:
#
# $cleanser = Data::Clean::ForJSON->new(
# -circular => ["clone", 4],
# );
#
#or you can perform other action for circular references, see L<Data::Clean> for
#more details.
#
#=item * Unbless other types of objects
#
#=back
#
#Cleaning recurses into objects.
#
#Data that has been cleaned will probably not be convertible back to the
#original, due to information loss (for example, coderefs converted to string
#C<"CODE">).
#
#The design goals are good performance, good defaults, and just enough
#flexibility. The original use-case is for returning JSON response in HTTP API
#service.
#
#This module is significantly faster than modules like L<Data::Rmap> or
#L<Data::Visitor::Callback> because with something like Data::Rmap you repeatedly
#invoke callback for each data item. This module, on the other hand, generates a
#cleanser code using eval(), using native Perl for() loops.
#
#If C<LOG_CLEANSER_CODE> environment is set to true, the generated cleanser code
#will be logged using L<Log::ger> at trace level. You can see it, e.g. using
#L<Log::ger::Output::Screen>:
#
# % LOG_CLEANSER_CODE=1 perl -MLog::ger::Output=Screen -MLog::ger::Level::trace -MData::Clean::ForJSON \
# -e'$c=Data::Clean::ForJSON->new; ...'
#
#=head1 FUNCTIONS
#
#None of the functions are exported by default.
#
#=head2 clean_json_in_place($data)
#
#A shortcut for:
#
# Data::Clean::ForJSON->get_cleanser->clean_in_place($data)
#
#=head2 clone_and_clean_json($data) => $cleaned
#
( run in 0.759 second using v1.01-cache-2.11-cpan-39bf76dae61 )