SL/DB/Object.pm

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