/usr/local/CPAN/Keystone-Resolver/Keystone/Resolver/DB/Object.pm
# $Id: Object.pm,v 1.34 2008-04-29 17:05:38 mike Exp $
package Keystone::Resolver::DB::Object;
use strict;
use warnings;
use Carp;
sub new {
my $class = shift();
my($db) = shift();
my @fields = $class->physical_fields();
my %hash = (_db => $db);
foreach my $i (1 .. @fields) {
my $key = $fields[$i-1];
my $value = $_[$i-1];
$hash{$key} = $value;
}
return bless \%hash, $class;
}
sub class {
my $this = shift();
my $class = ref $this;
$class =~ s/^Keystone::Resolver::DB:://;
return $class;
}
# Accessors and delegations
sub db { shift()->{_db} }
sub log { shift()->{_db}->log(@_) }
sub quote { shift()->{_db}->quote(@_) }
# Default implementations of subclass-specific virtual functions
# fields() must be explicitly provided for searchable classes
# virtual_fields() must be explicitly provided for searchable classes
sub mandatory_fields { qw() }
# search_fields() must be explicitly provided for searchable classes
# display_fields() must be explicitly provided for searchable classes
sub fulldisplay_fields { shift()->display_fields(@_) }
sub field_map { {} }
# Returns an empty array if it's OK to delete this object, or
# otherwise an array of one or more strings, each specifying a reason
# why not. Can be overridden by subclasses, but by default insists on
# no non-dependent links.
#
sub undeletable {
my $this = shift();
my @reasons;
my %fields = $this->fields();
foreach my $key (sort keys %fields) {
my $ref = $fields{$key};
if (ref $ref && defined $ref->[3]) {
my($linkfield, $linkclass, $linkto) = @$ref;
### This is wasteful: it would be better to use a method
# that only counts hits instead of fetching all the data
# and constructing all the objects, but there is as yet
# no such method,
my @hits = $this->db()->find($linkclass, undef, $linkto,
$this->field($linkfield));
my $n = @hits;
if ($n == 1) {
push @reasons, "a $linkclass depends on it";
} elsif ($n != 0) {
push @reasons, "$n $linkclass objects depend on it";
}
}
}
return @reasons;
}
# Returns a list of all the field specified by fields(), with types
# drawn from fulldisplay_fields() where available and using "t" when
# not.
#
# Fields which are used as the link-field in a virtual-field recipe
# of the "dependent-link" type are omitted (e.g. service_type_id
# from the Service class, because it is the link-field in the
# service_type recipe).
#
# Virtual fields that are of not of the "dependent-link" type have a
# exclude-at-creation-time attribute prepended to their type, if they
# don't already have it.
#
sub editable_fields {
my $class = shift();
my @allfields = $class->fields();
my %hash = @allfields;
my(%omitFields, %virtualFields);
foreach my $key (keys %hash) {
my $value = $hash{$key};
if (defined $value && ref $value) {
### The correct test here might not be for @$value==3 but
# something like defined $value[3]. See all the virtual
# fields in Service.pm and think harder.
if (@$value == 3) {
$omitFields{$value->[0]} = 1;
} else {
$virtualFields{$key} = 1;
}
}
}
foreach my $skip ($class->uneditable_fields()) {
$omitFields{$skip} = 1;
}
my %fdfields = $class->fulldisplay_fields();
my @res;
while (@allfields) {
my $name = shift @allfields;
my $recipe = shift @allfields;
if (defined $omitFields{$name}) {
warn "omitting '$name' from editable_field($class)\n";
next;
}
my $display = $fdfields{$name} || "t";
if (defined $virtualFields{$name}) {
$display = "X$display" if $display !~ /X/;
warn "made '$name' readonly '$display' in editable_field($class)\n";
}
push @res, ($name, $display);
}
return @res;
}
# List of fields to omit from the return of editable fields (unless
# that method has been overridden, of course). This list is empty in
# general, but can be used to knock out link-fields and suchlike as
# required.
#
sub uneditable_fields {
return ();
}
sub physical_fields {
my $class = shift();
my @allfields = $class->fields();
my @pfields;
while (@allfields) {
my $name = shift @allfields;
my $recipe = shift @allfields;
push @pfields, $name if !defined $recipe;
}
return @pfields;
}
sub virtual_fields {
my $class = shift();
my @allfields = $class->fields();
my @vfields;
while (@allfields) {
my $name = shift @allfields;
my $recipe = shift @allfields;
push @vfields, $name, $recipe if defined $recipe;
}
return @vfields;
}
# Parses full-type strings such as those used on the RHS of
# display_fields() arrays, e.g. "c", "Lt", "Rn". Returns an array of
# four elements:
# 0: whether the field is a link
# 1: whether the field is readonly
# 2: the field's core type
# 3: whether the field should be excluded at creation time.
# (It would make more sense if 2 and 3 were reversed, but existing
# code assumes the first three elements from before the fourth was
# added.)
#
sub analyse_type {
my $_unused_this = shift();
my($type, $field) = @_;
return (undef, undef, $type) if ref $type;
my $link = ($type =~ s/L//);
my $readonly = ($type =~ s/R//);
my $exclude = ($type =~ s/X//);
# Special-case the fields that we know may never change
$readonly = 1 if grep { $field eq $_ } qw(id tag);
return ($link, $readonly, $type, $exclude);
}
# Returns name of CSS class to be used for displaying fields of the
# specified type. ### Knows about what's in "style.css"
#
sub type2class {
my $this = shift();
my($type) = @_;
return "enum" if ref($type) eq "ARRAY";
return $type if grep { $type eq $_ } qw(t c n b);
return "error";
}
sub create {
my $class = shift();
my($db, %maybe_data) = @_;
my %data;
foreach my $key (keys %maybe_data) {
$data{$key} = $maybe_data{$key}
if $maybe_data{$key} ne "" &&
grep { $_ eq $key } $class->physical_fields();
}
my $table = $class->table();
my $sql = "INSERT INTO " . $db->quote($table) .
" (" . join(", ", map { $db->quote($_) } sort keys %data) . ") VALUES" .
" (" . join(", ", map { sql_quote($data{$_}) } sort keys %data) . ")";
$db->do($sql);
my $id = $db->last_insert_id($table);
die "can't get new record's ID" if !defined $id;
return $db->find1($class, id => $id);
}
sub sql_quote {
my($text) = @_;
my $sq = "'";
$text =~ s/$sq/''/g;
return "'$text'";
}
# Returns a label to be used on-screen for the specified field
sub label {
my $this = shift();
my($field, $label) = @_;
return $label if defined $label;
my $map = $this->field_map();
$label = $map->{$field};
return $label if defined $label;
# No explicit label passed, and none in config: use default rules
$label = $field;
$label =~ s/_/ /g;
return ucfirst($label);
}
# Return the components needed to identify a linked-to object
sub link {
my $this = shift();
my($field) = @_;
my %virtual = $this->virtual_fields();
my $ref = $virtual{$field};
return undef if !defined $ref;
my($linkfield, $linkclass, $linkto) = @$ref;
my $linkid = $this->field($linkfield);
return ($linkclass, $linkto, $linkid, $linkfield);
}
# Returns the number of fields modified, dies on error
sub update {
my $this = shift();
my(%maybe_data) = @_;
my %data;
foreach my $key (keys %maybe_data) {
$data{$key} = $maybe_data{$key}
if (!defined $this->field($key) ||
$maybe_data{$key} ne $this->field($key));
}
return 0 if !%data; # nothing to do
my $sql = "UPDATE " . $this->quote($this->table()) . " SET " .
join(", ", map { $this->quote($_) . " = " . sql_quote($data{$_}) } sort keys %data) .
" WHERE " . $this->quote("id") . " = " . $this->id();
$this->db()->do($sql);
foreach my $key (keys %data) {
$this->field($key, $data{$key});
}
return scalar keys %data;
}
sub delete {
my $this = shift();
my $sql = "DELETE FROM " . $this->quote($this->table()) .
" WHERE " . $this->quote("id") . " = " . $this->id();
$this->db()->do($sql);
# Wow, that embarrasingly easy
}
sub field {
my $this = shift();
my($fieldname, $value) = @_;
die "$this: request for system-function field '$fieldname'"
if grep { $_ eq $fieldname } qw(table fields mandatory_fields
physical_fields
virtual_fields search_fields
sort_fields display_fields
fulldisplay_fields field_map
field);
if (grep { $_ eq $fieldname } $this->physical_fields()) {
$this->{$fieldname} = $value if defined $value;
return $this->{$fieldname};
}
my %virtual;
eval { %virtual = $this->virtual_fields() };
if (!defined $virtual{$fieldname}) {
confess "$this: field `$fieldname' not defined";
} elsif (defined $value) {
die "can't set virtual field '$fieldname'='$value'";
} else {
return $this->virtual_field($fieldname);
}
}
sub virtual_field {
my $this = shift();
my($fieldname) = @_;
my %virtual = $this->virtual_fields();
my $ref = $virtual{$fieldname};
my($linkfield, $class, $linkto, $sortby, $valfield) = @$ref;
my $value = $this->field($linkfield);
return undef if !defined $value; # e.g. link-field in new record
if (defined $sortby) {
# Link is to multiple records
my @obj = $this->db()->find($class, $sortby, $linkto, $value);
#warn "$this->virtual_fields($fieldname) -> @obj";
return [ @obj ];
}
# Link is to a single "parent" record
my $obj = $this->db()->find1($class, $linkto, $value);
if (!defined $obj) {
# The link is broken! The Dark Lord's reign begins!
return "[$class:$linkto:$value]";
}
if (defined $valfield) {
return $obj->field($valfield);
} else {
return $obj->render_name();
}
}
sub AUTOLOAD {
my $this = shift();
my $class = ref $this || $this;
use vars qw($AUTOLOAD);
(my $fieldname = $AUTOLOAD) =~ s/.*:://;
die "$class: request for field '$fieldname' on undefined object"
if !defined $this;
return $this->field($fieldname, @_);
}
sub DESTROY {} # Avoid warning from AUTOLOAD()
sub render {
my $this = shift();
my $class = ref($this);
my $name;
eval {
$name = $this->tag();
}; if ($@ || !$name) {
undef $@; ### should this really be necessary?
eval {
$name = $this->name();
}; if ($@ || !$name) {
undef $@; ### should this really be necessary?
$name = undef;
}
}
my $text = "$class " . $this->id();
$text .= " ($name)" if defined $name;
return $text;
}
sub render_name {
my $this = shift();
my $res;
eval { $res = $this->name() };
if (!$@ && defined $res) {
#warn "returning name()='$res'";
return $res;
}
eval { $res = $this->tag() };
if (!$@ && defined $res) {
#warn "returning tag()='$res'";
return $res;
}
my $id = $this->id();
if (defined $id) {
#warn "returning id '$id'";
return ref($this) . " " . $id;
}
#warn "returning new";
return "[NEW]";
}
1;