FS/FS/part_export/nas_wrapper.pm

   1 package FS::part_export::nas_wrapper;
   2
   3 =head1 FS::part_export::nas_wrapper
   4
   5 This is a meta-export that triggers other exports for FS::svc_broadband objects
   6 based on a set of configurable conditions.  These conditions are defined by the
   7 following FS::router virtual fields:
   8
   9 =over 4
  10
  11 =item nas_conf - Per-router meta-export configuration.  See L</"nas_conf Syntax">.
  12
  13 =back
  14
  15 =head2 nas_conf Syntax
  16
  17 export_name|routernum[,routernum]|[field,condition[,field,condition]][||...]
  18
  19 =over 4
  20
  21 =item export_name - Name or exportnum of the export to be executed.  In order to specify export options you must use the exportnum form.  (ex. 'router' for FS::part_export::router).
  22
  23 =item routernum - FS::router routernum corresponding to the desired FS::router for which this export will be run.
  24
  25 =item field - FS::svc_broadband field (real or virtual).  The following condition (regex) will be matched against the value of this field.
  26
  27 =item condition - A regular expression to be match against the value of the previously listed FS::svc_broadband field.
  28
  29 =back
  30
  31 If multiple routernum's are specified, then the export will be triggered for each router listed.  If multiple field/condition pairs are present, then the results of the matches will be and'd.  Note that if a false match is found, the rest of the matches may not be checked.
  32
  33 You can specify multiple export/router/condition sets by concatenating them with '||'.
  34
  35 =cut
  36
  37 use strict;
  38 use vars qw(@ISA %info $me $DEBUG);
  39
  40 use FS::Record qw(qsearchs);
  41 use FS::part_export;
  42
  43 use Tie::IxHash;
  44 use Data::Dumper qw(Dumper);
  45
  46 @ISA = qw(FS::part_export);
  47 $me = '[' . __PACKAGE__ . ']';
  48 $DEBUG = 1;
  49
  50 %info = (
  51   'svc'     => 'svc_broadband',
  52   'desc'    => 'A meta-export that triggers other svc_broadband exports.',
  53   'options' => {},
  54   'notes'   => '',
  55 );
  56
  57
  58 sub rebless { shift; }
  59
  60 sub _export_insert {
  61   my($self) = shift;
  62   $self->_export_command('insert', @_);
  63 }
  64
  65 sub _export_delete {
  66   my($self) = shift;
  67   $self->_export_command('delete', @_);
  68 }
  69
  70 sub _export_suspend {
  71   my($self) = shift;
  72   $self->_export_command('suspend', @_);
  73 }
  74
  75 sub _export_unsuspend {
  76   my($self) = shift;
  77   $self->_export_command('unsuspend', @_);
  78 }
  79
  80 sub _export_replace {
  81   my($self) = shift;
  82   $self->_export_command('replace', @_);
  83 }
  84
  85 sub _export_command {
  86   my ( $self, $action, $svc_broadband) = (shift, shift, shift);
  87
  88   my ($new, $old);
  89   if ($action eq 'replace') {
  90     $new = $svc_broadband;
  91     $old = shift;
  92   }
  93
  94   my $router = $svc_broadband->addr_block->router;
  95
  96   return '' unless grep(/^nas_conf$/, $router->fields);
  97   my $nas_conf = $router->nas_conf;
  98
  99   my $child_exports = &_parse_nas_conf($nas_conf);
 100
 101   my $error = '';
 102
 103   my $queue_child_exports = {};
 104
 105   # Similar to FS::svc_Common::replace, calling insert, delete, and replace
 106   # exports where necessary depending on which conditions match.
 107   if ($action eq 'replace') {
 108
 109     my @new_child_exports = ();
 110     my @old_child_exports = ();
 111
 112     # Find all the matching "new" child exports.
 113     foreach my $child_export (@$child_exports) {
 114       my $match = &_test_child_export_conditions(
 115         $child_export->{'conditions'},
 116         $new,
 117       );
 118
 119       if ($match) {
 120         push @new_child_exports, $child_export;
 121       }
 122     }
 123
 124     # Find all the matching "old" child exports.
 125     foreach my $child_export (@$child_exports) {
 126       my $match = &_test_child_export_conditions(
 127         $child_export->{'conditions'},
 128         $old,
 129       );
 130
 131       if ($match) {
 132         push @old_child_exports, $child_export;
 133       }
 134     }
 135
 136     # Insert exports for new.
 137     push @{$queue_child_exports->{'insert'}}, (
 138       map {
 139         my $new_child_export = $_;
 140         if (! grep { $new_child_export eq $_ } @old_child_exports) {
 141           $new_child_export->{'args'} = [ $new ];
 142           $new_child_export;
 143         } else {
 144           ();
 145         }
 146       } @new_child_exports
 147     );
 148
 149     # Replace exports for new and old.
 150     push @{$queue_child_exports->{'replace'}}, (
 151       map {
 152         my $new_child_export = $_;
 153         if (grep { $new_child_export eq $_ } @old_child_exports) {
 154           $new_child_export->{'args'} = [ $new, $old ];
 155           $new_child_export;
 156         } else {
 157           ();
 158         }
 159       } @new_child_exports
 160     );
 161
 162     # Delete exports for old.
 163     push @{$queue_child_exports->{'delete'}}, (
 164       grep {
 165         my $old_child_export = $_;
 166         if (! grep { $old_child_export eq $_ } @new_child_exports) {
 167           $old_child_export->{'args'} = [ $old ];
 168           $old_child_export;
 169         } else {
 170           ();
 171         }
 172       } @old_child_exports
 173     );
 174
 175   } else {
 176
 177     foreach my $child_export (@$child_exports) {
 178       my $match = &_test_child_export_conditions(
 179         $child_export->{'conditions'},
 180         $svc_broadband,
 181       );
 182
 183       if ($match) {
 184         $child_export->{'args'} = [ $svc_broadband ];
 185         push @{$queue_child_exports->{$action}}, $child_export;
 186       }
 187     }
 188
 189   }
 190
 191   warn "[debug]$me Dispatching child exports... "
 192     . &Dumper($queue_child_exports);
 193
 194   # Actually call the child exports now, with their preset action and arguments.
 195   foreach my $_action (keys(%$queue_child_exports)) {
 196
 197     foreach my $_child_export (@{$queue_child_exports->{$_action}}) {
 198       $error = &_dispatch_child_export(
 199         $_child_export,
 200         $_action,
 201         @{$_child_export->{'args'}},
 202       );
 203
 204       # Bail if there's an error queueing one of the exports.
 205       # This will all get rolled-back.
 206       return $error if $error;
 207     }
 208
 209   }
 210
 211   return '';
 212
 213 }
 214
 215
 216 sub _parse_nas_conf {
 217
 218   my $nas_conf = shift;
 219   my @child_exports = ();
 220
 221   foreach my $cond_set ($nas_conf =~ m/(.*?[^\\])(?:\|\||$)/g) {
 222
 223     warn "[debug]$me cond_set is '$cond_set'" if $DEBUG;
 224
 225     my @args = $cond_set =~ m/(.*?[^\\])(?:\||$)/g;
 226
 227     my %child_export = (
 228       'export' => $args[0],
 229       'routernum' => [ split(/,\s*/, $args[1]) ],
 230       'conditions' => { @args[2..$#args] },
 231     );
 232
 233     warn "[debug]$me " . Dumper(\%child_export) if $DEBUG;
 234
 235     push @child_exports, { %child_export };
 236
 237   }
 238
 239   return \@child_exports;
 240
 241 }
 242
 243 sub _dispatch_child_export {
 244
 245   my ($child_export, $action, @args) = (shift, shift, @_);
 246
 247   my $child_export_name = $child_export->{'export'};
 248   my @routernums = @{$child_export->{'routernum'}};
 249
 250   my $error = '';
 251
 252   # And the real hack begins...
 253
 254   my $child_part_export;
 255   if ($child_export_name =~ /^(\d+)$/) {
 256     my $exportnum = $1;
 257     $child_part_export = qsearchs('part_export', { exportnum => $exportnum });
 258     unless ($child_part_export) {
 259       return "No such FS::part_export with exportnum '$exportnum'";
 260     }
 261
 262     $child_export_name = $child_part_export->exporttype;
 263   } else {
 264     $child_part_export = new FS::part_export {
 265       'exporttype' => $child_export_name,
 266       'machine' => 'bogus',
 267     };
 268   }
 269
 270   warn "[debug]$me running export '$child_export_name' for routernum(s) '"
 271     . join(',', @routernums) . "'" if $DEBUG;
 272
 273   my $cmd_method = "_export_$action";
 274
 275   foreach my $routernum (@routernums) {
 276     $error ||= $child_part_export->$cmd_method(
 277       @args,
 278       'routernum' => $routernum,
 279     );
 280     last if $error;
 281   }
 282
 283   warn "[debug]$me export '$child_export_name' returned '$error'"
 284     if $DEBUG;
 285
 286   return $error;
 287
 288 }
 289
 290 sub _test_child_export_conditions {
 291
 292   my ($conditions, $svc_broadband) = (shift, shift);
 293
 294   my $match = 1;
 295   foreach my $cond_field (keys %$conditions) {
 296     my $cond_regex = $conditions->{$cond_field};
 297     warn "[debug]$me Condition: $cond_field =~ /$cond_regex/" if $DEBUG;
 298     unless ($svc_broadband->get($cond_field) =~ /$cond_regex/) {
 299       $match = 0;
 300       last;
 301     }
 302   }
 303
 304   return $match;
 305
 306 }
 307
 308
 309 1;
 310