File Coverage

blib/lib/Class/DBI/Plugin/PseudoColumns.pm

Criterion	Covered	Total	%
statement	21	129	16.2
branch	1	56	1.7
condition	0	33	0.0
subroutine	7	14	50.0
pod	2	2	100.0
total	31	234	13.2

package Class::DBI::Plugin::PseudoColumns;

use strict;
use warnings;
use Carp;
use Data::Dumper ();
use vars qw($VERSION);
$VERSION = 0.03;

sub import {
    my $class = shift;
    my $pkg   = caller;

    return unless $pkg->isa('Class::DBI');
    if ($pkg->isa('Class::DBI')) {
        $pkg->mk_classdata('_p_column_groups');
        $pkg->mk_classdata('_serializer');
    }

    no strict 'refs';

    *{"$pkg\::pseudo_columns"} = sub {
        my $class = shift;
        croak "You must set table before call pseudo_columns()"
            unless defined $class->table;
        my $parent_column = shift;
        my $p_col_groups = $class->_p_column_groups;
        if (defined $_[0]) {
            my @colnames = @_;
            $p_col_groups->{$class}->{$parent_column} = \@colnames;
            $class->_p_column_groups($p_col_groups);
            for my $p_column (@colnames) {
                *{"$class\::$p_column"} = sub {
                    my $self = shift;
                    my $property = $self->__deserialize($parent_column);
                    if (@_) {
                        $property->{$p_column} = shift;
                        my $serialized =
                            $self->__serialize($parent_column => $property);
                        $self->$parent_column($serialized);
                    }
                    return $property->{$p_column};
                };
            }
        }
        elsif (defined $parent_column) {
            return unless ref($p_col_groups) eq 'HASH' &&
                ref($p_col_groups->{$class}) eq 'HASH' &&
                    ref($p_col_groups->{$class}->{$parent_column}) eq 'ARRAY';
            return @{$p_col_groups->{$class}->{$parent_column}};
        }
        else {
            return unless ref($p_col_groups) eq 'HASH' &&
                ref($p_col_groups->{$class}) eq 'HASH';
            my @pseudo_cols = ();
            for my $col (keys %{$p_col_groups->{$class}}) {
                next unless ref($p_col_groups->{$class}->{$col}) eq 'ARRAY';
                push @pseudo_cols, @{$p_col_groups->{$class}->{$col}};
            }
            return @pseudo_cols;
        }
    };

    my $super_create = $pkg->can('create');
    croak "create() method can not be called in $pkg" unless $super_create;
    *{"$pkg\::create"} = sub {
        my($class, $hashref) = @_;
        croak "create needs a hashref" unless ref($hashref) eq 'HASH';
        croak "You must set table before call create()"
            unless defined $class->table;
        my %cols_check = map { $_ => 1 } $class->pseudo_columns;
        my %p_values = ();
        for my $col (keys %$hashref) {
            next unless $cols_check{$col};
            $p_values{$col} = delete $hashref->{$col};
        }
        my $row = $class->$super_create($hashref); # create()
        if (%p_values) {
            for my $col (keys %p_values) {
                $row->$col($p_values{$col});
            }
            $row->update;
        }
        return $row;
    };

    my $super_set = $pkg->can('set');
    croak "set() method can not be called in $pkg" unless $super_set;
    *{"$pkg\::set"} = sub {
        my $self = shift;
        my $column_values = {@_};
        my $class = ref($self) || $self;
        my %cols_check = map { $_ => 1 } $class->pseudo_columns;
        my %p_values = ();
        for my $col (keys %$column_values) {
            next unless $cols_check{$col};
            $p_values{$col} = delete $column_values->{$col};
        }
        $self->$super_set(%$column_values) if %$column_values;
        if (%p_values) {
            for my $col (keys %p_values) {
                $self->$col($p_values{$col});
            }
        }
    };

    for my $export (qw(__serialize __deserialize serializer deserializer)) {
        *{"$pkg\::$export"} = \&$export;
    }
}

sub serializer {
    my($class, $parent_column, $subref) = @_;
    croak "You must set table before call serializer()"
        unless defined $class->table;
    my $serializer = $class->_serializer;
    if (ref($subref) eq 'CODE') {
        $serializer->{serializer} = { $parent_column => $subref };
        $class->_serializer($serializer);
    }
    else {
        carp "Usage: __PACKAGE__->serializer(parent_column => \$subref)";
    }
}

sub deserializer {
    my($class, $parent_column, $subref) = @_;
    croak "You must set table before call deserializer()"
        unless defined $class->table;
    my $serializer = $class->_serializer;
    if (ref($subref) eq 'CODE') {
        $serializer->{deserializer} = { $parent_column => $subref };
        $class->_serializer($serializer);
    }
    else {
        carp "Usage: __PACKAGE__->deserializer(parent_column => \$subref)";
    }
}

sub __serialize {
    my($self, $column, $var) = @_;
    my $class = ref($self) || $self;
    croak "Can't lookup the table name via table() method."
        unless defined $class->table;
    my $serializer = $class->_serializer;
    if (ref($serializer->{serializer}) eq 'HASH' &&
        exists $serializer->{serializer}->{$column} &&
            ref($serializer->{serializer}->{$column}) eq 'CODE') {
        return $serializer->{serializer}->{$column}->($var);
    }
    else {
        local $Data::Dumper::Terse  = 1;
        local $Data::Dumper::Indent = 0;
        return Data::Dumper::Dumper($var);
    }
}

sub __deserialize {
    my($self, $column) = @_;
    my $class = ref($self) || $self;
    croak "Can't lookup the table name via table() method."
        unless defined $class->table;
    my $prop;
    my $dumped = $self->$column;
    if (defined $dumped) {
        my $serializer = $class->_serializer;
        if (ref($serializer->{deserializer}) eq 'HASH' &&
            exists $serializer->{deserializer}->{$column} &&
                ref($serializer->{deserializer}->{$column}) eq 'CODE') {
            $prop = $serializer->{deserializer}->{$column}->($dumped);
        }
        else {
            $prop = eval qq{ $dumped };
        }
    }
    return $prop if defined $prop && ref($prop) eq 'HASH';
    return {};
}

1;

__END__