Add generic store, destroy, and show methods and a get placeholder. The

basic methods are now complete.  Add the trace information as parameters
to the functions to set various attributes.  Rename delete to destroy to
avoid the Perl reserved word.  Rename _create_internal and _new_internal
to create and new to use a more conventional inheritance structure.
Always use exceptions for database errors.

1 files changed, 111 insertions, 27 deletions

diff --git a/perl/Wallet/Object.pm b/perl/Wallet/Object.pm
index 2a2f352..0cc7d69 100644
--- a/perl/Wallet/Object.pm
+++ b/perl/Wallet/Object.pm
@@ -30,11 +30,13 @@ $VERSION = '0.01';
 # Initialize an object from the database.  Verifies that the object already
 # exists with the given type, and if it does, returns a new blessed object of
 # the specified class.  Stores the database handle to use, the name, and the
-# type in the object.  This method should be called by the new method of any
-# subclass.
-sub _new_internal {
+# type in the object.  If the object doesn't exist, returns undef.  This will
+# probably be usable as-is by most object types.
+sub new {
     my ($class, $name, $type, $dbh) = shift;
     $dbh->{AutoCommit} = 0;
+    $dbh->{RaiseError} = 1;
+    $dbh->{PrintError} = 0;
     my $sql = 'select ob_name from objects where ob_name = ? and ob_type = ?';
     my $data = $dbh->selectrow_array ($sql, undef, $name, $type);
     return undef unless ($data and $data eq $name);
@@ -50,11 +52,12 @@ sub _new_internal {
 # Create a new object in the database of the specified name and type, setting
 # the ob_created_* fields accordingly, and returns a new blessed object of the
 # specified class.  Stores the database handle to use, the name, and the type
-# in the object.  This method should be called by the new method of any
-# subclass.
-sub _create_internal {
+# in the object.  Subclasses may need to override this to do additional setup.
+sub create {
     my ($class, $name, $type, $dbh, $creator, $host, $time) = @_;
     $dbh->{AutoCommit} = 0;
+    $dbh->{RaiseError} = 1;
+    $dbh->{PrintError} = 0;
     $time ||= time;
     eval {
         my $sql = 'insert into objects (ob_name, ob_type, ob_created_by,
@@ -75,26 +78,20 @@ sub _create_internal {
     return $self;
 }
 
-# The real create and new methods must be overridden by subclasses.
-sub new    { die "Do not instantiate Wallet::Object directly\n"; }
-sub create { die "Do not instantiate Wallet::Object directly\n"; }
-
 ##############################################################################
 # History functions
 ##############################################################################
 
 # Record a global object action for this object.  Takes the action (which must
-# be one of create, delete, get, or store), and the trace information: user,
-# host, and time.  Returns true on success and false on failure, setting error
-# appropriately.
+# be one of get or store), and the trace information: user, host, and time.
+# Returns true on success and false on failure, setting error appropriately.
 #
 # This function commits its transaction when complete and should not be called
 # inside another transaction.
 sub log_action {
     my ($self, $action, $user, $host, $time) = @_;
-    unless ($action =~ /^(create|delete|get|store)\z/) {
-        my $id = $self->{type} . ':' . $self->{name};
-        $self->{error} = "invalid history action $action for $id";
+    unless ($action =~ /^(get|store)\z/) {
+        $self->{error} = "invalid history action $action";
         return undef;
     }
 
@@ -144,7 +141,7 @@ sub log_set {
         ($field, $type_field) = split (' ', $field, 2);
     }
     my %fields = map { $_ => 1 }
-        qw(owner acl_get acl_store acl_show acl_delete acl_flags expires
+        qw(owner acl_get acl_store acl_show acl_destroy acl_flags expires
            flags type_data);
     unless ($fields{$field}) {
         die "invalid history field $field";
@@ -195,25 +192,26 @@ sub _get_internal {
     return $value;
 }
 
-# Get or set the owner of an object.
+# Get or set the owner of an object.  If setting it, trace information must
+# also be provided.
 sub owner {
-    my ($self, $owner) = @_;
+    my ($self, $owner, $user, $host, $time) = @_;
     if ($owner) {
         if ($owner !~ /^\d+\z/) {
             $self->{error} = "malformed owner ACL id $owner";
             return;
         }
-        return $self->_set_internal ('owner', $owner);
+        return $self->_set_internal ('owner', $owner, $user, $host, $time);
     } else {
         return $self->_get_internal ('owner');
     }
 }
 
 # Get or set an ACL on an object.  Takes the type of ACL and, if setting, the
-# new ACL identifier.
+# new ACL identifier.  If setting it, trace information must also be provided.
 sub acl {
-    my ($self, $type, $acl) = @_;
-    if ($type !~ /^(get|store|show|delete|flags)\z/) {
+    my ($self, $type, $acl, $user, $host, $time) = @_;
+    if ($type !~ /^(get|store|show|destroy|flags)\z/) {
         $self->{error} = "invalid ACL type $type";
         return;
     }
@@ -223,23 +221,109 @@ sub acl {
             $self->{error} = "malformed ACL id $acl";
             return;
         }
-        return $self->_set_internal ($attr, $acl);
+        return $self->_set_internal ($attr, $acl, $user, $host, $time);
     } else {
         return $self->_get_internal ($attr);
     }
 }
 
 # Get or set the expires value of an object.  Expects an expiration time in
-# seconds since epoch.
+# seconds since epoch.  If setting the expiration, trace information must also
+# be provided.
 sub expires {
-    my ($self, $expires) = @_;
+    my ($self, $expires, $user, $host, $time) = @_;
     if ($expires) {
         if ($expires !~ /^\d+\z/ || $expires == 0) {
             $self->{error} = "malformed expiration time $expires";
             return;
         }
-        return $self->_set_internal ('expires', $expires);
+        return $self->_set_internal ('expires', $expires, $user, $host, $time);
     } else {
         return $self->_get_internal ('expires');
     }
 }
+
+##############################################################################
+# Object manipulation
+##############################################################################
+
+# The get methods must always be overridden by the subclass.
+sub get { die "Do not instantiate Wallet::Object directly\n"; }
+
+# Provide a default store implementation that returns an immutable object
+# error so that auto-generated types don't have to provide their own.
+sub store {
+    my ($self, $data, $user, $host, $time) = @_;
+    my $id = $self->{type} . ':' . $self->{name};
+    $self->{error} = "cannot store $id: object type is immutable";
+    return;
+}
+
+# The default show function.  This may be adequate for many types; types that
+# have additional data should call this method, grab the results, and then add
+# their data on to the end.
+sub show {
+    my ($self) = @_;
+    my @attrs = ([ ob_type            => 'Type'            ],
+                 [ ob_name            => 'Name'            ],
+                 [ ob_owner           => 'Owner'           ],
+                 [ ob_acl_get         => 'Get ACL'         ],
+                 [ ob_acl_store       => 'Store ACL'       ],
+                 [ ob_acl_show        => 'Show ACL'        ],
+                 [ ob_acl_destroy     => 'Destroy ACL'     ],
+                 [ ob_acl_flags       => 'Flags ACL'       ],
+                 [ ob_expires         => 'Expires'         ],
+                 [ ob_created_by      => 'Created by'      ],
+                 [ ob_created_from    => 'Created from'    ],
+                 [ ob_created_on      => 'Created on'      ],
+                 [ ob_stored_by       => 'Stored by'       ],
+                 [ ob_stored_from     => 'Stored from'     ],
+                 [ ob_stored_on       => 'Stored on'       ],
+                 [ ob_downloaded_by   => 'Downloaded by'   ],
+                 [ ob_downloaded_from => 'Downloaded from' ],
+                 [ ob_downloaded_on   => 'Downloaded on'   ]);
+    my $fields = join (', ', map { $_->[0] } @attrs);
+    my @data;
+    eval {
+        my $sql = "select $fields from objects where ob_name = ? and
+            ob_type = ?";
+        @data = $self->{dbh}->selectrow_array ($sql, undef, $name, $type);
+    };
+    if ($@) {
+        my $id = $self->{type} . ':' . $self->{name};
+        $self->{error} = "cannot retrieve data for $id: $@";
+        return undef;
+    }
+    my $output = '';
+    for (my $i = 0; $i < @data; $i++) {
+        next unless defined $data[$i];
+        $output .= sprintf ("%15s: %s\n", $attrs[$i][1], $data[$i]);
+    }
+    return $output;
+}
+
+# The default destroy function only destroys the database metadata.  Generally
+# subclasses need to override this to destroy whatever additional information
+# is stored about this object.
+sub destroy {
+    my ($self, $user, $host, $time) = @_;
+    my $name = $self->{name};
+    my $type = $self->{type};
+    eval {
+        my $sql = 'delete from flags where fl_object = ? and fl_type = ?';
+        $self->{dbh}->do ($sql, undef, $name, $type);
+        $sql = 'delete from objects where ob_name = ? and ob_type = ?';
+        $self->{dbh}->do ($sql, undef, $name, $type);
+        my $sql = "insert into object_history (oh_object, oh_type, 'destroy',
+            oh_by, oh_from, oh_on) values (?, ?, ?, ?, ?)";
+        $self->{dbh}->do ($sql, undef, $name, $type, $user, $host, $time);
+        $self->{dbh}->commit;
+    };
+    if ($@) {
+        my $id = $self->{type} . ':' . $self->{name};
+        $self->{error} = "cannot destroy $id: $@";
+        $self->{dbh}->rollback;
+        return undef;
+    }
+    return 1;
+}