File Coverage

blib/lib/DB2/Row.pm

Criterion	Covered	Total	%
statement	12	168	7.1
branch	0	76	0.0
condition	0	45	0.0
subroutine	4	29	13.7
pod	20	20	100.0
total	36	338	10.6

package DB2::Row;

use diagnostics;
use Carp;
use strict;
use warnings;

our $VERSION = '0.23';

=head1 NAME

DB2::Row Framework wrapper around rows using DBD::DB2

=head1 SYNOPSIS

    package myRow;
    use DB2::Row;
    our @ISA = qw( DB2::Row );

    ...

    use myDB;
    use myTable;

    my $db = myDB->new;
    my $tbl = $db->get_table('myTable');
    my $row = $tbl->find($id);
    print $row->col_name;

=head1 FUNCTIONS

=over 4

=item C

Do not call this - you should get your row through your table object.
To create a new row, see C

=cut

sub new
{
    my $class = shift;
    my $self = {};
    bless $self, ref $class || $class;

    my $init = shift;
    if ($init)
    {
        %{$self->{CONFIG}} = %$init;
        if (exists $self->{CONFIG}{_db_object})
        {
            $self->{_db_object} = $self->{CONFIG}{_db_object};
            delete $self->{CONFIG}{_db_object};
        }
        %{$self->{ORIGVALUE}} = %{$self->{CONFIG}};
    }

    foreach my $p ($self->_table->column_list)
    {
        next if exists $self->{CONFIG}{$p};

        my $col = $self->_table->get_column($p);
        $self->{CONFIG}{$p} = $col->{default} if exists $col->{default};
    }

    return $self;
}

sub _modified
{ scalar keys %{shift->{modified}} > 0; }

sub _db
{ shift->{_db_object} }

sub _table
{
    my $self = shift;
    unless (exists $self->{_table})
    {
        $self->{_table} = $self->_db->get_table_for_row_type(ref $self);
    }
    $self->{_table};
}

=item C

Save the current row.  Will happen automatically if it can.  Only
really need to call this if you're interested in any generated identity
column for a new row.

=cut

sub save
{
    my $self = shift;
    if ($self and $self->_modified)
    {
        my $rc = $self->_table->save($self);

        # if we have any "generated" value, see if we can find it.
        my $genColumn = $self->_table->generatedIdentityColumn;
        if ($genColumn and not defined $self->column($genColumn))
        {
            my $stmt = 'values (IDENTITY_VAL_LOCAL())';
            my $sth = $self->_table->_prepare($stmt);
            $sth->execute;
            my $id = $sth->fetchrow_array();
            $self->column($genColumn, $id);
            $sth->finish();
        }

        $self->{ORIGVALUE} = { %{$self->{CONFIG}} };

        delete $self->{modified};
        $self->_table->commit;
        return $rc;
    }
    return '0E0';
}

=item C

If you do not want your changes up to this point to be kept,
C will do the obvious

=cut

sub discard_changes
{
    my $self = shift;
    if ($self->_modified)
    {
        $self->{CONFIG} = { %{$self->{ORIGVALUE}} };
        delete $self->{modified};
    }
}

=item C

Converts a DB2 timestamp column to a perl ("C") time value

=cut

my $timestamp_re = qr/(\d{4})-(\d\d)-(\d\d)[- ](\d\d)[.:](\d\d)[.:](\d\d)[.:](\d{6})/;

sub timestamp_to_time
{
    my $self = shift;
    my $ts = shift;

    if (not defined $ts)
    {
        return undef;
    }

    my ($year, $mon, $mday, $hour, $min, $sec) =
        ($ts =~ $timestamp_re);
    $year -= 1900;
    $mon  -= 1;
    timegm($sec, $min, $hour, $mday, $mon, $year);
}

=item C

Converts a perl ("C") time value to a DB2 timestamp string.

=cut

