Initial Commit
This commit is contained in:
Riley Schneider
465
database/perl/vendor/lib/Data/Buffer.pm
vendored
Normal file
465
database/perl/vendor/lib/Data/Buffer.pm
vendored
Normal file
@@ -0,0 +1,465 @@
|
||||
# $Id: Buffer.pm,v 1.9 2001/07/28 06:36:50 btrott Exp $
|
||||
|
||||
package Data::Buffer;
|
||||
use strict;
|
||||
|
||||
use vars qw( $VERSION );
|
||||
$VERSION = '0.04';
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %arg = @_;
|
||||
bless { buf => "", offset => 0, template => "" }, $class;
|
||||
}
|
||||
|
||||
sub new_with_init {
|
||||
my $class = shift;
|
||||
my $buf = $class->new;
|
||||
$buf->append($_) for @_;
|
||||
$buf;
|
||||
}
|
||||
|
||||
sub extract {
|
||||
my $buf = shift;
|
||||
my($nbytes) = @_;
|
||||
my $new = ref($buf)->new;
|
||||
$new->append( $buf->get_bytes($nbytes) );
|
||||
$new;
|
||||
}
|
||||
|
||||
sub empty {
|
||||
my $buf = shift;
|
||||
$buf->{buf} = "";
|
||||
$buf->{offset} = 0;
|
||||
$buf->{template} = "";
|
||||
}
|
||||
|
||||
sub set_offset { $_[0]->{offset} = $_[1] }
|
||||
sub reset_offset { $_[0]->set_offset(0) }
|
||||
|
||||
sub insert_template {
|
||||
my $buf = shift;
|
||||
$buf->bytes(0, 0, $buf->{template} . chr(0));
|
||||
}
|
||||
|
||||
sub append {
|
||||
my $buf = shift;
|
||||
$buf->{buf} .= $_[0];
|
||||
}
|
||||
|
||||
sub bytes {
|
||||
my $buf = shift;
|
||||
my($off, $len, $rep) = @_;
|
||||
$off ||= 0;
|
||||
$len = length $buf->{buf} unless defined $len;
|
||||
return defined $rep ?
|
||||
substr($buf->{buf}, $off, $len, $rep) :
|
||||
substr($buf->{buf}, $off, $len);
|
||||
}
|
||||
|
||||
sub length { length $_[0]->{buf} }
|
||||
sub offset { $_[0]->{offset} }
|
||||
sub template { $_[0]->{template} }
|
||||
|
||||
sub dump {
|
||||
my $buf = shift;
|
||||
my @r;
|
||||
for my $c (split //, $buf->bytes(@_)) {
|
||||
push @r, sprintf "%02x", ord $c;
|
||||
push @r, "\n" unless @r % 24;
|
||||
}
|
||||
join ' ', @r
|
||||
}
|
||||
|
||||
sub get_all {
|
||||
my $buf = shift;
|
||||
my($tmpl, $data) = $buf->{buf} =~ /^([NYaCn\d]+)\0(.+)$/s or
|
||||
die "Buffer $buf does not appear to contain a template";
|
||||
my $b = __PACKAGE__->new;
|
||||
$b->append($data);
|
||||
my @tmpl = split //, $tmpl;
|
||||
my @data;
|
||||
while (@tmpl) {
|
||||
my $el = shift @tmpl;
|
||||
if ($el eq "N") {
|
||||
next if $tmpl[0] eq "Y"; ## Peek ahead: is it a string?
|
||||
push @data, $b->get_int32;
|
||||
}
|
||||
elsif ($el eq "n") {
|
||||
push @data, $b->get_int16;
|
||||
}
|
||||
elsif ($el eq "C") {
|
||||
push @data, $b->get_int8;
|
||||
}
|
||||
elsif ($el eq "a") {
|
||||
my $len = shift @tmpl;
|
||||
push @data, $b->get_char for 1..$len;
|
||||
}
|
||||
elsif ($el eq "Y") {
|
||||
push @data, $b->get_str;
|
||||
}
|
||||
else {
|
||||
die "Unrecognized template token: $el";
|
||||
}
|
||||
}
|
||||
@data;
|
||||
}
|
||||
|
||||
sub get_int8 {
|
||||
my $buf = shift;
|
||||
my $off = defined $_[0] ? shift : $buf->{offset};
|
||||
$buf->{offset} += 1;
|
||||
unpack "C", $buf->bytes($off, 1);
|
||||
}
|
||||
|
||||
sub put_int8 {
|
||||
my $buf = shift;
|
||||
$buf->{buf} .= pack "C", $_[0];
|
||||
$buf->{template} .= "C";
|
||||
}
|
||||
|
||||
sub get_int16 {
|
||||
my $buf = shift;
|
||||
my $off = defined $_[0] ? shift : $buf->{offset};
|
||||
$buf->{offset} += 2;
|
||||
unpack "n", $buf->bytes($off, 2);
|
||||
}
|
||||
|
||||
sub put_int16 {
|
||||
my $buf = shift;
|
||||
$buf->{buf} .= pack "n", $_[0];
|
||||
$buf->{template} .= "n";
|
||||
}
|
||||
|
||||
sub get_int32 {
|
||||
my $buf = shift;
|
||||
my $off = defined $_[0] ? shift : $buf->{offset};
|
||||
$buf->{offset} += 4;
|
||||
unpack "N", $buf->bytes($off, 4);
|
||||
}
|
||||
|
||||
sub put_int32 {
|
||||
my $buf = shift;
|
||||
$buf->{buf} .= pack "N", $_[0];
|
||||
$buf->{template} .= "N";
|
||||
}
|
||||
|
||||
sub get_char {
|
||||
my $buf = shift;
|
||||
my $off = defined $_[0] ? shift : $buf->{offset};
|
||||
$buf->{offset}++;
|
||||
$buf->bytes($off, 1);
|
||||
}
|
||||
|
||||
sub put_char {
|
||||
my $buf = shift;
|
||||
$buf->{buf} .= $_[0];
|
||||
$buf->{template} .= "a" . CORE::length($_[0]);
|
||||
}
|
||||
|
||||
sub get_bytes {
|
||||
my $buf = shift;
|
||||
my($nbytes) = @_;
|
||||
my $d = $buf->bytes($buf->{offset}, $nbytes);
|
||||
$buf->{offset} += $nbytes;
|
||||
$d;
|
||||
}
|
||||
|
||||
sub put_bytes {
|
||||
my $buf = shift;
|
||||
my($str, $nbytes) = @_;
|
||||
$buf->{buf} .= $nbytes ? substr($str, 0, $nbytes) : $str;
|
||||
$buf->{template} .= "a" . ($nbytes ? $nbytes : CORE::length($str));
|
||||
}
|
||||
|
||||
*put_chars = \&put_char;
|
||||
|
||||
sub get_str {
|
||||
my $buf = shift;
|
||||
my $off = defined $_[0] ? shift : $buf->{offset};
|
||||
my $len = $buf->get_int32;
|
||||
$buf->{offset} += $len;
|
||||
$buf->bytes($off+4, $len);
|
||||
}
|
||||
|
||||
sub put_str {
|
||||
my $buf = shift;
|
||||
my $str = shift;
|
||||
$str = "" unless defined $str;
|
||||
$buf->put_int32(CORE::length($str));
|
||||
$buf->{buf} .= $str;
|
||||
$buf->{template} .= "Y";
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Data::Buffer - Read/write buffer class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Data::Buffer;
|
||||
my $buffer = Data::Buffer->new;
|
||||
|
||||
## Add a 32-bit integer.
|
||||
$buffer->put_int32(10932930);
|
||||
|
||||
## Get it back.
|
||||
my $int = $buffer->get_int32;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
I<Data::Buffer> implements a low-level binary buffer in which
|
||||
you can get and put integers, strings, and other data.
|
||||
Internally the implementation is based on C<pack> and C<unpack>,
|
||||
such that I<Data::Buffer> is really a layer on top of those
|
||||
built-in functions.
|
||||
|
||||
All of the I<get_*> and I<put_*> methods respect the
|
||||
internal offset state in the buffer object. This means that
|
||||
you should read data out of the buffer in the same order that
|
||||
you put it in. For example:
|
||||
|
||||
$buf->put_int16(24);
|
||||
$buf->put_int32(1233455);
|
||||
$buf->put_int16(99);
|
||||
|
||||
$buf->get_int16; # 24
|
||||
$buf->get_int32; # 1233455
|
||||
$buf->get_int16; # 99
|
||||
|
||||
Of course, this assumes that you I<know> the order of the data
|
||||
items in the buffer. If your setup is such that your sending
|
||||
and receiving processes won't necessarily know what's inside
|
||||
the buffers they receive, take a look at the I<TEMPLATE USAGE>
|
||||
section.
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
=head2 Data::Buffer->new
|
||||
|
||||
Creates a new buffer object and returns it. The buffer is
|
||||
initially empty.
|
||||
|
||||
This method takes no arguments.
|
||||
|
||||
=head2 Data::Buffer->new_with_init(@strs)
|
||||
|
||||
Creates a new buffer object and appends to it each of the
|
||||
octet strings in I<@strs>.
|
||||
|
||||
Returns the new buffer object.
|
||||
|
||||
=head2 $buffer->get_int8
|
||||
|
||||
Returns the next 8-bit integer from the buffer (which
|
||||
is really just the ASCII code for the next character/byte
|
||||
in the buffer).
|
||||
|
||||
=head2 $buffer->put_int8
|
||||
|
||||
Appends an 8-bit integer to the buffer (which is really
|
||||
just the character corresponding to that integer, in
|
||||
ASCII).
|
||||
|
||||
=head2 $buffer->get_int16
|
||||
|
||||
Returns the next 16-bit integer from the buffer.
|
||||
|
||||
=head2 $buffer->put_int16($integer)
|
||||
|
||||
Appends a 16-bit integer to the buffer.
|
||||
|
||||
=head2 $buffer->get_int32
|
||||
|
||||
Returns the next 32-bit integer from the buffer.
|
||||
|
||||
=head2 $buffer->put_int32($integer)
|
||||
|
||||
Appends a 32-bit integer to the buffer.
|
||||
|
||||
=head2 $buffer->get_char
|
||||
|
||||
More appropriately called I<get_byte>, perhaps, this
|
||||
returns the next byte from the buffer.
|
||||
|
||||
=head2 $buffer->put_char($bytes)
|
||||
|
||||
Appends a byte (or a sequence of bytes) to the buffer.
|
||||
There is no restriction on the length of the byte
|
||||
string I<$bytes>; if it makes you uncomfortable to call
|
||||
I<put_char> to put multiple bytes, you can instead
|
||||
call this method as I<put_chars>. It's the same thing.
|
||||
|
||||
=head2 $buffer->get_bytes($n)
|
||||
|
||||
Grabs I<$n> bytes from the buffer, where I<$n> is a positive
|
||||
integer. Increments the internal offset state by I<$n>.
|
||||
|
||||
=head2 $buffer->put_bytes($bytes [, $n ])
|
||||
|
||||
Appends a sequence of bytes to the buffer; if I<$n> is
|
||||
unspecified, appends the entire length of I<$bytes>.
|
||||
Otherwise appends only the first I<$n> bytes of I<$bytes>.
|
||||
|
||||
=head2 $buffer->get_str
|
||||
|
||||
Returns the next "string" from the buffer. A string here
|
||||
is represented as the length of the string (a 32-bit
|
||||
integer) followed by the string itself.
|
||||
|
||||
=head2 $buffer->put_str($string)
|
||||
|
||||
Appends a string (32-bit integer length and the string
|
||||
itself) to the buffer.
|
||||
|
||||
=head2 $buffer->extract($n)
|
||||
|
||||
Extracts the next I<$n> bytes from the buffer I<$buffer>,
|
||||
increments the offset state in I<$buffer>, and returns a
|
||||
new buffer object containing the extracted bytes.
|
||||
|
||||
=head1 TEMPLATE USAGE
|
||||
|
||||
Generally when you use I<Data::Buffer> it's to communicate
|
||||
with another process (perhaps a C program) that bundles up
|
||||
its data into binary buffers. In those cases, it's very likely
|
||||
that the data will be in some well-known order in the buffer:
|
||||
in other words, it might be documented that a certain C program
|
||||
creates a buffer containing:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * an int8
|
||||
|
||||
=item * a string
|
||||
|
||||
=item * an int32
|
||||
|
||||
=back
|
||||
|
||||
In this case, you would presumably know about the order of the
|
||||
data in the buffer, and you could extract it accordingly:
|
||||
|
||||
$buffer->get_int8;
|
||||
$buffer->get_str;
|
||||
$buffer->get_int32;
|
||||
|
||||
In other cases, however, there may not be a well-defined order
|
||||
of data items in the buffer. This might be the case if you're
|
||||
inventing your own protocol, and you want your binary buffers
|
||||
to "know" about their contents. In this case, you'll want to
|
||||
use the templating features of I<Data::Buffer>.
|
||||
|
||||
When you use the I<put_> methods to place data in a buffer,
|
||||
I<Data::Buffer> keeps track of the types of data that you're
|
||||
inserting in a template description of the buffer. This template
|
||||
contains all of the information necessary for a process to
|
||||
receive a buffer and extract the data in the buffer without
|
||||
knowledge of the order of the items.
|
||||
|
||||
To use this feature, simply use the I<insert_template> method
|
||||
after you've filled your buffer to completion. For example:
|
||||
|
||||
my $buffer = Data::Buffer->new;
|
||||
$buffer->put_str("foo");
|
||||
$buffer->put_int32(9999);
|
||||
$buffer->insert_template;
|
||||
|
||||
## Ship off the buffer to another process.
|
||||
|
||||
The receiving process should then invoke the I<get_all> method
|
||||
on the buffer to extract all of the data:
|
||||
|
||||
my $buffer = Data::Buffer->new;
|
||||
$buffer->append( $received_buffer_data );
|
||||
my @data = $buffer->get_all;
|
||||
|
||||
@data will now contain two elements: C<"foo"> and C<9999>.
|
||||
|
||||
=head1 LOW-LEVEL METHODS
|
||||
|
||||
=head2 $buffer->append($bytes)
|
||||
|
||||
Appends raw data I<$bytes> to the end of the in-memory
|
||||
buffer. Generally you don't need to use this method
|
||||
unless you're initializing an empty buffer, because
|
||||
when you need to add data to a buffer you should
|
||||
generally use one of the I<put_*> methods.
|
||||
|
||||
=head2 $buffer->empty
|
||||
|
||||
Empties out the buffer object.
|
||||
|
||||
=head2 $buffer->bytes([ $offset [, $length [, $replacement ]]])
|
||||
|
||||
Behaves exactly like the I<substr> built-in function,
|
||||
except on the buffer I<$buffer>. Given no arguments,
|
||||
I<bytes> returns the entire buffer; given one argument
|
||||
I<$offset>, returns everything from that position to
|
||||
the end of the string; given I<$offset> and I<$length>,
|
||||
returns the segment of the buffer starting at I<$offset>
|
||||
and consisting of I<$length> bytes; and given all three
|
||||
arguments, replaces that segment with I<$replacement>.
|
||||
|
||||
This is a very low-level method, and you generally
|
||||
won't need to use it.
|
||||
|
||||
Also be warned that you should not intermix use of this
|
||||
method with use of the I<get_*> and I<put_*> methods;
|
||||
the latter classes of methods maintain internal state
|
||||
of the buffer offset where arguments will be gotten from
|
||||
and put, respectively. The I<bytes> method gives no
|
||||
thought to this internal offset state.
|
||||
|
||||
=head2 $buffer->length
|
||||
|
||||
Returns the length of the buffer object.
|
||||
|
||||
=head2 $buffer->offset
|
||||
|
||||
Returns the internal offset state.
|
||||
|
||||
If you insist on intermixing calls to I<bytes> with calls
|
||||
to the I<get_*> and I<put_*> methods, you'll probably
|
||||
want to use this method to get some status on that
|
||||
internal offset.
|
||||
|
||||
=head2 $buffer->set_offset($offset)
|
||||
|
||||
Sets the internal offset state to I<$offset>.
|
||||
|
||||
=head2 $buffer->reset_offset
|
||||
|
||||
Sets the internal offset state to 0.
|
||||
|
||||
=head2 $buffer->dump(@args)
|
||||
|
||||
Returns a hex dump of the buffer. The dump is of the I<entire>
|
||||
buffer I<$buffer>; in other words, I<dump> doesn't respect the
|
||||
internal offset pointer.
|
||||
|
||||
I<@args> is passed directly through to the I<bytes> method,
|
||||
which means that you can supply arguments to emulate support
|
||||
of the internal offset:
|
||||
|
||||
my $dump = $buffer->dump($buffer->offset);
|
||||
|
||||
=head2 $buffer->insert_padding
|
||||
|
||||
A helper method: pads out the buffer so that the length
|
||||
of the transferred packet will be evenly divisible by
|
||||
8, which is a requirement of the SSH protocol.
|
||||
|
||||
=head1 AUTHOR & COPYRIGHTS
|
||||
|
||||
Benjamin Trott, ben@rhumba.pair.com
|
||||
|
||||
Except where otherwise noted, Data::Buffer is Copyright 2001
|
||||
Benjamin Trott. All rights reserved. Data::Buffer is free
|
||||
software; you may redistribute it and/or modify it under
|
||||
the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
3977
database/perl/vendor/lib/Data/Dump/Streamer.pm
vendored
Normal file
3977
database/perl/vendor/lib/Data/Dump/Streamer.pm
vendored
Normal file
File diff suppressed because it is too large
Load Diff
58
database/perl/vendor/lib/Data/Dump/Streamer/_/Printers.pm
vendored
Normal file
58
database/perl/vendor/lib/Data/Dump/Streamer/_/Printers.pm
vendored
Normal file
@@ -0,0 +1,58 @@
|
||||
{
|
||||
package Data::Dump::Streamer::_::StringPrinter;
|
||||
#$Id: Printers.pm 26 2006-04-16 15:18:52Z demerphq $#
|
||||
$VERSION= "0.1";
|
||||
my %items;
|
||||
sub DESTROY { delete $items{$_[0]} }
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = bless \do { my $str = '' }, $class;
|
||||
$self->print(@_);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub print {
|
||||
my $self = shift;
|
||||
$items{$self} .= join "", @_;
|
||||
}
|
||||
sub value { $items{$_[0]} }
|
||||
sub string { $_[0]->value() }
|
||||
1;
|
||||
}
|
||||
|
||||
{
|
||||
|
||||
package Data::Dump::Streamer::_::ListPrinter;
|
||||
$VERSION= "0.1";
|
||||
my %items;
|
||||
sub DESTROY { delete $items{$_[0]} }
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = bless \do { my $str = '' }, $class;
|
||||
$items{$self} = [];
|
||||
$self->print(@_);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub print {
|
||||
my $self = $items{shift (@_)};
|
||||
my $str = join ( '', @_ );
|
||||
if ( !@$self
|
||||
or $self->[-1] =~ /\n/
|
||||
or length( $self->[-1] ) > 4000 )
|
||||
{
|
||||
push @{$self}, $str;
|
||||
} else {
|
||||
$self->[-1] .= $str;
|
||||
}
|
||||
}
|
||||
sub value { @{$items{$_[0]}} }
|
||||
sub string { join ( '', @{$items{$_[0]}} ) }
|
||||
1;
|
||||
}
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
161
database/perl/vendor/lib/Data/Dumper/Concise.pm
vendored
Normal file
161
database/perl/vendor/lib/Data/Dumper/Concise.pm
vendored
Normal file
@@ -0,0 +1,161 @@
|
||||
package Data::Dumper::Concise;
|
||||
|
||||
use 5.006;
|
||||
|
||||
our $VERSION = '2.023';
|
||||
|
||||
require Exporter;
|
||||
require Data::Dumper;
|
||||
|
||||
BEGIN { @ISA = qw(Exporter) }
|
||||
|
||||
@EXPORT = qw(Dumper DumperF DumperObject);
|
||||
|
||||
sub DumperObject {
|
||||
my $dd = Data::Dumper->new([]);
|
||||
$dd->Trailingcomma(1) if $dd->can('Trailingcomma');
|
||||
$dd->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1);
|
||||
}
|
||||
|
||||
sub Dumper { DumperObject->Values([ @_ ])->Dump }
|
||||
|
||||
sub DumperF (&@) {
|
||||
my $code = shift;
|
||||
return $code->(map Dumper($_), @_);
|
||||
}
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Data::Dumper::Concise - Less indentation and newlines plus sub deparsing
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Data::Dumper::Concise;
|
||||
|
||||
warn Dumper($var);
|
||||
|
||||
is equivalent to:
|
||||
|
||||
use Data::Dumper;
|
||||
{
|
||||
local $Data::Dumper::Terse = 1;
|
||||
local $Data::Dumper::Indent = 1;
|
||||
local $Data::Dumper::Useqq = 1;
|
||||
local $Data::Dumper::Deparse = 1;
|
||||
local $Data::Dumper::Quotekeys = 0;
|
||||
local $Data::Dumper::Sortkeys = 1;
|
||||
local $Data::Dumper::Trailingcomma = 1;
|
||||
warn Dumper($var);
|
||||
}
|
||||
|
||||
So for the structure:
|
||||
|
||||
{ foo => "bar\nbaz", quux => sub { "fleem" } };
|
||||
|
||||
Data::Dumper::Concise will give you:
|
||||
|
||||
{
|
||||
foo => "bar\nbaz",
|
||||
quux => sub {
|
||||
use warnings;
|
||||
use strict 'refs';
|
||||
'fleem';
|
||||
},
|
||||
}
|
||||
|
||||
instead of the default Data::Dumper output:
|
||||
|
||||
$VAR1 = {
|
||||
'quux' => sub { "DUMMY" },
|
||||
'foo' => 'bar
|
||||
baz'
|
||||
};
|
||||
|
||||
(note the tab indentation, oh joy ...)
|
||||
|
||||
(The trailing comma on the last element of an array or hash is enabled by a new
|
||||
feature in Data::Dumper version 2.159, which was first released in Perl 5.24.
|
||||
Using Data::Dumper::Concise with an older version of Data::Dumper will still
|
||||
work, but you won't get those commas.)
|
||||
|
||||
If you need to get the underlying L<Dumper> object just call C<DumperObject>.
|
||||
|
||||
Also try out C<DumperF> which takes a C<CodeRef> as the first argument to
|
||||
format the output. For example:
|
||||
|
||||
use Data::Dumper::Concise;
|
||||
|
||||
warn DumperF { "result: $_[0] result2: $_[1]" } $foo, $bar;
|
||||
|
||||
Which is the same as:
|
||||
|
||||
warn 'result: ' . Dumper($foo) . ' result2: ' . Dumper($bar);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module always exports a single function, Dumper, which can be called
|
||||
with an array of values to dump those values.
|
||||
|
||||
It exists, fundamentally, as a convenient way to reproduce a set of Dumper
|
||||
options that we've found ourselves using across large numbers of applications,
|
||||
primarily for debugging output.
|
||||
|
||||
The principle guiding theme is "all the concision you can get while still
|
||||
having a useful dump and not doing anything cleverer than setting Data::Dumper
|
||||
options" - it's been pointed out to us that Data::Dump::Streamer can produce
|
||||
shorter output with less lines of code. We know. This is simpler and we've
|
||||
never seen it segfault. But for complex/weird structures, it generally rocks.
|
||||
You should use it as well, when Concise is underkill. We do.
|
||||
|
||||
Why is deparsing on when the aim is concision? Because you often want to know
|
||||
what subroutine refs you have when debugging and because if you were planning
|
||||
to eval this back in you probably wanted to remove subrefs first and add them
|
||||
back in a custom way anyway. Note that this -does- force using the pure perl
|
||||
Dumper rather than the XS one, but I've never in my life seen Data::Dumper
|
||||
show up in a profile so "who cares?".
|
||||
|
||||
=head1 BUT BUT BUT ...
|
||||
|
||||
Yes, we know. Consider this module in the ::Tiny spirit and feel free to
|
||||
write a Data::Dumper::Concise::ButWithExtraTwiddlyBits if it makes you
|
||||
happy. Then tell us so we can add it to the see also section.
|
||||
|
||||
=head1 SUGARY SYNTAX
|
||||
|
||||
This package also provides:
|
||||
|
||||
L<Data::Dumper::Concise::Sugar> - provides Dwarn and DwarnS convenience functions
|
||||
|
||||
L<Devel::Dwarn> - shorter form for Data::Dumper::Concise::Sugar
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
We use for some purposes, and dearly love, the following alternatives:
|
||||
|
||||
L<Data::Dump> - prettiness oriented but not amazingly configurable
|
||||
|
||||
L<Data::Dump::Streamer> - brilliant. beautiful. insane. extensive. excessive. try it.
|
||||
|
||||
L<JSON::XS> - no, really. If it's just plain data, JSON is a great option.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
mst - Matt S. Trout <mst@shadowcat.co.uk>
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
frew - Arthur Axel "fREW" Schmidt <frioux@gmail.com>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2010 the Data::Dumper::Concise L</AUTHOR> and L</CONTRIBUTORS>
|
||||
as listed above.
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This library is free software and may be distributed under the same terms
|
||||
as perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
219
database/perl/vendor/lib/Data/Dumper/Concise/Sugar.pm
vendored
Normal file
219
database/perl/vendor/lib/Data/Dumper/Concise/Sugar.pm
vendored
Normal file
@@ -0,0 +1,219 @@
|
||||
package Data::Dumper::Concise::Sugar;
|
||||
|
||||
use 5.006;
|
||||
|
||||
our $VERSION = '2.023';
|
||||
|
||||
use Exporter ();
|
||||
use Data::Dumper::Concise ();
|
||||
|
||||
BEGIN { @ISA = qw(Exporter) }
|
||||
|
||||
@EXPORT = qw(
|
||||
$Dwarn $DwarnN Dwarn DwarnS DwarnL DwarnN DwarnF
|
||||
$Ddie $DdieN Ddie DdieS DdieL DdieN DdieD
|
||||
);
|
||||
|
||||
sub Dwarn { DwarnL(@_); return wantarray ? @_ : $_[0] }
|
||||
|
||||
our $Dwarn = \&Dwarn;
|
||||
our $DwarnN = \&DwarnN;
|
||||
|
||||
sub DwarnL { warn Data::Dumper::Concise::Dumper @_; @_ }
|
||||
|
||||
sub DwarnS ($) { warn Data::Dumper::Concise::Dumper $_[0]; $_[0] }
|
||||
|
||||
sub DwarnN ($) {
|
||||
require Devel::ArgNames;
|
||||
my $x = Devel::ArgNames::arg_names();
|
||||
warn(($x?$x:'(anon)') . ' => ' . Data::Dumper::Concise::Dumper $_[0]); $_[0]
|
||||
}
|
||||
|
||||
sub DwarnF (&@) { my $c = shift; warn &Data::Dumper::Concise::DumperF($c, @_); @_ }
|
||||
|
||||
sub Ddie { DdieL(@_); return wantarray ? @_ : $_[0] }
|
||||
|
||||
our $Ddie = \&Ddie;
|
||||
our $DdieN = \&DdieN;
|
||||
|
||||
sub DdieL { die Data::Dumper::Concise::Dumper @_ }
|
||||
|
||||
sub DdieS ($) { die Data::Dumper::Concise::Dumper $_[0] }
|
||||
|
||||
sub DdieN ($) {
|
||||
require Devel::ArgNames;
|
||||
my $x = Devel::ArgNames::arg_names();
|
||||
die(($x?$x:'(anon)') . ' => ' . Data::Dumper::Concise::Dumper $_[0]);
|
||||
}
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Data::Dumper::Concise::Sugar - return Dwarn @return_value
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Data::Dumper::Concise::Sugar;
|
||||
|
||||
return Dwarn some_call(...)
|
||||
|
||||
is equivalent to:
|
||||
|
||||
use Data::Dumper::Concise;
|
||||
|
||||
if (wantarray) {
|
||||
my @return = some_call(...);
|
||||
warn Dumper(@return);
|
||||
return @return;
|
||||
} else {
|
||||
my $return = some_call(...);
|
||||
warn Dumper($return);
|
||||
return $return;
|
||||
}
|
||||
|
||||
but shorter. If you need to force scalar context on the value,
|
||||
|
||||
use Data::Dumper::Concise::Sugar;
|
||||
|
||||
return DwarnS some_call(...)
|
||||
|
||||
is equivalent to:
|
||||
|
||||
use Data::Dumper::Concise;
|
||||
|
||||
my $return = some_call(...);
|
||||
warn Dumper($return);
|
||||
return $return;
|
||||
|
||||
If you need to force list context on the value,
|
||||
|
||||
use Data::Dumper::Concise::Sugar;
|
||||
|
||||
return DwarnL some_call(...)
|
||||
|
||||
is equivalent to:
|
||||
|
||||
use Data::Dumper::Concise;
|
||||
|
||||
my @return = some_call(...);
|
||||
warn Dumper(@return);
|
||||
return @return;
|
||||
|
||||
If you want to label your output, try DwarnN
|
||||
|
||||
use Data::Dumper::Concise::Sugar;
|
||||
|
||||
return DwarnN $foo
|
||||
|
||||
is equivalent to:
|
||||
|
||||
use Data::Dumper::Concise;
|
||||
|
||||
my @return = some_call(...);
|
||||
warn '$foo => ' . Dumper(@return);
|
||||
return @return;
|
||||
|
||||
If you want to output a reference returned by a method easily, try $Dwarn
|
||||
|
||||
$foo->bar->{baz}->$Dwarn
|
||||
|
||||
is equivalent to:
|
||||
|
||||
my $return = $foo->bar->{baz};
|
||||
warn Dumper($return);
|
||||
return $return;
|
||||
|
||||
If you want to format the output of your data structures, try DwarnF
|
||||
|
||||
my ($a, $c) = DwarnF { "awesome: $_[0] not awesome: $_[1]" } $awesome, $cheesy;
|
||||
|
||||
is equivalent to:
|
||||
|
||||
my @return = ($awesome, $cheesy);
|
||||
warn DumperF { "awesome: $_[0] not awesome: $_[1]" } $awesome, $cheesy;
|
||||
return @return;
|
||||
|
||||
If you want to immediately die after outputting the data structure, every
|
||||
Dwarn subroutine has a paired Ddie version, so just replace the warn with die.
|
||||
For example:
|
||||
|
||||
DdieL 'foo', { bar => 'baz' };
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
use Data::Dumper::Concise::Sugar;
|
||||
|
||||
will import Dwarn, $Dwarn, DwarnL, DwarnN, and DwarnS into your namespace. Using
|
||||
L<Exporter>, so see its docs for ways to make it do something else.
|
||||
|
||||
=head2 Dwarn
|
||||
|
||||
sub Dwarn { return DwarnL(@_) if wantarray; DwarnS($_[0]) }
|
||||
|
||||
=head2 $Dwarn
|
||||
|
||||
$Dwarn = \&Dwarn
|
||||
|
||||
=head2 $DwarnN
|
||||
|
||||
$DwarnN = \&DwarnN
|
||||
|
||||
=head2 DwarnL
|
||||
|
||||
sub Dwarn { warn Data::Dumper::Concise::Dumper @_; @_ }
|
||||
|
||||
=head2 DwarnS
|
||||
|
||||
sub DwarnS ($) { warn Data::Dumper::Concise::Dumper $_[0]; $_[0] }
|
||||
|
||||
=head2 DwarnN
|
||||
|
||||
sub DwarnN { warn '$argname => ' . Data::Dumper::Concise::Dumper $_[0]; $_[0] }
|
||||
|
||||
B<Note>: this requires L<Devel::ArgNames> to be installed.
|
||||
|
||||
=head2 DwarnF
|
||||
|
||||
sub DwarnF (&@) { my $c = shift; warn &Data::Dumper::Concise::DumperF($c, @_); @_ }
|
||||
|
||||
=head1 TIPS AND TRICKS
|
||||
|
||||
=head2 global usage
|
||||
|
||||
Instead of always just doing:
|
||||
|
||||
use Data::Dumper::Concise::Sugar;
|
||||
|
||||
Dwarn ...
|
||||
|
||||
We tend to do:
|
||||
|
||||
perl -MData::Dumper::Concise::Sugar foo.pl
|
||||
|
||||
(and then in the perl code:)
|
||||
|
||||
::Dwarn ...
|
||||
|
||||
That way, if you leave them in and run without the
|
||||
C<< use Data::Dumper::Concise::Sugar >> the program will fail to compile and
|
||||
you are less likely to check it in by accident. Furthmore it allows that
|
||||
much less friction to add debug messages.
|
||||
|
||||
=head2 method chaining
|
||||
|
||||
One trick which is useful when doing method chaining is the following:
|
||||
|
||||
my $foo = Bar->new;
|
||||
$foo->bar->baz->Data::Dumper::Concise::Sugar::DwarnS->biff;
|
||||
|
||||
which is the same as:
|
||||
|
||||
my $foo = Bar->new;
|
||||
(DwarnS $foo->bar->baz)->biff;
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
You probably want L<Devel::Dwarn>, it's the shorter name for this module.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
2266
database/perl/vendor/lib/Data/Printer.pm
vendored
Normal file
2266
database/perl/vendor/lib/Data/Printer.pm
vendored
Normal file
File diff suppressed because it is too large
Load Diff
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>
|
||||
831
database/perl/vendor/lib/Data/Random.pm
vendored
Normal file
831
database/perl/vendor/lib/Data/Random.pm
vendored
Normal file
@@ -0,0 +1,831 @@
|
||||
################################################################################
|
||||
# Data::Random
|
||||
#
|
||||
# A module used to generate random data.
|
||||
################################################################################
|
||||
|
||||
package Data::Random;
|
||||
|
||||
################################################################################
|
||||
# - Modules and Libraries
|
||||
################################################################################
|
||||
use strict;
|
||||
use warnings;
|
||||
use 5.005_62;
|
||||
|
||||
use Carp qw(cluck);
|
||||
use Time::Piece;
|
||||
#use Data::Random::WordList;
|
||||
|
||||
require Exporter;
|
||||
|
||||
################################################################################
|
||||
# - Global Constants and Variables
|
||||
################################################################################
|
||||
use vars qw(
|
||||
@ISA
|
||||
%EXPORT_TAGS
|
||||
@EXPORT_OK
|
||||
@EXPORT
|
||||
);
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
|
||||
%EXPORT_TAGS = (
|
||||
'all' => [
|
||||
qw(
|
||||
rand_words
|
||||
rand_chars
|
||||
rand_set
|
||||
rand_enum
|
||||
rand_date
|
||||
rand_time
|
||||
rand_datetime
|
||||
rand_image
|
||||
)
|
||||
]
|
||||
);
|
||||
|
||||
@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
|
||||
@EXPORT = qw();
|
||||
|
||||
our $VERSION = '0.13';
|
||||
|
||||
################################################################################
|
||||
# - Subroutines
|
||||
################################################################################
|
||||
|
||||
################################################################################
|
||||
# rand_words()
|
||||
################################################################################
|
||||
sub rand_words {
|
||||
|
||||
# Get the options hash
|
||||
my %options = @_;
|
||||
|
||||
# Initialize max and min vars
|
||||
$options{'min'} ||= 1;
|
||||
$options{'max'} ||= 1;
|
||||
|
||||
# Initialize the wordlist param
|
||||
$options{'wordlist'} ||= '';
|
||||
|
||||
# Make sure the max and min vars are OK
|
||||
cluck('min value cannot be larger than max value') && return
|
||||
if $options{'min'} > $options{'max'};
|
||||
cluck('min value must be a positive integer') && return
|
||||
if $options{'min'} < 0 || $options{'min'} != int( $options{'min'} );
|
||||
cluck('max value must be a positive integer') && return
|
||||
if $options{'max'} < 0 || $options{'max'} != int( $options{'max'} );
|
||||
|
||||
# Initialize the size var
|
||||
$options{'size'} ||=
|
||||
int( rand( $options{'max'} - $options{'min'} + 1 ) ) + $options{'min'};
|
||||
|
||||
# Make sure the size var is OK
|
||||
cluck('size value must be a positive integer') && return
|
||||
if $options{'size'} < 0 || $options{'size'} != int( $options{'size'} );
|
||||
|
||||
# Initialize the shuffle flag
|
||||
$options{'shuffle'} =
|
||||
exists( $options{'shuffle'} ) ? $options{'shuffle'} : 1;
|
||||
|
||||
my $wl;
|
||||
my $close_wl = 1;
|
||||
|
||||
# Check for a pre-existing wordlist object
|
||||
if ( ref( $options{'wordlist'} ) ) {
|
||||
$wl = $options{'wordlist'};
|
||||
$close_wl = 0;
|
||||
}
|
||||
else {
|
||||
require Data::Random::WordList;
|
||||
|
||||
# Create a new wordlist object
|
||||
$wl = Data::Random::WordList->new( wordlist => $options{'wordlist'} );
|
||||
}
|
||||
|
||||
# Get the random words
|
||||
my $rand_words = $wl->get_words( $options{'size'} );
|
||||
|
||||
# Close the word list
|
||||
$wl->close() if $close_wl;
|
||||
|
||||
# Shuffle the words around
|
||||
_shuffle($rand_words) if $options{'shuffle'};
|
||||
|
||||
# Return an array or an array reference, depending on the context in which the sub was called
|
||||
if ( wantarray() ) {
|
||||
return @$rand_words;
|
||||
}
|
||||
else {
|
||||
return $rand_words;
|
||||
}
|
||||
}
|
||||
|
||||
################################################################################
|
||||
# rand_chars()
|
||||
################################################################################
|
||||
sub rand_chars {
|
||||
|
||||
# Get the options hash
|
||||
my %options = @_;
|
||||
my @chars;
|
||||
|
||||
# Build named character sets if one wasn't supplied
|
||||
if ( ref( $options{'set'} ) ne 'ARRAY' ) {
|
||||
my @charset = ();
|
||||
|
||||
if ( $options{'set'} eq 'all' ) {
|
||||
@charset =
|
||||
( 0 .. 9, 'a' .. 'z', 'A' .. 'Z', '#', ',',
|
||||
qw(~ ! @ $ % ^ & * ( ) _ + = - { } | : " < > ? / . ' ; ] [ \ `)
|
||||
);
|
||||
}
|
||||
elsif ( $options{'set'} eq 'alpha' ) {
|
||||
@charset = ( 'a' .. 'z', 'A' .. 'Z' );
|
||||
}
|
||||
elsif ( $options{'set'} eq 'upperalpha' ) {
|
||||
@charset = ( 'A' .. 'Z' );
|
||||
}
|
||||
elsif ( $options{'set'} eq 'loweralpha' ) {
|
||||
@charset = ( 'a' .. 'z' );
|
||||
}
|
||||
elsif ( $options{'set'} eq 'numeric' ) {
|
||||
@charset = ( 0 .. 9 );
|
||||
}
|
||||
elsif ( $options{'set'} eq 'alphanumeric' ) {
|
||||
@charset = ( 0 .. 9, 'a' .. 'z', 'A' .. 'Z' );
|
||||
}
|
||||
elsif ( $options{'set'} =~ /^(misc|char)$/ ) {
|
||||
@charset =
|
||||
( '#', ',',
|
||||
qw(~ ! @ $ % ^ & * ( ) _ + = - { } | : " < > ? / . ' ; ] [ \ `)
|
||||
);
|
||||
}
|
||||
|
||||
$options{'set'} = \@charset;
|
||||
}
|
||||
|
||||
@chars = rand_set(%options);
|
||||
return wantarray ? @chars : join('', @chars);
|
||||
}
|
||||
|
||||
################################################################################
|
||||
# rand_set()
|
||||
################################################################################
|
||||
sub rand_set {
|
||||
|
||||
# Get the options hash
|
||||
my %options = @_;
|
||||
|
||||
# Make sure the set array was defined
|
||||
cluck('set array is not defined') && return if !$options{'set'};
|
||||
|
||||
$options{'size'} = 1
|
||||
unless exists( $options{'min'} ) || exists( $options{'max'} )
|
||||
|| exists( $options{'size'} );
|
||||
|
||||
# Initialize max and min vars
|
||||
$options{'min'} ||= 0;
|
||||
$options{'max'} ||= @{ $options{'set'} };
|
||||
|
||||
# Make sure the max and min vars are OK
|
||||
cluck('min value cannot be larger than max value') && return
|
||||
if $options{'min'} > $options{'max'};
|
||||
cluck('min value must be a positive integer') && return
|
||||
if $options{'min'} < 0 || $options{'min'} != int( $options{'min'} );
|
||||
cluck('max value must be a positive integer') && return
|
||||
if $options{'max'} < 0 || $options{'max'} != int( $options{'max'} );
|
||||
|
||||
# Initialize the size var
|
||||
$options{'size'} ||=
|
||||
int( rand( $options{'max'} - $options{'min'} + 1 ) ) + $options{'min'};
|
||||
|
||||
# Make sure the size var is OK
|
||||
cluck('size value must be a positive integer') && return
|
||||
if $options{'size'} < 0 || $options{'size'} != int( $options{'size'} );
|
||||
cluck('size value exceeds set size') && return
|
||||
if $options{'size'} > @{ $options{'set'} };
|
||||
|
||||
# Initialize the shuffle flag
|
||||
$options{'shuffle'} =
|
||||
exists( $options{'shuffle'} ) ? $options{'shuffle'} : 1;
|
||||
|
||||
# Get the random items
|
||||
my %results = ();
|
||||
for ( my $i = 0 ; $i < $options{'size'} ; $i++ ) {
|
||||
my $result;
|
||||
|
||||
do {
|
||||
$result = int( rand( @{ $options{'set'} } ) );
|
||||
} while ( exists( $results{$result} ) );
|
||||
|
||||
$results{$result} = 1;
|
||||
}
|
||||
|
||||
my @results = sort { $a <=> $b } keys %results;
|
||||
|
||||
# Shuffle the items
|
||||
_shuffle( \@results ) if $options{'shuffle'};
|
||||
|
||||
# Return an array or an array reference, depending on the context in which the sub was called
|
||||
if ( wantarray() ) {
|
||||
return @{ $options{'set'} }[@results];
|
||||
}
|
||||
else {
|
||||
return \@{ $options{'set'} }[@results];
|
||||
}
|
||||
}
|
||||
|
||||
################################################################################
|
||||
# rand_enum()
|
||||
################################################################################
|
||||
sub rand_enum {
|
||||
|
||||
# Get the options hash
|
||||
my %options = @_ == 1 && ref $_[0] eq 'ARRAY' ? ( set => @_ ) : @_;
|
||||
|
||||
# Make sure the set array was defined
|
||||
cluck('set array is not defined') && return if !$options{'set'};
|
||||
|
||||
return $options{'set'}->[ int( rand( @{ $options{'set'} } ) ) ];
|
||||
}
|
||||
|
||||
################################################################################
|
||||
# rand_date()
|
||||
################################################################################
|
||||
sub rand_date {
|
||||
|
||||
# Get the options hash
|
||||
my %options = @_;
|
||||
|
||||
my $min;
|
||||
my $max;
|
||||
# Get today's date
|
||||
my $t = localtime;
|
||||
my ( $year, $month, $day ) = split('-', $t->ymd);
|
||||
my $today = Time::Piece->strptime($t->ymd, "%Y-%m-%d");
|
||||
|
||||
if ( $options{'min'} ) {
|
||||
if ( $options{'min'} eq 'now' ) {
|
||||
$min = $today;
|
||||
}
|
||||
else {
|
||||
$min = Time::Piece->strptime($options{'min'}, '%Y-%m-%d');
|
||||
}
|
||||
}
|
||||
else {
|
||||
$min = $today;
|
||||
}
|
||||
if ( $options{'max'} ) {
|
||||
if ( $options{'max'} eq 'now' ) {
|
||||
$max = $today;
|
||||
}
|
||||
else {
|
||||
$max = Time::Piece->strptime($options{max}, "%Y-%m-%d");
|
||||
}
|
||||
}
|
||||
else {
|
||||
$max = $min->add_years(1);
|
||||
}
|
||||
|
||||
my $delta_days = int($max->julian_day) - int($min->julian_day);
|
||||
cluck('max date is later than min date') && return if $delta_days < 0;
|
||||
|
||||
my $result = $min + ( 3600 * 24 * int( rand($delta_days + 1) ) );
|
||||
return $result->ymd;
|
||||
}
|
||||
|
||||
################################################################################
|
||||
# rand_time()
|
||||
################################################################################
|
||||
sub rand_time {
|
||||
|
||||
# Get the options hash
|
||||
my %options = @_;
|
||||
|
||||
my ( $min_hour, $min_min, $min_sec, $max_hour, $max_min, $max_sec );
|
||||
|
||||
if ( $options{'min'} ) {
|
||||
if ( $options{'min'} eq 'now' ) {
|
||||
|
||||
# Get the current time
|
||||
my ( $hour, $min, $sec ) = ( localtime() )[ 2, 1, 0 ];
|
||||
|
||||
( $min_hour, $min_min, $min_sec ) = ( $hour, $min, $sec );
|
||||
}
|
||||
else {
|
||||
eval {
|
||||
my $min = Time::Piece->strptime( $options{min}, '%T' );
|
||||
( $min_hour, $min_min, $min_sec )
|
||||
= ( $min->hour, $min->min, $min->sec );
|
||||
};
|
||||
if ($@) {
|
||||
cluck 'minimum time is not in valid time format HH:MM:SS';
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
( $min_hour, $min_min, $min_sec ) = ( 0, 0, 0 );
|
||||
}
|
||||
|
||||
if ( $options{'max'} ) {
|
||||
if ( $options{'max'} eq 'now' ) {
|
||||
|
||||
# Get the current time
|
||||
my ( $hour, $min, $sec ) = ( localtime() )[ 2, 1, 0 ];
|
||||
|
||||
( $max_hour, $max_min, $max_sec ) = ( $hour, $min, $sec );
|
||||
}
|
||||
else {
|
||||
eval {
|
||||
my $max = Time::Piece->strptime( $options{max}, '%T' );
|
||||
( $max_hour, $max_min, $max_sec )
|
||||
= ( $max->hour, $max->min, $max->sec );
|
||||
};
|
||||
if ($@) {
|
||||
cluck 'maximum time is not in valid time format HH:MM:SS';
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
( $max_hour, $max_min, $max_sec ) = ( 23, 59, 59 );
|
||||
}
|
||||
|
||||
my $min_secs = $min_hour * 3600 + $min_min * 60 + $min_sec;
|
||||
my $max_secs = ( $max_hour * 3600 ) + ( $max_min * 60 ) + $max_sec;
|
||||
|
||||
my $delta_secs = $max_secs - $min_secs;
|
||||
|
||||
cluck('min time is later than max time') && return if $delta_secs < 0;
|
||||
|
||||
$delta_secs = int( rand( $delta_secs + 1 ) );
|
||||
|
||||
my $result_secs = $min_secs + $delta_secs;
|
||||
|
||||
my $hour = int( $result_secs / 3600 );
|
||||
my $min = int( ( $result_secs - ( $hour * 3600 ) ) / 60 );
|
||||
my $sec = $result_secs % 60;
|
||||
|
||||
return sprintf( "%02u:%02u:%02u", $hour, $min, $sec );
|
||||
}
|
||||
|
||||
################################################################################
|
||||
# rand_datetime()
|
||||
################################################################################
|
||||
sub rand_datetime {
|
||||
|
||||
# Get the options hash
|
||||
my %options = @_;
|
||||
|
||||
# Get today's date
|
||||
my $now = localtime;
|
||||
my $minimum;
|
||||
my $maximum;
|
||||
|
||||
if ( $options{min} ) {
|
||||
if ( $options{min} eq 'now' ) {
|
||||
$minimum = Time::Piece->strptime(
|
||||
$now->strftime('%Y-%m-%d %H:%M:%S'),
|
||||
'%Y-%m-%d %H:%M:%S'
|
||||
);
|
||||
}
|
||||
else {
|
||||
$minimum = Time::Piece->strptime(
|
||||
$options{min},
|
||||
'%Y-%m-%d %H:%M:%S'
|
||||
);
|
||||
}
|
||||
}
|
||||
else {
|
||||
$minimum = $now;
|
||||
}
|
||||
|
||||
if ( $options{max} ) {
|
||||
if ( $options{max} eq 'now' ) {
|
||||
$maximum = Time::Piece->strptime(
|
||||
$now->strftime('%Y-%m-%d %H:%M:%S'),
|
||||
'%Y-%m-%d %H:%M:%S'
|
||||
);
|
||||
}
|
||||
else {
|
||||
$maximum = Time::Piece->strptime(
|
||||
$options{max},
|
||||
'%Y-%m-%d %H:%M:%S'
|
||||
);
|
||||
}
|
||||
}
|
||||
else {
|
||||
$maximum = $minimum->add_years(1);
|
||||
}
|
||||
|
||||
my $delta_secs = $maximum - $minimum;
|
||||
cluck('max_date is later than min date') && return if $delta_secs < 0;
|
||||
$delta_secs = int( rand( $delta_secs + 1 ) );
|
||||
|
||||
my $result = $minimum + $delta_secs;
|
||||
|
||||
return $result->strftime('%Y-%m-%d %H:%M:%S');
|
||||
}
|
||||
|
||||
################################################################################
|
||||
# rand_image()
|
||||
################################################################################
|
||||
sub rand_image {
|
||||
|
||||
# Get the options hash
|
||||
my %options = @_;
|
||||
|
||||
eval q{ require GD; };
|
||||
cluck($@) && return if $@;
|
||||
|
||||
$options{'minwidth'} ||= 1;
|
||||
$options{'maxwidth'} ||= 100;
|
||||
$options{'width'} ||=
|
||||
int( rand( $options{'maxwidth'} - $options{'minwidth'} + 1 ) ) +
|
||||
$options{'minwidth'};
|
||||
|
||||
$options{'minheight'} ||= 1;
|
||||
$options{'maxheight'} ||= 100;
|
||||
$options{'height'} ||=
|
||||
int( rand( $options{'maxheight'} - $options{'minheight'} + 1 ) ) +
|
||||
$options{'minheight'};
|
||||
|
||||
$options{'minpixels'} ||= 0;
|
||||
$options{'maxpixels'} ||= $options{'width'} * $options{'height'};
|
||||
$options{'pixels'} ||=
|
||||
int( rand( $options{'maxpixels'} - $options{'minpixels'} + 1 ) ) +
|
||||
$options{'minpixels'};
|
||||
|
||||
$options{'bgcolor'} ||= _color();
|
||||
$options{'fgcolor'} ||= _color();
|
||||
|
||||
my $image = GD::Image->new( $options{'width'}, $options{'height'} );
|
||||
|
||||
my $bgcolor = $image->colorAllocate( @{ $options{'bgcolor'} } );
|
||||
my $fgcolor = $image->colorAllocate( @{ $options{'fgcolor'} } );
|
||||
|
||||
$image->rectangle( 0, 0, $options{'width'}, $options{'height'}, $bgcolor );
|
||||
|
||||
for ( my $i = 0 ; $i < $options{'pixels'} ; $i++ ) {
|
||||
my $x = int( rand( $options{'width'} + 1 ) );
|
||||
my $y = int( rand( $options{'height'} + 1 ) );
|
||||
|
||||
$image->setPixel( $x, $y, $fgcolor );
|
||||
}
|
||||
|
||||
return $image->png();
|
||||
|
||||
sub _color {
|
||||
return [ int( rand(256) ), int( rand(256) ), int( rand(256) ) ];
|
||||
}
|
||||
}
|
||||
|
||||
################################################################################
|
||||
# _shuffle()
|
||||
################################################################################
|
||||
sub _shuffle {
|
||||
my $array = shift;
|
||||
|
||||
for ( my $i = @$array - 1 ; $i >= 0 ; $i-- ) {
|
||||
my $j = int( rand( $i + 1 ) );
|
||||
|
||||
@$array[ $i, $j ] = @$array[ $j, $i ] if $i != $j;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Data::Random - Perl module to generate random data
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Data::Random qw(:all);
|
||||
|
||||
my @random_words = rand_words( size => 10 );
|
||||
|
||||
my @random_chars = rand_chars( set => 'all', min => 5, max => 8 );
|
||||
my $string = rand_chars( set => 'all', min => 5, max => 8 );
|
||||
|
||||
my @random_set = rand_set( set => \@set, size => 5 );
|
||||
|
||||
my $random_enum = rand_enum( set => \@set );
|
||||
my $random_enum = rand_enum( \@set ); # shortcut
|
||||
|
||||
my $random_date = rand_date();
|
||||
|
||||
my $random_time = rand_time();
|
||||
|
||||
my $random_datetime = rand_datetime();
|
||||
|
||||
open(my $file, ">", "rand_image.png") or die $!;
|
||||
binmode($file);
|
||||
print $file rand_image( bgcolor => [0, 0, 0] );
|
||||
close($file);
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A module used to generate random data. Useful mostly for test programs.
|
||||
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 rand_words()
|
||||
|
||||
This returns a list of random words given a wordlist. See below for possible parameters.
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
wordlist - the path to the wordlist file. A lot of systems have one at /usr/dict/words. You can also optionally supply a Data::Random::WordList object to keep a persistent wordlist. The default is the wordlist distributed with this module.
|
||||
|
||||
=item *
|
||||
|
||||
min - the minimum number of words to return. The default is 1.
|
||||
|
||||
=item *
|
||||
|
||||
max - the maximum number of words to return. The default is 1.
|
||||
|
||||
=item *
|
||||
|
||||
size - the number of words to return. The default is 1. If you supply a value for 'size', then 'min' and 'max' aren't paid attention to.
|
||||
|
||||
=item *
|
||||
|
||||
shuffle - whether or not the words should be randomly shuffled. Set this to 0 if you don't want the words shuffled. The default is 1. Random::Data::WordList returns words in the order that they're viewed in the word list file, so shuffling will make sure that the results are a little more random.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head2 rand_chars()
|
||||
|
||||
When called in a list context this returns
|
||||
a list of random characters given a set of characters.
|
||||
In a scalar context it returns a string of random characters.
|
||||
See below for possible parameters.
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
set - the set of characters to be used. This value can be either a reference to an array of strings, or one of the following:
|
||||
|
||||
alpha - alphabetic characters: a-z, A-Z
|
||||
upperalpha - upper case alphabetic characters: A-Z
|
||||
loweralpha - lower case alphabetic characters: a-z
|
||||
numeric - numeric characters: 0-9
|
||||
alphanumeric - alphanumeric characters: a-z, A-Z, 0-9
|
||||
char - non-alphanumeric characters: # ~ ! @ $ % ^ & * ( ) _ + = - { } | : " < > ? / . ' ; ] [ \ `
|
||||
misc - same as 'char'
|
||||
all - all of the above
|
||||
|
||||
=item *
|
||||
|
||||
min - the minimum number of characters to return. The default is 0.
|
||||
|
||||
=item *
|
||||
|
||||
max - the maximum number of characters to return. The default is the size of the set.
|
||||
|
||||
=item *
|
||||
|
||||
size - the number of characters to return. The default is 1. If you supply a value for 'size', then 'min' and 'max' aren't paid attention to.
|
||||
|
||||
=item *
|
||||
|
||||
shuffle - whether or not the characters should be randomly shuffled. Set this to 0 if you want the characters to stay in the order received. The default is 1.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head2 rand_set()
|
||||
|
||||
This returns a random set of elements given an initial set. See below for possible parameters.
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
set - the set of strings to be used. This should be a reference to an array of strings.
|
||||
|
||||
=item *
|
||||
|
||||
min - the minimum number of strings to return. The default is 0.
|
||||
|
||||
=item *
|
||||
|
||||
max - the maximum number of strings to return. The default is the size of the set.
|
||||
|
||||
=item *
|
||||
|
||||
size - the number of strings to return. The default is 1. If you supply a value for 'size', then 'min' and 'max' aren't paid attention to.
|
||||
|
||||
=item *
|
||||
|
||||
shuffle - whether or not the strings should be randomly shuffled. Set this to 0 if you want the strings to stay in the order received. The default is 1.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head2 rand_enum()
|
||||
|
||||
This returns a random element given an initial set. See below for possible parameters.
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
set - the set of strings to be used. This should be a reference to an array of strings. The C<set> key will be assumed if the array reference is passed as the only argument.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head2 rand_date()
|
||||
|
||||
This returns a random date in the form "YYYY-MM-DD". 2-digit years are not currently supported. Efforts are made to make sure you're returned a truly valid date--ie, you'll never be returned the date February 31st. See the options below to find out how to control the date range. Here are a few examples:
|
||||
|
||||
# returns a date somewhere in between the current date, and one year from the current date
|
||||
$date = rand_date();
|
||||
|
||||
# returns a date somewhere in between September 21, 1978 and September 21, 1979
|
||||
$date = rand_date( min => '1978-9-21' );
|
||||
|
||||
# returns a date somewhere in between September 21, 1978 and the current date
|
||||
$date = rand_date( min => '1978-9-21', max => 'now' );
|
||||
|
||||
# returns a date somewhere in between the current date and September 21, 2008
|
||||
$date = rand_date( min => 'now', max => '2008-9-21' );
|
||||
|
||||
See below for possible parameters.
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
min - the minimum date to be returned. It should be in the form "YYYY-MM-DD" or you can alternatively use the string "now" to represent the current date. The default is the current date;
|
||||
|
||||
=item *
|
||||
|
||||
max - the maximum date to be returned. It should be in the form "YYYY-MM-DD" or you can alternatively use the string "now" to represent the current date. The default is one year from the minimum date;
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head2 rand_time()
|
||||
|
||||
This returns a random time in the form "HH:MM:SS". 24 hour times are supported. See the options below to find out how to control the time range. Here are a few examples:
|
||||
|
||||
# returns a random 24-hr time (between 00:00:00 and 23:59:59)
|
||||
$time = rand_time();
|
||||
|
||||
# returns a time somewhere in between 04:00:00 and the end of the day
|
||||
$time = rand_time( min => '4:0:0' );
|
||||
|
||||
# returns a time somewhere in between 8:00:00 and the current time (if it's after 8:00)
|
||||
$time = rand_time( min => '12:00:00', max => 'now' );
|
||||
|
||||
# returns a date somewhere in between the current time and the end of the day
|
||||
$time = rand_time( min => 'now' );
|
||||
|
||||
See below for possible parameters.
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
min - the minimum time to be returned. It should be in the form "HH:MM:SS" or you can alternatively use the string "now" to represent the current time. The default is 00:00:00;
|
||||
|
||||
=item *
|
||||
|
||||
max - the maximum time to be returned. It should be in the form "HH:MM:SS" or you can alternatively use the string "now" to represent the current time. The default is 23:59:59;
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head2 rand_datetime()
|
||||
|
||||
This returns a random date and time in the form "YYYY-MM-DD HH:MM:SS". See the options below to find out how to control the date/time range. Here are a few examples:
|
||||
|
||||
# returns a date somewhere in between the current date/time, and one year from the current date/time
|
||||
$datetime = rand_datetime();
|
||||
|
||||
# returns a date somewhere in between 4:00 September 21, 1978 and 4:00 September 21, 1979
|
||||
$datetime = rand_datetime( min => '1978-9-21 4:0:0' );
|
||||
|
||||
# returns a date somewhere in between 4:00 September 21, 1978 and the current date
|
||||
$datetime = rand_datetime( min => '1978-9-21 4:0:0', max => 'now' );
|
||||
|
||||
# returns a date somewhere in between the current date/time and the end of the day September 21, 2008
|
||||
$datetime = rand_datetime( min => 'now', max => '2008-9-21 23:59:59' );
|
||||
|
||||
See below for possible parameters.
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
min - the minimum date/time to be returned. It should be in the form "YYYY-MM-DD HH:MM:SS" or you can alternatively use the string "now" to represent the current date/time. The default is the current date/time;
|
||||
|
||||
=item *
|
||||
|
||||
max - the maximum date/time to be returned. It should be in the form "YYYY-MM-DD HH:MM:SS" or you can alternatively use the string "now" to represent the current date/time. The default is one year from the minimum date/time;
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head2 rand_image()
|
||||
|
||||
This returns a random image. Currently only PNG images are supported. See below for possible parameters.
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
minwidth - the minimum width of the image. The default is 1.
|
||||
|
||||
=item *
|
||||
|
||||
maxwidth - the maximum width of the image. The default is 100.
|
||||
|
||||
=item *
|
||||
|
||||
width - the width of the image. If you supply a value for 'width', then 'minwidth' and 'maxwidth' aren't paid attention to.
|
||||
|
||||
=item *
|
||||
|
||||
minheight - the minimum height of the image. The default is 1.
|
||||
|
||||
=item *
|
||||
|
||||
maxheight - the maximum height of the image. The default is 100.
|
||||
|
||||
=item *
|
||||
|
||||
height - the height of the image. If you supply a value for 'width', then 'minwidth' and 'maxwidth' aren't paid attention to.
|
||||
|
||||
=item *
|
||||
|
||||
minpixels - the minimum number of random pixels to display on the image. The default is 0.
|
||||
|
||||
=item *
|
||||
|
||||
maxpixels - the maximum number of random pixels to display on the image. The default is width * height.
|
||||
|
||||
=item *
|
||||
|
||||
pixels - the number of random pixels to display on the image. If you supply a value for 'pixels', then 'minpixels' and 'maxpixels' aren't paid attention to.
|
||||
|
||||
=item *
|
||||
|
||||
bgcolor - the background color of the image. The value must be a reference to an RGB array where each element is an integer between 0 and 255 (eg. [ 55, 120, 255 ]).
|
||||
|
||||
=item *
|
||||
|
||||
fgcolor - the foreground color of the image. The value must be a reference to an RGB array where each element is an integer between 0 and 255 (eg. [ 55, 120, 255 ]).
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
0.12
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Originally written by: Adekunle Olonoh
|
||||
|
||||
Currently maintained by: Buddy Burden (barefoot@cpan.org), starting with version 0.06
|
||||
|
||||
|
||||
=head1 CREDITS
|
||||
|
||||
Hiroki Chalfant
|
||||
David Sarno
|
||||
Michiel Beijen
|
||||
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2000-2011 Adekunle Olonoh.
|
||||
Copyright (c) 2011-2015 Buddy Burden.
|
||||
All rights reserved. This program is free software; you
|
||||
can redistribute it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Data::Random::WordList>
|
||||
|
||||
=cut
|
||||
200
database/perl/vendor/lib/Data/Random/WordList.pm
vendored
Normal file
200
database/perl/vendor/lib/Data/Random/WordList.pm
vendored
Normal file
@@ -0,0 +1,200 @@
|
||||
################################################################################
|
||||
# Data::Random
|
||||
#
|
||||
# A module used to generate random data.
|
||||
#
|
||||
# Author: Adekunle Olonoh
|
||||
# Date: October 2000
|
||||
################################################################################
|
||||
|
||||
package Data::Random::WordList;
|
||||
|
||||
################################################################################
|
||||
# - Modules and Libraries
|
||||
################################################################################
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use FileHandle;
|
||||
use File::Basename qw(dirname);
|
||||
|
||||
################################################################################
|
||||
# - Global Constants and Variables
|
||||
################################################################################
|
||||
our $VERSION = '0.13';
|
||||
|
||||
################################################################################
|
||||
# - Subroutines
|
||||
################################################################################
|
||||
|
||||
################################################################################
|
||||
# new()
|
||||
################################################################################
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my %options = @_;
|
||||
|
||||
# Check if what was passed in was a prototype reference or a class name
|
||||
my $class = ref($proto) || $proto;
|
||||
|
||||
$options{'wordlist'} ||= dirname($INC{'Data/Random.pm'}).'/Random/dict';
|
||||
|
||||
# Create a new filehandle object
|
||||
my $fh = new FileHandle $options{'wordlist'}
|
||||
or die "could not open $options{'wordlist'} : $!";
|
||||
|
||||
# Calculate the number of lines in the file
|
||||
my $size = 0;
|
||||
while (<$fh>) {
|
||||
$size++;
|
||||
}
|
||||
|
||||
# Create the object
|
||||
my $self = bless {
|
||||
'fh' => $fh,
|
||||
'size' => $size,
|
||||
}, $class;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
################################################################################
|
||||
# close()
|
||||
################################################################################
|
||||
sub close {
|
||||
my $self = shift;
|
||||
|
||||
# Close the filehandle
|
||||
$self->{'fh'}->close;
|
||||
}
|
||||
|
||||
################################################################################
|
||||
# get_words()
|
||||
################################################################################
|
||||
sub get_words {
|
||||
my $self = shift;
|
||||
my $num = shift || 1;
|
||||
|
||||
my $fh = $self->{'fh'};
|
||||
|
||||
# Perform some error checking
|
||||
die 'the size value must be a positive integer'
|
||||
if $num < 0 || $num != int($num);
|
||||
die
|
||||
"$num words were requested but only $self->{'size'} words exist in the wordlist"
|
||||
if $num > $self->{'size'};
|
||||
|
||||
# Pick which lines we want
|
||||
my %rand_lines = ();
|
||||
for ( my $i = 0 ; $i < $num ; $i++ ) {
|
||||
my $rand_line;
|
||||
|
||||
do {
|
||||
$rand_line = int( rand( $self->{'size'} ) );
|
||||
} while ( exists( $rand_lines{$rand_line} ) );
|
||||
|
||||
$rand_lines{$rand_line} = 1;
|
||||
}
|
||||
|
||||
my $line = 0;
|
||||
my @rand_words = ();
|
||||
|
||||
# Seek to the beginning of the filehandle
|
||||
$fh->seek( 0, 0 ) or die "could not seek to position 0 in wordlist: $!";
|
||||
|
||||
# Now get the lines
|
||||
while (<$fh>) {
|
||||
chomp;
|
||||
push ( @rand_words, $_ ) if $rand_lines{$line};
|
||||
|
||||
$line++;
|
||||
}
|
||||
|
||||
# Return an array or an array reference, depending on the context in which the sub was called
|
||||
if ( wantarray() ) {
|
||||
return @rand_words;
|
||||
}
|
||||
else {
|
||||
return \@rand_words;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Data::Random::WordList - Perl module to get random words from a word list
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Data::Random::WordList;
|
||||
|
||||
my $wl = new Data::Random::WordList( wordlist => '/usr/dict/words' );
|
||||
|
||||
my @rand_words = $wl->get_words(10);
|
||||
|
||||
$wl->close();
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Data::Random::WordList is a module that manages a file containing a list of words.
|
||||
|
||||
The module expects each line of the word list file to contain only one word. It could thus be easily used to select random lines from a file, but for coherency's sake, I'll keep referring to each line as a word.
|
||||
|
||||
The module uses a persistent filehandle so that there isn't a lot of overhead every time you want to fetch a list of random words. However, it's much more efficient to grab multiple words at a time than it is to fetch one word at a time multiple times.
|
||||
|
||||
The module also refrains from reading the whole file into memory, so it can be safer to use with larger files.
|
||||
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new()
|
||||
|
||||
Returns a reference to a new Data::Random::WordList object. Use the "wordlist" param to initialize the object:
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
wordlist - the path to the wordlist file. If a path isn't supplied, the wordlist distributed with this module is used.
|
||||
|
||||
=back
|
||||
|
||||
=head2 get_words([NUM])
|
||||
|
||||
NUM contains the number of words you want from the wordlist. NUM defaults to 1 if it's not specified. get_words() dies if NUM is greater than the number of words in the wordlist. This function returns an array or an array reference depending on the context in which it's called.
|
||||
|
||||
=head2 close()
|
||||
|
||||
Closes the filehandle associated with the word list. It's good practice to do this every time you're done with the word list.
|
||||
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
0.12
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Originally written by: Adekunle Olonoh
|
||||
|
||||
Currently maintained by: Buddy Burden (barefoot@cpan.org), starting with version 0.06
|
||||
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2000-2011 Adekunle Olonoh.
|
||||
Copyright (c) 2011-2015 Buddy Burden.
|
||||
All rights reserved. This program is free software; you
|
||||
can redistribute it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Data::Random>
|
||||
|
||||
=cut
|
||||
45427
database/perl/vendor/lib/Data/Random/dict
vendored
Normal file
45427
database/perl/vendor/lib/Data/Random/dict
vendored
Normal file
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user