Initial Commit
This commit is contained in:
Riley Schneider
375
database/perl/vendor/lib/Data/Printer/Filter.pm
vendored
Normal file
375
database/perl/vendor/lib/Data/Printer/Filter.pm
vendored
Normal file
@@ -0,0 +1,375 @@
|
||||
package Data::Printer::Filter;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Clone::PP qw(clone);
|
||||
require Carp;
|
||||
require Data::Printer;
|
||||
|
||||
my %_filters_for = ();
|
||||
my %_extras_for = ();
|
||||
|
||||
sub import {
|
||||
my $caller = caller;
|
||||
my $id = Data::Printer::_object_id( \$caller );
|
||||
|
||||
my %properties = ();
|
||||
|
||||
my $filter = sub {
|
||||
my ($type, $code, $extra) = @_;
|
||||
|
||||
Carp::croak( "syntax: filter 'Class', sub { ... }" )
|
||||
unless $type and $code and ref $code eq 'CODE';
|
||||
|
||||
if ($extra) {
|
||||
Carp::croak( 'extra filter field must be a hashref' )
|
||||
unless ref $extra and ref $extra eq 'HASH';
|
||||
|
||||
$_extras_for{$id}{$type} = $extra;
|
||||
}
|
||||
else {
|
||||
$_extras_for{$id}{$type} = {};
|
||||
}
|
||||
|
||||
unshift @{ $_filters_for{$id}{$type} }, sub {
|
||||
my ($item, $p) = @_;
|
||||
|
||||
# send our closured %properties var instead
|
||||
# so newline(), indent(), etc can work it
|
||||
%properties = %{ clone $p };
|
||||
delete $properties{filters}; # no need to rework filters
|
||||
$code->($item, \%properties);
|
||||
};
|
||||
};
|
||||
|
||||
my $filters = sub {
|
||||
return $_filters_for{$id};
|
||||
};
|
||||
|
||||
my $extras = sub {
|
||||
return $_extras_for{$id};
|
||||
};
|
||||
|
||||
my $newline = sub {
|
||||
return $properties{_linebreak} . (' ' x $properties{_current_indent});
|
||||
};
|
||||
|
||||
my $indent = sub {
|
||||
$properties{_current_indent} += $properties{indent};
|
||||
$properties{_depth}++;
|
||||
return;
|
||||
};
|
||||
|
||||
my $outdent = sub {
|
||||
$properties{_current_indent} -= $properties{indent};
|
||||
$properties{_depth}--;
|
||||
return;
|
||||
};
|
||||
|
||||
my $imported_p = sub (\[@$%&];%) {
|
||||
my ($item, $p) = @_;
|
||||
return Data::Printer::p( $item, %properties );
|
||||
};
|
||||
|
||||
my $imported_np = sub (\[@$%&];%) {
|
||||
my ($item, $p) = @_;
|
||||
return Data::Printer::np( $item, %properties );
|
||||
};
|
||||
{
|
||||
no strict 'refs';
|
||||
*{"$caller\::filter"} = $filter;
|
||||
*{"$caller\::indent"} = $indent;
|
||||
*{"$caller\::outdent"} = $outdent;
|
||||
*{"$caller\::newline"} = $newline;
|
||||
|
||||
*{"$caller\::np"} = $imported_np;
|
||||
*{"$caller\::p"} = $imported_p;
|
||||
|
||||
*{"$caller\::_filter_list"} = $filters;
|
||||
*{"$caller\::_extra_options"} = $extras;
|
||||
}
|
||||
};
|
||||
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Data::Printer::Filter - Create powerful stand-alone filters for Data::Printer
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Create your filter module:
|
||||
|
||||
package Data::Printer::Filter::MyFilter;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Data::Printer::Filter;
|
||||
|
||||
# type filter
|
||||
filter 'SCALAR', sub {
|
||||
my ($ref, $properties) = @_;
|
||||
my $val = $$ref;
|
||||
|
||||
if ($val > 100) {
|
||||
return 'too big!!';
|
||||
}
|
||||
else {
|
||||
return $val;
|
||||
}
|
||||
};
|
||||
|
||||
# you can also filter objects of any class
|
||||
filter 'Some::Class', sub {
|
||||
my ($object, $properties) = @_;
|
||||
|
||||
return $ref->some_method; # or whatever
|
||||
|
||||
# see 'HELPER FUNCTIONS' below for
|
||||
# customization options, including
|
||||
# proper indentation.
|
||||
};
|
||||
|
||||
1;
|
||||
|
||||
|
||||
Later, in your main code:
|
||||
|
||||
use Data::Printer {
|
||||
filters => {
|
||||
-external => [ 'MyFilter', 'OtherFilter' ],
|
||||
|
||||
# you can still add regular (inline) filters
|
||||
SCALAR => sub {
|
||||
...
|
||||
}
|
||||
},
|
||||
};
|
||||
|
||||
|
||||
|
||||
=head1 WARNING - ALPHA CODE (VERY LOOSE API)
|
||||
|
||||
We are still experimenting with the standalone filter syntax, so
|
||||
B<< filters written like so may break in the future without any warning! >>
|
||||
|
||||
B<< If you care, or have any suggestions >>, please drop me a line via RT, email,
|
||||
or find me ('garu') on irc.perl.org.
|
||||
|
||||
You have been warned.
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Data::Printer> lets you add custom filters to display data structures and
|
||||
objects, by either specifying them during "use", in the C<.dataprinter>
|
||||
configuration file, or even in runtime customizations.
|
||||
|
||||
But there are times when you may want to group similar filters, or make
|
||||
them standalone in order to be easily reutilized in other environments and
|
||||
applications, or even upload them to CPAN so other people can benefit from
|
||||
a cleaner - and clearer - object/structure dump.
|
||||
|
||||
This is where C<Data::Printer::Filter> comes in. It B<exports> into your
|
||||
package's namespace the L</filter> function, along with some helpers to
|
||||
create custom filter packages.
|
||||
|
||||
L<Data::Printer> recognizes all filters in the C<Data::Printer::Filter::*>
|
||||
namespace. You can load them by specifying them in the '-external' filter
|
||||
list (note the dash, to avoid clashing with a potential class or pragma
|
||||
labelled 'external'):
|
||||
|
||||
use Data::Printer {
|
||||
filters => {
|
||||
-external => 'MyFilter',
|
||||
},
|
||||
};
|
||||
|
||||
This will load all filters defined by the C<Data::Printer::Filter::MyFilter>
|
||||
module.
|
||||
|
||||
If there are more than one filter, use an array reference instead:
|
||||
|
||||
-external => [ 'MyFilter', 'MyOtherFilter' ]
|
||||
|
||||
B<< IMPORTANT: THIS WAY OF LOADING EXTERNAL PLUGINS IS EXPERIMENTAL AND
|
||||
SUBJECT TO SUDDEN CHANGE! IF YOU CARE, AND/OR HAVE IDEAS ON A BETTER API,
|
||||
PLEASE LET US KNOW >>
|
||||
|
||||
=head1 HELPER FUNCTIONS
|
||||
|
||||
=head2 filter TYPE, sub { ... };
|
||||
|
||||
The C<filter> function creates a new filter for I<TYPE>, using
|
||||
the given subref. The subref receives two arguments: the item
|
||||
itself - be it an object or a reference to a standard Perl type -
|
||||
and the properties in effect (so you can inspect for certain
|
||||
options, etc). The subroutine is expected to return a string
|
||||
containing whatever it wants C<Data::Printer> to display on screen.
|
||||
|
||||
=head2 p()
|
||||
|
||||
This is the same as C<Data::Printer>'s p(), only you can't rename it.
|
||||
You can use this to throw some data structures back at C<Data::Printer>
|
||||
and use the results in your own return string - like when manipulating
|
||||
hashes or arrays.
|
||||
|
||||
=head2 np()
|
||||
|
||||
This is the same as C<Data::Printer>'s np(). You can use this to throw some
|
||||
data structures back at C<Data::Printer> and use the results in your own return
|
||||
string - like when manipulating hashes or arrays.
|
||||
|
||||
=head2 newline()
|
||||
|
||||
This helper returns a string using the linebreak as specified by the
|
||||
caller's settings. For instance, it provides the proper indentation
|
||||
level of spaces for you and considers the C<multiline> option to
|
||||
avoid line breakage.
|
||||
|
||||
In other words, if you do this:
|
||||
|
||||
filter ARRAY => {
|
||||
my ($ref, $p) = @_;
|
||||
my $string = "Hey!! I got this array:";
|
||||
|
||||
foreach my $val (@$ref) {
|
||||
$string .= newline . p($val);
|
||||
}
|
||||
|
||||
return $string;
|
||||
};
|
||||
|
||||
... your C<p($val)> returns will be properly indented, vertically aligned
|
||||
to your level of the data structure, while simply using "\n" would just
|
||||
make things messy if your structure has more than one level of depth.
|
||||
|
||||
=head2 indent()
|
||||
|
||||
=head2 outdent()
|
||||
|
||||
These two helpers let you increase/decrease the indentation level of
|
||||
your data display, for C<newline()> and nested C<p()> calls inside your filters.
|
||||
|
||||
For example, the filter defined in the C<newline> explanation above would
|
||||
show the values on the same (vertically aligned) level as the "I got this array"
|
||||
message. If you wanted your array to be one level further deep, you could use
|
||||
this instead:
|
||||
|
||||
filter ARRAY => {
|
||||
my ($ref, $p) = @_;
|
||||
my $string = "Hey!! I got this array:";
|
||||
|
||||
indent;
|
||||
foreach my $val (@$ref) {
|
||||
$string .= newline . p($val);
|
||||
}
|
||||
outdent;
|
||||
|
||||
return $string;
|
||||
};
|
||||
|
||||
|
||||
=head1 COLORIZATION
|
||||
|
||||
You can use L<Term::ANSIColor>'s C<colored()>' for string
|
||||
colorization. Data::Printer will automatically enable/disable
|
||||
colors for you.
|
||||
|
||||
=head1 EXISTING FILTERS
|
||||
|
||||
This is meant to provide a complete list of standalone filters for
|
||||
Data::Printer available on CPAN. If you write one, please put it under
|
||||
the C<Data::Printer::Filter::*> namespace, and drop me a line so I can
|
||||
add it to this list!
|
||||
|
||||
=head2 Databases
|
||||
|
||||
L<Data::Printer::Filter::DB> provides filters for Database objects. So
|
||||
far only DBI is covered, but more to come!
|
||||
|
||||
=head2 Dates & Times
|
||||
|
||||
L<Data::Printer::Filter::DateTime> pretty-prints several date
|
||||
and time objects (not just DateTime) for you on the fly, including
|
||||
duration/delta objects!
|
||||
|
||||
=head2 Digest
|
||||
|
||||
L<Data::Printer::Filter::Digest> displays a string containing the
|
||||
hash of the actual message digest instead of the object. Works on
|
||||
C<Digest::MD5>, C<Digest::SHA>, any digest class that inherits from
|
||||
C<Digest::base> and some others that implement their own thing!
|
||||
|
||||
=head2 ClassicRegex
|
||||
|
||||
L<Data::Printer::Filter::ClassicRegex> changes the way Data::Printer
|
||||
dumps regular expressions, doing it the classic C<qr//> way that got
|
||||
popular in C<Data::Dumper>.
|
||||
|
||||
=head2 JSON
|
||||
|
||||
L<Data::Printer::Filter::JSON>, by Nuba Princigalli, lets you see
|
||||
your JSON structures replacing boolean objects with simple C<true/false>
|
||||
strings!
|
||||
|
||||
=head2 URIs
|
||||
|
||||
L<Data::Printer::Filter::URI> filters through several L<URI> manipulation
|
||||
classes and displays the URI as a colored string. A very nice addition
|
||||
by Stanislaw Pusep (SYP).
|
||||
|
||||
=head2 Perl Data Language (PDL)
|
||||
|
||||
L<Data::Printer::Filter::PDL>, by Zakariyya Mughal, lets you quickly see
|
||||
the relevant contents of a PDL variable.
|
||||
|
||||
=head1 USING MORE THAN ONE FILTER FOR THE SAME TYPE/CLASS
|
||||
|
||||
As of version 0.13, standalone filters let you stack together
|
||||
filters for the same type or class. Filters of the same type are
|
||||
called in order, until one of them returns a string. This lets
|
||||
you have several filters inspecting the same given value until
|
||||
one of them decides to actually treat it somehow.
|
||||
|
||||
If your filter caught a value and you don't want to treat it,
|
||||
simply return and the next filter will be called. If there are no
|
||||
other filters for that particular class or type available, the
|
||||
standard Data::Printer calls will be used.
|
||||
|
||||
For example:
|
||||
|
||||
filter SCALAR => sub {
|
||||
my ($ref, $properties) = @_;
|
||||
if ( Scalar::Util::looks_like_number $$ref ) {
|
||||
return sprintf "%.8d", $$ref;
|
||||
}
|
||||
return; # lets the other SCALAR filter have a go
|
||||
};
|
||||
|
||||
filter SCALAR => sub {
|
||||
my ($ref, $properties) = @_;
|
||||
return qq["$$ref"];
|
||||
};
|
||||
|
||||
Note that this "filter stack" is not possible on inline filters, since
|
||||
it's a hash and keys with the same name are overwritten. Instead, you
|
||||
can pass them as an array reference:
|
||||
|
||||
use Data::Printer filters => {
|
||||
SCALAR => [ sub { ... }, sub { ... } ],
|
||||
};
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Data::Printer>
|
||||
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
Copyright 2011 Breno G. de Oliveira C<< <garu at cpan.org> >>. All rights reserved.
|
||||
|
||||
This module is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself. See L<perlartistic>.
|
||||
191
database/perl/vendor/lib/Data/Printer/Filter/DB.pm
vendored
Normal file
191
database/perl/vendor/lib/Data/Printer/Filter/DB.pm
vendored
Normal file
@@ -0,0 +1,191 @@
|
||||
package Data::Printer::Filter::DB;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Data::Printer::Filter;
|
||||
use Term::ANSIColor;
|
||||
|
||||
filter 'DBI::db', sub {
|
||||
my ($dbh, $p) = @_;
|
||||
my $name = $dbh->{Driver}{Name};
|
||||
|
||||
my $string = "$name Database Handle ("
|
||||
. ($dbh->{Active}
|
||||
? colored('connected', 'bright_green')
|
||||
: colored('disconnected', 'bright_red'))
|
||||
. ') {'
|
||||
;
|
||||
indent;
|
||||
my %dsn = split( /[;=]/, $dbh->{Name} );
|
||||
foreach my $k (keys %dsn) {
|
||||
$string .= newline . "$k: " . $dsn{$k};
|
||||
}
|
||||
$string .= newline . 'Auto Commit: ' . $dbh->{AutoCommit};
|
||||
|
||||
my $kids = $dbh->{Kids};
|
||||
$string .= newline . 'Statement Handles: ' . $kids;
|
||||
if ($kids > 0) {
|
||||
$string .= ' (' . $dbh->{ActiveKids} . ' active)';
|
||||
}
|
||||
|
||||
if ( defined $dbh->err ) {
|
||||
$string .= newline . 'Error: ' . $dbh->errstr;
|
||||
}
|
||||
$string .= newline . 'Last Statement: '
|
||||
. colored( ($dbh->{Statement} || '-'), 'bright_yellow');
|
||||
|
||||
outdent;
|
||||
$string .= newline . '}';
|
||||
return $string;
|
||||
};
|
||||
|
||||
filter 'DBI::st', sub {
|
||||
my ($sth, $properties) = @_;
|
||||
my $str = colored( ($sth->{Statement} || '-'), 'bright_yellow');
|
||||
|
||||
if ($sth->{NUM_OF_PARAMS} > 0) {
|
||||
my $values = $sth->{ParamValues};
|
||||
if ($values) {
|
||||
$str .= ' ('
|
||||
. join(', ',
|
||||
map {
|
||||
my $v = $values->{$_};
|
||||
$v || 'undef';
|
||||
} 1 .. $sth->{NUM_OF_PARAMS}
|
||||
)
|
||||
. ')';
|
||||
}
|
||||
else {
|
||||
$str .= colored(' (bindings unavailable)', 'yellow');
|
||||
}
|
||||
}
|
||||
return $str;
|
||||
};
|
||||
|
||||
# DBIx::Class filters
|
||||
filter '-class' => sub {
|
||||
my ($obj, $properties) = @_;
|
||||
|
||||
# TODO: if it's a Result, show columns and relationships (anything that
|
||||
# doesn't involve touching the database
|
||||
if ( $obj->isa('DBIx::Class::Schema') ) {
|
||||
return ref($obj) . ' DBIC Schema with ' . p( $obj->storage->dbh );
|
||||
# TODO: show a list of all class_mappings available for the schema
|
||||
# (a.k.a. tables)
|
||||
}
|
||||
elsif ( grep { $obj->isa($_) } qw(DBIx::Class::ResultSet DBIx::Class::ResultSetColumn) ) {
|
||||
|
||||
my $str = colored( ref($obj), $properties->{color}{class} );
|
||||
$str .= ' (' . $obj->result_class . ')'
|
||||
if $obj->can( 'result_class' );
|
||||
|
||||
if (my $query_data = $obj->as_query) {
|
||||
my @query_data = @$$query_data;
|
||||
indent;
|
||||
my $sql = shift @query_data;
|
||||
$str .= ' {'
|
||||
. newline . colored($sql, 'bright_yellow')
|
||||
. newline . join ( newline, map {
|
||||
$_->[1] . ' (' . $_->[0]{sqlt_datatype} . ')'
|
||||
} @query_data
|
||||
)
|
||||
;
|
||||
outdent;
|
||||
$str .= newline . '}';
|
||||
}
|
||||
|
||||
return $str;
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
};
|
||||
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Data::Printer::Filter::DB - pretty printing database objects
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
In your program:
|
||||
|
||||
use Data::Printer filters => {
|
||||
-external => [ 'DB' ],
|
||||
};
|
||||
|
||||
or, in your C<.dataprinter> file:
|
||||
|
||||
{
|
||||
filters => {
|
||||
-external => [ 'DB' ],
|
||||
},
|
||||
};
|
||||
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a filter plugin for L<Data::Printer>. It filters through L<DBI>'s
|
||||
handlers (dbh) and statement (sth) objects displaying relevant information for
|
||||
the user. It also filters any object which inherits from
|
||||
L<DBIx::Class::Schema>, L<DBIx::Class::ResultSet> or
|
||||
L<DBIx::Class::ResultSetColumn>.
|
||||
|
||||
=head2 DBI Sample Output
|
||||
|
||||
L<DBI> is an extremely powerful and complete database interface. But
|
||||
it does a lot of magic under the hood, making their objects somewhat harder
|
||||
to debug. This filter aims to fix that :)
|
||||
|
||||
For instance, say you want to debug something like this:
|
||||
|
||||
use DBI;
|
||||
my $dbh = DBI->connect('dbi:DBM(RaiseError=1):', undef, undef );
|
||||
|
||||
A regular Data::Dumper output gives you absolutely nothing:
|
||||
|
||||
$VAR1 = bless( {}, 'DBI::db' );
|
||||
|
||||
L<Data::Printer> makes it better, but only to debug the class itself,
|
||||
not helpful at all to see its contents and debug your own code:
|
||||
|
||||
DBI::db {
|
||||
Parents DBI::common
|
||||
Linear @ISA DBI::db, DBI::common
|
||||
public methods (48) : begin_work, clone, column_info, commit, connected, data_sources, disconnect, do, foreign_key_info, get_info, last_insert_id, ping, prepare, prepare_cached, preparse, primary_key, primary_key_info, quote, quote_identifier, rollback, rows, selectall_arrayref, selectall_hashref, selectcol_arrayref, selectrow_array, selectrow_arrayref, selectrow_hashref, sqlite_backup_from_file, sqlite_backup_to_file, sqlite_busy_timeout, sqlite_collation_needed, sqlite_commit_hook, sqlite_create_aggregate, sqlite_create_collation, sqlite_create_function, sqlite_enable_load_extension, sqlite_last_insert_rowid, sqlite_progress_handler, sqlite_register_fts3_perl_tokenizer, sqlite_rollback_hook, sqlite_set_authorizer, sqlite_update_hook, statistics_info, table_info, tables, take_imp_data, type_info, type_info_all
|
||||
private methods (0)
|
||||
internals: {
|
||||
}
|
||||
}
|
||||
|
||||
Fear no more! If you use this filter, here's what you'll see:
|
||||
|
||||
SQLite Database Handle (connected) {
|
||||
dbname: file.db
|
||||
Auto Commit: 1
|
||||
Statement Handles: 0
|
||||
Last Statement: -
|
||||
}
|
||||
|
||||
Much better, huh? :)
|
||||
|
||||
Statement handlers are even better. Imagine you continued your code with something like:
|
||||
|
||||
my $sth = $dbh->prepare('SELECT * FROM foo WHERE bar = ?');
|
||||
$sth->execute(42);
|
||||
|
||||
With this filter, instead of an empty dump or full method information, you'll get
|
||||
exactly what you came for:
|
||||
|
||||
SELECT * FROM foo WHERE bar = ? (42)
|
||||
|
||||
Note that if your driver does not support holding of parameter values, you'll get a
|
||||
C<bindings unavailable> message instead of the bound values.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Data::Printer>, L<Data::Printer::Filter>
|
||||
165
database/perl/vendor/lib/Data/Printer/Filter/DateTime.pm
vendored
Normal file
165
database/perl/vendor/lib/Data/Printer/Filter/DateTime.pm
vendored
Normal file
@@ -0,0 +1,165 @@
|
||||
package Data::Printer::Filter::DateTime;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Data::Printer::Filter;
|
||||
use Term::ANSIColor;
|
||||
|
||||
filter 'Time::Piece', sub {
|
||||
return _format($_[0]->cdate, @_ );
|
||||
};
|
||||
|
||||
filter 'DateTime', sub {
|
||||
my ($obj, $p) = @_;
|
||||
my $string = "$obj";
|
||||
if ( not exists $p->{datetime}{show_timezone} or $p->{datetime}{show_timezone} ) {
|
||||
$string .= ' [' . $obj->time_zone->name . ']';
|
||||
}
|
||||
return _format( $string, @_ );
|
||||
};
|
||||
|
||||
# DateTime::TimeZone filters
|
||||
filter '-class' => sub {
|
||||
my ($obj, $properties) = @_;
|
||||
|
||||
if ( $obj->isa('DateTime::TimeZone' ) ) {
|
||||
return $obj->name;
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
};
|
||||
|
||||
filter 'DateTime::Incomplete', sub {
|
||||
return _format( $_[0]->iso8601, @_ );
|
||||
};
|
||||
|
||||
filter 'DateTime::Duration', sub {
|
||||
my ($object, $p) = @_;
|
||||
|
||||
my @dur = $object->in_units(
|
||||
qw(years months days hours minutes seconds)
|
||||
);
|
||||
|
||||
my $string = "$dur[0]y $dur[1]m $dur[2]d $dur[3]h $dur[4]m $dur[5]s";
|
||||
|
||||
return _format( $string, @_ );
|
||||
};
|
||||
|
||||
filter 'DateTime::Tiny', sub {
|
||||
return _format( $_[0]->as_string, @_ );
|
||||
};
|
||||
|
||||
filter 'Class::Date', sub {
|
||||
my ($object, $p) = @_;
|
||||
|
||||
my $string = $object->strftime("%Y-%m-%d %H:%M:%S") . " [" . $object->tzdst . "]";
|
||||
|
||||
return _format( $string, @_ );
|
||||
};
|
||||
|
||||
filter 'Date::Calc::Object', sub {
|
||||
return _format( $_[0]->string(2), @_ );
|
||||
};
|
||||
|
||||
filter 'Date::Pcalc::Object', sub {
|
||||
return _format( $_[0]->string(2), @_ );
|
||||
};
|
||||
|
||||
filter 'Date::Handler', sub {
|
||||
return _format( "$_[0]", @_ );
|
||||
};
|
||||
|
||||
filter 'Date::Handler::Delta', sub {
|
||||
return _format( $_[0]->AsScalar, @_ );
|
||||
};
|
||||
|
||||
|
||||
sub _format {
|
||||
my ($str, $obj, $p) = @_;
|
||||
|
||||
if ( $p->{datetime}{show_class_name} ) {
|
||||
$str .= ' (' . ref($obj) . ')';
|
||||
}
|
||||
|
||||
my $color = $p->{color}{datetime};
|
||||
$color = 'bright_green' unless defined $color;
|
||||
|
||||
return colored( $str, $color );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Data::Printer::Filter::DateTime - pretty-printing date and time objects (not just DateTime!)
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
In your program:
|
||||
|
||||
use Data::Printer filters => {
|
||||
-external => [ 'DateTime' ],
|
||||
};
|
||||
|
||||
or, in your C<.dataprinter> file:
|
||||
|
||||
{
|
||||
filters => {
|
||||
-external => [ 'DateTime' ],
|
||||
},
|
||||
};
|
||||
|
||||
You can also setup color and display details:
|
||||
|
||||
use Data::Printer
|
||||
filters => {
|
||||
-external => [ 'DateTime' ],
|
||||
},
|
||||
color => {
|
||||
datetime => 'bright_green',
|
||||
}
|
||||
datetime => {
|
||||
show_class_name => 1, # default is 0
|
||||
show_timezone => 0, # default is 1 (only works for DateTime objects)
|
||||
},
|
||||
};
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a filter plugin for L<Data::Printer>. It filters through
|
||||
several date and time manipulation classes and displays the time
|
||||
(or time duration) as a string.
|
||||
|
||||
=head2 Parsed Modules
|
||||
|
||||
=over 4
|
||||
|
||||
=item * L<DateTime>
|
||||
|
||||
=item * L<DateTime::Duration>
|
||||
|
||||
=item * L<DateTime::Incomplete>
|
||||
|
||||
=item * L<Class::Date>
|
||||
|
||||
=item * L<Time::Piece>
|
||||
|
||||
=item * L<Date::Handler>
|
||||
|
||||
=item * L<Date::Handler::Delta>
|
||||
|
||||
=item * L<Date::Calc::Object>
|
||||
|
||||
=item * L<Date::Pcalc::Object>
|
||||
|
||||
=back
|
||||
|
||||
If you have any suggestions for more modules or better output,
|
||||
please let us know.
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Data::Printer>
|
||||
143
database/perl/vendor/lib/Data/Printer/Filter/Digest.pm
vendored
Normal file
143
database/perl/vendor/lib/Data/Printer/Filter/Digest.pm
vendored
Normal file
@@ -0,0 +1,143 @@
|
||||
package Data::Printer::Filter::Digest;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Data::Printer::Filter;
|
||||
use Term::ANSIColor;
|
||||
|
||||
foreach my $digest ( qw(Digest::MD2 Digest::MD4) ) {
|
||||
filter $digest => \&_print_digest;
|
||||
}
|
||||
|
||||
filter '-class', sub {
|
||||
my ($obj, $p) = @_;
|
||||
return unless $obj->isa( 'Digest::base' );
|
||||
return _print_digest( $obj, $p );
|
||||
};
|
||||
|
||||
|
||||
sub _print_digest {
|
||||
my ($obj, $p) = @_;
|
||||
my $digest = $obj->clone->hexdigest;
|
||||
my $str = $digest;
|
||||
my $ref = ref $obj;
|
||||
|
||||
if ( $p->{digest}{show_class_name} ) {
|
||||
$str .= " ($ref)";
|
||||
}
|
||||
|
||||
unless ( exists $p->{digest}{show_reset}
|
||||
and !$p->{digest}{show_reset}
|
||||
) {
|
||||
if ($digest eq $ref->new->hexdigest) {
|
||||
$str .= ' [reset]';
|
||||
}
|
||||
}
|
||||
|
||||
my $color = $p->{color}{digest};
|
||||
$color = 'bright_green' unless defined $color;
|
||||
|
||||
return colored( $str, $color );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Data::Printer::Filter::Digest - pretty-printing MD5, SHA and friends
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
In your program:
|
||||
|
||||
use Data::Printer filters => {
|
||||
-external => [ 'Digest' ],
|
||||
};
|
||||
|
||||
or, in your C<.dataprinter> file:
|
||||
|
||||
{
|
||||
filters => {
|
||||
-external => [ 'Digest' ],
|
||||
},
|
||||
};
|
||||
|
||||
You can also setup color and display details:
|
||||
|
||||
use Data::Printer
|
||||
filters => {
|
||||
-external => [ 'Digest' ],
|
||||
},
|
||||
color => {
|
||||
digest => 'bright_green',
|
||||
}
|
||||
digest => {
|
||||
show_class_name => 0, # default.
|
||||
show_reset => 1, # default.
|
||||
},
|
||||
};
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a filter plugin for L<Data::Printer>. It filters through
|
||||
several digest classes and displays their current value in
|
||||
hexadecimal format as a string.
|
||||
|
||||
=head2 Parsed Modules
|
||||
|
||||
=over 4
|
||||
|
||||
=item * L<Digest::Adler32>
|
||||
|
||||
=item * L<Digest::MD2>
|
||||
|
||||
=item * L<Digest::MD4>
|
||||
|
||||
=item * L<Digest::MD5>
|
||||
|
||||
=item * L<Digest::SHA>
|
||||
|
||||
=item * L<Digest::SHA1>
|
||||
|
||||
=item * L<Digest::Whirlpool>
|
||||
|
||||
=back
|
||||
|
||||
If you have any suggestions for more modules or better output,
|
||||
please let us know.
|
||||
|
||||
=head2 Extra Options
|
||||
|
||||
Aside from the display color, there are a few other options to
|
||||
be customized via the C<digest> option key:
|
||||
|
||||
=head3 show_class_name
|
||||
|
||||
Set this to true to display the class name right next to the
|
||||
hexadecimal digest. Default is 0 (false).
|
||||
|
||||
=head3 show_reset
|
||||
|
||||
If set to true (the default), the filter will add a C<[reset]>
|
||||
tag after dumping an empty digest object. See the rationale below.
|
||||
|
||||
=head2 Note on dumping Digest::* objects
|
||||
|
||||
The digest operation is effectively a destructive, read-once operation. Once it has been performed, most Digest::* objects are automatically reset and can be used to calculate another digest value.
|
||||
|
||||
This behaviour - or, rather, forgetting about this behaviour - is
|
||||
a common source of issues when working with Digests.
|
||||
|
||||
This Data::Printer filter will B<not> destroy your object. Instead, we work on a cloned version to display the hexdigest, leaving your
|
||||
original object untouched.
|
||||
|
||||
As another debugging convenience for developers, since the empty
|
||||
object will produce a digest even after being used, this filter
|
||||
adds by default a C<[reset]> tag to indicate that the object is
|
||||
empty, in a 'reset' state - i.e. its hexdigest is the same as
|
||||
the hexdigest of a new, empty object of that same class.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Data::Printer>
|
||||
Reference in New Issue
Block a user