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 base qw( FS::option_Common FS::m2m_Common );
   8 use FS::Record qw( qsearch qsearchs dbh );
   9 use FS::part_svc;
  10 use FS::part_export_option;
  11 use FS::part_export_machine;
  12 use FS::export_svc;
  13
  14 #for export modules, though they should probably just use it themselves
  15 use FS::queue;
  16
  17 @EXPORT_OK = qw(export_info);
  18
  19 $DEBUG = 0;
  20
  21 =head1 NAME
  22
  23 FS::part_export - Object methods for part_export records
  24
  25 =head1 SYNOPSIS
  26
  27   use FS::part_export;
  28
  29   $record = new FS::part_export \%hash;
  30   $record = new FS::part_export { 'column' => 'value' };
  31
  32   #($new_record, $options) = $template_recored->clone( $svcpart );
  33
  34   $error = $record->insert( { 'option' => 'value' } );
  35   $error = $record->insert( \%options );
  36
  37   $error = $new_record->replace($old_record);
  38
  39   $error = $record->delete;
  40
  41   $error = $record->check;
  42
  43 =head1 DESCRIPTION
  44
  45 An FS::part_export object represents an export of Freeside data to an external
  46 provisioning system.  FS::part_export inherits from FS::Record.  The following
  47 fields are currently supported:
  48
  49 =over 4
  50
  51 =item exportnum - primary key
  52
  53 =item exportname - Descriptive name
  54
  55 =item machine - Machine name
  56
  57 =item exporttype - Export type
  58
  59 =item nodomain - blank or "Y" : usernames are exported to this service with no domain
  60
  61 =back
  62
  63 =head1 METHODS
  64
  65 =over 4
  66
  67 =item new HASHREF
  68
  69 Creates a new export.  To add the export to the database, see L<"insert">.
  70
  71 Note that this stores the hash reference, not a distinct copy of the hash it
  72 points to.  You can ask the object for a copy with the I<hash> method.
  73
  74 =cut
  75
  76 # the new method can be inherited from FS::Record, if a table method is defined
  77
  78 sub table { 'part_export'; }
  79
  80 =cut
  81
  82 #=item clone SVCPART
  83 #
  84 #An alternate constructor.  Creates a new export by duplicating an existing
  85 #export.  The given svcpart is assigned to the new export.
  86 #
  87 #Returns a list consisting of the new export object and a hashref of options.
  88 #
  89 #=cut
  90 #
  91 #sub clone {
  92 #  my $self = shift;
  93 #  my $class = ref($self);
  94 #  my %hash = $self->hash;
  95 #  $hash{'exportnum'} = '';
  96 #  $hash{'svcpart'} = shift;
  97 #  ( $class->new( \%hash ),
  98 #    { map { $_->optionname => $_->optionvalue }
  99 #        qsearch('part_export_option', { 'exportnum' => $self->exportnum } )
 100 #    }
 101 #  );
 102 #}
 103
 104 =item insert HASHREF
 105
 106 Adds this record to the database.  If there is an error, returns the error,
 107 otherwise returns false.
 108
 109 If a hash reference of options is supplied, part_export_option records are
 110 created (see L<FS::part_export_option>).
 111
 112 =cut
 113
 114 sub insert {
 115   my $self = shift;
 116
 117   local $SIG{HUP} = 'IGNORE';
 118   local $SIG{INT} = 'IGNORE';
 119   local $SIG{QUIT} = 'IGNORE';
 120   local $SIG{TERM} = 'IGNORE';
 121   local $SIG{TSTP} = 'IGNORE';
 122   local $SIG{PIPE} = 'IGNORE';
 123   my $oldAutoCommit = $FS::UID::AutoCommit;
 124   local $FS::UID::AutoCommit = 0;
 125   my $dbh = dbh;
 126
 127   my $error = $self->SUPER::insert(@_);
 128   if ( $error ) {
 129     $dbh->rollback if $oldAutoCommit;
 130     return $error;
 131   }
 132
 133   #kinda false laziness with process_m2name
 134   my @machines = map { $_ =~ s/^\s+//; $_ =~ s/\s+$//; $_ }
 135                    grep /\S/,
 136                      split /[\n\r]{1,2}/,
 137                        $self->part_export_machine_textarea;
 138
 139   foreach my $machine ( @machines ) {
 140
 141     my $part_export_machine = new FS::part_export_machine {
 142       'exportnum' => $self->exportnum,
 143       'machine'   => $machine,
 144     };
 145     $error = $part_export_machine->insert;
 146     if ( $error ) {
 147       $dbh->rollback if $oldAutoCommit;
 148       return $error;
 149     }
 150   }
 151
 152   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 153   '';
 154 }
 155
 156 =item delete
 157
 158 Delete this record from the database.
 159
 160 =cut
 161
 162 #foreign keys would make this much less tedious... grr dumb mysql
 163 sub delete {
 164   my $self = shift;
 165
 166   local $SIG{HUP} = 'IGNORE';
 167   local $SIG{INT} = 'IGNORE';
 168   local $SIG{QUIT} = 'IGNORE';
 169   local $SIG{TERM} = 'IGNORE';
 170   local $SIG{TSTP} = 'IGNORE';
 171   local $SIG{PIPE} = 'IGNORE';
 172   my $oldAutoCommit = $FS::UID::AutoCommit;
 173   local $FS::UID::AutoCommit = 0;
 174   my $dbh = dbh;
 175
 176   # clean up export_nas records
 177   my $error = $self->process_m2m(
 178     'link_table'    => 'export_nas',
 179     'target_table'  => 'nas',
 180     'params'        => [],
 181   ) || $self->SUPER::delete;
 182   if ( $error ) {
 183     $dbh->rollback if $oldAutoCommit;
 184     return $error;
 185   }
 186
 187   foreach my $export_svc ( $self->export_svc ) {
 188     my $error = $export_svc->delete;
 189     if ( $error ) {
 190       $dbh->rollback if $oldAutoCommit;
 191       return $error;
 192     }
 193   }
 194
 195   foreach my $part_export_machine ( $self->part_export_machine ) {
 196     my $error = $part_export_machine->delete;
 197     if ( $error ) {
 198       $dbh->rollback if $oldAutoCommit;
 199       return $error;
 200     }
 201   }
 202
 203   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 204   '';
 205 }
 206
 207 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
 208
 209 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 210 returns the error, otherwise returns false.
 211
 212 If a list or hash reference of options is supplied, option records are created
 213 or modified.
 214
 215 =cut
 216
 217 sub replace {
 218   my $self = shift;
 219
 220   local $SIG{HUP} = 'IGNORE';
 221   local $SIG{INT} = 'IGNORE';
 222   local $SIG{QUIT} = 'IGNORE';
 223   local $SIG{TERM} = 'IGNORE';
 224   local $SIG{TSTP} = 'IGNORE';
 225   local $SIG{PIPE} = 'IGNORE';
 226
 227   my $oldAutoCommit = $FS::UID::AutoCommit;
 228   local $FS::UID::AutoCommit = 0;
 229   my $dbh = dbh;
 230
 231   my $error = $self->SUPER::replace(@_);
 232   if ( $error ) {
 233     $dbh->rollback if $oldAutoCommit;
 234     return $error;
 235   }
 236
 237   if ( $self->part_export_machine_textarea ) {
 238
 239     my %part_export_machine = map { $_->machine => $_ }
 240                                 $self->part_export_machine;
 241
 242     my @machines = map { $_ =~ s/^\s+//; $_ =~ s/\s+$//; $_ }
 243                      grep /\S/,
 244                        split /[\n\r]{1,2}/,
 245                          $self->part_export_machine_textarea;
 246
 247     foreach my $machine ( @machines ) {
 248
 249       if ( $part_export_machine{$machine} ) {
 250
 251         if ( $part_export_machine{$machine}->disabled eq 'Y' ) {
 252           $part_export_machine{$machine}->disabled('');
 253           $error = $part_export_machine{$machine}->replace;
 254           if ( $error ) {
 255             $dbh->rollback if $oldAutoCommit;
 256             return $error;
 257           }
 258         }
 259
 260         delete $part_export_machine{$machine}; #so we don't disable it below
 261
 262       } else {
 263
 264         my $part_export_machine = new FS::part_export_machine {
 265                                         'exportnum' => $self->exportnum,
 266                                         'machine'   => $machine
 267                                       };
 268         $error = $part_export_machine->insert;
 269         if ( $error ) {
 270           $dbh->rollback if $oldAutoCommit;
 271           return $error;
 272         }
 273
 274       }
 275
 276     }
 277
 278
 279     foreach my $part_export_machine ( values %part_export_machine ) {
 280       $part_export_machine->disabled('Y');
 281       $error = $part_export_machine->replace;
 282       if ( $error ) {
 283         $dbh->rollback if $oldAutoCommit;
 284         return $error;
 285       }
 286     }
 287
 288   }
 289
 290   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 291   '';
 292 }
 293
 294 =item check
 295
 296 Checks all fields to make sure this is a valid export.  If there is
 297 an error, returns the error, otherwise returns false.  Called by the insert
 298 and replace methods.
 299
 300 =cut
 301
 302 sub check {
 303   my $self = shift;
 304   my $error =
 305     $self->ut_numbern('exportnum')
 306     || $self->ut_textn('exportname')
 307     || $self->ut_domainn('machine')
 308     || $self->ut_alpha('exporttype')
 309   ;
 310   return $error if $error;
 311
 312   $self->nodomain =~ /^(Y?)$/ or return "Illegal nodomain: ". $self->nodomain;
 313   $self->nodomain($1);
 314
 315   $self->deprecated(1); #BLAH
 316
 317   #check exporttype?
 318
 319   $self->SUPER::check;
 320 }
 321
 322 =item label
 323
 324 Returns a label for this export, "exportname||exportype (machine)".
 325
 326 =cut
 327
 328 sub label {
 329   my $self = shift;
 330   ($self->exportname || $self->exporttype ). ' ('. $self->machine. ')';
 331 }
 332
 333 #=item part_svc
 334 #
 335 #Returns the service definition (see L<FS::part_svc>) for this export.
 336 #
 337 #=cut
 338 #
 339 #sub part_svc {
 340 #  my $self = shift;
 341 #  qsearchs('part_svc', { svcpart => $self->svcpart } );
 342 #}
 343
 344 sub part_svc {
 345   use Carp;
 346   croak "FS::part_export::part_svc deprecated";
 347   #confess "FS::part_export::part_svc deprecated";
 348 }
 349
 350 =item svc_x
 351
 352 Returns a list of associated FS::svc_* records.
 353
 354 =cut
 355
 356 sub svc_x {
 357   my $self = shift;
 358   map { $_->svc_x } $self->cust_svc;
 359 }
 360
 361 =item cust_svc
 362
 363 Returns a list of associated FS::cust_svc records.
 364
 365 =cut
 366
 367 sub cust_svc {
 368   my $self = shift;
 369   map { qsearch('cust_svc', { 'svcpart' => $_->svcpart } ) }
 370     grep { qsearch('cust_svc', { 'svcpart' => $_->svcpart } ) }
 371       $self->export_svc;
 372 }
 373
 374 =item part_export_machine
 375
 376 Returns all machines as FS::part_export_machine objects (see
 377 L<FS::part_export_machine>).
 378
 379 =cut
 380
 381 sub part_export_machine {
 382   my $self = shift;
 383   map { $_ } #behavior of sort undefined in scalar context
 384     sort { $a->machine cmp $b->machine }
 385       qsearch('part_export_machine', { 'exportnum' => $self->exportnum } );
 386 }
 387
 388 =item export_svc
 389
 390 Returns a list of associated FS::export_svc records.
 391
 392 =cut
 393
 394 sub export_svc {
 395   my $self = shift;
 396   qsearch('export_svc', { 'exportnum' => $self->exportnum } );
 397 }
 398
 399 =item export_device
 400
 401 Returns a list of associated FS::export_device records.
 402
 403 =cut
 404
 405 sub export_device {
 406   my $self = shift;
 407   qsearch('export_device', { 'exportnum' => $self->exportnum } );
 408 }
 409
 410 =item part_export_option
 411
 412 Returns all options as FS::part_export_option objects (see
 413 L<FS::part_export_option>).
 414
 415 =cut
 416
 417 sub part_export_option {
 418   my $self = shift;
 419   $self->option_objects;
 420 }
 421
 422 =item options
 423
 424 Returns a list of option names and values suitable for assigning to a hash.
 425
 426 =item option OPTIONNAME
 427
 428 Returns the option value for the given name, or the empty string.
 429
 430 =item _rebless
 431
 432 Reblesses the object into the FS::part_export::EXPORTTYPE class, where
 433 EXPORTTYPE is the object's I<exporttype> field.  There should be better docs
 434 on how to create new exports, but until then, see L</NEW EXPORT CLASSES>.
 435
 436 =cut
 437
 438 sub _rebless {
 439   my $self = shift;
 440   my $exporttype = $self->exporttype;
 441   my $class = ref($self). "::$exporttype";
 442   eval "use $class;";
 443   #die $@ if $@;
 444   bless($self, $class) unless $@;
 445   $self;
 446 }
 447
 448 #these should probably all go away, just let the subclasses define em
 449
 450 =item export_insert SVC_OBJECT
 451
 452 =cut
 453
 454 sub export_insert {
 455   my $self = shift;
 456   #$self->rebless;
 457   $self->_export_insert(@_);
 458 }
 459
 460 #sub AUTOLOAD {
 461 #  my $self = shift;
 462 #  $self->rebless;
 463 #  my $method = $AUTOLOAD;
 464 #  #$method =~ s/::(\w+)$/::_$1/; #infinite loop prevention
 465 #  $method =~ s/::(\w+)$/_$1/; #infinite loop prevention
 466 #  $self->$method(@_);
 467 #}
 468
 469 =item export_replace NEW OLD
 470
 471 =cut
 472
 473 sub export_replace {
 474   my $self = shift;
 475   #$self->rebless;
 476   $self->_export_replace(@_);
 477 }
 478
 479 =item export_delete
 480
 481 =cut
 482
 483 sub export_delete {
 484   my $self = shift;
 485   #$self->rebless;
 486   $self->_export_delete(@_);
 487 }
 488
 489 =item export_suspend
 490
 491 =cut
 492
 493 sub export_suspend {
 494   my $self = shift;
 495   #$self->rebless;
 496   $self->_export_suspend(@_);
 497 }
 498
 499 =item export_unsuspend
 500
 501 =cut
 502
 503 sub export_unsuspend {
 504   my $self = shift;
 505   #$self->rebless;
 506   $self->_export_unsuspend(@_);
 507 }
 508
 509 #fallbacks providing useful error messages intead of infinite loops
 510 sub _export_insert {
 511   my $self = shift;
 512   return "_export_insert: unknown export type ". $self->exporttype;
 513 }
 514
 515 sub _export_replace {
 516   my $self = shift;
 517   return "_export_replace: unknown export type ". $self->exporttype;
 518 }
 519
 520 sub _export_delete {
 521   my $self = shift;
 522   return "_export_delete: unknown export type ". $self->exporttype;
 523 }
 524
 525 #call svcdb-specific fallbacks
 526
 527 sub _export_suspend {
 528   my $self = shift;
 529   #warn "warning: _export_suspened unimplemented for". ref($self);
 530   my $svc_x = shift;
 531   my $new = $svc_x->clone_suspended;
 532   $self->_export_replace( $new, $svc_x );
 533 }
 534
 535 sub _export_unsuspend {
 536   my $self = shift;
 537   #warn "warning: _export_unsuspend unimplemented for ". ref($self);
 538   my $svc_x = shift;
 539   my $old = $svc_x->clone_kludge_unsuspend;
 540   $self->_export_replace( $svc_x, $old );
 541 }
 542
 543 =item export_links SVC_OBJECT ARRAYREF
 544
 545 Adds a list of web elements to ARRAYREF specific to this export and SVC_OBJECT.
 546 The elements are displayed in the UI to lead the the operator to external
 547 configuration, monitoring, and similar tools.
 548
 549 =item export_getsettings SVC_OBJECT SETTINGS_HASHREF DEFAUTS_HASHREF
 550
 551 Adds a hashref of settings to SETTINGSREF specific to this export and
 552 SVC_OBJECT.  The elements can be displayed in the UI on the service view.
 553
 554 DEFAULTSREF is a hashref with the same keys where true values indicate the
 555 setting is a default (and thus can be displayed in the UI with less emphasis,
 556 or hidden by default).
 557
 558 =cut
 559
 560 =item weight
 561
 562 Returns the 'weight' element from the export's %info hash, or 0 if there is
 563 no weight defined.
 564
 565 =cut
 566
 567 sub weight {
 568   my $self = shift;
 569   export_info()->{$self->exporttype}->{'weight'} || 0;
 570 }
 571
 572 =back
 573
 574 =head1 SUBROUTINES
 575
 576 =over 4
 577
 578 =item export_info [ SVCDB ]
 579
 580 Returns a hash reference of the exports for the given I<svcdb>, or if no
 581 I<svcdb> is specified, for all exports.  The keys of the hash are
 582 I<exporttype>s and the values are again hash references containing information
 583 on the export:
 584
 585   'desc'     => 'Description',
 586   'options'  => {
 587                   'option'  => { label=>'Option Label' },
 588                   'option2' => { label=>'Another label' },
 589                 },
 590   'nodomain' => 'Y', #or ''
 591   'notes'    => 'Additional notes',
 592
 593 =cut
 594
 595 sub export_info {
 596   #warn $_[0];
 597   return $exports{$_[0]} || {} if @_;
 598   #{ map { %{$exports{$_}} } keys %exports };
 599   my $r = { map { %{$exports{$_}} } keys %exports };
 600 }
 601
 602
 603 sub _upgrade_data {  #class method
 604   my ($class, %opts) = @_;
 605
 606   my @part_export_option = qsearch('part_export_option', { 'optionname' => 'overlimit_groups' });
 607   foreach my $opt ( @part_export_option ) {
 608     next if $opt->optionvalue =~ /^[\d\s]+$/ || !$opt->optionvalue;
 609     my @groupnames = split(' ',$opt->optionvalue);
 610     my @groupnums;
 611     my $error = '';
 612     foreach my $groupname ( @groupnames ) {
 613         my $g = qsearchs('radius_group', { 'groupname' => $groupname } );
 614         unless ( $g ) {
 615             $g = new FS::radius_group {
 616                             'groupname' => $groupname,
 617                             'description' => $groupname,
 618                             };
 619             $error = $g->insert;
 620             die $error if $error;
 621         }
 622         push @groupnums, $g->groupnum;
 623     }
 624     $opt->optionvalue(join(' ',@groupnums));
 625     $error = $opt->replace;
 626     die $error if $error;
 627   }
 628   # pass downstream
 629   my %exports_in_use;
 630   $exports_in_use{ref $_} = 1 foreach qsearch('part_export', {});
 631   foreach (keys(%exports_in_use)) {
 632     $_->_upgrade_exporttype(%opts) if $_->can('_upgrade_exporttype');
 633   }
 634 }
 635
 636 #=item exporttype2svcdb EXPORTTYPE
 637 #
 638 #Returns the applicable I<svcdb> for an I<exporttype>.
 639 #
 640 #=cut
 641 #
 642 #sub exporttype2svcdb {
 643 #  my $exporttype = $_[0];
 644 #  foreach my $svcdb ( keys %exports ) {
 645 #    return $svcdb if grep { $exporttype eq $_ } keys %{$exports{$svcdb}};
 646 #  }
 647 #  '';
 648 #}
 649
 650 #false laziness w/part_pkg & cdr
 651 foreach my $INC ( @INC ) {
 652   foreach my $file ( glob("$INC/FS/part_export/*.pm") ) {
 653     warn "attempting to load export info from $file\n" if $DEBUG;
 654     $file =~ /\/(\w+)\.pm$/ or do {
 655       warn "unrecognized file in $INC/FS/part_export/: $file\n";
 656       next;
 657     };
 658     my $mod = $1;
 659     my $info = eval "use FS::part_export::$mod; ".
 660                     "\\%FS::part_export::$mod\::info;";
 661     if ( $@ ) {
 662       die "error using FS::part_export::$mod (skipping): $@\n" if $@;
 663       next;
 664     }
 665     unless ( keys %$info ) {
 666       warn "no %info hash found in FS::part_export::$mod, skipping\n"
 667         unless $mod =~ /^(passwdfile|null|.+_Common)$/; #hack but what the heck
 668       next;
 669     }
 670     warn "got export info from FS::part_export::$mod: $info\n" if $DEBUG;
 671     no strict 'refs';
 672     foreach my $svc (
 673       ref($info->{'svc'}) ? @{$info->{'svc'}} : $info->{'svc'}
 674     ) {
 675       unless ( $svc ) {
 676         warn "blank svc for FS::part_export::$mod (skipping)\n";
 677         next;
 678       }
 679       $exports{$svc}->{$mod} = $info;
 680     }
 681   }
 682 }
 683
 684 =back
 685
 686 =head1 NEW EXPORT CLASSES
 687
 688 A module should be added in FS/FS/part_export/ (an example may be found in
 689 eg/export_template.pm)
 690
 691 =head1 BUGS
 692
 693 Hmm... cust_export class (not necessarily a database table...) ... ?
 694
 695 deprecated column...
 696
 697 =head1 SEE ALSO
 698
 699 L<FS::part_export_option>, L<FS::export_svc>, L<FS::svc_acct>,
 700 L<FS::svc_domain>,
 701 L<FS::svc_forward>, L<FS::Record>, schema.html from the base documentation.
 702
 703 =cut
 704
 705 1;
 706