File-RsyBak
view release on metacpan or search on metacpan
script/rsybak view on Meta::CPAN
# }
# my $res = $self->_push_include_stack($path);
# if ($res->[0] != 200) {
# $self->_err("Can't include '$path': $res->[1]");
# }
# $path = $res->[2];
# $self->_read_string($self->_read_file($path, $cb), $cb);
# $self->_pop_include_stack;
# } elsif ($directive eq 'merge') {
# $self->{_merge} = @$args ? $args : undef;
# } elsif ($directive eq 'noop') {
# } else {
# if ($self->{ignore_unknown_directive}) {
# next LINE;
# } else {
# $self->_err("Unknown directive '$directive'");
# }
# }
# next LINE;
# }
#
# if ($line =~ /^\s*[;#]/) {
#
# if ($cb) {
# $cb->(
# event => 'comment',
# linum=>$self->{_linum}, line=>$line, cur_section=>$self->{_cur_section},
# );
# }
#
# next LINE;
# }
#
# if ($line =~ /^\s*\[\s*(.+?)\s*\](?: \s*[;#].*)?/) {
# my $prev_section = $self->{_cur_section};
# $self->{_cur_section} = $cur_section = $1;
# $res->{$cur_section} //= {};
# $self->{_num_seen_section_lines}++;
#
# if ($self->{_merge} && $self->{_num_seen_section_lines} > 1) {
# $self->_merge($prev_section);
# }
#
# if ($cb) {
# $cb->(
# event => 'section',
# linum=>$self->{_linum}, line=>$line, cur_section=>$self->{_cur_section},
# section => $cur_section,
# );
# }
#
# next LINE;
# }
#
# if ($line =~ /^\s*([^=]+?)\s*=\s*(.*)/) {
# my $key = $1;
# my $val = $2;
#
# if ($val =~ /\A["!\\[\{~]/) {
# $_raw_val = $val if $cb;
# my ($err, $parse_res, $decoded_val) = $self->_parse_raw_value($val);
# $self->_err("Invalid value: " . $err) if $err;
# $val = $decoded_val;
# } else {
# $_raw_val = $val if $cb;
# $val =~ s/\s*[#;].*//;
# }
#
# if (exists $res->{$cur_section}{$key}) {
# if (!$self->{allow_duplicate_key}) {
# $self->_err("Duplicate key: $key (section $cur_section)");
# } elsif ($self->{_arrayified}{$cur_section}{$key}++) {
# push @{ $res->{$cur_section}{$key} }, $val;
# } else {
# $res->{$cur_section}{$key} = [
# $res->{$cur_section}{$key}, $val];
# }
# } else {
# $res->{$cur_section}{$key} = $val;
# }
#
# if ($cb) {
# $cb->(
# event => 'key',
# linum=>$self->{_linum}, line=>$line, cur_section=>$self->{_cur_section},
# key => $key,
# val => $val,
# raw_val => $_raw_val,
# );
# }
#
# next LINE;
# }
#
# $self->_err("Invalid syntax");
# }
#
# if ($self->{_merge} && $self->{_num_seen_section_lines} > 1) {
# $self->_merge($cur_section);
# }
#
# $res;
#}
#
#1;
#
#__END__
#
### Data/Check/Structure.pm ###
#package Data::Check::Structure;
#
#our $DATE = '2017-07-18';
#our $VERSION = '0.04';
#
#use strict;
#
#use Exporter 'import';
#our @EXPORT_OK = qw(
# is_aoa
# is_aoaos
# is_aoh
# is_aohos
# is_aos
script/rsybak view on Meta::CPAN
#infinities or NaN's - these cannot be represented in JSON, and it is an
#error to pass those in.
#
#=back
#
#=head2 OBJECT SERIALISATION
#
#As for Perl objects, this module only supports a pure JSON representation
#(without the ability to deserialise the object automatically again).
#
#=head3 SERIALISATION
#
#What happens when this module encounters a Perl object depends on the
#C<allow_blessed> and C<convert_blessed> settings, which are used in
#this order:
#
#=over 4
#
#=item 1. C<convert_blessed> is enabled and the object has a C<TO_JSON> method.
#
#In this case, the C<TO_JSON> method of the object is invoked in scalar
#context. It must return a single scalar that can be directly encoded into
#JSON. This scalar replaces the object in the JSON text.
#
#For example, the following C<TO_JSON> method will convert all L<URI>
#objects to JSON strings when serialised. The fact that these values
#originally were L<URI> objects is lost.
#
# sub URI::TO_JSON {
# my ($uri) = @_;
# $uri->as_string
# }
#
#=item 2. C<allow_blessed> is enabled.
#
#The object will be serialised as a JSON null value.
#
#=item 3. none of the above
#
#If none of the settings are enabled or the respective methods are missing,
#this module throws an exception.
#
#=back
#
#=head1 ENCODING/CODESET FLAG NOTES
#
#This section is taken from JSON::XS.
#
#The interested reader might have seen a number of flags that signify
#encodings or codesets - C<utf8>, C<latin1> and C<ascii>. There seems to be
#some confusion on what these do, so here is a short comparison:
#
#C<utf8> controls whether the JSON text created by C<encode> (and expected
#by C<decode>) is UTF-8 encoded or not, while C<latin1> and C<ascii> only
#control whether C<encode> escapes character values outside their respective
#codeset range. Neither of these flags conflict with each other, although
#some combinations make less sense than others.
#
#Care has been taken to make all flags symmetrical with respect to
#C<encode> and C<decode>, that is, texts encoded with any combination of
#these flag values will be correctly decoded when the same flags are used
#- in general, if you use different flag settings while encoding vs. when
#decoding you likely have a bug somewhere.
#
#Below comes a verbose discussion of these flags. Note that a "codeset" is
#simply an abstract set of character-codepoint pairs, while an encoding
#takes those codepoint numbers and I<encodes> them, in our case into
#octets. Unicode is (among other things) a codeset, UTF-8 is an encoding,
#and ISO-8859-1 (= latin 1) and ASCII are both codesets I<and> encodings at
#the same time, which can be confusing.
#
#=over 4
#
#=item C<utf8> flag disabled
#
#When C<utf8> is disabled (the default), then C<encode>/C<decode> generate
#and expect Unicode strings, that is, characters with high ordinal Unicode
#values (> 255) will be encoded as such characters, and likewise such
#characters are decoded as-is, no changes to them will be done, except
#"(re-)interpreting" them as Unicode codepoints or Unicode characters,
#respectively (to Perl, these are the same thing in strings unless you do
#funny/weird/dumb stuff).
#
#This is useful when you want to do the encoding yourself (e.g. when you
#want to have UTF-16 encoded JSON texts) or when some other layer does
#the encoding for you (for example, when printing to a terminal using a
#filehandle that transparently encodes to UTF-8 you certainly do NOT want
#to UTF-8 encode your data first and have Perl encode it another time).
#
#=item C<utf8> flag enabled
#
#If the C<utf8>-flag is enabled, C<encode>/C<decode> will encode all
#characters using the corresponding UTF-8 multi-byte sequence, and will
#expect your input strings to be encoded as UTF-8, that is, no "character"
#of the input string must have any value > 255, as UTF-8 does not allow
#that.
#
#The C<utf8> flag therefore switches between two modes: disabled means you
#will get a Unicode string in Perl, enabled means you get an UTF-8 encoded
#octet/binary string in Perl.
#
#=item C<latin1> or C<ascii> flags enabled
#
#With C<latin1> (or C<ascii>) enabled, C<encode> will escape characters
#with ordinal values > 255 (> 127 with C<ascii>) and encode the remaining
#characters as specified by the C<utf8> flag.
#
#If C<utf8> is disabled, then the result is also correctly encoded in those
#character sets (as both are proper subsets of Unicode, meaning that a
#Unicode string with all character values < 256 is the same thing as a
#ISO-8859-1 string, and a Unicode string with all character values < 128 is
#the same thing as an ASCII string in Perl).
#
#If C<utf8> is enabled, you still get a correct UTF-8-encoded string,
#regardless of these flags, just some more characters will be escaped using
#C<\uXXXX> then before.
#
#Note that ISO-8859-1-I<encoded> strings are not compatible with UTF-8
#encoding, while ASCII-encoded strings are. That is because the ISO-8859-1
#encoding is NOT a subset of UTF-8 (despite the ISO-8859-1 I<codeset> being
#a subset of Unicode), while ASCII is.
#
#Surprisingly, C<decode> will ignore these flags and so treat all input
#values as governed by the C<utf8> flag. If it is disabled, this allows you
#to decode ISO-8859-1- and ASCII-encoded strings, as both strict subsets of
#Unicode. If it is enabled, you can correctly decode UTF-8 encoded strings.
#
#So neither C<latin1> nor C<ascii> are incompatible with the C<utf8> flag -
#they only govern when the JSON output engine escapes a character or not.
#
#The main use for C<latin1> is to relatively efficiently store binary data
#as JSON, at the expense of breaking compatibility with most JSON decoders.
#
#The main use for C<ascii> is to force the output to not contain characters
#with values > 127, which means you can interpret the resulting string
#as UTF-8, ISO-8859-1, ASCII, KOI8-R or most about any character set and
#8-bit-encoding, and still get the same data structure back. This is useful
#when your channel for JSON transfer is not 8-bit clean or the encoding
#might be mangled in between (e.g. in mail), and works because ASCII is a
script/rsybak view on Meta::CPAN
# my $rargs = $args{rargs};
# my $go_spec = $args{go_spec};
# my $specmeta = $args{specmeta};
#
# my $args_prop = $meta->{args} // {};
#
# for my $arg (keys %$args_prop) {
# my $fqarg = "$argprefix$arg";
# my $arg_spec = $args_prop->{$arg};
# next if grep { $_ eq 'hidden' || $_ eq 'hidden-cli' }
# @{ $arg_spec->{tags} // [] };
# my $sch = $arg_spec->{schema} // ['any', {}];
# my ($is_simple, $is_array_of_simple, $is_hash_of_simple, $type, $cset, $eltype) =
# _is_simple_or_array_of_simple_or_hash_of_simple($sch);
#
# if ($type eq 'array' && $cset->{of}) {
# $cset->{of} = normalize_schema($cset->{of});
# }
# my $opt = _arg2opt($fqarg);
# if ($seen_opts->{$opt}) {
# my $i = 1;
# my $opt2;
# while (1) {
# $opt2 = "$opt-arg" . ($i > 1 ? $i : '');
# last unless $seen_opts->{$opt2};
# $i++;
# }
# $opt = $opt2;
# }
#
# my $stash = {};
#
#
# my $handler = sub {
# my ($val, $val_set);
#
# my $num_called = ++$stash->{called}{$arg};
#
# my $rargs = do {
# if (ref($rargs) eq 'ARRAY') {
# $rargs->[$num_called-1] //= {};
# $rargs->[$num_called-1];
# } else {
# $rargs;
# }
# };
#
# if ($is_simple) {
# $val_set = 1; $val = $_[1];
# $rargs->{$arg} = $val;
# } elsif ($is_array_of_simple) {
# $rargs->{$arg} //= [];
# $val_set = 1; $val = $_[1];
# push @{ $rargs->{$arg} }, $val;
# } elsif ($is_hash_of_simple) {
# $rargs->{$arg} //= {};
# $val_set = 1; $val = $_[2];
# $rargs->{$arg}{$_[1]} = $val;
# } else {
# {
# my ($success, $e, $decoded);
# ($success, $e, $decoded) = _parse_json($_[1]);
# if ($success) {
# $val_set = 1; $val = $decoded;
# $rargs->{$arg} = $val;
# last;
# }
# ($success, $e, $decoded) = _parse_yaml($_[1]);
# if ($success) {
# $val_set = 1; $val = $decoded;
# $rargs->{$arg} = $val;
# last;
# }
# die "Invalid YAML/JSON in arg '$fqarg'";
# }
# }
# if ($val_set && $arg_spec->{cmdline_on_getopt}) {
# $arg_spec->{cmdline_on_getopt}->(
# arg=>$arg, fqarg=>$fqarg, value=>$val, args=>$rargs,
# opt=>$opt,
# );
# }
# };
#
# my @triplets = _opt2ospec($opt, $sch, $arg_spec);
# my $aliases_processed;
# while (my ($ospec, $parsed, $extra) = splice @triplets, 0, 3) {
# $extra //= {};
# if ($extra->{is_neg}) {
# $go_spec->{$ospec} = sub { $handler->($_[0], 0) };
# } elsif (defined $extra->{is_neg}) {
# $go_spec->{$ospec} = sub { $handler->($_[0], 1) };
# } elsif ($extra->{is_base64}) {
# $go_spec->{$ospec} = sub {
# require MIME::Base64;
# my $decoded = MIME::Base64::decode($_[1]);
# $handler->($_[0], $decoded);
# };
# } else {
# $go_spec->{$ospec} = $handler;
# }
#
# $specmeta->{$ospec} = {arg=>$arg, fqarg=>$fqarg, parsed=>$parsed, %$extra};
# for (@{ $parsed->{opts} }) {
# $seen_opts->{$_}++; $seen_func_opts->{$_} = $fqarg;
# }
#
# if ($parent_args->{per_arg_json} && !$is_simple) {
# my $jopt = "$opt-json";
# if ($seen_opts->{$jopt}) {
# warn "Clash of option: $jopt, not added";
# } else {
# my $jospec = "$jopt=s";
# my $parsed = {type=>"s", opts=>[$jopt]};
# $go_spec->{$jospec} = sub {
# my ($success, $e, $decoded);
# ($success, $e, $decoded) = _parse_json($_[1]);
# if ($success) {
# $rargs->{$arg} = $decoded;
# } else {
# die "Invalid JSON in option --$jopt: $_[1]: $e";
# }
# };
# $specmeta->{$jospec} = {arg=>$arg, fqarg=>$fqarg, is_json=>1, parsed=>$parsed, %$extra};
# $seen_opts->{$jopt}++; $seen_func_opts->{$jopt} = $fqarg;
# }
# }
# if ($parent_args->{per_arg_yaml} && !$is_simple) {
# my $yopt = "$opt-yaml";
# if ($seen_opts->{$yopt}) {
# warn "Clash of option: $yopt, not added";
# } else {
# my $yospec = "$yopt=s";
# my $parsed = {type=>"s", opts=>[$yopt]};
# $go_spec->{$yospec} = sub {
# my ($success, $e, $decoded);
# ($success, $e, $decoded) = _parse_yaml($_[1]);
# if ($success) {
# $rargs->{$arg} = $decoded;
# } else {
# die "Invalid YAML in option --$yopt: $_[1]: $e";
# }
# };
# $specmeta->{$yospec} = {arg=>$arg, fqarg=>$fqarg, is_yaml=>1, parsed=>$parsed, %$extra};
# $seen_opts->{$yopt}++; $seen_func_opts->{$yopt} = $fqarg;
# }
# }
#
# if ($arg_spec->{cmdline_aliases} && !$aliases_processed++) {
# for my $al (keys %{$arg_spec->{cmdline_aliases}}) {
# my $alspec = $arg_spec->{cmdline_aliases}{$al};
# my $alsch = $alspec->{schema} //
# $alspec->{is_flag} ? [bool=>{req=>1,is=>1}] : $sch;
# my $altype = $alsch->[0];
# my $alopt = _arg2opt("$argprefix$al");
# if ($seen_opts->{$alopt}) {
# warn "Clash of cmdline_alias option $al";
# next;
# }
# my $alcode = $alspec->{code};
# my $alospec;
# my $parsed;
# if ($alcode && $alsch->[0] eq 'bool') {
# $alospec = $alopt;
# $parsed = {opts=>[$alopt]};
# } else {
# ($alospec, $parsed) = _opt2ospec($alopt, $alsch);
# }
#
# if ($alcode) {
# if ($alcode eq 'CODE') {
# if ($parent_args->{ignore_converted_code}) {
# $alcode = sub {};
# } else {
# return [
# 501,
# join("",
# "Code in cmdline_aliases for arg $fqarg ",
# "got converted into string, probably ",
# "because of JSON/YAML transport"),
# ];
# }
# }
# $go_spec->{$alospec} = sub {
#
# my $num_called = ++$stash->{called}{$arg};
# my $rargs = do {
# if (ref($rargs) eq 'ARRAY') {
# $rargs->[$num_called-1] //= {};
# $rargs->[$num_called-1];
# } else {
# $rargs;
# }
# };
#
# $alcode->($rargs, $_[1]);
# };
# } else {
# $go_spec->{$alospec} = $handler;
script/rsybak view on Meta::CPAN
# my $on_missing = $fargs{on_missing_required_args};
# my $ignore_converted_code = $fargs{ignore_converted_code};
#
# my $rargs = $fargs{args} // {};
#
# my $genres = $fargs{ggls_res} // gen_getopt_long_spec_from_meta(
# meta => $meta, meta_is_normalized => 1,
# args => $rargs,
# common_opts => $common_opts,
# per_arg_json => $per_arg_json,
# per_arg_yaml => $per_arg_yaml,
# ignore_converted_code => $ignore_converted_code,
# );
# return err($genres->[0], "Can't generate Getopt::Long spec", $genres)
# if $genres->[0] != 200;
# my $go_spec = $genres->[2];
#
# {
# local $SIG{__WARN__} = sub{} if !$strict;
# my $old_go_conf = Getopt::Long::Configure(
# $strict ? "no_pass_through" : "pass_through",
# "no_ignore_case", "permute", "no_getopt_compat", "gnu_compat", "bundling");
# my $res = Getopt::Long::GetOptionsFromArray($argv, %$go_spec);
# Getopt::Long::Configure($old_go_conf);
# unless ($res) {
# return [500, "GetOptions failed"] if $strict;
# }
# }
#
#
# my $args_prop = $meta->{args};
#
# if (@$argv) {
# my $res = get_args_from_array(
# array=>$argv, meta => $meta,
# meta_is_normalized => 1,
# allow_extra_elems => $allow_extra_elems,
# );
# if ($res->[0] != 200 && $strict) {
# return err(500, "Get args from array failed", $res);
# } elsif ($strict && $res->[0] != 200) {
# return err("Can't get args from argv", $res);
# } elsif ($res->[0] == 200) {
# my $pos_args = $res->[2];
# for my $name (keys %$pos_args) {
# my $arg_spec = $args_prop->{$name};
# my $val = $pos_args->{$name};
# if (exists $rargs->{$name}) {
# return [400, "You specified option --$name but also ".
# "argument #".$arg_spec->{pos}] if $strict;
# }
# my ($is_simple, $is_array_of_simple, $is_hash_of_simple, $type, $cset, $eltype) =
# _is_simple_or_array_of_simple_or_hash_of_simple($arg_spec->{schema});
#
# if ($arg_spec->{greedy} && ref($val) eq 'ARRAY' &&
# !$is_array_of_simple && !$is_hash_of_simple) {
# my $i = 0;
# for (@$val) {
# TRY_PARSING_AS_JSON_YAML:
# {
# my ($success, $e, $decoded);
# if ($per_arg_json) {
# ($success, $e, $decoded) = _parse_json($_);
# if ($success) {
# $_ = $decoded;
# last TRY_PARSING_AS_JSON_YAML;
# } else {
# warn "Failed trying to parse argv #$i as JSON: $e";
# }
# }
# if ($per_arg_yaml) {
# ($success, $e, $decoded) = _parse_yaml($_);
# if ($success) {
# $_ = $decoded;
# last TRY_PARSING_AS_JSON_YAML;
# } else {
# warn "Failed trying to parse argv #$i as YAML: $e";
# }
# }
# }
# $i++;
# }
# }
# if (!$arg_spec->{greedy} && !$is_simple) {
# TRY_PARSING_AS_JSON_YAML:
# {
# my ($success, $e, $decoded);
# if ($per_arg_json) {
# ($success, $e, $decoded) = _parse_json($val);
# if ($success) {
# $val = $decoded;
# last TRY_PARSING_AS_JSON_YAML;
# } else {
# warn "Failed trying to parse argv #$arg_spec->{pos} as JSON: $e";
# }
# }
# if ($per_arg_yaml) {
# ($success, $e, $decoded) = _parse_yaml($val);
# if ($success) {
# $val = $decoded;
# last TRY_PARSING_AS_JSON_YAML;
# } else {
# warn "Failed trying to parse argv #$arg_spec->{pos} as YAML: $e";
# }
# }
# }
# }
# $rargs->{$name} = $val;
# if ($arg_spec->{cmdline_on_getopt}) {
# if ($arg_spec->{greedy}) {
# $arg_spec->{cmdline_on_getopt}->(
# arg=>$name, fqarg=>$name, value=>$_, args=>$rargs,
# opt=>undef,
# ) for @$val;
# } else {
# $arg_spec->{cmdline_on_getopt}->(
# arg=>$name, fqarg=>$name, value=>$val, args=>$rargs,
# opt=>undef,
# );
# }
# }
# }
# }
# }
#
#
# my %missing_args;
# for my $arg (keys %$args_prop) {
# my $arg_spec = $args_prop->{$arg};
# if (!exists($rargs->{$arg})) {
# next unless $arg_spec->{req};
# if ($on_missing) {
# next if $on_missing->(arg=>$arg, args=>$rargs, spec=>$arg_spec);
# }
# next if exists $rargs->{$arg};
# $missing_args{$arg} = 1;
# }
# }
#
# {
# last unless $strict;
#
# for my $arg (keys %$args_prop) {
# my $arg_spec = $args_prop->{$arg};
# next unless exists $rargs->{$arg};
# next unless $arg_spec->{deps};
# my $dep_arg = $arg_spec->{deps}{arg};
# next unless $dep_arg;
# return [400, "You specify '$arg', but don't specify '$dep_arg' ".
# "(upon which '$arg' depends)"]
# unless exists $rargs->{$dep_arg};
# }
# }
#
# [200, "OK", $rargs, {
# "func.missing_args" => [sort keys %missing_args],
# "func.gen_getopt_long_spec_result" => $genres,
# }];
#}
#
( run in 3.135 seconds using v1.01-cache-2.11-cpan-600a1bdf6e4 )