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