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 label_html
 334
 335 Returns a label for this export, "exportname: exporttype to machine".
 336
 337 =cut
 338
 339 sub label_html {
 340   my $self = shift;
 341
 342   my $label = $self->exportname
 343                 ? '<B>'. $self->exportname. '</B>: ' #<BR>'.
 344                 : '';
 345
 346   $label .= $self->exporttype;
 347
 348   $label .= ' to '. ( $self->machine eq '_SVC_MACHINE'
 349                         ? 'per-service hostname'
 350                         : $self->machine
 351                     )
 352     if $self->machine;
 353
 354   $label;
 355
 356 }
 357
 358 #=item part_svc
 359 #
 360 #Returns the service definition (see L<FS::part_svc>) for this export.
 361 #
 362 #=cut
 363 #
 364 #sub part_svc {
 365 #  my $self = shift;
 366 #  qsearchs('part_svc', { svcpart => $self->svcpart } );
 367 #}
 368
 369 sub part_svc {
 370   use Carp;
 371   croak "FS::part_export::part_svc deprecated";
 372   #confess "FS::part_export::part_svc deprecated";
 373 }
 374
 375 =item svc_x
 376
 377 Returns a list of associated FS::svc_* records.
 378
 379 =cut
 380
 381 sub svc_x {
 382   my $self = shift;
 383   map { $_->svc_x } $self->cust_svc;
 384 }
 385
 386 =item cust_svc
 387
 388 Returns a list of associated FS::cust_svc records.
 389
 390 =cut
 391
 392 sub cust_svc {
 393   my $self = shift;
 394   map { qsearch('cust_svc', { 'svcpart' => $_->svcpart } ) }
 395     grep { qsearch('cust_svc', { 'svcpart' => $_->svcpart } ) }
 396       $self->export_svc;
 397 }
 398
 399 =item part_export_machine
 400
 401 Returns all machines as FS::part_export_machine objects (see
 402 L<FS::part_export_machine>).
 403
 404 =cut
 405
 406 sub part_export_machine {
 407   my $self = shift;
 408   map { $_ } #behavior of sort undefined in scalar context
 409     sort { $a->machine cmp $b->machine }
 410       qsearch('part_export_machine', { 'exportnum' => $self->exportnum } );
 411 }
 412
 413 =item export_svc
 414
 415 Returns a list of associated FS::export_svc records.
 416
 417 =cut
 418
 419 sub export_svc {
 420   my $self = shift;
 421   qsearch('export_svc', { 'exportnum' => $self->exportnum } );
 422 }
 423
 424 =item export_device
 425
 426 Returns a list of associated FS::export_device records.
 427
 428 =cut
 429
 430 sub export_device {
 431   my $self = shift;
 432   qsearch('export_device', { 'exportnum' => $self->exportnum } );
 433 }
 434
 435 =item part_export_option
 436
 437 Returns all options as FS::part_export_option objects (see
 438 L<FS::part_export_option>).
 439
 440 =cut
 441
 442 sub part_export_option {
 443   my $self = shift;
 444   $self->option_objects;
 445 }
 446
 447 =item options
 448
 449 Returns a list of option names and values suitable for assigning to a hash.
 450
 451 =item option OPTIONNAME
 452
 453 Returns the option value for the given name, or the empty string.
 454
 455 =item _rebless
 456
 457 Reblesses the object into the FS::part_export::EXPORTTYPE class, where
 458 EXPORTTYPE is the object's I<exporttype> field.  There should be better docs
 459 on how to create new exports, but until then, see L</NEW EXPORT CLASSES>.
 460
 461 =cut
 462
 463 sub _rebless {
 464   my $self = shift;
 465   my $exporttype = $self->exporttype;
 466   my $class = ref($self). "::$exporttype";
 467   eval "use $class;";
 468   #die $@ if $@;
 469   bless($self, $class) unless $@;
 470   $self;
 471 }
 472
 473 #these should probably all go away, just let the subclasses define em
 474
 475 =item export_insert SVC_OBJECT
 476
 477 =cut
 478
 479 sub export_insert {
 480   my $self = shift;
 481   #$self->rebless;
 482   $self->_export_insert(@_);
 483 }
 484
 485 #sub AUTOLOAD {
 486 #  my $self = shift;
 487 #  $self->rebless;
 488 #  my $method = $AUTOLOAD;
 489 #  #$method =~ s/::(\w+)$/::_$1/; #infinite loop prevention
 490 #  $method =~ s/::(\w+)$/_$1/; #infinite loop prevention
 491 #  $self->$method(@_);
 492 #}
 493
 494 =item export_replace NEW OLD
 495
 496 =cut
 497
 498 sub export_replace {
 499   my $self = shift;
 500   #$self->rebless;
 501   $self->_export_replace(@_);
 502 }
 503
 504 =item export_delete
 505
 506 =cut
 507
 508 sub export_delete {
 509   my $self = shift;
 510   #$self->rebless;
 511   $self->_export_delete(@_);
 512 }
 513
 514 =item export_suspend
 515
 516 =cut
 517
 518 sub export_suspend {
 519   my $self = shift;
 520   #$self->rebless;
 521   $self->_export_suspend(@_);
 522 }
 523
 524 =item export_unsuspend
 525
 526 =cut
 527
 528 sub export_unsuspend {
 529   my $self = shift;
 530   #$self->rebless;
 531   $self->_export_unsuspend(@_);
 532 }
 533
 534 #fallbacks providing useful error messages intead of infinite loops
 535 sub _export_insert {
 536   my $self = shift;
 537   return "_export_insert: unknown export type ". $self->exporttype;
 538 }
 539
 540 sub _export_replace {
 541   my $self = shift;
 542   return "_export_replace: unknown export type ". $self->exporttype;
 543 }
 544
 545 sub _export_delete {
 546   my $self = shift;
 547   return "_export_delete: unknown export type ". $self->exporttype;
 548 }
 549
 550 #call svcdb-specific fallbacks
 551
 552 sub _export_suspend {
 553   my $self = shift;
 554   #warn "warning: _export_suspened unimplemented for". ref($self);
 555   my $svc_x = shift;
 556   my $new = $svc_x->clone_suspended;
 557   $self->_export_replace( $new, $svc_x );
 558 }
 559
 560 sub _export_unsuspend {
 561   my $self = shift;
 562   #warn "warning: _export_unsuspend unimplemented for ". ref($self);
 563   my $svc_x = shift;
 564   my $old = $svc_x->clone_kludge_unsuspend;
 565   $self->_export_replace( $svc_x, $old );
 566 }
 567
 568 =item export_links SVC_OBJECT ARRAYREF
 569
 570 Adds a list of web elements to ARRAYREF specific to this export and SVC_OBJECT.
 571 The elements are displayed in the UI to lead the the operator to external
 572 configuration, monitoring, and similar tools.
 573
 574 =item export_getsettings SVC_OBJECT SETTINGS_HASHREF DEFAUTS_HASHREF
 575
 576 Adds a hashref of settings to SETTINGSREF specific to this export and
 577 SVC_OBJECT.  The elements can be displayed in the UI on the service view.
 578
 579 DEFAULTSREF is a hashref with the same keys where true values indicate the
 580 setting is a default (and thus can be displayed in the UI with less emphasis,
 581 or hidden by default).
 582
 583 =cut
 584
 585 =item weight
 586
 587 Returns the 'weight' element from the export's %info hash, or 0 if there is
 588 no weight defined.
 589
 590 =cut
 591
 592 sub weight {
 593   my $self = shift;
 594   export_info()->{$self->exporttype}->{'weight'} || 0;
 595 }
 596
 597 =back
 598
 599 =head1 SUBROUTINES
 600
 601 =over 4
 602
 603 =item export_info [ SVCDB ]
 604
 605 Returns a hash reference of the exports for the given I<svcdb>, or if no
 606 I<svcdb> is specified, for all exports.  The keys of the hash are
 607 I<exporttype>s and the values are again hash references containing information
 608 on the export:
 609
 610   'desc'     => 'Description',
 611   'options'  => {
 612                   'option'  => { label=>'Option Label' },
 613                   'option2' => { label=>'Another label' },
 614                 },
 615   'nodomain' => 'Y', #or ''
 616   'notes'    => 'Additional notes',
 617
 618 =cut
 619
 620 sub export_info {
 621   #warn $_[0];
 622   return $exports{$_[0]} || {} if @_;
 623   #{ map { %{$exports{$_}} } keys %exports };
 624   my $r = { map { %{$exports{$_}} } keys %exports };
 625 }
 626
 627
 628 sub _upgrade_data {  #class method
 629   my ($class, %opts) = @_;
 630
 631   my @part_export_option = qsearch('part_export_option', { 'optionname' => 'overlimit_groups' });
 632   foreach my $opt ( @part_export_option ) {
 633     next if $opt->optionvalue =~ /^[\d\s]+$/ || !$opt->optionvalue;
 634     my @groupnames = split(' ',$opt->optionvalue);
 635     my @groupnums;
 636     my $error = '';
 637     foreach my $groupname ( @groupnames ) {
 638         my $g = qsearchs('radius_group', { 'groupname' => $groupname } );
 639         unless ( $g ) {
 640             $g = new FS::radius_group {
 641                             'groupname' => $groupname,
 642                             'description' => $groupname,
 643                             };
 644             $error = $g->insert;
 645             die $error if $error;
 646         }
 647         push @groupnums, $g->groupnum;
 648     }
 649     $opt->optionvalue(join(' ',@groupnums));
 650     $error = $opt->replace;
 651     die $error if $error;
 652   }
 653   # pass downstream
 654   my %exports_in_use;
 655   $exports_in_use{ref $_} = 1 foreach qsearch('part_export', {});
 656   foreach (keys(%exports_in_use)) {
 657     $_->_upgrade_exporttype(%opts) if $_->can('_upgrade_exporttype');
 658   }
 659 }
 660
 661 #=item exporttype2svcdb EXPORTTYPE
 662 #
 663 #Returns the applicable I<svcdb> for an I<exporttype>.
 664 #
 665 #=cut
 666 #
 667 #sub exporttype2svcdb {
 668 #  my $exporttype = $_[0];
 669 #  foreach my $svcdb ( keys %exports ) {
 670 #    return $svcdb if grep { $exporttype eq $_ } keys %{$exports{$svcdb}};
 671 #  }
 672 #  '';
 673 #}
 674
 675 #false laziness w/part_pkg & cdr
 676 foreach my $INC ( @INC ) {
 677   foreach my $file ( glob("$INC/FS/part_export/*.pm") ) {
 678     warn "attempting to load export info from $file\n" if $DEBUG;
 679     $file =~ /\/(\w+)\.pm$/ or do {
 680       warn "unrecognized file in $INC/FS/part_export/: $file\n";
 681       next;
 682     };
 683     my $mod = $1;
 684     my $info = eval "use FS::part_export::$mod; ".
 685                     "\\%FS::part_export::$mod\::info;";
 686     if ( $@ ) {
 687       die "error using FS::part_export::$mod (skipping): $@\n" if $@;
 688       next;
 689     }
 690     unless ( keys %$info ) {
 691       warn "no %info hash found in FS::part_export::$mod, skipping\n"
 692         unless $mod =~ /^(passwdfile|null|.+_Common)$/; #hack but what the heck
 693       next;
 694     }
 695     warn "got export info from FS::part_export::$mod: $info\n" if $DEBUG;
 696     no strict 'refs';
 697     foreach my $svc (
 698       ref($info->{'svc'}) ? @{$info->{'svc'}} : $info->{'svc'}
 699     ) {
 700       unless ( $svc ) {
 701         warn "blank svc for FS::part_export::$mod (skipping)\n";
 702         next;
 703       }
 704       $exports{$svc}->{$mod} = $info;
 705     }
 706   }
 707 }
 708
 709 =back
 710
 711 =head1 NEW EXPORT CLASSES
 712
 713 A module should be added in FS/FS/part_export/ (an example may be found in
 714 eg/export_template.pm)
 715
 716 =head1 BUGS
 717
 718 Hmm... cust_export class (not necessarily a database table...) ... ?
 719
 720 deprecated column...
 721
 722 =head1 SEE ALSO
 723
 724 L<FS::part_export_option>, L<FS::export_svc>, L<FS::svc_acct>,
 725 L<FS::svc_domain>,
 726 L<FS::svc_forward>, L<FS::Record>, schema.html from the base documentation.
 727
 728 =cut
 729
 730 1;
 731