##########################################################################
## All portions of this code are copyright (c) 2003,2004 nethype GmbH   ##
##########################################################################
## Using, reading, modifying or copying this code requires a LICENSE    ##
## from nethype GmbH, Franz-Werfel-Str. 11, 74078 Heilbronn,            ##
## Germany. If you happen to have questions, feel free to contact us at ##
## license@nethype.de.                                                  ##
##########################################################################

=head1 NAME

PApp::DataRef - reference data stored in scalars, databases...

=head1 SYNOPSIS

 use PApp::DataRef;

=head1 DESCRIPTION

You often want to store return values from HTML forms
(e.g. L<macro/editform>) or other "action at a distance" events
in your state variable or in a database (e.g. after updates). The
L<DBIx::Recordset|DBIx::Recordset> provides similar functionality.

C<PApp::DataRef> provides the means to create "handles" that can act like
normal perl references. When accessed they fetch/store data from the
underlying storage.

All of the generated references and handles can be serialized.

=over 4

=cut

package PApp::DataRef;

use Convert::Scalar ();

$VERSION = 2.1;

=item $hd = new PApp::DataRef 'DB_row', table => $table, where => [key, value], ...

Create a new handle to a table in a SQL database. C<table> is the name
(view) of the database table. The handle will act like a reference to a
hash. Accessing the hash returns references to tied scalars that can be
read or set (or serialized).

 my $hd = new PApp::DataRef 'DB_row', table => env, where => [name => 'TT_LIBDIR'];
 print ${ $hd->{value} }, "\n";
 ${ $hd->{value} } = "new libdir value";

The default database handle (C<$PApp::SQL::DBH>) is used for all sql
accesses. (Future versions might be more intelligent).

As a special case, if the C<value> part of the C<where> agruments is
undef, it will be replaced by some valid (newly created) id on the first
STORE operation. This currently only works for mysql.

Parameters

   table         the database table to use.
   key           a string or arrayref containing the (primary) key fields.
   id            a scalar or araryref giving the values for the key.

   where         [deprecated but supported] a array-ref with the primary key
                 fieldname and primary key value.

   autocommit    if set to one (default) automatically store the contents
                 when necessary or when the object gets destroyed.
   delay         if set, do not write the table for each update.
                 (delay implies caching of stored values(!))
   cache         if set, cache values that were read.
   preload       if set to a true value, preloads the values from the table on
                 object creation. If set to an array reference, only the mentioned
                 fields are being cached. Implies C<cache => 1>.
   database      the PApp::SQL::Database object to use. If not specified,
                 the default database at the time of the new call is used.
   insertid      when set to true, makes this object allocate sequences using
                 sql_insertid.
   sequence      (use insertid) when set to one and the (single) key id is C<undef>
                 or C<zero>, use sql_insertid to allocate a new one (will be extended
                 to handle the case where no id is given, in which case this parameter
                 describes how to allocate a new id).
   utf8          can be set to a boolean, an arrayref or hashref that decides
                 wether to force the utf8 bit on or off for the selected fields.

=item $hd = new $dataref arg => value, ...

Instead of specifying all the same parameters again and again, you can
create a I<partial> DataRef object (e.g. one without an id) with default
parameters and use this form of the method invocation to "specialise", e.g.

   my $template = new PApp::DataRef 'DB_row', table => "message", key => "id";

   for (1,2,3) {
      my $row = $template->new(id => $_);
      ...
   }

=item $hd = new PApp::DataRef 'Scalar', fetch => ..., ...

Create a scalar reference that calls your callbacks when accessed. Valid arguments are:

  fetch => coderef($self)          # ref not present
  fetch => coderef($self, $value)  # ref present
    A coderef which is to be called for every read access

  value => constant
    As an alternative to fetch, always return a constant on read accesses

  ref => scalar-ref
    When present, this references the scalar that is passed to the fetch
    method or overwritten by the store method.

  store => coderef($value, $value) # ref not present (first argument is DEPRECATED)
  store => coderef($self, $value)  # ref present
    A coderef which is to be called with the new value for every write
    access. If ref is given, the new value should be returned from this
    callback. If the callback returns the empty list, the value won't be
    changed.