sub time_to_timestamp
{
    my $self = shift;
    my $time = shift;

    if (not defined $time)
    {
        return undef;
    }

    # if you pass in a timestamp, you'll get it back.
    if ($time =~ $timestamp_re)
    {
        return $time;
    }

    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($time);
    sprintf "%04d-%02d-%02d-%02d.%02d.%02d.%06d",
        ($year + 1900), $mon + 1, $mday, $hour, $min, $sec, 0;
}

=item C

Convert time to date.  Converts a C/perl time to DB2's DATE format.

=cut

sub time_to_date
{
    my $self = shift;
    my $time = shift;

    if (not defined $time)
    {
        return undef;
    }

    if ($time =~ /^\d+$/)
    {
        my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($time);
        return sprintf "%04d-%02d-%02d", ($year + 1900), $mon + 1, $mday;
    }
    elsif ($time =~ m.^(\d{2})/(\d{2})/(\d{4})$.)
    {
        # assume mm/dd/yyyy?
        my ($m, $d, $y) = ($1, $2, $3);
        if ($m > 12)
        {
            # bad assumption?
            my $t = $m;
            $m = $d;
            $d = $t;
        }
        return sprintf("%04d-%02d-%02d", $y, $m, $d);
    }
    elsif ($time =~ /^(\d{2}).(\d{2}).(\d{4})$/)
    {
        # assume dd.mm.yyyy
        my ($d, $m, $y) = ($1, $2, $3);
        if ($m > 12)
        {
            # bad assumption?
            my $t = $m;
            $m = $d;
            $d = $t;
        }
        return sprintf("%04d-%02d-%02d", $y, $m, $d);
    }
}

=item C

Override this if you need to validate changes to a column.  Normally
you can leave this to the database itself, but you may want to do this
earlier than that.  You can also use this to massage the value before
it is kept.

The parameters are:

  self
  column name
  new value

To keep the value as given, simply return it.  To modify (massage) the
value, return the modified value.  To prevent the update, die.

Remember to call your SUPER before validating yourself to allow for
future enhancements in C.  The base function may perform
massaging such as converting time to timestamp, etc., in the future, so
you can get that for free then.  Currently this behaviour is done in
the C method, but it may move into here in the future.

Beware not to try to update the current column directly or indirectly
through this method as you could easily end up with infinite recursion.

=cut

sub validate_column
{
    my $self = shift;
    my $column = shift;
    my $value = shift;

    $value;
}

=item C

This get/set method allows you to retrieve or update any given column
for this row.  With a single parameter, it will return the current
value of that column.  The second parameter will be the new value to
use.  This value will be validated before being used.

=cut

sub column
{
    my $self = shift;
    my $name = uc shift;
    my $type = ref($self);

    if (scalar @_)
    {
        # modifying?
        my $col_type = uc $self->_table->get_column($name, 'type');
        if (scalar @_)
        {
            my $val = shift;

            # eval because validate_column may die.
            eval
            {
                if ($col_type eq 'TIMESTAMP')
                {
                    $val = $self->time_to_timestamp($val);
                }
                elsif ($col_type eq 'DATE')
                {
                    $val = $self->time_to_date($val);
                }
                elsif ($col_type eq 'NULLBOOL')
                {
                    $val = $val ? 'Y' : defined $val ? 'N' : undef;
                }
                elsif ($col_type eq 'BOOL')
                {
                    $val = $val ? 'Y' : 'N';
                }
                $val = $self->validate_column($name, $val);
                $self->{CONFIG}{$name} = $val;

                # if it's not what we started with, keep track of it.
                if (not exists $self->{ORIGVALUE}{$name} or
                    (not defined $val and defined $self->{ORIGVALUE}{$name}) or
                    $val ne $self->{ORIGVALUE}{$name})
                {
                    $self->{modified}{$name} = 1;
                }
                # if it is where we started, it may be BACK to the original
                # setting - clear the modification tag.
                else
                {
                    delete $self->{modified}{$name};
                    delete $self->{modified} unless $self->_modified;
                }
            }
        }
        my $rc = $self->{CONFIG}{$name};
        #if (not defined $self->{CONFIG}{$name})
        #{
        #    $rc = undef;
        #}
        #els
        return $rc;
    }

    (my $name_mod = $name) =~ s/^IS_?//;
    if (defined $self->_table->get_column($name_mod))
    {
        my $type = uc $self->_table->get_column($name_mod, 'type');
        my $rc = $self->{CONFIG}{$name_mod};

        if ($type eq 'BOOL')
        {
            $rc = $rc eq 'Y';
        }
        elsif ($type eq 'NULLBOOL')
        {
            $rc =
                not defined $rc ? undef :
                uc $rc eq 'Y'   ? 1 : 0;
        }

        return $rc;
    }

    croak "Can't do '$name' in $type";
    undef;

}

