FS/FS/option_Common.pm

   1 package FS::option_Common;
   2
   3 use strict;
   4 use base qw( FS::Record );
   5 use vars qw( $DEBUG );
   6 use Carp qw( cluck );
   7 use Scalar::Util qw( blessed );
   8 use FS::Record qw( qsearch qsearchs dbh );
   9
  10 $DEBUG = 0;
  11
  12 =head1 NAME
  13
  14 FS::option_Common - Base class for option sub-classes
  15
  16 =head1 SYNOPSIS
  17
  18 use FS::option_Common;
  19
  20 @ISA = qw( FS::option_Common );
  21
  22 #optional for non-standard names
  23 sub _option_table    { 'table_name'; }  #defaults to ${table}_option
  24 sub _option_namecol  { 'column_name'; } #defaults to optionname
  25 sub _option_valuecol { 'column_name'; } #defaults to optionvalue
  26
  27 =head1 DESCRIPTION
  28
  29 FS::option_Common is intended as a base class for classes which have a
  30 simple one-to-many class associated with them, used to store a hash-like data
  31 structure of keys and values.
  32
  33 =head1 METHODS
  34
  35 =over 4
  36
  37 =item insert [ HASHREF | OPTION => VALUE ... ]
  38
  39 Adds this record to the database.  If there is an error, returns the error,
  40 otherwise returns false.
  41
  42 If a list or hash reference of options is supplied, option records are also
  43 created.
  44
  45 =cut
  46
  47 #false laziness w/queue.pm
  48 sub insert {
  49   my $self = shift;
  50   my $options =
  51     ( ref($_[0]) eq 'HASH' )
  52       ? shift
  53       : { @_ };
  54   warn "FS::option_Common::insert called on $self with options ".
  55        join(', ', map "$_ => ".$options->{$_}, keys %$options)
  56     if $DEBUG;
  57
  58   local $SIG{HUP} = 'IGNORE';
  59   local $SIG{INT} = 'IGNORE';
  60   local $SIG{QUIT} = 'IGNORE';
  61   local $SIG{TERM} = 'IGNORE';
  62   local $SIG{TSTP} = 'IGNORE';
  63   local $SIG{PIPE} = 'IGNORE';
  64
  65   my $oldAutoCommit = $FS::UID::AutoCommit;
  66   local $FS::UID::AutoCommit = 0;
  67   my $dbh = dbh;
  68
  69   my $error;
  70
  71   $error = $self->check_options($options)
  72            || $self->SUPER::insert;
  73   if ( $error ) {
  74     $dbh->rollback if $oldAutoCommit;
  75     return $error;
  76   }
  77
  78   my $pkey = $self->primary_key;
  79   my $option_table = $self->option_table;
  80
  81   my $namecol = $self->_option_namecol;
  82   my $valuecol = $self->_option_valuecol;
  83
  84   foreach my $optionname ( keys %{$options} ) {
  85
  86     my $optionvalue = $options->{$optionname};
  87
  88     my $href = {
  89       $pkey     => $self->get($pkey),
  90       $namecol  => $optionname,
  91       $valuecol => ( ref($optionvalue) || $optionvalue ),
  92     };
  93
  94     #my $option_record = eval "new FS::$option_table \$href";
  95     #if ( $@ ) {
  96     #  $dbh->rollback if $oldAutoCommit;
  97     #  return $@;
  98     #}
  99     my $option_record = "FS::$option_table"->new($href);
 100
 101     my @args = ();
 102     push @args, $optionvalue if ref($optionvalue); #only hashes supported so far
 103
 104     $error = $option_record->insert(@args);
 105     if ( $error ) {
 106       $dbh->rollback if $oldAutoCommit;
 107       return $error;
 108     }
 109
 110   }
 111
 112   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 113
 114   '';
 115
 116 }
 117
 118 =item delete
 119
 120 Delete this record from the database.  Any associated option records are also
 121 deleted.
 122
 123 =cut
 124
 125 #foreign keys would make this much less tedious... grr dumb mysql
 126 sub delete {
 127   my $self = shift;
 128   local $SIG{HUP} = 'IGNORE';
 129   local $SIG{INT} = 'IGNORE';
 130   local $SIG{QUIT} = 'IGNORE';
 131   local $SIG{TERM} = 'IGNORE';
 132   local $SIG{TSTP} = 'IGNORE';
 133   local $SIG{PIPE} = 'IGNORE';
 134
 135   my $oldAutoCommit = $FS::UID::AutoCommit;
 136   local $FS::UID::AutoCommit = 0;
 137   my $dbh = dbh;
 138
 139   my $pkey = $self->primary_key;
 140   #my $option_table = $self->option_table;
 141
 142   foreach my $obj ( $self->option_objects ) {
 143     my $error = $obj->delete;
 144     if ( $error ) {
 145       $dbh->rollback if $oldAutoCommit;
 146       return $error;
 147     }
 148   }
 149
 150   my $error = $self->SUPER::delete;
 151   if ( $error ) {
 152     $dbh->rollback if $oldAutoCommit;
 153     return $error;
 154   }
 155
 156   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 157
 158   '';
 159
 160 }
 161
 162 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
 163
 164 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 165 returns the error, otherwise returns false.
 166
 167 If a list or hash reference of options is supplied, option records are created
 168 or modified.
 169
 170 =cut
 171
 172 sub replace {
 173   my $self = shift;
 174
 175   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 176               ? shift
 177               : $self->replace_old;
 178
 179   my $options;
 180   my $options_supplied = 0;
 181   if ( ref($_[0]) eq 'HASH' ) {
 182     $options = shift;
 183     $options_supplied = 1;
 184   } else {
 185     $options = { @_ };
 186     $options_supplied = scalar(@_) ? 1 : 0;
 187   }
 188
 189   warn "FS::option_Common::replace called on $self with options ".
 190        join(', ', map "$_ => ". $options->{$_}, keys %$options)
 191     if $DEBUG;
 192
 193   local $SIG{HUP} = 'IGNORE';
 194   local $SIG{INT} = 'IGNORE';
 195   local $SIG{QUIT} = 'IGNORE';
 196   local $SIG{TERM} = 'IGNORE';
 197   local $SIG{TSTP} = 'IGNORE';
 198   local $SIG{PIPE} = 'IGNORE';
 199
 200   my $oldAutoCommit = $FS::UID::AutoCommit;
 201   local $FS::UID::AutoCommit = 0;
 202   my $dbh = dbh;
 203
 204   my $error;
 205
 206   if ($options_supplied) {
 207     $error = $self->check_options($options);
 208     if ( $error ) {
 209       $dbh->rollback if $oldAutoCommit;
 210       return $error;
 211     }
 212   }
 213
 214   $error = $self->SUPER::replace($old);
 215   if ( $error ) {
 216     $dbh->rollback if $oldAutoCommit;
 217     return $error;
 218   }
 219
 220   my $pkey = $self->primary_key;
 221   my $option_table = $self->option_table;
 222
 223   my $namecol = $self->_option_namecol;
 224   my $valuecol = $self->_option_valuecol;
 225
 226   foreach my $optionname ( keys %{$options} ) {
 227
 228     warn "FS::option_Common::replace: inserting or replacing option: $optionname"
 229       if $DEBUG > 1;
 230
 231     my $oldopt = qsearchs( $option_table, {
 232         $pkey    => $self->get($pkey),
 233         $namecol => $optionname,
 234     } );
 235
 236     my $optionvalue = $options->{$optionname};
 237
 238     my %oldhash = $oldopt ? $oldopt->hash : ();
 239
 240     my $href = {
 241         %oldhash,
 242         $pkey     => $self->get($pkey),
 243         $namecol  => $optionname,
 244         $valuecol => ( ref($optionvalue) || $optionvalue ),
 245     };
 246
 247     #my $newopt = eval "new FS::$option_table \$href";
 248     #if ( $@ ) {
 249     #  $dbh->rollback if $oldAutoCommit;
 250     #  return $@;
 251     #}
 252     my $newopt = "FS::$option_table"->new($href);
 253
 254     my $opt_pkey = $newopt->primary_key;
 255
 256     $newopt->$opt_pkey($oldopt->$opt_pkey) if $oldopt;
 257
 258     my @args = ();
 259     push @args, $optionvalue if ref($optionvalue); #only hashes supported so far
 260
 261     warn "FS::option_Common::replace: ".
 262          ( $oldopt ? "$newopt -> replace($oldopt)" : "$newopt -> insert" )
 263       if $DEBUG > 2;
 264     my $error = $oldopt ? $newopt->replace($oldopt, @args)
 265                         : $newopt->insert( @args);
 266     if ( $error ) {
 267       $dbh->rollback if $oldAutoCommit;
 268       return $error;
 269     }
 270   }
 271
 272   #remove extraneous old options
 273   if ( $options_supplied ) {
 274     foreach my $opt (
 275       grep { !exists $options->{$_->$namecol()} } $old->option_objects
 276     ) {
 277       my $error = $opt->delete;
 278       if ( $error ) {
 279         $dbh->rollback if $oldAutoCommit;
 280         return $error;
 281       }
 282     }
 283   }
 284
 285   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 286
 287   '';
 288
 289 }
 290
 291 =item check_options HASHREF
 292
 293 This method is called by 'insert' and 'replace' to check the options that were supplied.
 294
 295 Return error-message, or false.
 296
 297 (In this class, this is a do-nothing routine that always returns false.  Override as necessary.  No need to call superclass.)
 298
 299 =cut
 300
 301 sub check_options {
 302         my ($self, $options) = @_;
 303         '';
 304 }
 305
 306 =item option_objects
 307
 308 Returns all options as FS::I<tablename>_option objects.
 309
 310 =cut
 311
 312 sub option_objects {
 313   my $self = shift;
 314   my $pkey = $self->primary_key;
 315   my $option_table = $self->option_table;
 316   qsearch($option_table, { $pkey => $self->get($pkey) } );
 317 }
 318
 319 =item options
 320
 321 Returns a list of option names and values suitable for assigning to a hash.
 322
 323 =cut
 324
 325 sub options {
 326   my $self = shift;
 327   my $namecol = $self->_option_namecol;
 328   my $valuecol = $self->_option_valuecol;
 329   map { $_->$namecol() => $_->$valuecol() } $self->option_objects;
 330 }
 331
 332 =item option OPTIONNAME
 333
 334 Returns the option value for the given name, or the empty string.
 335
 336 =cut
 337
 338 sub option {
 339   my $self = shift;
 340   my $pkey = $self->primary_key;
 341   my $option_table = $self->option_table;
 342   my $namecol = $self->_option_namecol;
 343   my $valuecol = $self->_option_valuecol;
 344   my $hashref = {
 345       $pkey    => $self->get($pkey),
 346       $namecol => shift,
 347   };
 348   cluck "$self -> option: searching for ".
 349          join(' / ', map { "$_ => ". $hashref->{$_} } keys %$hashref )
 350     if $DEBUG;
 351   my $obj = qsearchs($option_table, $hashref);
 352   $obj ? $obj->$valuecol() : '';
 353 }
 354
 355 =item option_cacheable OPTIONNAME
 356
 357 Same as the option method, but may cache and return a cached value.
 358 Good for use within loops; otherwise, probably avoid.
 359
 360 =cut
 361
 362 sub option_cacheable {
 363   my( $self, $name ) = @_;
 364   return $self->{option_cache}{$name} if exists $self->{option_cache}{$name};
 365   $self->{option_cache}{$name} = $self->option($name,1);
 366 }
 367
 368
 369 sub option_table {
 370   my $self = shift;
 371   my $option_table = $self->_option_table;
 372   eval "use FS::$option_table";
 373   die $@ if $@;
 374   $option_table;
 375 }
 376
 377 #defaults
 378 sub _option_table    { shift->table .'_option'; }
 379 sub _option_namecol  { 'optionname'; }
 380 sub _option_valuecol { 'optionvalue'; }
 381
 382 =back
 383
 384 =head1 BUGS
 385
 386 =head1 SEE ALSO
 387
 388 L<FS::Record>
 389
 390 =cut
 391
 392 1;
 393