For read access, either C<fetch>, C<value> or C<ref> must be present (they
are checked in this order). If C<store> is missing, stored values are
thrown away.

=cut

sub new {
   my $class = shift;

   my $type = "PApp::DataRef::".shift;

   unless (defined &{"${type}::new"}) {
      eval "use $type"; die if $@;
   }

   $type->new(@_);
}

sub new_locked {
   my $class = shift;

   use Carp ();
   Carp::cluck "PApp::DataRef::new_locked is deprecated, use autocommit => 0, delay => 1, preload => 1, cache => 1";
   
   my $type = "PApp::DataRef::".shift;

   unless (defined &{"${type}::new"}) {
      eval "use $type"; die if $@;
   }

   $type->new_locked(@_);
}

package PApp::DataRef::Base;

use Carp ();

sub TIESCALAR {
   my $class = shift;
   bless shift, $class;
}

sub new   { Carp::croak "new() not implemented for ".ref $_[0] }
sub FETCH { Carp::croak "FETCH not implemented for ".ref $_[0] }
sub STORE { Carp::croak "STORE not implemented for ".ref $_[0] }

sub DESTROY { }

package PApp::DataRef::Scalar;

@ISA = PApp::DataRef::Base::;

sub new {
   my $class = shift;

   no warnings;

   my $handle;
   tie $handle, ref $class ? ref $class : $class,
                ref $class ? %$class : (),
                @_;
   bless \$handle, PApp::DataRef::Scalar::Proxy;
}

sub TIESCALAR {
   my $class = shift;
   bless { @_ }, $class;
}

sub FETCH {
   my $self = $_[0];
   if ($self->{fetch}) {
      return $self->{fetch}($self, $self->{ref} ? ${$self->{ref}} : ());
   } elsif (exists $self->{value}) {
      return $self->{value};
   } elsif (exists $self->{ref}) {
      return ${$self->{ref}};
   } else {
      # might become a warning or fatal error
      return undef;
   }
}

sub STORE {
   my $self = $_[0];
   if ($self->{store}) {
      if ($self->{ref}) {
         my @data = $self->{store}($self, $_[1]);
         ${$self->{ref}} = $data[0] if @data;
      } else {
         $self->{store}($_[1], $_[1]);
      }
   } else {
      # might become a warning or fatal error
      ();
   }
}

package PApp::DataRef::DB_row;

use PApp::SQL;
use PApp::Callback ();

use Carp ();

my $sql_insertid = PApp::Callback::register_callback {
   sql_insertid sql_exec $_[0]->dbh, "insert into $_[0]{table} values ()";
} name => "papp_dataref_insertid";

sub new {
   my $class = shift;
   my %handle;

   tie %handle, ref $class ? ref $class : $class,
                autocommit => 1,
                ref $class ? %$class : (),
                @_;
   bless \%handle, PApp::DataRef::Hash::Proxy;
}

sub new_locked {
   my $class = shift;
   my %handle;

   tie %handle, $class, autocommit => 0, delay => 1, preload => 1, cache => 1, @_;
   bless \%handle, PApp::DataRef::Hash::Proxy;
}

sub dbh {
   $_[0]{database}->dbh;
}

