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 sub call_sub_if {
  88   my $self  = shift;
  89   my $sub   = shift;
  90   my $check = shift;
  91
  92   $check    = $check->($self) if ref($check) eq 'CODE';
  93
  94   return $check ? $self->$sub(@_) : $self;
  95 }
  96
  97 1;
  98
  99 __END__
 100
 101 =pod
 102
 103 =head1 NAME
 104
 105 SL::DB::Object: Base class for all of our model classes
 106
 107 =head1 DESCRIPTION
 108
 109 This is the base class from which all other model classes are
 110 derived. It contains functionality and settings required for all model
 111 classes.
 112
 113 Several functions (e.g. C<make_manager_class>, C<init_db>) in this
 114 class are used for setting up the classes / base classes used for all
 115 model instances. They overwrite the functions from
 116 L<Rose::DB::Object>.
 117
 118 =head1 FUNCTIONS
 119
 120 =over 4
 121
 122 =item assign_attributes %attributes
 123
 124 =item _assign_attributes %attributes
 125
 126 Assigns all elements from C<%attributes> to the columns by calling
 127 their setter functions. The difference between the two functions is
 128 that C<assign_attributes> protects primary key columns while
 129 C<_assign_attributes> doesn't.
 130
 131 Both functions handle values that are empty strings by replacing them
 132 with C<undef> for non-text columns. This allows the calling functions
 133 to use data from HTML forms as the input for C<assign_attributes>
 134 without having to remove empty strings themselves (think of
 135 e.g. select boxes with an empty option which should be turned into
 136 C<NULL> in the database).
 137
 138 =item update_attributes %attributes
 139
 140 Assigns the attributes from C<%attributes> by calling the
 141 C<assign_attributes> function and saves the object afterwards. Returns
 142 the object itself.
 143
 144 =item _get_manager_class
 145
 146 Returns the manager package for the object or class that it is called
 147 on. Can be used from methods in this package for getting the actual
 148 object's manager.
 149
 150 =item C<call_sub $name, @args>
 151
 152 Calls the sub C<$name> on C<$self> with the arguments C<@args> and
 153 returns its result. This is meant for situations in which the sub's
 154 name is a composite, e.g.
 155
 156   my $chart_id = $buchungsgruppe->call_sub(($is_sales ? "income" : "expense") . "_accno_id_${taxzone_id}");
 157
 158 =item C<call_sub_if $name, $check, @args>
 159
 160 Calls the sub C<$name> on C<$self> with the arguments C<@args> if
 161 C<$check> is trueish. If C<$check> is a code reference then it will be
 162 called with C<$self> as the only argument and its result determines
 163 whether or not C<$name> is called.
 164
 165 Returns the sub's result if the check is positive and C<$self>
 166 otherwise.
 167
 168 =back
 169
 170 =head1 AUTHOR
 171
 172 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 173
 174 =cut