File Coverage

blib/lib/Class/PObject/Driver.pm

Criterion	Covered	Total	%
statement	78	120	65.0
branch	18	30	60.0
condition	11	24	45.8
subroutine	13	21	61.9
pod	11	13	84.6
total	131	208	62.9

package Class::PObject::Driver;

# Driver.pm,v 1.19 2003/11/07 00:36:21 sherzodr Exp

use strict;
#use diagnostics;
use Carp;
use Log::Agent;
use vars ('$VERSION');

$VERSION = '2.00';

# Preloaded methods go here.

sub new {
    my $class = shift;
    $class = ref($class) || $class;

    logtrc 3, "%s->new()", $class;

    my $self = {
        _stash    => { },
    };
    return bless($self, $class)
}


sub DESTROY { }


sub errstr {
    my ($self, $errstr) = @_;
    my $class = ref($self) || $self;

    no strict 'refs';
    if ( defined $errstr ) {
        ${ "$class\::errstr" } = $errstr
    }
    return ${ "$class\::errstr" }
}




sub stash {
    my ($self, $key, $value) = @_;

    if ( defined($key) && defined($value) ) {
        $self->{_stash}->{$key} = $value
    }
    return $self->{_stash}->{$key}
}




sub dump {
    my $self = shift;

    require Data::Dumper;
    my $d = new Data::Dumper([$self], [ref $self]);
    return $d->Dump()
}


sub save {
    my $self = shift;
    my ($object_name, $props, $columns) = @_;

    croak "'$object_name' object doesn't support 'save()' method"
}

sub load {
    my $self = shift;
    my ($object_name, $props, $id) = @_;

    croak "'$object_name' doesn't support 'load()' method"
}



sub load_ids {
    my $self = shift;
    my ($object_name, $props, $terms, $args) = @_;

    croak "'$object_name' doesn't support  'load()' method"
}



sub remove {
    my $self = shift;
    my ($object_name, $props, $id) = @_;

    croak "'$object_name' doesn't support 'remove()' method"
}

sub drop_datasource {
    my $self = shift;
    my ($object_name, $props) = @_;

    croak "'$object_name' doesn't support 'drop_datasource()' method"
}


sub remove_all {
    my $self = shift;
    my $class = ref($self) || $self;
    my ($object_name, $props, $terms) = @_;

    logtrc 3, "%s->remove_all(%s)", $class, join ", ", @_;

    my $data_set = $self->load_ids($object_name, $props, $terms);
    for ( @$data_set ) {
        $self->remove($object_name, $props, $_)
    }
    return 1
}




sub count {
    my $self = shift;
    my $class = ref($self) || $self;
    my ($object_name, $props, $terms) = @_;

    logtrc 3, "%s->count(%s)", $class, join ", ", @_;

    my $data_set = $self->load_ids($object_name, $props, $terms);
    return scalar( @$data_set ) || 0
}










sub _filter_by_args {
    my ($self, $data_set, $args) = @_;

    unless ( keys %$args ) {
        return $data_set
    }
    # if sorting column was defined
    if ( defined $args->{'sort'} ) {
        # default to 'asc' sorting direction if it was not specified
        $args->{direction} ||= 'asc';
        # and sort the data set
        if ( $args->{direction} eq 'desc' ) {
            $data_set = [ sort {$b->{$args->{'sort'}} cmp $a->{$args->{'sort'}} } @$data_set]
        } else {
            $data_set = [ sort {$a->{$args->{'sort'}} cmp $b->{$args->{'sort'}} } @$data_set]
        }
    }
    # if 'limit' was defined
    if ( defined $args->{limit} ) {
        # default to 0 for 'offset' if 'offset' was not set
        $args->{offset} ||= 0;
        # and splice the data set
        return [splice(@$data_set, $args->{offset}, $args->{limit})]
    }
    return $data_set
}






sub _matches_terms {
    my $self = shift;
    my $class = ref($self) || $self;
    my ($data, $terms) = @_;

    logtrc 3, "%s->_matches_terms(@_)", $class;
    unless ( keys %$terms ) {
        return 1
    }
    # otherwise check this data set against all the terms
    # provided. If even one of those terms are not satisfied,
    # return false
    while ( my ($column, $value) = each %$terms ) {
        $^W = 0;
        if ( $data->{$column} ne $value ) {
            return 0
        }
    }
    return 1
}




sub freeze {
    my ($self, $object_name, $props, $data) = @_;

    my $rv = undef;
    if ( $props->{serializer} eq "xml" ) {
        require Data::DumpXML;
        $rv = Data::DumpXML::dump_xml($data)
    } elsif ( $props->{serializer} eq "dumper" ) {
        require Data::Dumper;
        my $d = Data::Dumper->new([$data]);
        $d->Terse(1);
        $d->Indent(0);
        $rv =  $d->Dump();
    } elsif ( $props->{serializer} eq 'freezethaw' ) {
        require FreezeThaw;
        $rv = FreezeThaw::freeze($data)
    } else {
        require Storable;
        $rv = Storable::freeze( $data )
    }
    return $rv
}




sub thaw {
    my ($self, $object_name, $props, $datastr) = @_;

    unless ( $datastr ) {
        return undef
    }

    my $rv = undef;
    if ( $props->{serializer} eq "xml" ) {
        require Data::DumpXML::Parser;
        my $p = Data::DumpXML::Parser->new();
        warn "parsing '$datastr'";
        $rv = $p->parse($datastr)
    } elsif ( $props->{serializer} eq "dumper" ) {
        $rv = eval $datastr;
    } elsif ( $props->{serializer} eq 'freezethaw' ) {
        require FreezeThaw;
        $rv = (FreezeThaw::thaw($datastr))[0]
    } else {
        require Storable;
        $rv = Storable::thaw( $datastr );
    }
    return $rv
}







1;
__END__