sub TIEHASH {
   my $class = shift;
   my $self = bless { @_ }, $class;

   $self->{database} ||= $PApp::SQL::Database;

   if (my $where = delete $self->{where}) {
      $self->{key} = $where->[0];
      $self->{id}  = $where->[1];
      if ((!ref $self->{key} || @{$self->{key}} == 1) && !$self->{id} && !$self->{insertid}) {
         use Carp ();
         Carp::cluck "PApp::DataRef automatic auto_increment behaviour is deprecated, specify insertid => 1";
         $self->{insertid} = 1;
      }
   }

   exists $self->{table} or Carp::croak("mandatory parameter table missing");
   exists $self->{key}   or Carp::croak("mandatory parameter key missing");

   $self->{key} = [$self->{key}] if defined $self->{key} && !ref $self->{key};
   $self->{id}  = [$self->{id}]  if defined $self->{id}  && !ref $self->{id};

   if (delete $self->{insertid}) {
      $self->{sequence} = $sql_insertid->refer();

      #d# 0 => undef with insertid (should we really?)
      if ($self->{id} && !$self->{id}[0]) {
         delete $self->{id};
      }
   }

   if ($self->{id} && !defined $self->{id}[0]) {
      delete $self->{id};
   }

   $self->{key_expr} = "(".(join " and ", map "$_ = ?", @{$self->{key}}).")";

   if (exists $self->{utf8}) {
      if (ref $self->{utf8} eq "ARRAY") {
         my %utf8;
         $utf8{$_} = 1 for @{$self->{utf8}};
         $self->{utf8} = \%utf8;
      }
   }

   if ($self->{id}) {
      $self->{database} or
         Carp::croak("no database given and no default database found");

      if (my $preload = $self->{preload}) {
         $self->{cache} = 1;

         # try to preload, enable caching
         $preload = ref $preload ? join ",", @$preload : "*";
         my $st = eval {
            local $SIG{__DIE__};
            sql_exec $self->{database}->dbh,
                     "select $preload from $self->{table} where $self->{key_expr}",
                     @{$self->{id}};
         };
         if ($st) {
            my $hash = $st->fetchrow_hashref;
            while (my ($field, $value) = each %$hash) {
               Convert::Scalar::utf8_on $value if $self->{utf8} && (!ref $self->{utf8} || $self->{utf8}{$field});
               $self->{_cache}{$field} = $value;
            }
            $st->finish;
         }
      }
      # ...
   }

   $self;
}

=item $hd->{fieldname} or $hd->{[fieldname, extra-args]}

Return a lvalue to the given field of the row. The optional arguments
C<fetch> and C<store> can be given code-references that are called at
every fetch and store, and should return their first argument (possibly
modified), e.g. to fetch and store a crypt'ed password field:

  my $pass_fetch = create_callback { "" };
  my $pass_store = create_callback { crypt $_[1], <salt> };

  $hd->{["password", fetch => $pass_fetch, store => $pass_store]};

Additional named parameters are:

  fetch => $fetch_cb,
  store => $store_cb,
     
     Functions that should be called with the fetched/to-be-stored value
     as second argument that should be returned, probably after some
     transformations have been used on it. This can be used to convert
     sql-sets or password fields from/to their internal database format.

     If the store function returns nothing (an empty 'list', as it is
     called in list context), the update is being skipped.

     L<PApp::Callback> for a way to create serializable code references.

     PApp::DataRef::DB_row predefines some filter types (these functions
     return four elements, i.e. fetch => xxx, store => xxx, so that you
     can just cut & paste them).

        PApp::DataRef::DB_row::filter_sql_set
                  converts strings of the form a,b,c into array-refs and
                  vice versa.

        PApp::DataRef::DB_row::filter_password
                  returns the empty string and crypt's the value if nonempty.

        PApp::DataRef::DB_row::filter_sfreeze_cr
                  filters the data through Compress::LZF's sfreeze_cr and sthaw.

=cut

use PApp::Callback;

my $sql_set_fetch = create_callback {
   [split /,/, $_[1]];
} name => "papp_dataref_set_fetch";

my $sql_set_store = create_callback {
   join ",", @{$_[1]};
} name => "papp_dataref_set_store";

my $sql_pass_fetch = create_callback {
   "";
} name => "papp_dataref_pass_fetch";

my $sql_pass_store = create_callback {
   $_[1] ne "" ? crypt $_[1], join '', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64] : ();
} name => "papp_dataref_pass_store";

my $sql_sfreeze_cr_fetch = create_callback {
   require Compress::LZF;
   Compress::LZF::sthaw(Convert::Scalar::utf8_on $_[1]);
} name => "papp_dataref_sfreeze_cr_fetch";

