diff options
Diffstat (limited to 'perl/Wallet/Object.pm')
| -rw-r--r-- | perl/Wallet/Object.pm | 138 |
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; +} |