File Coverage

blib/lib/Data/Direct.pm

Criterion	Covered	Total	%
statement	9	190	4.7
branch	0	54	0.0
condition	0	13	0.0
subroutine	3	29	10.3
pod	18	23	78.2
total	30	309	9.7

package Data::Direct;

use strict qw(vars subs);
use vars qw($VERSION @EXPORT @ISA $opt_u $opt_p $table $opt_w $opt_a
	$gen_unique);

$VERSION = 0.05;

require Exporter;
@EXPORT = qw(edit);
@ISA = qw(Exporter);

use DBI;

sub new {
    my ($class, $dsn, $user, $pass, $table, $filter, $add) = @_;
    my $self = {};
    bless $self, $class;
    $self->{' dsn'} = $dsn;
    my $dbh;

####
## Try to connect with transactions first; otherwise just connect

    eval '$dbh = DBI->connect($dsn, $user, $pass, {AutoCommit => 0});';
    $dbh = DBI->connect($dsn, $user, $pass) unless ($dbh);
    return undef unless ($dbh);

    $self->{' dbh'} = $dbh;
    my $sql = "SELECT * FROM $table" . ($filter ? " WHERE $filter" : "")
            . ($add ? " $add" : "");
    my $sth = $dbh->prepare($sql);
    return undef unless ($sth);

    $self->{' table'} = $table;
    $self->{' filter'} = $filter;
    $sth->execute();

####
## Find field names

    my $fields = $sth->{NAME};
    $self->{' fields'} = $fields;

####
## Fetch rows

    my ($r, @rs);
    while ($r = $sth->fetchrow_arrayref) {
####
## Recreate array ref. Could I use while (my $r = ?

        push(@rs, [@$r]);
    }
    $self->{' recs'} = \@rs;
    undef $sth;

    $self->fetch(0);
    $self->{' bookmarks'} = {};
    $self->{' zap'} = [];
    $self;
}

sub bind {
    my $self = shift;
    my %hash = @_;
    $self->{' binding'} = \%hash;
    $self->fetch;
}

sub simplebind {
    my ($self, $pkg) = @_;
    my @fields = @{$self->{' fields'}};

####
## Create tuples 'var', \$var

    my @ary = map {($_, \${"${pkg}::$_"})} @fields;
    $self->bind(@ary);
}

sub flush {
    my $self = shift;
    my $param = shift;
    my ($table, $filter, $fields, $rs, $dbh) =
        @$self{(' table', ' filter', ' fields', ' recs', ' dbh')};

####
## Delete records before inserting everything back
## Can be hazardous if there are no transactions and
## somebody added data meanwhile!

    my $sql = "DELETE FROM $table" . ($filter ? " WHERE $filter" : "");
    $dbh->do($sql) || die $DBI::errstr;

####
## Not sure why I wrote this:

    return if ($param eq 'pseudo');

####
## Prepare an INSERT statement

    $sql = "INSERT INTO $table (" . join(", ", @$fields) . ") VALUES ("
        . join(", ", map {"?";} @$fields) . ")";
    my $sth = $dbh->prepare($sql) || die $DBI::errstr;
    my $i;
    foreach (@$rs) {
        ($sth->execute(@$_) || die $DBI::errstr)
             unless ($self->{' zap'}->[$i++]);
    }
    undef $sth;
    eval '$dbh->commit;' unless ($dbh->{AutoCommit});
    $dbh->disconnect;
}

sub recs {
    my $self = shift;
    scalar(@{$self->{' recs'}});
}

sub rows {
    my $self = shift;
    $self->recs - $self->{' dels'};
}

sub cursor {
    my $self = shift;
    $self->{' cursor'};
}

sub fetch {
    my $self = shift;

####
## Find cursor

    my $rs = $self->{' recs'};
    my $rec;

####
## Did we have a parameter?

    if (defined($_[0])) {
        $rec = shift;
        return undef if ($rec < 0 || $rec > @$rs);
        $self->{' cursor'} = $rec;
        return undef if ($rec == @$rs);
    } else {
        $rec = $self->{' cursor'};
    }

####
## Take row

    my $ref = $rs->[$rec];
    my @fields = @{$self->{' fields'}};
    my $bind = $self->{' binding'};

####
## Iterate over fields

    foreach (@$ref) {
        my $col = shift @fields;
####
## Bind variable

        my $ref = $bind->{$col};
        $$ref = $_ if (ref($ref));

####
## Load self

        $self->{$col} = $_;
    }
    1;
}

sub addnew {
    my $self = shift;
    my $rs = $self->{' recs'};
    my $fields = $self->{' fields'};
    my $cursor = $self->{' cursor'};

####
## Create an empty record

    my $new = [map {undef;} @$fields];

####
## Add it

    splice(@$rs, $cursor, 0, $new);
    $self->fetch($cursor);
}

sub setbookmark {
    my ($self, $name) = @_;
    $self->{' bookmarks'}->{$name} = $self->cursor;
}