my $sql_sfreeze_cr_store = create_callback {
   require Compress::LZF;
   Compress::LZF::sfreeze_cr(Convert::Scalar::utf8_upgrade $_[1]);
} name => "papp_dataref_sfreeze_cr_store";

sub filter_sql_set  (){ ( fetch => $sql_set_fetch,        store => $sql_set_store        ) }
sub filter_password (){ ( fetch => $sql_pass_fetch,       store => $sql_pass_store       ) }
sub filter_sfree_cr (){ ( fetch => $sql_sfreeze_cr_fetch, store => $sql_sfreeze_cr_store ) }

sub _sequence {
   my $self = shift;

   unless (defined $self->{id}) {
      # create a new ID
      $self->{id} = [$self->{sequence}->($self)];
   }
}

sub FETCH {
   my $self = shift; my ($field, %args) = ref $_[0] ? @{+shift} : shift;
   my $value;

   if (exists $self->{_cache}{$field}) {
      $value = $self->{_cache}{$field};
   } else {
      if ($self->{id}) {
         $value = sql_fetch $self->dbh, "select $field from $self->{table} where $self->{key_expr}",  @{$self->{id}};
         Convert::Scalar::utf8_on $value if $self->{utf8} && (!ref $self->{utf8} || $self->{utf8}{$field});
         $self->{_cache}{$field} = $value if $self->{cache};
      } else {
         $value = ();
      }
   }

   ref $args{fetch} ? $args{fetch}->($self, $value) : $value;
}

sub STORE {
   my $self = shift; my ($field, %args) = ref $_[0] ? @{+shift} : shift;
   my @value = ref $args{store} ? $args{store}->($self, shift) : shift;
   return unless @value;

   Convert::Scalar::utf8_upgrade $value[0] if $self->{utf8} && (!ref $self->{utf8} || $self->{utf8}{$field});

   if ($self->{delay}) {
      $self->{_store}{$field} = \($self->{_cache}{$field} = $value[0]);
   } else {
      $self->{_cache}{$field} = $value[0] if $self->{cache};

      $self->_sequence unless defined $self->{id};
      sql_exec $self->dbh,
               "update $self->{table} set $field = ? where $self->{key_expr}",
               $value[0], @{$self->{id}};
      $sql_exec > 0
         or sql_exec $self->dbh,
            "insert into $self->{table} (" .
               (join ",", $field, @{$self->{key}}) .
            ") values (" .
               (join ",", ("?") x (1 + @{$self->{key}})) .
            ")",
            $value[0],
            @{$self->{id}};
   }
}

# we do not officially support iterators yet, but define them so we can display this object
sub FIRSTKEY {
   my $self = shift;
   keys %{$self->{_cache}};
   each %{$self->{_cache}};
}

sub NEXTKEY {
   my $self = shift;
   each %{$self->{_cache}};
}

sub EXISTS {
   my $self = shift;
   my $field = shift;
   exists $self->{_cache}{$field} or do {
      # do it the slow way. not sure wether the limit 0 is portable or not
      my $st = sql_exec $self->{database}->dbh,
                        "select * from $self->{table} limit 0";
      my %f; @f{@{$st->{NAME_lc}}} = ();
      $st->finish;
      exists $f{lc $field};
   };
}

=item @key = $hd->id

Returns the key value(s) for the selected row, creating it if necessary.

=cut

sub id($) {
   my $self = shift;
   $self->_sequence;
   wantarray ? @{$self->{id}} : $self->{id}[0];
}

=item $hd->flush

Flush all pending store operations. See HOW FLUSHES ARE IMPLEMENTED below
to see how, well, flushes are implemented on the SQL-level.

=cut

