KevinSchoenmayer/GseTDDUebungKCLR
2
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial Commit

Browse Source
This commit is contained in:
Riley Schneider
2025-12-03 16:38:10 +01:00
parent c5e26bf594
commit b732d8d4b5
17680 changed files with 5977495 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

90
database/perl/lib/Data/Binary.pm Normal file
View File

@@ -0,0 +1,90 @@
package Data::Binary;
use strict;
use warnings;
our $VERSION = 0.01;
use base qw(Exporter);
use Encode qw(decode_utf8);
our @EXPORT_OK = qw(is_text is_binary);
sub is_text {
my ($string) = @_;
if (length($string) > 512) {
$string = substr($string, 0, 512);
}
return '' if (index($string, "\c@") != -1);
my $length = length($string);
my $odd = ($string =~ tr/\x01\x02\x03\x04\x05\x06\x07\x09\x0b\x0c\x0e\x0f\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f//d);
# Detecting >=128 and non-UTF-8 is interesting. Note that all UTF-8 >=128 has several bytes with
# >=128 set, so a quick test is possible by simply checking if any are >=128. However, the count
# from that is typically wrong, if this is binary data, it'll not have been decoded. So we do this
# in two steps.
my $copy = $string;
if (($copy =~ tr[\x80-\xff][]d) > 0) {
my $modified = decode_utf8($string, Encode::FB_DEFAULT);
my $substitions = ($modified =~ tr/\x{fffd}//d);
$odd += $substitions;
}
return '' if ($odd * 3 > $length);
return 1;
}
sub is_binary {
my ($string) = @_;
return ! is_text($string);
}
1;
=head1 NAME
Data::Binary - Simple detection of binary versus text in strings
=head1 SYNOPSIS
use Data::Binary qw(is_text is_binary);
my $text = File::Slurp::read_file("test1.doc");
my $is_text = is_text($text); # equivalent to -T "test1.doc"
my $is_binary = is_binary($text); # equivalent to -B "test1.doc"
=head1 DESCRIPTION
This simple module provides string equivalents to the -T / -B operators. Since
these only work on file names and file handles, this module provides the same
functions but on strings.
Note that the actual implementation is currently different, basically because
the -T / -B functions are in C/XS, and this module is written in pure Perl.
For now, anyway.
=head1 FUNCTIONS
=head2 is_text($string)
Uses the same kind of heuristics in -T, but applies them to a string. Returns true
if the string is basically text.
=head2 is_binary($string)
Uses the same kind of heuristics in -B, but applies them to a string. Returns true
if the string is basically binary.
=head1 AUTHOR
Stuart Watt, stuart@morungos.com
=head1 COPYRIGHT
Copyright (c) 2014 Stuart Watt. All rights reserved.
=cut

720
database/perl/lib/Data/Dump.pm Normal file
View File

@@ -0,0 +1,720 @@
package Data::Dump;
use strict;
use vars qw(@EXPORT @EXPORT_OK $VERSION $DEBUG);
use subs qq(dump);
require Exporter;
*import = \&Exporter::import;
@EXPORT = qw(dd ddx);
@EXPORT_OK = qw(dump pp dumpf quote);
$VERSION = "1.23";
$DEBUG = 0;
use overload ();
use vars qw(%seen %refcnt @dump @fixup %require $TRY_BASE64 @FILTERS $INDENT);
$TRY_BASE64 = 50 unless defined $TRY_BASE64;
$INDENT = " " unless defined $INDENT;
sub dump
{
local %seen;
local %refcnt;
local %require;
local @fixup;
require Data::Dump::FilterContext if @FILTERS;
my $name = "a";
my @dump;
for my $v (@_) {
my $val = _dump($v, $name, [], tied($v));
push(@dump, [$name, $val]);
} continue {
$name++;
}
my $out = "";
if (%require) {
for (sort keys %require) {
$out .= "require $_;\n";
}
}
if (%refcnt) {
# output all those with refcounts first
for (@dump) {
my $name = $_->[0];
if ($refcnt{$name}) {
$out .= "my \$$name = $_->[1];\n";
undef $_->[1];
}
}
for (@fixup) {
$out .= "$_;\n";
}
}
my $paren = (@dump != 1);
$out .= "(" if $paren;
$out .= format_list($paren, undef,
map {defined($_->[1]) ? $_->[1] : "\$".$_->[0]}
@dump
);
$out .= ")" if $paren;
if (%refcnt || %require) {
$out .= ";\n";
$out =~ s/^/$INDENT/gm;
$out = "do {\n$out}";
}
print STDERR "$out\n" unless defined wantarray;
$out;
}
*pp = \&dump;
sub dd {
print dump(@_), "\n";
}
sub ddx {
my(undef, $file, $line) = caller;
$file =~ s,.*[\\/],,;
my $out = "$file:$line: " . dump(@_) . "\n";
$out =~ s/^/# /gm;
print $out;
}
sub dumpf {
require Data::Dump::Filtered;
goto &Data::Dump::Filtered::dump_filtered;
}
sub _dump
{
my $ref = ref $_[0];
my $rval = $ref ? $_[0] : \$_[0];
shift;
my($name, $idx, $dont_remember, $pclass, $pidx) = @_;
my($class, $type, $id);
my $strval = overload::StrVal($rval);
# Parse $strval without using regexps, in order not to clobber $1, $2,...
if ((my $i = rindex($strval, "=")) >= 0) {
$class = substr($strval, 0, $i);
$strval = substr($strval, $i+1);
}
if ((my $i = index($strval, "(0x")) >= 0) {
$type = substr($strval, 0, $i);
$id = substr($strval, $i + 2, -1);
}
else {
die "Can't parse " . overload::StrVal($rval);
}
if ($] < 5.008 && $type eq "SCALAR") {
$type = "REF" if $ref eq "REF";
}
warn "\$$name(@$idx) $class $type $id ($ref)" if $DEBUG;
my $out;
my $comment;
my $hide_keys;
if (@FILTERS) {
my $pself = "";
$pself = fullname("self", [@$idx[$pidx..(@$idx - 1)]]) if $pclass;
my $ctx = Data::Dump::FilterContext->new($rval, $class, $type, $ref, $pclass, $pidx, $idx);
my @bless;
for my $filter (@FILTERS) {
if (my $f = $filter->($ctx, $rval)) {
if (my $v = $f->{object}) {
local @FILTERS;
$out = _dump($v, $name, $idx, 1);
$dont_remember++;
}
if (defined(my $c = $f->{bless})) {
push(@bless, $c);
}
if (my $c = $f->{comment}) {
$comment = $c;
}
if (defined(my $c = $f->{dump})) {
$out = $c;
$dont_remember++;
}
if (my $h = $f->{hide_keys}) {
if (ref($h) eq "ARRAY") {
$hide_keys = sub {
for my $k (@$h) {
return 1 if $k eq $_[0];
}
return 0;
};
}
}
}
}
push(@bless, "") if defined($out) && !@bless;
if (@bless) {
$class = shift(@bless);
warn "More than one filter callback tried to bless object" if @bless;
}
}
unless ($dont_remember) {
if (my $s = $seen{$id}) {
my($sname, $sidx) = @$s;
$refcnt{$sname}++;
my $sref = fullname($sname, $sidx,
($ref && $type eq "SCALAR"));
warn "SEEN: [\$$name(@$idx)] => [\$$sname(@$sidx)] ($ref,$sref)" if $DEBUG;
return $sref unless $sname eq $name;
$refcnt{$name}++;
push(@fixup, fullname($name,$idx)." = $sref");
return "do{my \$fix}" if @$idx && $idx->[-1] eq '$';
return "'fix'";
}
$seen{$id} = [$name, $idx];
}
if ($class) {
$pclass = $class;
$pidx = @$idx;
}
if (defined $out) {
# keep it
}
elsif ($type eq "SCALAR" || $type eq "REF" || $type eq "REGEXP") {
if ($ref) {
if ($class && $class eq "Regexp") {
my $v = "$rval";
my $mod = "";
if ($v =~ /^\(\?\^?([msix-]*):([\x00-\xFF]*)\)\z/) {
$mod = $1;
$v = $2;
$mod =~ s/-.*//;
}
my $sep = '/';
my $sep_count = ($v =~ tr/\///);
if ($sep_count) {
# see if we can find a better one
for ('|', ',', ':', '#') {
my $c = eval "\$v =~ tr/\Q$_\E//";
#print "SEP $_ $c $sep_count\n";
if ($c < $sep_count) {
$sep = $_;
$sep_count = $c;
last if $sep_count == 0;
}
}
}
$v =~ s/\Q$sep\E/\\$sep/g;
$out = "qr$sep$v$sep$mod";
undef($class);
}
else {
delete $seen{$id} if $type eq "SCALAR"; # will be seen again shortly
my $val = _dump($$rval, $name, [@$idx, "\$"], 0, $pclass, $pidx);
$out = $class ? "do{\\(my \$o = $val)}" : "\\$val";
}
} else {
if (!defined $$rval) {
$out = "undef";
}
elsif (do {no warnings 'numeric'; $$rval + 0 eq $$rval}) {
$out = $$rval;
}
else {
$out = str($$rval);
}
if ($class && !@$idx) {
# Top is an object, not a reference to one as perl needs
$refcnt{$name}++;
my $obj = fullname($name, $idx);
my $cl = quote($class);
push(@fixup, "bless \\$obj, $cl");
}
}
}
elsif ($type eq "GLOB") {
if ($ref) {
delete $seen{$id};
my $val = _dump($$rval, $name, [@$idx, "*"], 0, $pclass, $pidx);
$out = "\\$val";
if ($out =~ /^\\\*Symbol::/) {
$require{Symbol}++;
$out = "Symbol::gensym()";
}
} else {
my $val = "$$rval";
$out = "$$rval";
for my $k (qw(SCALAR ARRAY HASH)) {
my $gval = *$$rval{$k};
next unless defined $gval;
next if $k eq "SCALAR" && ! defined $$gval; # always there
my $f = scalar @fixup;
push(@fixup, "RESERVED"); # overwritten after _dump() below
$gval = _dump($gval, $name, [@$idx, "*{$k}"], 0, $pclass, $pidx);
$refcnt{$name}++;
my $gname = fullname($name, $idx);
$fixup[$f] = "$gname = $gval"; #XXX indent $gval
}
}
}
elsif ($type eq "ARRAY") {
my @vals;
my $tied = tied_str(tied(@$rval));
my $i = 0;
for my $v (@$rval) {
push(@vals, _dump($v, $name, [@$idx, "[$i]"], $tied, $pclass, $pidx));
$i++;
}
$out = "[" . format_list(1, $tied, @vals) . "]";
}
elsif ($type eq "HASH") {
my(@keys, @vals);
my $tied = tied_str(tied(%$rval));
# statistics to determine variation in key lengths
my $kstat_max = 0;
my $kstat_sum = 0;
my $kstat_sum2 = 0;
my @orig_keys = keys %$rval;
if ($hide_keys) {
@orig_keys = grep !$hide_keys->($_), @orig_keys;
}
my $text_keys = 0;
for (@orig_keys) {
$text_keys++, last unless /^[-+]?(?:0|[1-9]\d*)(?:\.\d+)?\z/;
}
if ($text_keys) {
@orig_keys = sort { lc($a) cmp lc($b) } @orig_keys;
}
else {
@orig_keys = sort { $a <=> $b } @orig_keys;
}
my $quote;
for my $key (@orig_keys) {
next if $key =~ /^-?[a-zA-Z_]\w*\z/;
next if $key =~ /^-?[1-9]\d{0,8}\z/;
$quote++;
last;
}
for my $key (@orig_keys) {
my $val = \$rval->{$key}; # capture value before we modify $key
$key = quote($key) if $quote;
$kstat_max = length($key) if length($key) > $kstat_max;
$kstat_sum += length($key);
$kstat_sum2 += length($key)*length($key);
push(@keys, $key);
push(@vals, _dump($$val, $name, [@$idx, "{$key}"], $tied, $pclass, $pidx));
}
my $nl = "";
my $klen_pad = 0;
my $tmp = "@keys @vals";
if (length($tmp) > 60 || $tmp =~ /\n/ || $tied) {
$nl = "\n";
# Determine what padding to add
if ($kstat_max < 4) {
$klen_pad = $kstat_max;
}
elsif (@keys >= 2) {
my $n = @keys;
my $avg = $kstat_sum/$n;
my $stddev = sqrt(($kstat_sum2 - $n * $avg * $avg) / ($n - 1));
# I am not actually very happy with this heuristics
if ($stddev / $kstat_max < 0.25) {
$klen_pad = $kstat_max;
}
if ($DEBUG) {
push(@keys, "__S");
push(@vals, sprintf("%.2f (%d/%.1f/%.1f)",
$stddev / $kstat_max,
$kstat_max, $avg, $stddev));
}
}
}
$out = "{$nl";
$out .= "$INDENT# $tied$nl" if $tied;
while (@keys) {
my $key = shift @keys;
my $val = shift @vals;
my $vpad = $INDENT . (" " x ($klen_pad ? $klen_pad + 4 : 0));
$val =~ s/\n/\n$vpad/gm;
my $kpad = $nl ? $INDENT : " ";
$key .= " " x ($klen_pad - length($key)) if $nl && $klen_pad > length($key);
$out .= "$kpad$key => $val,$nl";
}
$out =~ s/,$/ / unless $nl;
$out .= "}";
}
elsif ($type eq "CODE") {
$out = 'sub { ... }';
}
elsif ($type eq "VSTRING") {
$out = sprintf +($ref ? '\v%vd' : 'v%vd'), $$rval;
}
else {
warn "Can't handle $type data";
$out = "'#$type#'";
}
if ($class && $ref) {
$out = "bless($out, " . quote($class) . ")";
}
if ($comment) {
$comment =~ s/^/# /gm;
$comment .= "\n" unless $comment =~ /\n\z/;
$comment =~ s/^#[ \t]+\n/\n/;
$out = "$comment$out";
}
return $out;
}
sub tied_str {
my $tied = shift;
if ($tied) {
if (my $tied_ref = ref($tied)) {
$tied = "tied $tied_ref";
}
else {
$tied = "tied";
}
}
return $tied;
}
sub fullname
{
my($name, $idx, $ref) = @_;
substr($name, 0, 0) = "\$";
my @i = @$idx; # need copy in order to not modify @$idx
if ($ref && @i && $i[0] eq "\$") {
shift(@i); # remove one deref
$ref = 0;
}
while (@i && $i[0] eq "\$") {
shift @i;
$name = "\$$name";
}
my $last_was_index;
for my $i (@i) {
if ($i eq "*" || $i eq "\$") {
$last_was_index = 0;
$name = "$i\{$name}";
} elsif ($i =~ s/^\*//) {
$name .= $i;
$last_was_index++;
} else {
$name .= "->" unless $last_was_index++;
$name .= $i;
}
}
$name = "\\$name" if $ref;
$name;
}
sub format_list
{
my $paren = shift;
my $comment = shift;
my $indent_lim = $paren ? 0 : 1;
if (@_ > 3) {
# can we use range operator to shorten the list?
my $i = 0;
while ($i < @_) {
my $j = $i + 1;
my $v = $_[$i];
while ($j < @_) {
# XXX allow string increment too?
if ($v eq "0" || $v =~ /^-?[1-9]\d{0,9}\z/) {
$v++;
}
elsif ($v =~ /^"([A-Za-z]{1,3}\d*)"\z/) {
$v = $1;
$v++;
$v = qq("$v");
}
else {
last;
}
last if $_[$j] ne $v;
$j++;
}
if ($j - $i > 3) {
splice(@_, $i, $j - $i, "$_[$i] .. $_[$j-1]");
}
$i++;
}
}
my $tmp = "@_";
if ($comment || (@_ > $indent_lim && (length($tmp) > 60 || $tmp =~ /\n/))) {
my @elem = @_;
for (@elem) { s/^/$INDENT/gm; }
return "\n" . ($comment ? "$INDENT# $comment\n" : "") .
join(",\n", @elem, "");
} else {
return join(", ", @_);
}
}
sub str {
if (length($_[0]) > 20) {
for ($_[0]) {
# Check for repeated string
if (/^(.)\1\1\1/s) {
# seems to be a repeating sequence, let's check if it really is
# without backtracking
unless (/[^\Q$1\E]/) {
my $base = quote($1);
my $repeat = length;
return "($base x $repeat)"
}
}
# Length protection because the RE engine will blow the stack [RT#33520]
if (length($_) < 16 * 1024 && /^(.{2,5}?)\1*\z/s) {
my $base = quote($1);
my $repeat = length($_)/length($1);
return "($base x $repeat)";
}
}
}
local $_ = &quote;
if (length($_) > 40 && !/\\x\{/ && length($_) > (length($_[0]) * 2)) {
# too much binary data, better to represent as a hex/base64 string
# Base64 is more compact than hex when string is longer than
# 17 bytes (not counting any require statement needed).
# But on the other hand, hex is much more readable.
if ($TRY_BASE64 && length($_[0]) > $TRY_BASE64 &&
(defined &utf8::is_utf8 && !utf8::is_utf8($_[0])) &&
eval { require MIME::Base64 })
{
$require{"MIME::Base64"}++;
return "MIME::Base64::decode(\"" .
MIME::Base64::encode($_[0],"") .
"\")";
}
return "pack(\"H*\",\"" . unpack("H*", $_[0]) . "\")";
}
return $_;
}
my %esc = (
"\a" => "\\a",
"\b" => "\\b",
"\t" => "\\t",
"\n" => "\\n",
"\f" => "\\f",
"\r" => "\\r",
"\e" => "\\e",
);
# put a string value in double quotes
sub quote {
local($_) = $_[0];
# If there are many '"' we might want to use qq() instead
s/([\\\"\@\$])/\\$1/g;
return qq("$_") unless /[^\040-\176]/; # fast exit
s/([\a\b\t\n\f\r\e])/$esc{$1}/g;
# no need for 3 digits in escape for these
s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
s/([^\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
return qq("$_");
}
1;
__END__
=head1 NAME
Data::Dump - Pretty printing of data structures
=head1 SYNOPSIS
use Data::Dump qw(dump);
$str = dump(@list);
@copy_of_list = eval $str;
# or use it for easy debug printout
use Data::Dump; dd localtime;
=head1 DESCRIPTION
This module provide a few functions that traverse their
argument and produces a string as its result. The string contains
Perl code that, when C<eval>ed, produces a deep copy of the original
arguments.
The main feature of the module is that it strives to produce output
that is easy to read. Example:
@a = (1, [2, 3], {4 => 5});
dump(@a);
Produces:
"(1, [2, 3], { 4 => 5 })"
If you dump just a little data, it is output on a single line. If
you dump data that is more complex or there is a lot of it, line breaks
are automatically added to keep it easy to read.
The following functions are provided (only the dd* functions are exported by default):
=over
=item dump( ... )
=item pp( ... )
Returns a string containing a Perl expression. If you pass this
string to Perl's built-in eval() function it should return a copy of
the arguments you passed to dump().
If you call the function with multiple arguments then the output will
be wrapped in parenthesis "( ..., ... )". If you call the function with a
single argument the output will not have the wrapping. If you call the function with
a single scalar (non-reference) argument it will just return the
scalar quoted if needed, but never break it into multiple lines. If you
pass multiple arguments or references to arrays of hashes then the
return value might contain line breaks to format it for easier
reading. The returned string will never be "\n" terminated, even if
contains multiple lines. This allows code like this to place the
semicolon in the expected place:
print '$obj = ', dump($obj), ";\n";
If dump() is called in void context, then the dump is printed on
STDERR and then "\n" terminated. You might find this useful for quick
debug printouts, but the dd*() functions might be better alternatives
for this.
There is no difference between dump() and pp(), except that dump()
shares its name with a not-so-useful perl builtin. Because of this
some might want to avoid using that name.
=item quote( $string )
Returns a quoted version of the provided string.
It differs from C<dump($string)> in that it will quote even numbers and
not try to come up with clever expressions that might shorten the
output. If a non-scalar argument is provided then it's just stringified
instead of traversed.
=item dd( ... )
=item ddx( ... )
These functions will call dump() on their argument and print the
result to STDOUT (actually, it's the currently selected output handle, but
STDOUT is the default for that).
The difference between them is only that ddx() will prefix the lines
it prints with "# " and mark the first line with the file and line
number where it was called. This is meant to be useful for debug
printouts of state within programs.
=item dumpf( ..., \&filter )
Short hand for calling the dump_filtered() function of L<Data::Dump::Filtered>.
This works like dump(), but the last argument should be a filter callback
function. As objects are visited the filter callback is invoked and it
can modify how the objects are dumped.
=back
=head1 CONFIGURATION
There are a few global variables that can be set to modify the output
generated by the dump functions. It's wise to localize the setting of
these.
=over
=item $Data::Dump::INDENT
This holds the string that's used for indenting multiline data structures.
It's default value is " " (two spaces). Set it to "" to suppress indentation.
Setting it to "| " makes for nice visuals even if the dump output then fails to
be valid Perl.
=item $Data::Dump::TRY_BASE64
How long must a binary string be before we try to use the base64 encoding
for the dump output. The default is 50. Set it to 0 to disable base64 dumps.
=back
=head1 LIMITATIONS
Code references will be dumped as C<< sub { ... } >>. Thus, C<eval>ing them will
not reproduce the original routine. The C<...>-operator used will also require
perl-5.12 or better to be evaled.
If you forget to explicitly import the C<dump> function, your code will
core dump. That's because you just called the builtin C<dump> function
by accident, which intentionally dumps core. Because of this you can
also import the same function as C<pp>, mnemonic for "pretty-print".
=head1 HISTORY
The C<Data::Dump> module grew out of frustration with Sarathy's
in-most-cases-excellent C<Data::Dumper>. Basic ideas and some code
are shared with Sarathy's module.
The C<Data::Dump> module provides a much simpler interface than
C<Data::Dumper>. No OO interface is available and there are fewer
configuration options to worry about. The other benefit is
that the dump produced does not try to set any variables. It only
returns what is needed to produce a copy of the arguments. This means
that C<dump("foo")> simply returns C<'"foo"'>, and C<dump(1..3)> simply
returns C<'(1, 2, 3)'>.
=head1 SEE ALSO
L<Data::Dump::Filtered>, L<Data::Dump::Trace>, L<Data::Dumper>, L<JSON>,
L<Storable>
=head1 AUTHORS
The C<Data::Dump> module is written by Gisle Aas <gisle@aas.no>, based
on C<Data::Dumper> by Gurusamy Sarathy <gsar@umich.edu>.
Copyright 1998-2010 Gisle Aas.
Copyright 1996-1998 Gurusamy Sarathy.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut

94
database/perl/lib/Data/Dump/FilterContext.pm Normal file
View File

@@ -0,0 +1,94 @@
package Data::Dump::FilterContext;
sub new {
my($class, $obj, $oclass, $type, $ref, $pclass, $pidx, $idx) = @_;
return bless {
object => $obj,
class => $ref && $oclass,
reftype => $type,
is_ref => $ref,
pclass => $pclass,
pidx => $pidx,
idx => $idx,
}, $class;
}
sub object_ref {
my $self = shift;
return $self->{object};
}
sub class {
my $self = shift;
return $self->{class} || "";
}
*is_blessed = \&class;
sub reftype {
my $self = shift;
return $self->{reftype};
}
sub is_scalar {
my $self = shift;
return $self->{reftype} eq "SCALAR";
}
sub is_array {
my $self = shift;
return $self->{reftype} eq "ARRAY";
}
sub is_hash {
my $self = shift;
return $self->{reftype} eq "HASH";
}
sub is_code {
my $self = shift;
return $self->{reftype} eq "CODE";
}
sub is_ref {
my $self = shift;
return $self->{is_ref};
}
sub container_class {
my $self = shift;
return $self->{pclass} || "";
}
sub container_self {
my $self = shift;
return "" unless $self->{pclass};
my $idx = $self->{idx};
my $pidx = $self->{pidx};
return Data::Dump::fullname("self", [@$idx[$pidx..(@$idx - 1)]]);
}
sub expr {
my $self = shift;
my $top = shift || "var";
$top =~ s/^\$//; # it's always added by fullname()
my $idx = $self->{idx};
return Data::Dump::fullname($top, $idx);
}
sub object_isa {
my($self, $class) = @_;
return $self->{class} && $self->{class}->isa($class);
}
sub container_isa {
my($self, $class) = @_;
return $self->{pclass} && $self->{pclass}->isa($class);
}
sub depth {
my $self = shift;
return scalar @{$self->{idx}};
}
1;

208
database/perl/lib/Data/Dump/Filtered.pm Normal file
View File

@@ -0,0 +1,208 @@
package Data::Dump::Filtered;
use Data::Dump ();
use Carp ();
use base 'Exporter';
our @EXPORT_OK = qw(add_dump_filter remove_dump_filter dump_filtered);
sub add_dump_filter {
my $filter = shift;
unless (ref($filter) eq "CODE") {
Carp::croak("add_dump_filter argument must be a code reference");
}
push(@Data::Dump::FILTERS, $filter);
return $filter;
}
sub remove_dump_filter {
my $filter = shift;
@Data::Dump::FILTERS = grep $_ ne $filter, @Data::Dump::FILTERS;
}
sub dump_filtered {
my $filter = pop;
if (defined($filter) && ref($filter) ne "CODE") {
Carp::croak("Last argument to dump_filtered must be undef or a code reference");
}
local @Data::Dump::FILTERS = ($filter ? $filter : ());
return &Data::Dump::dump;
}
1;
=head1 NAME
Data::Dump::Filtered - Pretty printing with filtering
=head1 DESCRIPTION
The following functions are provided:
=over
=item add_dump_filter( \&filter )
This registers a filter function to be used by the regular Data::Dump::dump()
function. By default no filters are active.
Since registering filters has a global effect is might be more appropriate
to use the dump_filtered() function instead.
=item remove_dump_filter( \&filter )
Unregister the given callback function as filter callback.
This undoes the effect of L<add_filter>.
=item dump_filtered(..., \&filter )
Works like Data::Dump::dump(), but the last argument should
be a filter callback function. As objects are visited the
filter callback is invoked at it might influence how objects are dumped.
Any filters registered with L<add_filter()> are ignored when
this interface is invoked. Actually, passing C<undef> as \&filter
is allowed and C<< dump_filtered(..., undef) >> is the official way to
force unfiltered dumps.
=back
=head2 Filter callback
A filter callback is a function that will be invoked with 2 arguments;
a context object and reference to the object currently visited. The return
value should either be a hash reference or C<undef>.
sub filter_callback {
my($ctx, $object_ref) = @_;
...
return { ... }
}
If the filter callback returns C<undef> (or nothing) then normal
processing and formatting of the visited object happens.
If the filter callback returns a hash it might replace
or annotate the representation of the current object.
=head2 Filter context
The context object provide methods that can be used to determine what kind of
object is currently visited and where it's located. The context object has the
following interface:
=over
=item $ctx->object_ref
Alternative way to obtain a reference to the current object
=item $ctx->class
If the object is blessed this return the class. Returns ""
for objects not blessed.
=item $ctx->reftype
Returns what kind of object this is. It's a string like "SCALAR",
"ARRAY", "HASH", "CODE",...
=item $ctx->is_ref
Returns true if a reference was provided.
=item $ctx->is_blessed
Returns true if the object is blessed. Actually, this is just an alias
for C<< $ctx->class >>.
=item $ctx->is_array
Returns true if the object is an array
=item $ctx->is_hash
Returns true if the object is a hash
=item $ctx->is_scalar
Returns true if the object is a scalar (a string or a number)
=item $ctx->is_code
Returns true if the object is a function (aka subroutine)
=item $ctx->container_class
Returns the class of the innermost container that contains this object.
Returns "" if there is no blessed container.
=item $ctx->container_self
Returns an textual expression relative to the container object that names this
object. The variable C<$self> in this expression is the container itself.
=item $ctx->object_isa( $class )
Returns TRUE if the current object is of the given class or is of a subclass.
=item $ctx->container_isa( $class )
Returns TRUE if the innermost container is of the given class or is of a
subclass.
=item $ctx->depth
Returns how many levels deep have we recursed into the structure (from the
original dump_filtered() arguments).
=item $ctx->expr
=item $ctx->expr( $top_level_name )
Returns an textual expression that denotes the current object. In the
expression C<$var> is used as the name of the top level object dumped. This
can be overridden by providing a different name as argument.
=back
=head2 Filter return hash
The following elements has significance in the returned hash:
=over
=item dump => $string
incorporate the given string as the representation for the
current value
=item object => $value
dump the given value instead of the one visited and passed in as $object.
Basically the same as specifying C<< dump => Data::Dump::dump($value) >>.
=item comment => $comment
prefix the value with the given comment string
=item bless => $class
make it look as if the current object is of the given $class
instead of the class it really has (if any). The internals of the object
is dumped in the regular way. The $class can be the empty string
to make Data::Dump pretend the object wasn't blessed at all.
=item hide_keys => ['key1', 'key2',...]
=item hide_keys => \&code
If the $object is a hash dump is as normal but pretend that the
listed keys did not exist. If the argument is a function then
the function is called to determine if the given key should be
hidden.
=back
=head1 SEE ALSO
L<Data::Dump>

411
database/perl/lib/Data/Dump/Trace.pm Normal file
View File

@@ -0,0 +1,411 @@
package Data::Dump::Trace;
$VERSION = "0.02";
# Todo:
# - prototypes
# in/out parameters key/value style
# - exception
# - wrap class
# - configurable colors
# - show call depth using indentation
# - show nested calls sensibly
# - time calls
use strict;
use base 'Exporter';
our @EXPORT_OK = qw(call mcall wrap autowrap trace);
use Carp qw(croak);
use overload ();
my %obj_name;
my %autowrap_class;
my %name_count;
sub autowrap {
while (@_) {
my $class = shift;
my $info = shift;
$info = { prefix => $info } unless ref($info);
for ($info->{prefix}) {
unless ($_) {
$_ = lc($class);
s/.*:://;
}
$_ = '$' . $_ unless /^\$/;
}
$autowrap_class{$class} = $info;
}
}
sub wrap {
my %arg = @_;
my $name = $arg{name} || "func";
my $func = $arg{func};
my $proto = $arg{proto};
return sub {
call($name, $func, $proto, @_);
} if $func;
if (my $obj = $arg{obj}) {
$name = '$' . $name unless $name =~ /^\$/;
$obj_name{overload::StrVal($obj)} = $name;
return bless {
name => $name,
obj => $obj,
proto => $arg{proto},
}, "Data::Dump::Trace::Wrapper";
}
croak("Either the 'func' or 'obj' option must be given");
}
sub trace {
my($symbol, $prototype) = @_;
no strict 'refs';
no warnings 'redefine';
*{$symbol} = wrap(name => $symbol, func => \&{$symbol}, proto => $prototype);
}
sub call {
my $name = shift;
my $func = shift;
my $proto = shift;
my $fmt = Data::Dump::Trace::Call->new($name, $proto, \@_);
if (!defined wantarray) {
$func->(@_);
return $fmt->return_void(\@_);
}
elsif (wantarray) {
return $fmt->return_list(\@_, $func->(@_));
}
else {
return $fmt->return_scalar(\@_, scalar $func->(@_));
}
}
sub mcall {
my $o = shift;
my $method = shift;
my $proto = shift;
return if $method eq "DESTROY" && !$o->can("DESTROY");
my $oname = ref($o) ? $obj_name{overload::StrVal($o)} || "\$o" : $o;
my $fmt = Data::Dump::Trace::Call->new("$oname->$method", $proto, \@_);
if (!defined wantarray) {
$o->$method(@_);
return $fmt->return_void(\@_);
}
elsif (wantarray) {
return $fmt->return_list(\@_, $o->$method(@_));
}
else {
return $fmt->return_scalar(\@_, scalar $o->$method(@_));
}
}
package Data::Dump::Trace::Wrapper;
sub AUTOLOAD {
my $self = shift;
our $AUTOLOAD;
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
Data::Dump::Trace::mcall($self->{obj}, $method, $self->{proto}{$method}, @_);
}
package Data::Dump::Trace::Call;
use Term::ANSIColor ();
use Data::Dump ();
*_dump = \&Data::Dump::dump;
our %COLOR = (
name => "yellow",
output => "cyan",
error => "red",
debug => "red",
);
%COLOR = () unless -t STDOUT;
sub _dumpav {
return "(" . _dump(@_) . ")" if @_ == 1;
return _dump(@_);
}
sub _dumpkv {
return _dumpav(@_) if @_ % 2;
my %h = @_;
my $str = _dump(\%h);
$str =~ s/^\{/(/ && $str =~ s/\}\z/)/;
return $str;
}
sub new {
my($class, $name, $proto, $input_args) = @_;
my $self = bless {
name => $name,
proto => $proto,
}, $class;
my $proto_arg = $self->proto_arg;
if ($proto_arg =~ /o/) {
for (@$input_args) {
push(@{$self->{input_av}}, _dump($_));
}
}
else {
$self->{input} = $proto_arg eq "%" ? _dumpkv(@$input_args) : _dumpav(@$input_args);
}
return $self;
}
sub proto_arg {
my $self = shift;
my($arg, $ret) = split(/\s*=\s*/, $self->{proto} || "");
$arg ||= '@';
return $arg;
}
sub proto_ret {
my $self = shift;
my($arg, $ret) = split(/\s*=\s*/, $self->{proto} || "");
$ret ||= '@';
return $ret;
}
sub color {
my($self, $category, $text) = @_;
return $text unless $COLOR{$category};
return Term::ANSIColor::colored($text, $COLOR{$category});
}
sub print_call {
my $self = shift;
my $outarg = shift;
print $self->color("name", "$self->{name}");
if (my $input = $self->{input}) {
$input = "" if $input eq "()" && $self->{name} =~ /->/;
print $self->color("input", $input);
}
else {
my $proto_arg = $self->proto_arg;
print "(";
my $i = 0;
for (@{$self->{input_av}}) {
print ", " if $i;
my $proto = substr($proto_arg, 0, 1, "");
if ($proto ne "o") {
print $self->color("input", $_);
}
if ($proto eq "o" || $proto eq "O") {
print " = " if $proto eq "O";
print $self->color("output", _dump($outarg->[$i]));
}
}
continue {
$i++;
}
print ")";
}
}
sub return_void {
my $self = shift;
my $arg = shift;
$self->print_call($arg);
print "\n";
return;
}
sub return_scalar {
my $self = shift;
my $arg = shift;
$self->print_call($arg);
my $s = shift;
my $name;
my $proto_ret = $self->proto_ret;
my $wrap = $autowrap_class{ref($s)};
if ($proto_ret =~ /^\$\w+\z/ && ref($s) && ref($s) !~ /^(?:ARRAY|HASH|CODE|GLOB)\z/) {
$name = $proto_ret;
}
else {
$name = $wrap->{prefix} if $wrap;
}
if ($name) {
$name .= $name_count{$name} if $name_count{$name}++;
print " = ", $self->color("output", $name), "\n";
$s = Data::Dump::Trace::wrap(name => $name, obj => $s, proto => $wrap->{proto});
}
else {
print " = ", $self->color("output", _dump($s));
if (!$s && $proto_ret =~ /!/ && $!) {
print " ", $self->color("error", errno($!));
}
print "\n";
}
return $s;
}
sub return_list {
my $self = shift;
my $arg = shift;
$self->print_call($arg);
print " = ", $self->color("output", $self->proto_ret eq "%" ? _dumpkv(@_) : _dumpav(@_)), "\n";
return @_;
}
sub errno {
my $t = "";
for (keys %!) {
if ($!{$_}) {
$t = $_;
last;
}
}
my $n = int($!);
return "$t($n) $!";
}
1;
__END__
=head1 NAME
Data::Dump::Trace - Helpers to trace function and method calls
=head1 SYNOPSIS
use Data::Dump::Trace qw(autowrap mcall);
autowrap("LWP::UserAgent" => "ua", "HTTP::Response" => "res");
use LWP::UserAgent;
$ua = mcall(LWP::UserAgent => "new"); # instead of LWP::UserAgent->new;
$ua->get("http://www.example.com")->dump;
=head1 DESCRIPTION
The following functions are provided:
=over
=item autowrap( $class )
=item autowrap( $class => $prefix )
=item autowrap( $class1 => $prefix1, $class2 => $prefix2, ... )
=item autowrap( $class1 => \%info1, $class2 => \%info2, ... )
Register classes whose objects are automatically wrapped when
returned by one of the call functions below. If $prefix is provided
it will be used as to name the objects.
Alternative is to pass an %info hash for each class. The recognized keys are:
=over
=item prefix => $string
The prefix string used to name objects of this type.
=item proto => \%hash
A hash of prototypes to use for the methods when an object is wrapped.
=back
=item wrap( name => $str, func => \&func, proto => $proto )
=item wrap( name => $str, obj => $obj, proto => \%hash )
Returns a wrapped function or object. When a wrapped function is
invoked then a trace is printed after the underlying function has returned.
When a method on a wrapped object is invoked then a trace is printed
after the methods on the underlying objects has returned.
See L</"Prototypes"> for description of the C<proto> argument.
=item call( $name, \&func, $proto, @ARGS )
Calls the given function with the given arguments. The trace will use
$name as the name of the function.
See L</"Prototypes"> for description of the $proto argument.
=item mcall( $class, $method, $proto, @ARGS )
=item mcall( $object, $method, $proto, @ARGS )
Calls the given method with the given arguments.
See L</"Prototypes"> for description of the $proto argument.
=item trace( $symbol, $prototype )
Replaces the function given by $symbol with a wrapped function.
=back
=head2 Prototypes
B<Note: The prototype string syntax described here is experimental and
likely to change in revisions of this interface>.
The $proto argument to call() and mcall() can optionally provide a
prototype for the function call. This give the tracer hints about how
to best format the argument lists and if there are I<in/out> or I<out>
arguments. The general form for the prototype string is:
<arguments> = <return_value>
The default prototype is "@ = @"; list of values as input and list of
values as output.
The value '%' can be used for both arguments and return value to say
that key/value pair style lists are used.
Alternatively, individual positional arguments can be listed each
represented by a letter:
=over
=item C<i>
input argument
=item C<o>
output argument
=item C<O>
both input and output argument
=back
If the return value prototype has C<!> appended, then it signals that
this function sets errno ($!) when it returns a false value. The
trace will display the current value of errno in that case.
If the return value prototype looks like a variable name (with C<$>
prefix), and the function returns a blessed object, then the variable
name will be used as prefix and the returned object automatically
traced.
=head1 SEE ALSO
L<Data::Dump>
=head1 AUTHOR
Copyright 2009 Gisle Aas.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut

1476
database/perl/lib/Data/Dumper.pm Normal file
View File

File diff suppressed because it is too large Load Diff

406
database/perl/lib/Data/OptList.pm Normal file
View File

@@ -0,0 +1,406 @@
use strict;
use warnings;
package Data::OptList;
# ABSTRACT: parse and validate simple name/value option pairs
$Data::OptList::VERSION = '0.110';
use List::Util ();
use Params::Util ();
use Sub::Install 0.921 ();
#pod =head1 SYNOPSIS
#pod
#pod use Data::OptList;
#pod
#pod my $options = Data::OptList::mkopt([
#pod qw(key1 key2 key3 key4),
#pod key5 => { ... },
#pod key6 => [ ... ],
#pod key7 => sub { ... },
#pod key8 => { ... },
#pod key8 => [ ... ],
#pod ]);
#pod
#pod ...is the same thing, more or less, as:
#pod
#pod my $options = [
#pod [ key1 => undef, ],
#pod [ key2 => undef, ],
#pod [ key3 => undef, ],
#pod [ key4 => undef, ],
#pod [ key5 => { ... }, ],
#pod [ key6 => [ ... ], ],
#pod [ key7 => sub { ... }, ],
#pod [ key8 => { ... }, ],
#pod [ key8 => [ ... ], ],
#pod ]);
#pod
#pod =head1 DESCRIPTION
#pod
#pod Hashes are great for storing named data, but if you want more than one entry
#pod for a name, you have to use a list of pairs. Even then, this is really boring
#pod to write:
#pod
#pod $values = [
#pod foo => undef,
#pod bar => undef,
#pod baz => undef,
#pod xyz => { ... },
#pod ];
#pod
#pod Just look at all those undefs! Don't worry, we can get rid of those:
#pod
#pod $values = [
#pod map { $_ => undef } qw(foo bar baz),
#pod xyz => { ... },
#pod ];
#pod
#pod Aaaauuugh! We've saved a little typing, but now it requires thought to read,
#pod and thinking is even worse than typing... and it's got a bug! It looked right,
#pod didn't it? Well, the C<< xyz => { ... } >> gets consumed by the map, and we
#pod don't get the data we wanted.
#pod
#pod With Data::OptList, you can do this instead:
#pod
#pod $values = Data::OptList::mkopt([
#pod qw(foo bar baz),
#pod xyz => { ... },
#pod ]);
#pod
#pod This works by assuming that any defined scalar is a name and any reference
#pod following a name is its value.
#pod
#pod =func mkopt
#pod
#pod my $opt_list = Data::OptList::mkopt($input, \%arg);
#pod
#pod Valid arguments are:
#pod
#pod moniker - a word used in errors to describe the opt list; encouraged
#pod require_unique - if true, no name may appear more than once
#pod must_be - types to which opt list values are limited (described below)
#pod name_test - a coderef used to test whether a value can be a name
#pod (described below, but you probably don't want this)
#pod
#pod This produces an array of arrays; the inner arrays are name/value pairs.
#pod Values will be either "undef" or a reference.
#pod
#pod Positional parameters may be used for compatibility with the old C<mkopt>
#pod interface:
#pod
#pod my $opt_list = Data::OptList::mkopt($input, $moniker, $req_uni, $must_be);
#pod
#pod Valid values for C<$input>:
#pod
#pod undef -> []
#pod hashref -> [ [ key1 => value1 ] ... ] # non-ref values become undef
#pod arrayref -> every name followed by a non-name becomes a pair: [ name => ref ]
#pod every name followed by undef becomes a pair: [ name => undef ]
#pod otherwise, it becomes [ name => undef ] like so:
#pod [ "a", "b", [ 1, 2 ] ] -> [ [ a => undef ], [ b => [ 1, 2 ] ] ]
#pod
#pod By default, a I<name> is any defined non-reference. The C<name_test> parameter
#pod can be a code ref that tests whether the argument passed it is a name or not.
#pod This should be used rarely. Interactions between C<require_unique> and
#pod C<name_test> are not yet particularly elegant, as C<require_unique> just tests
#pod string equality. B<This may change.>
#pod
#pod The C<must_be> parameter is either a scalar or array of scalars; it defines
#pod what kind(s) of refs may be values. If an invalid value is found, an exception
#pod is thrown. If no value is passed for this argument, any reference is valid.
#pod If C<must_be> specifies that values must be CODE, HASH, ARRAY, or SCALAR, then
#pod Params::Util is used to check whether the given value can provide that
#pod interface. Otherwise, it checks that the given value is an object of the kind.
#pod
#pod In other words:
#pod
#pod [ qw(SCALAR HASH Object::Known) ]
#pod
#pod Means:
#pod
#pod _SCALAR0($value) or _HASH($value) or _INSTANCE($value, 'Object::Known')
#pod
#pod =cut
my %test_for;
BEGIN {
%test_for = (
CODE => \&Params::Util::_CODELIKE, ## no critic
HASH => \&Params::Util::_HASHLIKE, ## no critic
ARRAY => \&Params::Util::_ARRAYLIKE, ## no critic
SCALAR => \&Params::Util::_SCALAR0, ## no critic
);
}
sub mkopt {
my ($opt_list) = shift;
my ($moniker, $require_unique, $must_be); # the old positional args
my ($name_test, $is_a);
if (@_) {
if (@_ == 1 and Params::Util::_HASHLIKE($_[0])) {
($moniker, $require_unique, $must_be, $name_test)
= @{$_[0]}{ qw(moniker require_unique must_be name_test) };
} else {
($moniker, $require_unique, $must_be) = @_;
}
# Transform the $must_be specification into a closure $is_a
# that will check if a value matches the spec
if (defined $must_be) {
$must_be = [ $must_be ] unless ref $must_be;
my @checks = map {
my $class = $_;
$test_for{$_}
|| sub { $_[1] = $class; goto \&Params::Util::_INSTANCE }
} @$must_be;
$is_a = (@checks == 1)
? $checks[0]
: sub {
my $value = $_[0];
List::Util::first { defined($_->($value)) } @checks
};
$moniker = 'unnamed' unless defined $moniker;
}
}
return [] unless $opt_list;
$name_test ||= sub { ! ref $_[0] };
$opt_list = [
map { $_ => (ref $opt_list->{$_} ? $opt_list->{$_} : ()) } keys %$opt_list
] if ref $opt_list eq 'HASH';
my @return;
my %seen;
for (my $i = 0; $i < @$opt_list; $i++) { ## no critic
my $name = $opt_list->[$i];
if ($require_unique) {
Carp::croak "multiple definitions provided for $name" if $seen{$name}++;
}
my $value;
if ($i < $#$opt_list) {
if (not defined $opt_list->[$i+1]) {
$i++
} elsif (! $name_test->($opt_list->[$i+1])) {
$value = $opt_list->[++$i];
if ($is_a && !$is_a->($value)) {
my $ref = ref $value;
Carp::croak "$ref-ref values are not valid in $moniker opt list";
}
}
}
push @return, [ $name => $value ];
}
return \@return;
}
#pod =func mkopt_hash
#pod
#pod my $opt_hash = Data::OptList::mkopt_hash($input, $moniker, $must_be);
#pod
#pod Given valid C<L</mkopt>> input, this routine returns a reference to a hash. It
#pod will throw an exception if any name has more than one value.
#pod
#pod =cut
sub mkopt_hash {
my ($opt_list, $moniker, $must_be) = @_;
return {} unless $opt_list;
$opt_list = mkopt($opt_list, $moniker, 1, $must_be);
my %hash = map { $_->[0] => $_->[1] } @$opt_list;
return \%hash;
}
#pod =head1 EXPORTS
#pod
#pod Both C<mkopt> and C<mkopt_hash> may be exported on request.
#pod
#pod =cut
BEGIN {
*import = Sub::Install::exporter {
exports => [qw(mkopt mkopt_hash)],
};
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Data::OptList - parse and validate simple name/value option pairs
=head1 VERSION
version 0.110
=head1 SYNOPSIS
use Data::OptList;
my $options = Data::OptList::mkopt([
qw(key1 key2 key3 key4),
key5 => { ... },
key6 => [ ... ],
key7 => sub { ... },
key8 => { ... },
key8 => [ ... ],
]);
...is the same thing, more or less, as:
my $options = [
[ key1 => undef, ],
[ key2 => undef, ],
[ key3 => undef, ],
[ key4 => undef, ],
[ key5 => { ... }, ],
[ key6 => [ ... ], ],
[ key7 => sub { ... }, ],
[ key8 => { ... }, ],
[ key8 => [ ... ], ],
]);
=head1 DESCRIPTION
Hashes are great for storing named data, but if you want more than one entry
for a name, you have to use a list of pairs. Even then, this is really boring
to write:
$values = [
foo => undef,
bar => undef,
baz => undef,
xyz => { ... },
];
Just look at all those undefs! Don't worry, we can get rid of those:
$values = [
map { $_ => undef } qw(foo bar baz),
xyz => { ... },
];
Aaaauuugh! We've saved a little typing, but now it requires thought to read,
and thinking is even worse than typing... and it's got a bug! It looked right,
didn't it? Well, the C<< xyz => { ... } >> gets consumed by the map, and we
don't get the data we wanted.
With Data::OptList, you can do this instead:
$values = Data::OptList::mkopt([
qw(foo bar baz),
xyz => { ... },
]);
This works by assuming that any defined scalar is a name and any reference
following a name is its value.
=head1 FUNCTIONS
=head2 mkopt
my $opt_list = Data::OptList::mkopt($input, \%arg);
Valid arguments are:
moniker - a word used in errors to describe the opt list; encouraged
require_unique - if true, no name may appear more than once
must_be - types to which opt list values are limited (described below)
name_test - a coderef used to test whether a value can be a name
(described below, but you probably don't want this)
This produces an array of arrays; the inner arrays are name/value pairs.
Values will be either "undef" or a reference.
Positional parameters may be used for compatibility with the old C<mkopt>
interface:
my $opt_list = Data::OptList::mkopt($input, $moniker, $req_uni, $must_be);
Valid values for C<$input>:
undef -> []
hashref -> [ [ key1 => value1 ] ... ] # non-ref values become undef
arrayref -> every name followed by a non-name becomes a pair: [ name => ref ]
every name followed by undef becomes a pair: [ name => undef ]
otherwise, it becomes [ name => undef ] like so:
[ "a", "b", [ 1, 2 ] ] -> [ [ a => undef ], [ b => [ 1, 2 ] ] ]
By default, a I<name> is any defined non-reference. The C<name_test> parameter
can be a code ref that tests whether the argument passed it is a name or not.
This should be used rarely. Interactions between C<require_unique> and
C<name_test> are not yet particularly elegant, as C<require_unique> just tests
string equality. B<This may change.>
The C<must_be> parameter is either a scalar or array of scalars; it defines
what kind(s) of refs may be values. If an invalid value is found, an exception
is thrown. If no value is passed for this argument, any reference is valid.
If C<must_be> specifies that values must be CODE, HASH, ARRAY, or SCALAR, then
Params::Util is used to check whether the given value can provide that
interface. Otherwise, it checks that the given value is an object of the kind.
In other words:
[ qw(SCALAR HASH Object::Known) ]
Means:
_SCALAR0($value) or _HASH($value) or _INSTANCE($value, 'Object::Known')
=head2 mkopt_hash
my $opt_hash = Data::OptList::mkopt_hash($input, $moniker, $must_be);
Given valid C<L</mkopt>> input, this routine returns a reference to a hash. It
will throw an exception if any name has more than one value.
=head1 EXPORTS
Both C<mkopt> and C<mkopt_hash> may be exported on request.
=head1 AUTHOR
Ricardo Signes <rjbs@cpan.org>
=head1 CONTRIBUTORS
=for stopwords Olivier Mengué Ricardo SIGNES
=over 4
=item *
Olivier Mengué <dolmen@cpan.org>
=item *
Ricardo SIGNES <rjbs@codesimply.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Ricardo Signes.
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

625
database/perl/lib/Data/Section.pm Normal file
View File

@@ -0,0 +1,625 @@
use strict;
use warnings;
package Data::Section;
# ABSTRACT: read multiple hunks of data out of your DATA section
$Data::Section::VERSION = '0.200007';
use Encode qw/decode/;
use MRO::Compat 0.09;
use Sub::Exporter 0.979 -setup => {
groups => { setup => \'_mk_reader_group' },
collectors => { INIT => sub { $_[0] = { into => $_[1]->{into} } } },
};
#pod =head1 SYNOPSIS
#pod
#pod package Letter::Resignation;
#pod use Data::Section -setup;
#pod
#pod sub quit {
#pod my ($class, $angry, %arg) = @_;
#pod
#pod my $template = $self->section_data(
#pod ($angry ? "angry_" : "professional_") . "letter"
#pod );
#pod
#pod return fill_in($$template, \%arg);
#pod }
#pod
#pod __DATA__
#pod __[ angry_letter ]__
#pod Dear jerks,
#pod
#pod I quit!
#pod
#pod --
#pod {{ $name }}
#pod __[ professional_letter ]__
#pod Dear {{ $boss }},
#pod
#pod I quit, jerks!
#pod
#pod
#pod --
#pod {{ $name }}
#pod
#pod =head1 DESCRIPTION
#pod
#pod Data::Section provides an easy way to access multiple named chunks of
#pod line-oriented data in your module's DATA section. It was written to allow
#pod modules to store their own templates, but probably has other uses.
#pod
#pod =head1 WARNING
#pod
#pod You will need to use C<__DATA__> sections and not C<__END__> sections. Yes, it
#pod matters. Who knew!
#pod
#pod =head1 EXPORTS
#pod
#pod To get the methods exported by Data::Section, you must import like this:
#pod
#pod use Data::Section -setup;
#pod
#pod Optional arguments may be given to Data::Section like this:
#pod
#pod use Data::Section -setup => { ... };
#pod
#pod Valid arguments are:
#pod
#pod encoding - if given, gives the encoding needed to decode bytes in
#pod data sections; default; UTF-8
#pod
#pod the special value "bytes" will leave the bytes in the string
#pod verbatim
#pod
#pod inherit - if true, allow packages to inherit the data of the packages
#pod from which they inherit; default: true
#pod
#pod header_re - if given, changes the regex used to find section headers
#pod in the data section; it should leave the section name in $1
#pod
#pod default_name - if given, allows the first section to has no header and set
#pod its name
#pod
#pod Three methods are exported by Data::Section:
#pod
#pod =head2 section_data
#pod
#pod my $string_ref = $pkg->section_data($name);
#pod
#pod This method returns a reference to a string containing the data from the name
#pod section, either in the invocant's C<DATA> section or in that of one of its
#pod ancestors. (The ancestor must also derive from the class that imported
#pod Data::Section.)
#pod
#pod By default, named sections are delimited by lines that look like this:
#pod
#pod __[ name ]__
#pod
#pod You can use as many underscores as you want, and the space around the name is
#pod optional. This pattern can be configured with the C<header_re> option (see
#pod above). If present, a single leading C<\> is removed, so that sections can
#pod encode lines that look like section delimiters.
#pod
#pod When a line containing only C<__END__> is reached, all processing of sections
#pod ends.
#pod
#pod =head2 section_data_names
#pod
#pod my @names = $pkg->section_data_names;
#pod
#pod This returns a list of all the names that will be recognized by the
#pod C<section_data> method.
#pod
#pod =head2 merged_section_data
#pod
#pod my $data = $pkg->merged_section_data;
#pod
#pod This method returns a hashref containing all the data extracted from the
#pod package data for all the classes from which the invocant inherits -- as long as
#pod those classes also inherit from the package into which Data::Section was
#pod imported.
#pod
#pod In other words, given this inheritance tree:
#pod
#pod A
#pod \
#pod B C
#pod \ /
#pod D
#pod
#pod ...if Data::Section was imported by A, then when D's C<merged_section_data> is
#pod invoked, C's data section will not be considered. (This prevents the read
#pod position of C's data handle from being altered unexpectedly.)
#pod
#pod The keys in the returned hashref are the section names, and the values are
#pod B<references to> the strings extracted from the data sections.
#pod
#pod =head2 merged_section_data_names
#pod
#pod my @names = $pkg->merged_section_data_names;
#pod
#pod This returns a list of all the names that will be recognized by the
#pod C<merged_section_data> method.
#pod
#pod =head2 local_section_data
#pod
#pod my $data = $pkg->local_section_data;
#pod
#pod This method returns a hashref containing all the data extracted from the
#pod package on which the method was invoked. If called on an object, it will
#pod operate on the package into which the object was blessed.
#pod
#pod This method needs to be used carefully, because it's weird. It returns only
#pod the data for the package on which it was invoked. If the package on which it
#pod was invoked has no data sections, it returns an empty hashref.
#pod
#pod =head2 local_section_data_names
#pod
#pod my @names = $pkg->local_section_data_names;
#pod
#pod This returns a list of all the names that will be recognized by the
#pod C<local_section_data> method.
#pod
#pod =cut
sub _mk_reader_group {
my ($mixin, $name, $arg, $col) = @_;
my $base = $col->{INIT}{into};
my $default_header_re = qr/
\A # start
_+\[ # __[
\s* # any whitespace
([^\]]+?) # this is the actual name of the section
\s* # any whitespace
\]_+ # ]__
[\x0d\x0a]{1,2} # possible cariage return for windows files
\z # end
/x;
my $header_re = $arg->{header_re} || $default_header_re;
$arg->{inherit} = 1 unless exists $arg->{inherit};
my $default_encoding = defined $arg->{encoding} ? $arg->{encoding} : 'UTF-8';
my %export;
my %stash = ();
$export{local_section_data} = sub {
my ($self) = @_;
my $pkg = ref $self ? ref $self : $self;
return $stash{ $pkg } if $stash{ $pkg };
my $template = $stash{ $pkg } = { };
my $dh = do { no strict 'refs'; \*{"$pkg\::DATA"} }; ## no critic Strict
return $stash{ $pkg } unless defined fileno *$dh;
binmode( $dh, ":raw :bytes" );
my ($current, $current_line);
if ($arg->{default_name}) {
$current = $arg->{default_name};
$template->{ $current } = \(my $blank = q{});
}
LINE: while (my $line = <$dh>) {
if ($line =~ $header_re) {
$current = $1;
$current_line = 0;
$template->{ $current } = \(my $blank = q{});
next LINE;
}
last LINE if $line =~ /^__END__/;
next LINE if !defined $current and $line =~ /^\s*$/;
Carp::confess("bogus data section: text outside of named section")
unless defined $current;
$current_line++;
unless ($default_encoding eq 'bytes') {
my $decoded_line = eval { decode($default_encoding, $line, Encode::FB_CROAK) }
or warn "Invalid character encoding in $current, line $current_line\n";
$line = $decoded_line if defined $decoded_line;
}
$line =~ s/\A\\//;
${$template->{$current}} .= $line;
}
return $stash{ $pkg };
};
$export{local_section_data_names} = sub {
my ($self) = @_;
my $method = $export{local_section_data};
return keys %{ $self->$method };
};
$export{merged_section_data} =
!$arg->{inherit} ? $export{local_section_data} : sub {
my ($self) = @_;
my $pkg = ref $self ? ref $self : $self;
my $lsd = $export{local_section_data};
my %merged;
for my $class (@{ mro::get_linear_isa($pkg) }) {
# in case of c3 + non-$base item showing up
next unless $class->isa($base);
my $sec_data = $class->$lsd;
# checking for truth is okay, since things must be undef or a ref
# -- rjbs, 2008-06-06
$merged{ $_ } ||= $sec_data->{$_} for keys %$sec_data;
}
return \%merged;
};
$export{merged_section_data_names} = sub {
my ($self) = @_;
my $method = $export{merged_section_data};
return keys %{ $self->$method };
};
$export{section_data} = sub {
my ($self, $name) = @_;
my $pkg = ref $self ? ref $self : $self;
my $prefix = $arg->{inherit} ? 'merged' : 'local';
my $method = "$prefix\_section_data";
my $data = $self->$method;
return $data->{ $name };
};
$export{section_data_names} = sub {
my ($self) = @_;
my $prefix = $arg->{inherit} ? 'merged' : 'local';
my $method = "$prefix\_section_data_names";
return $self->$method;
};
return \%export;
}
#pod =head1 TIPS AND TRICKS
#pod
#pod =head2 MooseX::Declare and namespace::autoclean
#pod
#pod The L<namespace::autoclean|namespace::autoclean> library automatically cleans
#pod foreign routines from a class, including those imported by Data::Section.
#pod
#pod L<MooseX::Declare|MooseX::Declare> does the same thing, and can also cause your
#pod C<__DATA__> section to appear outside your class's package.
#pod
#pod These are easy to address. The
#pod L<Sub::Exporter::ForMethods|Sub::Exporter::ForMethods> library provides an
#pod installer that will cause installed methods to appear to come from the class
#pod and avoid autocleaning. Using an explicit C<package> statement will keep the
#pod data section in the correct package.
#pod
#pod package Foo;
#pod
#pod use MooseX::Declare;
#pod class Foo {
#pod
#pod # Utility to tell Sub::Exporter modules to export methods.
#pod use Sub::Exporter::ForMethods qw( method_installer );
#pod
#pod # method_installer returns a sub.
#pod use Data::Section { installer => method_installer }, -setup;
#pod
#pod method my_method {
#pod my $content_ref = $self->section_data('SectionA');
#pod
#pod print $$content_ref;
#pod }
#pod }
#pod
#pod __DATA__
#pod __[ SectionA ]__
#pod Hello, world.
#pod
#pod =head1 SEE ALSO
#pod
#pod =begin :list
#pod
#pod * L<article for RJBS Advent 2009|http://advent.rjbs.manxome.org/2009/2009-12-09.html>
#pod
#pod * L<Inline::Files|Inline::Files> does something that is at first look similar,
#pod but it works with source filters, and contains the warning:
#pod
#pod It is possible that this module may overwrite the source code in files that
#pod use it. To protect yourself against this possibility, you are strongly
#pod advised to use the -backup option described in "Safety first".
#pod
#pod Enough said.
#pod
#pod =end :list
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Data::Section - read multiple hunks of data out of your DATA section
=head1 VERSION
version 0.200007
=head1 SYNOPSIS
package Letter::Resignation;
use Data::Section -setup;
sub quit {
my ($class, $angry, %arg) = @_;
my $template = $self->section_data(
($angry ? "angry_" : "professional_") . "letter"
);
return fill_in($$template, \%arg);
}
__DATA__
__[ angry_letter ]__
Dear jerks,
I quit!
--
{{ $name }}
__[ professional_letter ]__
Dear {{ $boss }},
I quit, jerks!
--
{{ $name }}
=head1 DESCRIPTION
Data::Section provides an easy way to access multiple named chunks of
line-oriented data in your module's DATA section. It was written to allow
modules to store their own templates, but probably has other uses.
=head1 WARNING
You will need to use C<__DATA__> sections and not C<__END__> sections. Yes, it
matters. Who knew!
=head1 EXPORTS
To get the methods exported by Data::Section, you must import like this:
use Data::Section -setup;
Optional arguments may be given to Data::Section like this:
use Data::Section -setup => { ... };
Valid arguments are:
encoding - if given, gives the encoding needed to decode bytes in
data sections; default; UTF-8
the special value "bytes" will leave the bytes in the string
verbatim
inherit - if true, allow packages to inherit the data of the packages
from which they inherit; default: true
header_re - if given, changes the regex used to find section headers
in the data section; it should leave the section name in $1
default_name - if given, allows the first section to has no header and set
its name
Three methods are exported by Data::Section:
=head2 section_data
my $string_ref = $pkg->section_data($name);
This method returns a reference to a string containing the data from the name
section, either in the invocant's C<DATA> section or in that of one of its
ancestors. (The ancestor must also derive from the class that imported
Data::Section.)
By default, named sections are delimited by lines that look like this:
__[ name ]__
You can use as many underscores as you want, and the space around the name is
optional. This pattern can be configured with the C<header_re> option (see
above). If present, a single leading C<\> is removed, so that sections can
encode lines that look like section delimiters.
When a line containing only C<__END__> is reached, all processing of sections
ends.
=head2 section_data_names
my @names = $pkg->section_data_names;
This returns a list of all the names that will be recognized by the
C<section_data> method.
=head2 merged_section_data
my $data = $pkg->merged_section_data;
This method returns a hashref containing all the data extracted from the
package data for all the classes from which the invocant inherits -- as long as
those classes also inherit from the package into which Data::Section was
imported.
In other words, given this inheritance tree:
A
\
B C
\ /
D
...if Data::Section was imported by A, then when D's C<merged_section_data> is
invoked, C's data section will not be considered. (This prevents the read
position of C's data handle from being altered unexpectedly.)
The keys in the returned hashref are the section names, and the values are
B<references to> the strings extracted from the data sections.
=head2 merged_section_data_names
my @names = $pkg->merged_section_data_names;
This returns a list of all the names that will be recognized by the
C<merged_section_data> method.
=head2 local_section_data
my $data = $pkg->local_section_data;
This method returns a hashref containing all the data extracted from the
package on which the method was invoked. If called on an object, it will
operate on the package into which the object was blessed.
This method needs to be used carefully, because it's weird. It returns only
the data for the package on which it was invoked. If the package on which it
was invoked has no data sections, it returns an empty hashref.
=head2 local_section_data_names
my @names = $pkg->local_section_data_names;
This returns a list of all the names that will be recognized by the
C<local_section_data> method.
=head1 TIPS AND TRICKS
=head2 MooseX::Declare and namespace::autoclean
The L<namespace::autoclean|namespace::autoclean> library automatically cleans
foreign routines from a class, including those imported by Data::Section.
L<MooseX::Declare|MooseX::Declare> does the same thing, and can also cause your
C<__DATA__> section to appear outside your class's package.
These are easy to address. The
L<Sub::Exporter::ForMethods|Sub::Exporter::ForMethods> library provides an
installer that will cause installed methods to appear to come from the class
and avoid autocleaning. Using an explicit C<package> statement will keep the
data section in the correct package.
package Foo;
use MooseX::Declare;
class Foo {
# Utility to tell Sub::Exporter modules to export methods.
use Sub::Exporter::ForMethods qw( method_installer );
# method_installer returns a sub.
use Data::Section { installer => method_installer }, -setup;
method my_method {
my $content_ref = $self->section_data('SectionA');
print $$content_ref;
}
}
__DATA__
__[ SectionA ]__
Hello, world.
=head1 SEE ALSO
=over 4
=item *
L<article for RJBS Advent 2009|http://advent.rjbs.manxome.org/2009/2009-12-09.html>
=item *
L<Inline::Files|Inline::Files> does something that is at first look similar,
but it works with source filters, and contains the warning:
It is possible that this module may overwrite the source code in files that
use it. To protect yourself against this possibility, you are strongly
advised to use the -backup option described in "Safety first".
Enough said.
=back
=head1 AUTHOR
Ricardo SIGNES <rjbs@cpan.org>
=head1 CONTRIBUTORS
=for stopwords Christian Walde Dan Kogai David Golden Steinbrunner Karen Etheridge Kenichi Ishigaki kentfredric Tatsuhiko Miyagawa
=over 4
=item *
Christian Walde <walde.christian@googlemail.com>
=item *
Dan Kogai <dankogai+github@gmail.com>
=item *
David Golden <dagolden@cpan.org>
=item *
David Steinbrunner <dsteinbrunner@pobox.com>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Kenichi Ishigaki <ishigaki@cpan.org>
=item *
kentfredric <kentfredric+gravitar@gmail.com>
=item *
Tatsuhiko Miyagawa <miyagawa@bulknews.net>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Ricardo SIGNES.
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