FS/FS/part_export.pm

   1 package FS::part_export;
   2
   3 use strict;
   4 use vars qw( @ISA @EXPORT_OK $DEBUG %exports );
   5 use Exporter;
   6 use Tie::IxHash;
   7 use FS::Record qw( qsearch qsearchs dbh );
   8 use FS::part_svc;
   9 use FS::part_export_option;
  10 use FS::export_svc;
  11
  12 @ISA = qw(FS::Record);
  13 @EXPORT_OK = qw(export_info);
  14
  15 $DEBUG = 0;
  16
  17 =head1 NAME
  18
  19 FS::part_export - Object methods for part_export records
  20
  21 =head1 SYNOPSIS
  22
  23   use FS::part_export;
  24
  25   $record = new FS::part_export \%hash;
  26   $record = new FS::part_export { 'column' => 'value' };
  27
  28   #($new_record, $options) = $template_recored->clone( $svcpart );
  29
  30   $error = $record->insert( { 'option' => 'value' } );
  31   $error = $record->insert( \%options );
  32
  33   $error = $new_record->replace($old_record);
  34
  35   $error = $record->delete;
  36
  37   $error = $record->check;
  38
  39 =head1 DESCRIPTION
  40
  41 An FS::part_export object represents an export of Freeside data to an external
  42 provisioning system.  FS::part_export inherits from FS::Record.  The following
  43 fields are currently supported:
  44
  45 =over 4
  46
  47 =item exportnum - primary key
  48
  49 =item machine - Machine name
  50
  51 =item exporttype - Export type
  52
  53 =item nodomain - blank or "Y" : usernames are exported to this service with no domain
  54
  55 =back
  56
  57 =head1 METHODS
  58
  59 =over 4
  60
  61 =item new HASHREF
  62
  63 Creates a new export.  To add the export to the database, see L<"insert">.
  64
  65 Note that this stores the hash reference, not a distinct copy of the hash it
  66 points to.  You can ask the object for a copy with the I<hash> method.
  67
  68 =cut
  69
  70 # the new method can be inherited from FS::Record, if a table method is defined
  71
  72 sub table { 'part_export'; }
  73
  74 =cut
  75
  76 #=item clone SVCPART
  77 #
  78 #An alternate constructor.  Creates a new export by duplicating an existing
  79 #export.  The given svcpart is assigned to the new export.
  80 #
  81 #Returns a list consisting of the new export object and a hashref of options.
  82 #
  83 #=cut
  84 #
  85 #sub clone {
  86 #  my $self = shift;
  87 #  my $class = ref($self);
  88 #  my %hash = $self->hash;
  89 #  $hash{'exportnum'} = '';
  90 #  $hash{'svcpart'} = shift;
  91 #  ( $class->new( \%hash ),
  92 #    { map { $_->optionname => $_->optionvalue }
  93 #        qsearch('part_export_option', { 'exportnum' => $self->exportnum } )
  94 #    }
  95 #  );
  96 #}
  97
  98 =item insert HASHREF
  99
 100 Adds this record to the database.  If there is an error, returns the error,
 101 otherwise returns false.
 102
 103 If a hash reference of options is supplied, part_export_option records are
 104 created (see L<FS::part_export_option>).
 105
 106 =cut
 107
 108 #false laziness w/queue.pm
 109 sub insert {
 110   my $self = shift;
 111   my $options = shift;
 112   local $SIG{HUP} = 'IGNORE';
 113   local $SIG{INT} = 'IGNORE';
 114   local $SIG{QUIT} = 'IGNORE';
 115   local $SIG{TERM} = 'IGNORE';
 116   local $SIG{TSTP} = 'IGNORE';
 117   local $SIG{PIPE} = 'IGNORE';
 118
 119   my $oldAutoCommit = $FS::UID::AutoCommit;
 120   local $FS::UID::AutoCommit = 0;
 121   my $dbh = dbh;
 122
 123   my $error = $self->SUPER::insert;
 124   if ( $error ) {
 125     $dbh->rollback if $oldAutoCommit;
 126     return $error;
 127   }
 128
 129   foreach my $optionname ( keys %{$options} ) {
 130     my $part_export_option = new FS::part_export_option ( {
 131       'exportnum'   => $self->exportnum,
 132       'optionname'  => $optionname,
 133       'optionvalue' => $options->{$optionname},
 134     } );
 135     $error = $part_export_option->insert;
 136     if ( $error ) {
 137       $dbh->rollback if $oldAutoCommit;
 138       return $error;
 139     }
 140   }
 141
 142   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 143
 144   '';
 145
 146 }
 147
 148 =item delete
 149
 150 Delete this record from the database.
 151
 152 =cut
 153
 154 #foreign keys would make this much less tedious... grr dumb mysql
 155 sub delete {
 156   my $self = shift;
 157   local $SIG{HUP} = 'IGNORE';
 158   local $SIG{INT} = 'IGNORE';
 159   local $SIG{QUIT} = 'IGNORE';
 160   local $SIG{TERM} = 'IGNORE';
 161   local $SIG{TSTP} = 'IGNORE';
 162   local $SIG{PIPE} = 'IGNORE';
 163
 164   my $oldAutoCommit = $FS::UID::AutoCommit;
 165   local $FS::UID::AutoCommit = 0;
 166   my $dbh = dbh;
 167
 168   my $error = $self->SUPER::delete;
 169   if ( $error ) {
 170     $dbh->rollback if $oldAutoCommit;
 171     return $error;
 172   }
 173
 174   foreach my $part_export_option ( $self->part_export_option ) {
 175     my $error = $part_export_option->delete;
 176     if ( $error ) {
 177       $dbh->rollback if $oldAutoCommit;
 178       return $error;
 179     }
 180   }
 181
 182   foreach my $export_svc ( $self->export_svc ) {
 183     my $error = $export_svc->delete;
 184     if ( $error ) {
 185       $dbh->rollback if $oldAutoCommit;
 186       return $error;
 187     }
 188   }
 189
 190   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 191
 192   '';
 193
 194 }
 195
 196 =item replace OLD_RECORD HASHREF
 197
 198 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 199 returns the error, otherwise returns false.
 200
 201 If a hash reference of options is supplied, part_export_option records are
 202 created or modified (see L<FS::part_export_option>).
 203
 204 =cut
 205
 206 sub replace {
 207   my $self = shift;
 208   my $old = shift;
 209   my $options = shift;
 210   local $SIG{HUP} = 'IGNORE';
 211   local $SIG{INT} = 'IGNORE';
 212   local $SIG{QUIT} = 'IGNORE';
 213   local $SIG{TERM} = 'IGNORE';
 214   local $SIG{TSTP} = 'IGNORE';
 215   local $SIG{PIPE} = 'IGNORE';
 216
 217   my $oldAutoCommit = $FS::UID::AutoCommit;
 218   local $FS::UID::AutoCommit = 0;
 219   my $dbh = dbh;
 220
 221   my $error = $self->SUPER::replace($old);
 222   if ( $error ) {
 223     $dbh->rollback if $oldAutoCommit;
 224     return $error;
 225   }
 226
 227   foreach my $optionname ( keys %{$options} ) {
 228     my $old = qsearchs( 'part_export_option', {
 229         'exportnum'   => $self->exportnum,
 230         'optionname'  => $optionname,
 231     } );
 232     my $new = new FS::part_export_option ( {
 233         'exportnum'   => $self->exportnum,
 234         'optionname'  => $optionname,
 235         'optionvalue' => $options->{$optionname},
 236     } );
 237     $new->optionnum($old->optionnum) if $old;
 238     my $error = $old ? $new->replace($old) : $new->insert;
 239     if ( $error ) {
 240       $dbh->rollback if $oldAutoCommit;
 241       return $error;
 242     }
 243   }
 244
 245   #remove extraneous old options
 246   foreach my $opt (
 247     grep { !exists $options->{$_->optionname} } $old->part_export_option
 248   ) {
 249     my $error = $opt->delete;
 250     if ( $error ) {
 251       $dbh->rollback if $oldAutoCommit;
 252       return $error;
 253     }
 254   }
 255
 256   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 257
 258   '';
 259
 260 };
 261
 262 =item check
 263
 264 Checks all fields to make sure this is a valid export.  If there is
 265 an error, returns the error, otherwise returns false.  Called by the insert
 266 and replace methods.
 267
 268 =cut
 269
 270 sub check {
 271   my $self = shift;
 272   my $error =
 273     $self->ut_numbern('exportnum')
 274     || $self->ut_domain('machine')
 275     || $self->ut_alpha('exporttype')
 276   ;
 277   return $error if $error;
 278
 279   $self->nodomain =~ /^(Y?)$/ or return "Illegal nodomain: ". $self->nodomain;
 280   $self->nodomain($1);
 281
 282   $self->deprecated(1); #BLAH
 283
 284   #check exporttype?
 285
 286   $self->SUPER::check;
 287 }
 288
 289 #=item part_svc
 290 #
 291 #Returns the service definition (see L<FS::part_svc>) for this export.
 292 #
 293 #=cut
 294 #
 295 #sub part_svc {
 296 #  my $self = shift;
 297 #  qsearchs('part_svc', { svcpart => $self->svcpart } );
 298 #}
 299
 300 sub part_svc {
 301   use Carp;
 302   croak "FS::part_export::part_svc deprecated";
 303   #confess "FS::part_export::part_svc deprecated";
 304 }
 305
 306 =item svc_x
 307
 308 Returns a list of associated FS::svc_* records.
 309
 310 =cut
 311
 312 sub svc_x {
 313   my $self = shift;
 314   map { $_->svc_x } $self->cust_svc;
 315 }
 316
 317 =item cust_svc
 318
 319 Returns a list of associated FS::cust_svc records.
 320
 321 =cut
 322
 323 sub cust_svc {
 324   my $self = shift;
 325   map { qsearch('cust_svc', { 'svcpart' => $_->svcpart } ) }
 326     grep { qsearch('cust_svc', { 'svcpart' => $_->svcpart } ) }
 327       $self->export_svc;
 328 }
 329
 330 =item export_svc
 331
 332 Returns a list of associated FS::export_svc records.
 333
 334 =cut
 335
 336 sub export_svc {
 337   my $self = shift;
 338   qsearch('export_svc', { 'exportnum' => $self->exportnum } );
 339 }
 340
 341 =item part_export_option
 342
 343 Returns all options as FS::part_export_option objects (see
 344 L<FS::part_export_option>).
 345
 346 =cut
 347
 348 sub part_export_option {
 349   my $self = shift;
 350   qsearch('part_export_option', { 'exportnum' => $self->exportnum } );
 351 }
 352
 353 =item options
 354
 355 Returns a list of option names and values suitable for assigning to a hash.
 356
 357 =cut
 358
 359 sub options {
 360   my $self = shift;
 361   map { $_->optionname => $_->optionvalue } $self->part_export_option;
 362 }
 363
 364 =item option OPTIONNAME
 365
 366 Returns the option value for the given name, or the empty string.
 367
 368 =cut
 369
 370 sub option {
 371   my $self = shift;
 372   my $part_export_option =
 373     qsearchs('part_export_option', {
 374       exportnum  => $self->exportnum,
 375       optionname => shift,
 376   } );
 377   $part_export_option ? $part_export_option->optionvalue : '';
 378 }
 379
 380 =item rebless
 381
 382 Reblesses the object into the FS::part_export::EXPORTTYPE class, where
 383 EXPORTTYPE is the object's I<exporttype> field.  There should be better docs
 384 on how to create new exports (and they should live in their own files and be
 385 autoloaded-on-demand), but until then, see L</NEW EXPORT CLASSES>.
 386
 387 =cut
 388
 389 sub rebless {
 390   my $self = shift;
 391   my $exporttype = $self->exporttype;
 392   my $class = ref($self). "::$exporttype";
 393   eval "use $class;";
 394   die $@ if $@;
 395   bless($self, $class);
 396 }
 397
 398 =item export_insert SVC_OBJECT
 399
 400 =cut
 401
 402 sub export_insert {
 403   my $self = shift;
 404   $self->rebless;
 405   $self->_export_insert(@_);
 406 }
 407
 408 #sub AUTOLOAD {
 409 #  my $self = shift;
 410 #  $self->rebless;
 411 #  my $method = $AUTOLOAD;
 412 #  #$method =~ s/::(\w+)$/::_$1/; #infinite loop prevention
 413 #  $method =~ s/::(\w+)$/_$1/; #infinite loop prevention
 414 #  $self->$method(@_);
 415 #}
 416
 417 =item export_replace NEW OLD
 418
 419 =cut
 420
 421 sub export_replace {
 422   my $self = shift;
 423   $self->rebless;
 424   $self->_export_replace(@_);
 425 }
 426
 427 =item export_delete
 428
 429 =cut
 430
 431 sub export_delete {
 432   my $self = shift;
 433   $self->rebless;
 434   $self->_export_delete(@_);
 435 }
 436
 437 =item export_suspend
 438
 439 =cut
 440
 441 sub export_suspend {
 442   my $self = shift;
 443   $self->rebless;
 444   $self->_export_suspend(@_);
 445 }
 446
 447 =item export_unsuspend
 448
 449 =cut
 450
 451 sub export_unsuspend {
 452   my $self = shift;
 453   $self->rebless;
 454   $self->_export_unsuspend(@_);
 455 }
 456
 457 #fallbacks providing useful error messages intead of infinite loops
 458 sub _export_insert {
 459   my $self = shift;
 460   return "_export_insert: unknown export type ". $self->exporttype;
 461 }
 462
 463 sub _export_replace {
 464   my $self = shift;
 465   return "_export_replace: unknown export type ". $self->exporttype;
 466 }
 467
 468 sub _export_delete {
 469   my $self = shift;
 470   return "_export_delete: unknown export type ". $self->exporttype;
 471 }
 472
 473 #call svcdb-specific fallbacks
 474
 475 sub _export_suspend {
 476   my $self = shift;
 477   #warn "warning: _export_suspened unimplemented for". ref($self);
 478   my $svc_x = shift;
 479   my $new = $svc_x->clone_suspended;
 480   $self->_export_replace( $new, $svc_x );
 481 }
 482
 483 sub _export_unsuspend {
 484   my $self = shift;
 485   #warn "warning: _export_unsuspend unimplemented for ". ref($self);
 486   my $svc_x = shift;
 487   my $old = $svc_x->clone_kludge_unsuspend;
 488   $self->_export_replace( $svc_x, $old );
 489 }
 490
 491 =back
 492
 493 =head1 SUBROUTINES
 494
 495 =over 4
 496
 497 =item export_info [ SVCDB ]
 498
 499 Returns a hash reference of the exports for the given I<svcdb>, or if no
 500 I<svcdb> is specified, for all exports.  The keys of the hash are
 501 I<exporttype>s and the values are again hash references containing information
 502 on the export:
 503
 504   'desc'     => 'Description',
 505   'options'  => {
 506                   'option'  => { label=>'Option Label' },
 507                   'option2' => { label=>'Another label' },
 508                 },
 509   'nodomain' => 'Y', #or ''
 510   'notes'    => 'Additional notes',
 511
 512 =cut
 513
 514 sub export_info {
 515   #warn $_[0];
 516   return $exports{$_[0]} || {} if @_;
 517   #{ map { %{$exports{$_}} } keys %exports };
 518   my $r = { map { %{$exports{$_}} } keys %exports };
 519 }
 520
 521 #=item exporttype2svcdb EXPORTTYPE
 522 #
 523 #Returns the applicable I<svcdb> for an I<exporttype>.
 524 #
 525 #=cut
 526 #
 527 #sub exporttype2svcdb {
 528 #  my $exporttype = $_[0];
 529 #  foreach my $svcdb ( keys %exports ) {
 530 #    return $svcdb if grep { $exporttype eq $_ } keys %{$exports{$svcdb}};
 531 #  }
 532 #  '';
 533 #}
 534
 535 foreach my $INC ( @INC ) {
 536   $INC =~ /^(.*)$/;
 537   my $untainted_INC = $1;
 538   foreach my $file ( glob("$untainted_INC/FS/part_export/*.pm") ) {
 539     warn "attempting to load export info from $file\n" if $DEBUG;
 540     $file =~ /\/(\w+)\.pm$/ or do {
 541       warn "unrecognized file in $INC/FS/part_export/: $file\n";
 542       next;
 543     };
 544     my $mod = $1;
 545     my $info = eval "use FS::part_export::$mod; ".
 546                     "\\%FS::part_export::$mod\::info;";
 547     if ( $@ ) {
 548       die "error using FS::part_export::$mod (skipping): $@\n" if $@;
 549       next;
 550     }
 551     unless ( keys %$info ) {
 552       warn "no %info hash found in FS::part_export::$mod, skipping\n"
 553         unless $mod =~ /^(passwdfile|null)$/; #hack but what the heck
 554       next;
 555     }
 556     warn "got export info from FS::part_export::$mod: $info\n" if $DEBUG;
 557     no strict 'refs';
 558     foreach my $svc (
 559       ref($info->{'svc'}) ? @{$info->{'svc'}} : $info->{'svc'}
 560     ) {
 561       unless ( $svc ) {
 562         warn "blank svc for FS::part_export::$mod (skipping)\n";
 563         next;
 564       }
 565       $exports{$svc}->{$mod} = $info;
 566     }
 567   }
 568 }
 569
 570 =back
 571
 572 =head1 NEW EXPORT CLASSES
 573
 574 A module should be added in FS/FS/part_export/ (an example may be found in
 575 eg/export_template.pm)
 576
 577 =head1 BUGS
 578
 579 Hmm... cust_export class (not necessarily a database table...) ... ?
 580
 581 deprecated column...
 582
 583 =head1 SEE ALSO
 584
 585 L<FS::part_export_option>, L<FS::export_svc>, L<FS::svc_acct>,
 586 L<FS::svc_domain>,
 587 L<FS::svc_forward>, L<FS::Record>, schema.html from the base documentation.
 588
 589 =cut
 590
 591 1;
 592