sub gotobookmark {
    my ($self, $name) = @_;
    $self->fetch($self->{' bookmarks'}->{$name});
}

sub delete {
    my $self = shift;
    my $where = $self->cursor;
    return if ($self->{' zap'}->[$where]);
    $self->{' zap'}->[$where] = 1;
    $self->{' dels'}++;
}

sub undelete {
    my $self = shift;
    my $where = $self->cursor;
    return unless ($self->{' zap'}->[$where]);
    $self->{' zap'}->[$where] = undef;
    $self->{' dels'}--;
}

sub isdeleted {
    my $self = shift;
    $self->{' zap'}->[$self->cursor];
}

sub update {
    my $self = shift;
    my $fields = $self->{' fields'};
    my @ary;
    my $bind = $self->{' binding'};
####
## Retrieve bound variables

    foreach (keys %$bind) {
        $self->{$_} = ${$bind->{$_}};
    }

####
## Retrieve row

    foreach (@$fields) {
        push(@ary, $self->{$_});
    }

####
## Put

    my $rs = $self->{' recs'};
    $rs->[$self->cursor] = \@ary;
}

sub next {
    my $self = shift;
    $self->fetch($self->cursor + 1);
}

sub back {
    my $self = shift;
    $self->fetch($self->cursor - 1);
}

sub bof {
   my $self = shift;
   $self->cursor <= 0;
}

sub eof {
    my $self = shift;
    $self->cursor >= $self->recs;
}

sub fields {
    my $self = shift;
    my $ref = $self->{' fields'};
    @$ref;
}

sub spawn {
    require Text::ParseWords;
    my ($self, $cmd, $pack, $unpack) = @_;

####
## Find editor, unless a different command requested

    $cmd = $ENV{'EDITOR'} || 'vi' unless ($cmd);
####
## Default delimiter is comma

    $pack = "," unless ($pack);

####
## If pack information is a string and not a routine, pack line by quoting
## tokens and adding delmiters
    my $packc = !UNIVERSAL::isa($pack, 'CODE') ?
            sub {join($pack, (map {qq!"$_"!} @_)) . "\n";} : $pack;

####
## Assume unpack routine to be supplied only if pack routine was supplied.
## Otherwise, unpacking is done by parsing the delimited line

## NOTE:
## Packing function recieves a list; Unpacking function gets a stream to
## read from.

    my $unpackc = ref($pack) !~ /CODE/ ?
            sub { my $l = scalar(<$_>); chop $l;
              Text::ParseWords::parse_line($pack, undef, $l);} : $unpack;

####
## Save bookmark

    my $save = $self->cursor;

####
## Create file

    my $fn = &gentemp;
    open(O, ">$fn") || die "Can't open $fn for write: $!";
    my $rs = $self->{' recs'};

####
## Iterate

    foreach (@$rs) {
        print O &$packc(@$_);
    }
    close(O);

####
## Take file stamp to figure if it was changed

    my @st = stat($fn);
    splice(@st, 8); # Access time obviously changes
    my $s = join(":", @st);

####
## Invoke editor
    $cmd .= " %1" unless ($cmd =~ /[\$\%]1/);
    $cmd =~ s/[\$\%]1/$fn/g;
    system $cmd;

####
## Recreate file stamp

    @st = stat($fn);
    splice(@st, 8);
    my $ss = join(":", @st);

    my $ret = undef;

####
## If there were changes

    if ($s ne $ss) {
        @$rs = ();
        open(I, $fn) || die "Can't open $fn for read: $!";
        while (!CORE::eof(I)) {
            $_ = \*I;
            push(@$rs, [ &$unpackc($_) ]);
        }
        close(I);
        $ret = 1;
    }
    unlink $fn || die "Can't remove $fn: $!";
    $ret;
}

sub DESTROY {
    my $self = shift;
    $self->{' dbh'}->disconnect;
}

sub edit {

#####
## Front end for spawn() to be called from command line

    require Getopt::Std;
    import Getopt::Std;

####
## Change slashes to dashes. Dashes would have been parsed by perl istelf.

    my @dummy = map {s|^/|-|;} @ARGV;
    getopt("u:p:w:a:");

    my ($dsn, $table) = @ARGV;

    my $d = new Data::Direct($dsn, $opt_u, $opt_p, $table, $opt_w,
         $opt_a) || die "Connection failed";

####
## Updated database only if changes were detected

    $d->flush if ($d->spawn);
}

sub gentemp {
    my $fn;
    eval {
####
## Make POSIX do the hard job

        require POSIX;
        $fn = &POSIX::tmpnam;
    };
    return $fn if ($fn);
    $fn = join("-", "data_direct", $$, $0, time, localtime, rand,
         $gen_unique++);
    $fn =~ s/[^a-zA-Z0-9]/_/g;
####
## Ultra safety check - run the function again if that weird filename
## already exists.

    return &gentemp if (-e $fn);
    $fn;
}

1;

__END__