Initial Commit

database/perl/vendor/lib/DBI/Util/CacheMemory.pm

@@ -0,0 +1,117 @@
+package DBI::Util::CacheMemory;
+
+#   $Id: CacheMemory.pm 10314 2007-11-26 22:25:33Z Tim $
+#
+#   Copyright (c) 2007, Tim Bunce, Ireland
+#
+#   You may distribute under the terms of either the GNU General Public
+#   License or the Artistic License, as specified in the Perl README file.
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+DBI::Util::CacheMemory - a very fast but very minimal subset of Cache::Memory
+
+=head1 DESCRIPTION
+
+Like Cache::Memory (part of the Cache distribution) but doesn't support any fancy features.
+
+This module aims to be a very fast compatible strict sub-set for simple cases,
+such as basic client-side caching for DBD::Gofer.
+
+Like Cache::Memory, and other caches in the Cache and Cache::Cache
+distributions, the data will remain in the cache until cleared, it expires,
+or the process dies. The cache object simply going out of scope will I<not>
+destroy the data.
+
+=head1 METHODS WITH CHANGES
+
+=head2 new
+
+All options except C<namespace> are ignored.
+
+=head2 set
+
+Doesn't support expiry.
+
+=head2 purge
+
+Same as clear() - deletes everything in the namespace.
+
+=head1 METHODS WITHOUT CHANGES
+
+=over
+
+=item clear
+
+=item count
+
+=item exists
+
+=item remove
+
+=back
+
+=head1 UNSUPPORTED METHODS
+
+If it's not listed above, it's not supported.
+
+=cut
+
+our $VERSION = "0.010315";
+
+my %cache;
+
+sub new {
+    my ($class, %options ) = @_;
+    my $namespace = $options{namespace} ||= 'Default';
+    #$options{_cache} = \%cache; # can be handy for debugging/dumping
+    my $self =  bless \%options => $class;
+    $cache{ $namespace } ||= {}; # init - ensure it exists
+    return $self;
+}
+
+sub set {
+    my ($self, $key, $value) = @_;
+    $cache{ $self->{namespace} }->{$key} = $value;
+}
+
+sub get {
+    my ($self, $key) = @_;
+    return $cache{ $self->{namespace} }->{$key};
+}
+
+sub exists {
+    my ($self, $key) = @_;
+    return exists $cache{ $self->{namespace} }->{$key};
+}
+
+sub remove {
+    my ($self, $key) = @_;
+    return delete $cache{ $self->{namespace} }->{$key};
+}
+
+sub purge {
+    return shift->clear;
+}
+
+sub clear {
+    $cache{ shift->{namespace} } = {};
+}
+
+sub count {
+    return scalar keys %{ $cache{ shift->{namespace} } };
+}
+
+sub size {
+    my $c = $cache{ shift->{namespace} };
+    my $size = 0;
+    while ( my ($k,$v) = each %$c ) {
+        $size += length($k) + length($v);
+    }
+    return $size;
+}
+
+1;

database/perl/vendor/lib/DBI/Util/_accessor.pm

@@ -0,0 +1,65 @@
+package DBI::Util::_accessor;
+use strict;
+use Carp;
+our $VERSION = "0.009479";
+
+# inspired by Class::Accessor::Fast
+
+sub new {
+    my($proto, $fields) = @_;
+    my($class) = ref $proto || $proto;
+    $fields ||= {};
+
+    my @dubious = grep { !m/^_/ && !$proto->can($_) } keys %$fields;
+    carp "$class doesn't have accessors for fields: @dubious" if @dubious;
+
+    # make a (shallow) copy of $fields.
+    bless {%$fields}, $class;
+}
+
+sub mk_accessors {
+    my($self, @fields) = @_;
+    $self->mk_accessors_using('make_accessor', @fields);
+}
+
+sub mk_accessors_using {
+    my($self, $maker, @fields) = @_;
+    my $class = ref $self || $self;
+
+    # So we don't have to do lots of lookups inside the loop.
+    $maker = $self->can($maker) unless ref $maker;
+
+    no strict 'refs';
+    foreach my $field (@fields) {
+        my $accessor = $self->$maker($field);
+        *{$class."\:\:$field"} = $accessor
+            unless defined &{$class."\:\:$field"};
+    }
+    #my $hash_ref = \%{$class."\:\:_accessors_hash};
+    #$hash_ref->{$_}++ for @fields;
+    # XXX also copy down _accessors_hash of base class(es)
+    # so one in this class is complete
+    return;
+}
+
+sub make_accessor {
+    my($class, $field) = @_;
+    return sub {
+        my $self = shift;
+        return $self->{$field} unless @_;
+        croak "Too many arguments to $field" if @_ > 1;
+        return $self->{$field} = shift;
+    };
+}
+
+sub make_accessor_autoviv_hashref {
+    my($class, $field) = @_;
+    return sub {
+        my $self = shift;
+        return $self->{$field} ||= {} unless @_;
+        croak "Too many arguments to $field" if @_ > 1;
+        return $self->{$field} = shift;
+    };
+}
+
+1;