Initial Commit
This commit is contained in:
Riley Schneider
469
database/perl/vendor/lib/Tie/Array/CSV.pm
vendored
Normal file
469
database/perl/vendor/lib/Tie/Array/CSV.pm
vendored
Normal file
@@ -0,0 +1,469 @@
|
||||
package Tie::Array::CSV;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.08';
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
use Carp;
|
||||
|
||||
use Tie::File;
|
||||
use Text::CSV;
|
||||
|
||||
use Scalar::Util qw/blessed/;
|
||||
|
||||
use Tie::Array;
|
||||
our @ISA = ('Tie::Array');
|
||||
|
||||
sub parse_opts {
|
||||
my $class = shift;
|
||||
|
||||
croak "Must specify a file" unless @_;
|
||||
|
||||
my ($file, %opts);
|
||||
|
||||
# handle one arg as either hashref (of opts) or file
|
||||
if (@_ == 1) {
|
||||
if (ref $_[0] eq 'HASH') {
|
||||
%opts = %{ shift() };
|
||||
} else {
|
||||
$file = shift;
|
||||
}
|
||||
}
|
||||
|
||||
# handle file and hashref of opts
|
||||
if (@_ == 2 and ref $_[1] eq 'HASH') {
|
||||
$file = shift;
|
||||
%opts = %{ shift() };
|
||||
}
|
||||
|
||||
# handle file before hash of opts
|
||||
if (@_ % 2) {
|
||||
$file = shift;
|
||||
}
|
||||
|
||||
# handle hash of opts
|
||||
if (@_) {
|
||||
%opts = @_;
|
||||
}
|
||||
|
||||
# handle file passed has hash(ref) value to 'file' key
|
||||
if (!$file and defined $opts{file}) {
|
||||
$file = delete $opts{file};
|
||||
}
|
||||
|
||||
# file wasn't specified as lone arg or as a hash opt
|
||||
croak "Must specify a file" unless $file;
|
||||
|
||||
# parse specific options
|
||||
if (exists $opts{sep_char}) {
|
||||
$opts{text_csv}{sep_char} = delete $opts{sep_char};
|
||||
}
|
||||
|
||||
return ($file, \%opts);
|
||||
}
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my ($file, $opts) = $class->parse_opts(@_);
|
||||
|
||||
my @self;
|
||||
tie @self, $class, $file, $opts;
|
||||
|
||||
return \@self;
|
||||
|
||||
}
|
||||
|
||||
sub TIEARRAY {
|
||||
my $class = shift;
|
||||
my ($file, $opts) = $class->parse_opts(@_);
|
||||
|
||||
my @tiefile;
|
||||
tie @tiefile, 'Tie::File', $file, recsep => "\n", %{ $opts->{tie_file} || {} }
|
||||
or croak "Cannot tie file $file";
|
||||
|
||||
my $csv;
|
||||
if (blessed $opts->{text_csv} and $opts->{text_csv}->isa('Text::CSV')) {
|
||||
$csv = $opts->{text_csv};
|
||||
} else {
|
||||
$csv = Text::CSV->new($opts->{text_csv} || {})
|
||||
or croak "CSV (new) error: " . Text::CSV->error_diag();
|
||||
}
|
||||
|
||||
my $self = {
|
||||
file => \@tiefile,
|
||||
csv => $csv,
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub FETCH {
|
||||
my $self = shift;
|
||||
my $index = shift;
|
||||
|
||||
my $line = $self->{file}[$index];
|
||||
|
||||
my $rowclass = ref($self) . '::Row';
|
||||
tie my @line, $rowclass, {
|
||||
file => $self->{file},
|
||||
line_num => $index,
|
||||
fields => $self->_parse($line),
|
||||
csv => $self->{csv},
|
||||
};
|
||||
|
||||
return \@line;
|
||||
}
|
||||
|
||||
sub STORE {
|
||||
my $self = shift;
|
||||
my ($index, $value) = @_;
|
||||
|
||||
$self->{file}[$index] = $self->_combine($value);
|
||||
}
|
||||
|
||||
sub FETCHSIZE {
|
||||
my $self = shift;
|
||||
|
||||
return scalar @{ $self->{file} };
|
||||
}
|
||||
|
||||
sub STORESIZE {
|
||||
my $self = shift;
|
||||
my $new_size = shift;
|
||||
|
||||
$#{ $self->{file} } = $new_size - 1;
|
||||
|
||||
}
|
||||
|
||||
sub EXISTS {
|
||||
my $self = shift;
|
||||
my ($index) = shift;
|
||||
return exists $self->{file}[$index];
|
||||
}
|
||||
|
||||
sub DELETE {
|
||||
my $self = shift;
|
||||
my $index = shift;
|
||||
return $self->SPLICE($index,1);
|
||||
}
|
||||
|
||||
sub _parse {
|
||||
my $self = shift;
|
||||
my ($line) = @_;
|
||||
$line = '' unless defined $line;
|
||||
|
||||
return [$self->{csv}->fields] if $self->{csv}->parse($line);
|
||||
|
||||
croak "CSV parse error: " . $self->{csv}->error_diag;
|
||||
}
|
||||
|
||||
sub _combine {
|
||||
my $self = shift;
|
||||
my ($value) = @_;
|
||||
|
||||
return $self->{csv}->string
|
||||
if $self->{csv}->combine( ref $value ? @$value : ($value) );
|
||||
|
||||
croak "CSV combine error: " . $self->{csv}->error_diag();
|
||||
}
|
||||
|
||||
package Tie::Array::CSV::Row;
|
||||
|
||||
use Carp;
|
||||
|
||||
use Tie::Array;
|
||||
our @ISA = ('Tie::Array');
|
||||
|
||||
use overload
|
||||
'@{}' => sub{ $_[0]{fields} };
|
||||
|
||||
sub TIEARRAY {
|
||||
my $class = shift;
|
||||
my $self = shift;
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub FETCH {
|
||||
my $self = shift;
|
||||
my $index = shift;
|
||||
|
||||
return $self->{fields}[$index];
|
||||
}
|
||||
|
||||
sub STORE {
|
||||
my $self = shift;
|
||||
my ($index, $value) = @_;
|
||||
|
||||
$self->{fields}[$index] = $value;
|
||||
|
||||
$self->_update;
|
||||
|
||||
}
|
||||
|
||||
sub FETCHSIZE {
|
||||
my $self = shift;
|
||||
|
||||
return scalar @{ $self->{fields} };
|
||||
}
|
||||
|
||||
sub STORESIZE {
|
||||
my $self = shift;
|
||||
my $new_size = shift;
|
||||
|
||||
my $return = (
|
||||
$#{ $self->{fields} } = $new_size - 1
|
||||
);
|
||||
|
||||
$self->_update;
|
||||
|
||||
return $return;
|
||||
}
|
||||
|
||||
sub SHIFT {
|
||||
my $self = shift;
|
||||
|
||||
my $value = shift @{ $self->{fields} };
|
||||
|
||||
$self->_update;
|
||||
|
||||
return $value;
|
||||
}
|
||||
|
||||
sub UNSHIFT {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
|
||||
unshift @{ $self->{fields} }, $value;
|
||||
|
||||
$self->_update;
|
||||
|
||||
return $self->FETCHSIZE();
|
||||
}
|
||||
|
||||
sub DELETE {
|
||||
my $self = shift;
|
||||
my $index = shift;
|
||||
|
||||
my $return = splice @{ $self->{fields} }, $index, 1;
|
||||
$self->_update;
|
||||
|
||||
return $return;
|
||||
}
|
||||
|
||||
sub EXISTS {
|
||||
my $self = shift;
|
||||
my $index = shift;
|
||||
|
||||
return exists $self->{fields}[$index];
|
||||
}
|
||||
|
||||
sub _update {
|
||||
my $self = shift;
|
||||
|
||||
if(@{ $self->{fields} }) {
|
||||
$self->{csv}->combine(@{ $self->{fields} })
|
||||
or croak "CSV combine error: " . $self->{csv}->error_diag();
|
||||
$self->{file}[$self->{line_num}] = $self->{csv}->string;
|
||||
} else {
|
||||
$self->{file}[$self->{line_num}] = '';
|
||||
}
|
||||
}
|
||||
|
||||
__END__
|
||||
__POD__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Tie::Array::CSV - A tied array which combines the power of Tie::File and Text::CSV
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use strict; use warnings;
|
||||
use Tie::Array::CSV;
|
||||
tie my @file, 'Tie::Array::CSV', 'filename';
|
||||
|
||||
print $file[0][2];
|
||||
$file[3][5] = "Camel";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module allows an array to be tied to a CSV file for reading and writing. The array is a standard Perl 2D array (i.e. an array of array references) which gives access to the row and column of the user's choosing. This is done using the well established modules:
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
L<Tie::File>
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
|
||||
arbitrary line access
|
||||
|
||||
=item *
|
||||
|
||||
low memory use even for large files
|
||||
|
||||
=back
|
||||
|
||||
=item *
|
||||
|
||||
L<Text::CSV>
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
|
||||
row parsing
|
||||
|
||||
=item *
|
||||
|
||||
row updating
|
||||
|
||||
=item *
|
||||
|
||||
uses the speedy L<Text::CSV_XS> if installed
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
This module was inspired by L<Tie::CSV_File> which (sadly) hasn't been maintained. It also doesn't attempt to do any of the parsing (as that module did), but rather passes all of the heavy lifting to other modules.
|
||||
|
||||
Note that while the L<Tie::File> prevents the need to read in the entire file, while in use, a parsed row IS held in memory.
|
||||
|
||||
=head1 CONSTRUCTORS
|
||||
|
||||
Since version 0.04 both constructors allow the options that version 0.03 only offered for the C<new> constructor. The constructors must be passed a file name, either as the first argument, or as the value to the option key C<file>. Options may be passed as key-value pairs or as a hash reference. This yields the many ways of calling the constructors shown below, one for every taste.
|
||||
|
||||
N.B. Should a lone argument filename and a C<file> option key both be passed to the constructor, the lone argument wins.
|
||||
|
||||
=head2 C<tie> Constructor
|
||||
|
||||
As with any tied array, the construction uses the C<tie> function. Basic usage is as follows:
|
||||
|
||||
tie my @file, 'Tie::Array::CSV', 'filename';
|
||||
|
||||
which would tie the lexically scoped array C<@file> to the file C<filename> using this module. Following the first two arguements to C<tie>, one may optionally pass a key-value pairs or a hashref containing additional configuration or even file specification.
|
||||
|
||||
tie my @file, 'Tie::Array::CSV', 'filename', { opt_key => val, ... };
|
||||
tie my @file, 'Tie::Array::CSV', 'filename', opt_key => val, ... ;
|
||||
tie my @file, 'Tie::Array::CSV', { file => 'filename', opt_key => val, ... };
|
||||
tie my @file, 'Tie::Array::CSV', file => 'filename', opt_key => val, ... ;
|
||||
|
||||
Of course, the magical Perl C<tie> can be scary for some, for those people there is the ...
|
||||
|
||||
=head2 C<new> Constructor
|
||||
|
||||
[ Added in version 0.03 ]
|
||||
|
||||
my $array = Tie::Array::CSV->new( 'filename' );
|
||||
my $array = Tie::Array::CSV->new( 'filename', { opt_key => val, ... });
|
||||
my $array = Tie::Array::CSV->new( 'filename', opt_key => val, ... );
|
||||
my $array = Tie::Array::CSV->new( file => 'filename', opt_key => val, ... );
|
||||
my $array = Tie::Array::CSV->new( { file => 'filename', opt_key => val, ... } );
|
||||
|
||||
It only returns a reference to the C<tie>d array due to a limitations in how C<tie> magic works.
|
||||
|
||||
=head2 Options
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
|
||||
C<file> - alternative method for specifing the file to C<tie>. This is overridden by a lone filename or handle passed as the first argument to the constructor.
|
||||
|
||||
=item *
|
||||
|
||||
C<tie_file> - hashref of options which are passed to the L<Tie::File> constructor
|
||||
|
||||
=item *
|
||||
|
||||
C<text_csv> - either:
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
|
||||
hashref of options which are passed to the L<Text::CSV> constructor
|
||||
|
||||
=item *
|
||||
|
||||
an object which satisfies C<< isa('Text::CSV') >> (added in version 0.05)
|
||||
|
||||
=back
|
||||
|
||||
=item *
|
||||
|
||||
C<sep_char> - for ease of use, a C<sep_char> option may be specified, which is passed to the L<Text::CSV> constructor. This option overrides a corresponding entry in the C<text_csv> pass-through hash.
|
||||
|
||||
=back
|
||||
|
||||
Equivalent examples:
|
||||
|
||||
tie my @file, 'Tie::Array::CSV', 'filename', {
|
||||
tie_file => {},
|
||||
text_csv => { sep_char => ';' },
|
||||
};
|
||||
|
||||
tie my @file, 'Tie::Array::CSV', 'filename', sep_char => ';';
|
||||
|
||||
Note that as of version 0.05 the functionality from the former C<hold_row> option has been separated into its own subclass module L<Tie::Array::CSV::HoldRow>. If deferring row operations is of interest to you, please see that module.
|
||||
|
||||
=head1 ERRORS
|
||||
|
||||
For simplicity this module C<croak>s on all almost all errors, which are trappable using a C<$SIG{__DIE__}> handler. Modifing a severed row object issues a warning.
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
|
||||
Much of the functionality of normal arrays is mimicked using L<Tie::Array>. The interaction of this with L<Tie::File> should be mentioned in that certain actions may be very inefficient. For example, C<(un)shift>-ing the first row of data will probably involve L<Tie::Array> asking L<Tie::File> to move each row up one line, one-by-one. As a note, the intra-row C<(un)shift> does not suffer this problem.
|
||||
|
||||
=item *
|
||||
|
||||
At one time, some effort was been made to allow for fields which contain linebreaks. Quickly it became clear that linebreaks would change line numbers used for row access by L<Tie::File>. Attempts to compensate for this, unfortunately, moved the module far from its stated goals, and therefore far less powerful for its intended purposes. The decision has been made (for now) not to support such files.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
|
||||
L<Tie::CSV_File> - inspiration for this module, but problematic
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE REPOSITORY
|
||||
|
||||
L<http://github.com/jberger/Tie-Array-CSV>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Joel Berger, E<lt>joel.a.berger@gmail.comE<gt>
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
Christian Walde (Mithaldu)
|
||||
Graham Ollis (plicease)
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (C) 2013 by L</AUTHOR> and L</CONTRIBUTORS>.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
210
database/perl/vendor/lib/Tie/Array/CSV/HoldRow.pm
vendored
Normal file
210
database/perl/vendor/lib/Tie/Array/CSV/HoldRow.pm
vendored
Normal file
@@ -0,0 +1,210 @@
|
||||
package Tie::Array::CSV::HoldRow;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp;
|
||||
|
||||
use Tie::File;
|
||||
use Text::CSV;
|
||||
|
||||
use Scalar::Util qw/weaken/;
|
||||
|
||||
use Tie::Array::CSV;
|
||||
our @ISA = ('Tie::Array::CSV');
|
||||
|
||||
# This is essentially the same TIEARRAY method as T::A::CSV,
|
||||
# but initializes active_rows. This isn't strictly necessary, thanks to autoviv
|
||||
sub TIEARRAY {
|
||||
my $class = shift;
|
||||
|
||||
my $self = $class->SUPER::TIEARRAY(@_);
|
||||
|
||||
$self->{active_rows} = {},
|
||||
|
||||
# rebless
|
||||
bless $self, $class;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub FETCH {
|
||||
my $self = shift;
|
||||
my $index = shift;
|
||||
|
||||
if ($self->{active_rows}{$index}) {
|
||||
return $self->{active_rows}{$index}
|
||||
}
|
||||
|
||||
my $line_array = $self->SUPER::FETCH($index);
|
||||
|
||||
weaken(
|
||||
$self->{active_rows}{$index} = $line_array
|
||||
);
|
||||
|
||||
return $line_array;
|
||||
}
|
||||
|
||||
sub STORE {
|
||||
my $self = shift;
|
||||
my ($index, $value) = @_;
|
||||
|
||||
$self->{file}[$index] = $self->_combine($value);
|
||||
}
|
||||
|
||||
sub SPLICE {
|
||||
my $self = shift;
|
||||
my $size = $self->FETCHSIZE;
|
||||
my $offset = @_ ? shift : 0;
|
||||
$offset += $size if $offset < 0;
|
||||
my $length = @_ ? shift : $size-$offset;
|
||||
|
||||
my @replace_rows = map { $self->_combine($_) } @_;
|
||||
|
||||
## reindex active_rows ##
|
||||
|
||||
# assuming removing items
|
||||
my @active_rows =
|
||||
sort { $a <=> $b }
|
||||
grep { defined $self->{active_rows}{$_} }
|
||||
keys %{ $self->{active_rows} };
|
||||
my $delta = @replace_rows - $length;
|
||||
|
||||
# if instead adding items
|
||||
if ($length < @replace_rows) {
|
||||
# reverse ot avoid overwriting active items
|
||||
@active_rows = reverse @active_rows;
|
||||
$delta = @replace_rows + $length;
|
||||
}
|
||||
|
||||
foreach my $index (@active_rows) {
|
||||
# skip lines before those affected
|
||||
next if ($index < $offset);
|
||||
|
||||
if ($index >= $offset and $index < ($offset + $length)) { #items that are being removed
|
||||
tied(@{$self->{active_rows}{$index}})->{line_num} = undef;
|
||||
} else { #shifting affected items
|
||||
tied(@{$self->{active_rows}{$index}})->{line_num} = $index+$delta;
|
||||
$self->{active_rows}{$index+$delta} = delete $self->{active_rows}{$index};
|
||||
}
|
||||
}
|
||||
|
||||
## end reindexing logic ##
|
||||
|
||||
my @return = map { $self->_parse($_) }
|
||||
splice(@{ $self->{file} },$offset,$length,@replace_rows);
|
||||
|
||||
return @return
|
||||
|
||||
}
|
||||
|
||||
sub SHIFT {
|
||||
my $self = shift;
|
||||
my ($return) = $self->SPLICE(0,1);
|
||||
return $return;
|
||||
}
|
||||
|
||||
sub UNSHIFT { scalar shift->SPLICE(0,0,@_) }
|
||||
|
||||
sub PUSH {
|
||||
my $self = shift;
|
||||
my $i = $self->FETCHSIZE;
|
||||
$self->STORE($i++, shift) while (@_);
|
||||
}
|
||||
|
||||
sub POP {
|
||||
my $self = shift;
|
||||
my $newsize = $self->FETCHSIZE - 1;
|
||||
my $val;
|
||||
if ($newsize >= 0) {
|
||||
$val = $self->FETCH($newsize);
|
||||
$self->STORESIZE($newsize);
|
||||
}
|
||||
return $val;
|
||||
}
|
||||
|
||||
sub CLEAR { shift->STORESIZE(0) }
|
||||
|
||||
sub EXTEND { }
|
||||
|
||||
package Tie::Array::CSV::HoldRow::Row;
|
||||
|
||||
use Carp;
|
||||
|
||||
use Tie::Array::CSV;
|
||||
our @ISA = ('Tie::Array::CSV::Row');
|
||||
|
||||
sub TIEARRAY {
|
||||
my $class = shift;
|
||||
my $self = $class->SUPER::TIEARRAY(@_);
|
||||
|
||||
# rebless
|
||||
bless $self, $class;
|
||||
|
||||
$self->{need_update} = 0;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# _update now marks for deferred update
|
||||
sub _update {
|
||||
my $self = shift;
|
||||
$self->{need_update} = 1;
|
||||
}
|
||||
|
||||
sub _deferred_update {
|
||||
my $self = shift;
|
||||
unless (defined $self->{line_num}) {
|
||||
carp "Attempted to write out from a severed row";
|
||||
return undef;
|
||||
}
|
||||
|
||||
$self->SUPER::_update();
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
$self->_deferred_update if $self->{need_update} == 1;
|
||||
}
|
||||
|
||||
__END__
|
||||
__POD__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Tie::Array::CSV::HoldRow - A Tie::Array::CSV subclass for deferring row operations
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use strict; use warnings;
|
||||
use Tie::Array::CSV::HoldRow;
|
||||
tie my @file, 'Tie::Array::CSV::HoldRow', 'filename';
|
||||
|
||||
print $file[0][2];
|
||||
$file[3][5] = "Camel";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is an experimental subclass of L<Tie::Array::CSV>, see usage information in that documentation.
|
||||
|
||||
While the usage is the same, the timing of the file IO is different. As opposed to the base module, the file is not updated while the reference to the row is still in scope. Note that for both modules, the parsed row is still held in memory while the row is in scope, the ONLY difference is that the file reflects changes immediately when C<hold_row> is false. To reiterate, this option only affects file IO, not memory usage.
|
||||
|
||||
When multiple rows are kept alive/removed/modified there was the possibility that conflicting directives could be given to a single physical line. To combat this possibility, as of version 0.05, all (living) child row objects are made aware of line number changes in the parent (outer array) should these occur. Futher if a row object is alive, but the parent object removes that line, the row object is remains intact, but the links between the row object and parent/file are severed.
|
||||
|
||||
=head1 SOURCE REPOSITORY
|
||||
|
||||
L<http://github.com/jberger/Tie-Array-CSV>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Joel Berger, E<lt>joel.a.berger@gmail.comE<gt>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (C) 2013 by Joel Berger
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
451
database/perl/vendor/lib/Tie/EncryptedHash.pm
vendored
Normal file
451
database/perl/vendor/lib/Tie/EncryptedHash.pm
vendored
Normal file
@@ -0,0 +1,451 @@
|
||||
#!/usr/bin/perl -s
|
||||
##
|
||||
## Tie::EncryptedHash - A tied hash with encrypted fields.
|
||||
##
|
||||
## Copyright (c) 2000, Vipul Ved Prakash. All rights reserved.
|
||||
## This code is based on Damian Conway's Tie::SecureHash.
|
||||
##
|
||||
## $Id: EncryptedHash.pm,v 1.8 2000/09/02 19:23:00 vipul Exp vipul $
|
||||
## vi:expandtab=1;ts=4;
|
||||
|
||||
package Tie::EncryptedHash;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION $strict);
|
||||
use Digest::MD5 qw(md5_base64);
|
||||
use Crypt::CBC;
|
||||
use Data::Dumper;
|
||||
use Carp;
|
||||
|
||||
( $VERSION ) = '$Revision: 1.8 $' =~ /\s(\d+\.\d+)\s/;
|
||||
|
||||
my $DEBUG = 0;
|
||||
|
||||
sub debug {
|
||||
return undef unless $DEBUG;
|
||||
my ($caller, undef) = caller;
|
||||
my (undef,undef,$line,$sub) = caller(1); $sub =~ s/.*://;
|
||||
$sub = sprintf "%10s()%4d",$sub,$line;
|
||||
print "$sub " . (shift) . "\n";
|
||||
}
|
||||
|
||||
# sub new {
|
||||
# my ($class,%args) = @_;
|
||||
# my %self = (); tie %self, $class;
|
||||
# my $self = bless \%self, $class;
|
||||
# $self->{__password} = $args{__password} if $args{__password};
|
||||
# $self->{__cipher} = $args{__cipher} || qq{Blowfish};
|
||||
# return $self;
|
||||
# }
|
||||
|
||||
sub new {
|
||||
my ($class,%args) = @_;
|
||||
my $self = {}; tie %$self, $class;
|
||||
bless $self, $class;
|
||||
$self->{__password} = $args{__password} if $args{__password};
|
||||
$self->{__cipher} = $args{__cipher} || qq{Blowfish};
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
sub _access {
|
||||
|
||||
my ($self, $key, $caller, $file, $value, $delete) = @_;
|
||||
my $class = ref $self || $self;
|
||||
# SPECIAL ATTRIBUTE
|
||||
if ( $key =~ /(__password|__hide|__scaffolding|__cipher)$/ ) {
|
||||
my $key = $1;
|
||||
unless($value||$delete) {return undef unless $caller eq $class}
|
||||
if ($delete && ($key =~ /__password/)) {
|
||||
for (keys %{$$self{__scaffolding}}) {
|
||||
if ( ref $self->{$_} ) {
|
||||
$self->{$_} = encrypt($self->{$_}, $self->{__scaffolding}{$_}, $self->{__cipher});
|
||||
delete $self->{__scaffolding}{$_};
|
||||
}
|
||||
}
|
||||
}
|
||||
delete $$self{$key} if $delete;
|
||||
return $self->{$key} = $value if $value;
|
||||
return $self->{$key};
|
||||
# SECRET FIELD
|
||||
} elsif ( $key =~ m/^(_{1}[^_][^:]*)$/ ||$key =~ m/.*?::(_{1}[^_][^:]*)/ ) {
|
||||
my $ctext = $self->{$1};
|
||||
if ( ref $ctext && !($value)) { # ENCRYPT REF AT FETCH
|
||||
my $pass = $self->{__scaffolding}{$1} || $self->{__password};
|
||||
return undef unless $pass;
|
||||
$self->{$1} = encrypt($ctext, $pass, $self->{__cipher});
|
||||
return $self->FETCH ($1);
|
||||
}
|
||||
my $ptext = qq{}; my $isnot = !( exists $self->{$1} );
|
||||
my $auth = verify($self,$1);
|
||||
return undef if !($auth) && ref $self->{$1};
|
||||
return undef if !($auth) && $self->{__hide};
|
||||
if ($auth && $auth ne "1") { $ptext = $auth }
|
||||
if ($value && $auth) { # STORE
|
||||
if ( ref $value ) {
|
||||
$self->{__scaffolding}{$1} = $self->{__password}; $ctext = $value;
|
||||
} else {
|
||||
my $key = $1;
|
||||
unless ($self->{__password}) {
|
||||
if ($value =~ m:^\S+\s\S{22}\s:) {
|
||||
return $self->{$key} = $value;
|
||||
} else { return undef }
|
||||
}
|
||||
$ctext = encrypt($value, $self->{__password}, $self->{__cipher});
|
||||
}
|
||||
$self->{$1} = $ctext;
|
||||
return $value;
|
||||
} elsif ($auth && $delete) { # DELETE
|
||||
delete $$self{$1}
|
||||
} elsif ($isnot && (!($value))) { # DOESN'T EXIST
|
||||
return;
|
||||
} elsif ((!($auth)) && $ctext) {
|
||||
return $ctext; # FETCH return ciphertext
|
||||
} elsif ($auth && !($isnot)) { # FETCH return plaintext
|
||||
if (ref $ptext) {
|
||||
$self->{$1} = $ptext;
|
||||
$self->{__scaffolding}{$1} = $self->{__password}; # Ref counting mechanism
|
||||
return $self->{$1};
|
||||
}
|
||||
}
|
||||
return undef unless $auth;
|
||||
return $ptext;
|
||||
# PUBLIC FIELD
|
||||
} elsif ( $key =~ m/([^:]*)$/ || $key =~ m/.*?::([^:]*)/ ) {
|
||||
$self->{$1} = $value if $value;
|
||||
delete $$self{$1} if $delete;
|
||||
return $self->{$1} if $self->{$1};
|
||||
return undef;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub encrypt { # ($plaintext, $password, $cipher)
|
||||
$_[0] = qq{REF }. Data::Dumper->new([$_[0]])->Indent(0)->Terse(0)->Purity(1)->Dumpxs if ref $_[0];
|
||||
return qq{$_[2] } . md5_base64($_[0]) .qq{ } .
|
||||
Crypt::CBC->new($_[1],$_[2])->encrypt_hex($_[0])
|
||||
}
|
||||
|
||||
sub decrypt { # ($cipher $md5sum $ciphertext, $password)
|
||||
return undef unless $_[1];
|
||||
my ($m, $d, $c) = split /\s/,$_[0];
|
||||
my $ptext = Crypt::CBC->new($_[1],$m)->decrypt_hex($c);
|
||||
my $check = md5_base64($ptext);
|
||||
if ( $d eq $check ) {
|
||||
if ($ptext =~ /^REF (.*)/is) {
|
||||
my ($VAR1,$VAR2,$VAR3,$VAR4,$VAR5,$VAR6,$VAR7,$VAR8);
|
||||
return eval qq{$1};
|
||||
}
|
||||
return $ptext;
|
||||
}
|
||||
}
|
||||
|
||||
sub verify { # ($self, $key)
|
||||
my ($self, $key) = splice @_,0,2;
|
||||
# debug ("$self->{__scaffolding}{$key}, $self->{__password}, $self->{$key}");
|
||||
return 1 unless $key =~ m:^_:;
|
||||
return 1 unless exists $self->{$key};
|
||||
return undef if ref $self->{$key} && ($self->{__scaffolding}{$key} ne
|
||||
$self->{__password});
|
||||
my $ptext = decrypt($self->{$key}, $self->{__password});
|
||||
return $ptext if $ptext;
|
||||
}
|
||||
|
||||
sub each { CORE::each %{$_[0]} }
|
||||
sub keys { CORE::keys %{$_[0]} }
|
||||
sub values { CORE::values %{$_[0]} }
|
||||
sub exists { CORE::exists $_[0]->{$_[1]} }
|
||||
|
||||
sub TIEHASH # ($class, @args)
|
||||
{
|
||||
my $class = ref($_[0]) || $_[0];
|
||||
my $self = bless {}, $class;
|
||||
$self->{__password} = $_[1] if $_[1];
|
||||
$self->{__cipher} = $_[2] || qq{Blowfish};
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub FETCH # ($self, $key)
|
||||
{
|
||||
my ($self, $key) = @_;
|
||||
my $entry = _access($self,$key,(caller)[0..1]);
|
||||
return $entry if $entry;
|
||||
}
|
||||
|
||||
sub STORE # ($self, $key, $value)
|
||||
{
|
||||
my ($self, $key, $value) = @_;
|
||||
my $entry = _access($self,$key,(caller)[0..1],$value);
|
||||
return $entry if $entry;
|
||||
}
|
||||
|
||||
sub DELETE # ($self, $key)
|
||||
{
|
||||
my ($self, $key) = @_;
|
||||
return _access($self,$key,(caller)[0..1],'',1);
|
||||
}
|
||||
|
||||
sub CLEAR # ($self)
|
||||
{
|
||||
my ($self) = @_;
|
||||
return undef if grep { ! $self->verify($_) }
|
||||
grep { ! /__/ } CORE::keys %{$self};
|
||||
%{$self} = ();
|
||||
}
|
||||
|
||||
sub EXISTS # ($self, $key)
|
||||
{
|
||||
my ($self, $key) = @_;
|
||||
my @context = (caller)[0..1];
|
||||
return _access($self,$key,@context) ? 1 : '';
|
||||
}
|
||||
|
||||
sub FIRSTKEY # ($self)
|
||||
{
|
||||
my ($self) = @_;
|
||||
CORE::keys %{$self};
|
||||
goto &NEXTKEY;
|
||||
}
|
||||
|
||||
sub NEXTKEY # ($self)
|
||||
{
|
||||
my $self = $_[0]; my $key;
|
||||
my @context = (caller)[0..1];
|
||||
while (defined($key = CORE::each %{$self})) {
|
||||
last if eval { _access($self,$key,@context) }
|
||||
}
|
||||
return $key;
|
||||
}
|
||||
|
||||
sub DESTROY # ($self)
|
||||
{
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Tie::EncryptedHash - Hashes (and objects based on hashes) with encrypting fields.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Tie::EncryptedHash;
|
||||
|
||||
my %s = ();
|
||||
tie %s, Tie::EncryptedHash, 'passwd';
|
||||
|
||||
$s{foo} = "plaintext"; # Normal field, stored in plaintext.
|
||||
print $s{foo}; # (plaintext)
|
||||
|
||||
$s{_bar} = "signature"; # Fieldnames that begin in single
|
||||
# underscore are encrypted.
|
||||
print $s{_bar}; # (signature) Though, while the password
|
||||
# is set, they behave like normal fields.
|
||||
delete $s{__password}; # Delete password to disable access
|
||||
# to encrypting fields.
|
||||
print $s{_bar}; # (Blowfish NuRVFIr8UCAJu5AWY0w...)
|
||||
|
||||
$s{__password} = 'passwd'; # Restore password to gain access.
|
||||
print $s{_bar}; # (signature)
|
||||
|
||||
$s{_baz}{a}{b} = 42; # Refs are fine, we encrypt them too.
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Tie::EncryptedHash augments Perl hash semantics to build secure, encrypting
|
||||
containers of data. Tie::EncryptedHash introduces special hash fields that
|
||||
are coupled with encrypt/decrypt routines to encrypt assignments at STORE()
|
||||
and decrypt retrievals at FETCH(). By design, I<encrypting fields> are
|
||||
associated with keys that begin in single underscore. The remaining
|
||||
keyspace is used for accessing normal hash fields, which are retained
|
||||
without modification.
|
||||
|
||||
While the password is set, a Tie::EncryptedHash behaves exactly like a
|
||||
standard Perl hash. This is its I<transparent mode> of access. Encrypting
|
||||
and normal fields are identical in this mode. When password is deleted,
|
||||
encrypting fields are accessible only as ciphertext. This is
|
||||
Tie::EncryptedHash's I<opaque mode> of access, optimized for serialization.
|
||||
|
||||
Encryption is done with Crypt::CBC(3) which encrypts in the cipher block
|
||||
chaining mode with Blowfish, DES or IDEA. Tie::EncryptedHash uses Blowfish
|
||||
by default, but can be instructed to employ any cipher supported by
|
||||
Crypt::CBC(3).
|
||||
|
||||
=head1 MOTIVATION
|
||||
|
||||
Tie::EncryptedHash was designed for storage and communication of key
|
||||
material used in public key cryptography algorithms. I abstracted out the
|
||||
mechanism for encrypting selected fields of a structured data record because
|
||||
of the sheer convenience of this data security method.
|
||||
|
||||
Quite often, applications that require data confidentiality eschew strong
|
||||
cryptography in favor of OS-based access control mechanisms because of the
|
||||
additional costs of cryptography integration. Besides cipher
|
||||
implementations, which are available as ready-to-deploy perl modules, use of
|
||||
cryptography in an application requires code to aid conversion and
|
||||
representation of encrypted data. This code is usually encapsulated in a
|
||||
data access layer that manages encryption, decryption, access control and
|
||||
re-structuring of flat plaintext according to a data model.
|
||||
Tie::EncryptedHash provides these functions under the disguise of a Perl
|
||||
hash so perl applications can use strong cryptography without the cost of
|
||||
implementing a complex data access layer.
|
||||
|
||||
|
||||
=head1 CONSTRUCTION
|
||||
|
||||
=head2 Tied Hash
|
||||
|
||||
C<tie %h, Tie::EncryptedHash, 'Password', 'Cipher';>
|
||||
|
||||
Ties %h to Tie::EncryptedHash and sets the value of password and cipher to
|
||||
'Password' and 'Cipher'. Both arguments are optional.
|
||||
|
||||
=head2 Blessed Object
|
||||
|
||||
C<$h = new Tie::EncryptedHash __password => 'Password',
|
||||
__cipher => 'Cipher';>
|
||||
|
||||
The new() constructor returns an object that is both tied and blessed into
|
||||
Tie::EncryptedHash. Both arguments are optional. When used in this manner,
|
||||
Tie::EncryptedHash behaves like a class with encrypting data members.
|
||||
|
||||
=head1 RESERVED ATTRIBUTES
|
||||
|
||||
The attributes __password, __cipher and __hide are reserved for
|
||||
communication with object methods. They are "write-only" from everywhere
|
||||
except the class to which the hash is tied. __scaffolding is inaccessible.
|
||||
Tie::EncryptedHash stores the current encryption password and some transient
|
||||
data structures in these fields and restricts access to them on need-to-know
|
||||
basis.
|
||||
|
||||
=head2 __password
|
||||
|
||||
C<$h{__password} = "new password";
|
||||
delete $h{__password};>
|
||||
|
||||
The password is stored under the attribute C<__password>. In addition to
|
||||
specifying a password at construction, assigning to the __password attribute
|
||||
sets the current encryption password to the assigned value. Deleting the
|
||||
__password unsets it and switches the hash into opaque mode.
|
||||
|
||||
=head2 __cipher
|
||||
|
||||
C<$h{__cipher} = 'DES'; $h{__cipher} = 'Blowfish';>
|
||||
|
||||
The cipher used for encryption/decryption is stored under the attribute
|
||||
__cipher. The value defaults to 'Blowfish'.
|
||||
|
||||
=head2 __hide
|
||||
|
||||
C<$h{__hide} = 1;>
|
||||
|
||||
Setting this attribute I<hides> encrypting fields in opaque mode. 'undef'
|
||||
is returned at FETCH() and EXISTS().
|
||||
|
||||
=head1 BEHAVIOR
|
||||
|
||||
=head2 References
|
||||
|
||||
A reference stored in an encrypting field is serialized before encryption.
|
||||
The data structure represented by the reference is folded into a single line
|
||||
of ciphertext which is stored under the first level key. In the opaque
|
||||
mode, therefore, only the first level of keys of the hash will be visible.
|
||||
|
||||
=head2 Opaque Mode
|
||||
|
||||
The opaque mode introduces several other constraints on access of encrypting
|
||||
fields. Encrypting fields return ciphertext on FETCH() unless __hide
|
||||
attribute is set, which forces Tie::EncryptedHash to behave as if encrypting
|
||||
fields don't exist. Irrespective of __hide, however, DELETE() and CLEAR()
|
||||
fail in opaque mode. So does STORE() on an existing encrypting field.
|
||||
Plaintext assignments to encrypting fields are silently ignored, but
|
||||
ciphertext assignments are fine. Ciphertext assignments can be used to move
|
||||
data between different EncryptedHashes.
|
||||
|
||||
=head2 Multiple Passwords and Ciphers
|
||||
|
||||
Modality of Tie::EncryptedHash's access system breaks down when more than
|
||||
one password is used to with different encrypting fields. This is a
|
||||
feature. Tie::EncryptedHash lets you mix passwords and ciphers in the same
|
||||
hash. Assign new values to __password and __cipher and create a new
|
||||
encrypting field. Transparent mode will be restricted to fields encrypted
|
||||
with the current password.
|
||||
|
||||
=head2 Error Handling
|
||||
|
||||
Tie::Encrypted silently ignores access errors. It doesn't carp/croak when
|
||||
you perform an illegal operation (like assign plaintext to an encrypting
|
||||
field in opaque mode). This is to prevent data lossage, the kind that
|
||||
results from abnormal termination of applications.
|
||||
|
||||
=head1 QUIRKS
|
||||
|
||||
=head2 Autovivification
|
||||
|
||||
Due to the nature of autovivified references (which spring into existence
|
||||
when an undefined reference is dereferenced), references are stored as
|
||||
plaintext in transparent mode. Analogous ciphertext representations are
|
||||
maintained in parallel and restored to encrypting fields when password is
|
||||
deleted. This process is completely transparent to the user, though it's
|
||||
advisable to delete the password after the final assignment to a
|
||||
Tie::EncryptedHash. This ensures plaintext representations and scaffolding
|
||||
data structures are duly flushed.
|
||||
|
||||
=head2 Data::Dumper
|
||||
|
||||
Serialization of references is done with Data::Dumper, therefore the nature
|
||||
of data that can be assigned to encrypting fields is limited by what
|
||||
Data::Dumper can grok. We set $Data::Dumper::Purity = 1, so
|
||||
self-referential and recursive structures should be OK.
|
||||
|
||||
=head2 Speed
|
||||
|
||||
Tie::EncryptedHash'es keep their contents encrypted as much as possible, so
|
||||
there's a rather severe speed penalty. With Blowfish, STORE() on
|
||||
EncryptedHash can be upto 70 times slower than a standard perl hash.
|
||||
Reference STORE()'es will be quicker, but speed gain will be adjusted at
|
||||
FETCH(). FETCH() is about 35 times slower than a standard perl hash. DES
|
||||
affords speed improvements of upto 2x, but is not considered secure for
|
||||
long-term storage of data. These values were computed on a DELL PIII-300
|
||||
Mhz notebook with 128 Mb RAM running perl 5.003 on Linux 2.2.16. Variations
|
||||
in speed might be different on your machine.
|
||||
|
||||
=head1 STANDARD USAGE
|
||||
|
||||
The standard usage for this module would be something along the lines of:
|
||||
populate Tie::EncryptedHash with sensitive data, delete the password,
|
||||
serialize the encrypted hash with Data::Dumper, store the result on disk or
|
||||
send it over the wire to another machine. Later, when the sensitive data is
|
||||
required, procure the EncryptedHash, set the password and accesses the
|
||||
encrypted data fields.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
Data::Dumper(3),
|
||||
Crypt::CBC(3),
|
||||
Crypt::DES(3),
|
||||
Crypt::Blowfish(3),
|
||||
Tie::SecureHash(3)
|
||||
|
||||
=head1 ACKNOWLEDGEMENTS
|
||||
|
||||
The framework of Tie::EncryptedHash derives heavily from Damian Conway's
|
||||
Tie::SecureHash. Objects that are blessed as well as tied are just one of
|
||||
the pleasant side-effects of stealing Damian's code. Thanks to Damian for
|
||||
this brilliant module.
|
||||
|
||||
PacificNet (http://www.pacificnet.net) loaned me the aforementioned notebook
|
||||
to hack from the comfort of my bed. Thanks folks!
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Vipul Ved Prakash <mail@vipul.net>
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This module is distributed under the same license as Perl itself.
|
||||
|
||||
|
||||
45
database/perl/vendor/lib/Tie/Registry.pm
vendored
Normal file
45
database/perl/vendor/lib/Tie/Registry.pm
vendored
Normal file
@@ -0,0 +1,45 @@
|
||||
package Tie::Registry;
|
||||
|
||||
# Tie/Registry.pm -- Provides backward compatibility for Win32::TieRegistry
|
||||
# that was called Tie::Registry prior to version 0.20.
|
||||
# by Tye McQueen, tye@metronet.com, see http://www.metronet.com/~tye/.
|
||||
|
||||
use strict;
|
||||
use Carp;
|
||||
|
||||
use vars qw( $VERSION @ISA );
|
||||
BEGIN {
|
||||
require Win32::TieRegistry;
|
||||
$VERSION = '0.15';
|
||||
@ISA = qw{Win32::TieRegistry};
|
||||
}
|
||||
|
||||
sub import {
|
||||
my $pkg = shift;
|
||||
Win32::TieRegistry->import( ExportLevel => 1, SplitMultis => 0, @_ );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Tie::Registry - Legacy interface to Win32::TieRegistry (DEPRECATED)
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides backward compatibility for L<Win32::TieRegistry>
|
||||
that was called Tie::Registry prior to version 0.20.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Tye McQueen E<lt>tye@metronet.comE<gt>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 1999 Tye McQueen.
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user