SL/DB/Object.pm

   1 package SL::DB::Object;
   2
   3 use strict;
   4
   5 use Rose::DB::Object;
   6 use List::MoreUtils qw(any);
   7
   8 use SL::DB;
   9 use SL::DB::Helper::Attr;
  10 use SL::DB::Helper::Metadata;
  11 use SL::DB::Helper::Manager;
  12
  13 use base qw(Rose::DB::Object);
  14
  15 sub new {
  16   my $class = shift;
  17   my $self  = $class->SUPER::new();
  18
  19   $self->_assign_attributes(@_) if $self;
  20
  21   return $self;
  22 }
  23
  24 sub init_db {
  25   my $class_or_self = shift;
  26   my $class         = ref($class_or_self) || $class_or_self;
  27   my $type          = $class =~ m/::Auth/ ? 'LXOFFICE_AUTH' : 'LXOFFICE';
  28
  29   return SL::DB::create(undef, $type);
  30 }
  31
  32 sub meta_class {
  33   return 'SL::DB::Helper::Metadata';
  34 }
  35
  36 sub _get_manager_class {
  37   my $class_or_self = shift;
  38   my $class         = ref($class_or_self) || $class_or_self;
  39
  40   return $class->meta->convention_manager->auto_manager_class_name($class);
  41 }
  42
  43 my %text_column_types = (text => 1, char => 1, varchar => 1);
  44
  45 sub assign_attributes {
  46   my $self       = shift;
  47   my %attributes = @_;
  48
  49   my $pk         = ref($self)->meta->primary_key;
  50   delete @attributes{$pk->column_names} if $pk;
  51
  52   return $self->_assign_attributes(%attributes);
  53 }
  54
  55 sub _assign_attributes {
  56   my $self       = shift;
  57   my %attributes = @_;
  58
  59   my %types      = map { $_->name => $_->type } ref($self)->meta->columns;
  60
  61   while (my ($attribute, $value) = each %attributes) {
  62     my $type = lc($types{$attribute} || 'text');
  63     $value   = $type eq 'boolean'                ? ($value ? 't' : 'f')
  64              : $text_column_types{$type}         ? $value
  65              : defined($value) && ($value eq '') ? undef
  66              :                                     $value;
  67     $self->$attribute($value);
  68   }
  69
  70   return $self;
  71 }
  72
  73 sub update_attributes {
  74   my $self = shift;
  75
  76   $self->assign_attributes(@_)->save;
  77
  78   return $self;
  79 }
  80
  81 sub call_sub {
  82   my $self = shift;
  83   my $sub  = shift;
  84   return $self->$sub(@_);
  85 }
  86
  87 1;
  88
  89 __END__
  90
  91 =pod
  92
  93 =head1 NAME
  94
  95 SL::DB::Object: Base class for all of our model classes
  96
  97 =head1 DESCRIPTION
  98
  99 This is the base class from which all other model classes are
 100 derived. It contains functionality and settings required for all model
 101 classes.
 102
 103 Several functions (e.g. C<make_manager_class>, C<init_db>) in this
 104 class are used for setting up the classes / base classes used for all
 105 model instances. They overwrite the functions from
 106 L<Rose::DB::Object>.
 107
 108 =head1 FUNCTIONS
 109
 110 =over 4
 111
 112 =item assign_attributes %attributes
 113
 114 =item _assign_attributes %attributes
 115
 116 Assigns all elements from C<%attributes> to the columns by calling
 117 their setter functions. The difference between the two functions is
 118 that C<assign_attributes> protects primary key columns while
 119 C<_assign_attributes> doesn't.
 120
 121 Both functions handle values that are empty strings by replacing them
 122 with C<undef> for non-text columns. This allows the calling functions
 123 to use data from HTML forms as the input for C<assign_attributes>
 124 without having to remove empty strings themselves (think of
 125 e.g. select boxes with an empty option which should be turned into
 126 C<NULL> in the database).
 127
 128 =item update_attributes %attributes
 129
 130 Assigns the attributes from C<%attributes> by calling the
 131 C<assign_attributes> function and saves the object afterwards. Returns
 132 the object itself.
 133
 134 =item _get_manager_class
 135
 136 Returns the manager package for the object or class that it is called
 137 on. Can be used from methods in this package for getting the actual
 138 object's manager.
 139
 140 =item C<call_sub $name, @args>
 141
 142 Calls the sub C<$name> on C<$self> with the arguments C<@args> and
 143 returns its result. This is meant for situations in which the sub's
 144 name is a composite, e.g.
 145
 146   my $chart_id = $buchungsgruppe->call_sub(($is_sales ? "income" : "expense") . "_accno_id_${taxzone_id}");
 147
 148 =back
 149
 150 =head1 AUTHOR
 151
 152 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 153
 154 =cut