=item C

This is intended to help template users by returning the current row
as a hash/hashref.  For example, if you have a set of rows, @rows,
you can give them to HTML::Template as:

    loop => [ map { $_->as_hash(1) } @rows ],

The optional parameter will force a scalar return (hashref) despite an
array context, such as the map context above.

=cut

sub as_hash
{
    my $self = shift;
    my $force_scalar = shift;

    my %ret = map {
        $_ => $self->column($_);
    } $self->_table->column_list();
    (not $force_scalar && wantarray) ? %ret : \%ret;
}

=item C

Shortcut to calling C.

=cut

sub find
{
    my $self = shift;

    unless ((ref $self and $self->isa(__PACKAGE__)) or
            $self eq __PACKAGE__ or ($self and $self->isa(__PACKAGE__)))
    {
        unshift @_,$self;
    }
    $self->_table->find_id(@_);
}

=item C

Shortcut to calling C

=cut

sub find_where
{
    my $self = shift;

    unless ((ref $self and $self->isa(__PACKAGE__)) or
            $self eq __PACKAGE__ or ($self and $self->isa(__PACKAGE__)))
    {
        unshift @_,$self;
    }

    $self->_table->find_where(@_);
}

=item C

Shortcut to calling C

=cut

sub table_name
{
    my $self = shift;
    $self->_table->full_table_name;
}

=item C

Shortcut to calling C

=cut

sub count
{
    my $self = shift;
    $self->_table->count(@_);
}

=item C

Shortcut to calling C

=cut

sub count_where
{
    my $self = shift;
    $self->_table->count_where(@_);
}

=item C

Shortcut to calling C for this ID

=cut

sub delete
{
    my $self = shift;
    $self->_table->delete($self);
}

sub DESTROY
{
    my $self = shift;
    $self->save if $self;
}

=item C

Shortcut to calling C

=cut

sub SELECT
{
    my $self = shift;

    $self->_table->SELECT(@_);
}

=item C

=item C

=item C

The relevant variable from DBI for the last problem occurring on this
table.

=cut

sub dbi_err    { shift->_table->dbi_err }
sub dbi_errstr { shift->_table->dbi_errstr }
sub dbi_state  { shift->_table->dbi_state }

=item Dump

Dumps the current values of this row without any internal variables
that Data::Dumper would follow.

=cut

sub Dump
{
    my $self = shift;
    my @cols = $self->_table()->column_list();

    ref ($self) . '={' . join(', ', map {
                my $val = $self->column($_);
                $val = defined $val ? "'$val'" : "";
                "$_ => " . $val;
            } @cols) . '}';
}

=back

=head2 Ced functions

Any column defined by the corresponding DB2::Table object is also a
get/set accessor method for DB2::Row.  For example, if you have a
column named "LASTNAME" in your table, C<$row_obj-Elastname()> will
retrieve that column from the $row_obj object, while
C<$row_obj-Elastname('Smith')> will set that objects' lastname to
'Smith'.

=cut

sub AUTOLOAD
{
    my $self = shift;
    our $AUTOLOAD;
    my $name = $AUTOLOAD;
    $name =~ s/.*://;   # strip fully-qualified portion

    $self->column($name, @_);
}

1;