sub flush {
   my $self = shift;

   my $store = delete $self->{_store};

   if (%$store) {
      my $dbh = $self->dbh;

      my $insrep = sub {
         sql_exec $dbh,
               "$_[0] into $self->{table} (" .
                  (join ",", @{$self->{key}}, keys %$store) .
               ") values (" .
                  (join ",", ("?") x (@{$self->{key}} + keys %$store)) .
               ")",
               @{$self->{id}},
               (map $$_, values %$store);
      };

      my $update = sub {
         sql_exec $dbh,
                  "update $self->{table} set" .
                     (join ",", map " $_ = ?", keys %$store) .
                  " where $self->{key_expr}",
                  (map $$_, values %$store), @{$self->{id}};
      };

      $self->_sequence unless $self->{id};

      if (0 && $self->{preload} && !ref $self->{preload}
          && $dbh->{Driver}{Name} eq "mysql"
        ) {
         # disabled because $store doesn't contain all values, and _cache might contain
         # the id field twice. reenable when id is a normal member of _cache
         $insrep->("replace");
         delete $self->{preload}; # preload also acts as a "we know all columns" flag
      } else {
         &$update;
         $sql_exec > 0 or eval { local $SIG{__DIE__}; $insrep->("insert") };
         $sql_exec > 0 or &$update;
      }
   }
}

=item $hd->dirty

Return true when there are store operations that are delayed. Call
C<flush> to execute these.

=cut

sub dirty {
   my $self = shift;
   ! ! %{$self->{_store}}; # !! Isnogood for vim
}

=item $hd->invalidate

Empties any internal caches. The next access will reload the values
from the database again. Any dirty values will be discarded.

=cut

sub invalidate {
   my $self = shift;
   delete $self->{_cache};
   delete $self->{_store};
}

=item $hd->discard

Discard all pending store operations. Only sensible when C<delay> is true.

=cut

sub discard {
   my $self = shift;
   delete $self->{_store};
}

=item $hd->delete

Delete the row from the database

=cut

sub delete {
   my $self = shift;

   if ($self->{id}) {
      sql_exec $self->dbh,
               "delete from $self->{table} where $self->{key_expr}",
               @{$self->{id}};
   }

   $self->discard;
}

sub DESTROY {
   my $self = shift;

   if ($self->{autocommit}) {
      local $@; # do not erase valuable error information (like upcalls ;)
      eval {
         local $SIG{__DIE__} = \&PApp::Exception::diehandler;
         $self->flush;
      };
      warn "$@, during PApp::DataRef object destruction" if $@;
   }
}

package PApp::DataRef::Scalar::Proxy;

# merely a proxy class to re-route method calls

sub AUTOLOAD {
   my $package = ref tied ${$_[0]};
   (my $method = $AUTOLOAD) =~ s/.*(?=::)/$package/se;
   *{$AUTOLOAD} = sub {
      unshift @_, tied ${+shift};
      goto &$method;
   };
   goto &$AUTOLOAD;
}

sub DESTROY { }

package PApp::DataRef::Hash::Proxy;

# merely a proxy class to re-route method calls

sub AUTOLOAD {
   my $package = ref tied %{$_[0]};
   (my $method = $AUTOLOAD) =~ s/.*(?=::)/$package/se;
   *{$AUTOLOAD} = sub {
      unshift @_, tied %{+shift};
      goto &$method;
   };
   goto &$AUTOLOAD;
}

sub DESTROY { }

=back

=head1 How Flushes are Implemented

When a single value (delay => 0) is being read or written, DataRef creates
a single access:

   SELECT column FROM table WHERE id = ?
   UPDATE table SET column = ? where id = ?

In other cases, DataRef reads and writes full rows:

   SELECT * FROM table WHERE id = ?

When a row is being written and the id is C<undef> or zero, DataRef uses
the C<insertid> callback to create a new insertion id followed by an
INSERT (if insretid is 1, it uses an INSERT followed by C<sql_insertid>,
so your id volumn should better be defined as auto increment in your
database). If the id is defined, the update is driver specific:

for mysql (if appropriate):

   REPLACE INTO table (...) VALUES (...)

and for other databases:

   INSERT INTO table (...) VALUES (...)
   and, if the above commend fails,
   UPDATE table SET ? = ?, ? = ?, ... WHERE id = ?

no checking wether the UPDATE succeeded is done (yet).

=head1 SEE ALSO

L<PApp>.

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut