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