turn off debug
[freeside.git] / 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 = 0;
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) if $DEBUG;
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
205       # Bail if there's an error queueing one of the exports.
206       # This will all get rolled-back.
207       return $error if $error;
208     }
209
210   }
211
212   return '';
213
214 }
215
216
217 sub _parse_nas_conf {
218
219   my $nas_conf = shift;
220   my @child_exports = ();
221
222   foreach my $cond_set ($nas_conf =~ m/(.*?[^\\])(?:\|\||$)/g) {
223
224     warn "[debug]$me cond_set is '$cond_set'" if $DEBUG;
225
226     my @args = $cond_set =~ m/(.*?[^\\])(?:\||$)/g;
227
228     my %child_export = (
229       'export' => $args[0],
230       'routernum' => [ split(/,\s*/, $args[1]) ],
231       'conditions' => { @args[2..$#args] },
232     );
233
234     warn "[debug]$me " . Dumper(\%child_export) if $DEBUG;
235
236     push @child_exports, { %child_export };
237
238   }
239
240   return \@child_exports;
241
242 }
243
244 sub _dispatch_child_export {
245
246   my ($child_export, $action, @args) = (shift, shift, @_);
247
248   my $child_export_name = $child_export->{'export'};
249   my @routernums = @{$child_export->{'routernum'}};
250
251   my $error = '';
252
253   # And the real hack begins...
254
255   my $child_part_export;
256   if ($child_export_name =~ /^(\d+)$/) {
257     my $exportnum = $1;
258     $child_part_export = qsearchs('part_export', { exportnum => $exportnum });
259     unless ($child_part_export) {
260       return "No such FS::part_export with exportnum '$exportnum'";
261     }
262
263     $child_export_name = $child_part_export->exporttype;
264   } else {
265     $child_part_export = new FS::part_export {
266       'exporttype' => $child_export_name,
267       'machine' => 'bogus',
268     };
269   }
270
271   warn "[debug]$me running export '$child_export_name' for routernum(s) '"
272     . join(',', @routernums) . "'" if $DEBUG;
273
274   my $cmd_method = "_export_$action";
275
276   foreach my $routernum (@routernums) {
277     $error ||= $child_part_export->$cmd_method(
278       @args,
279       'routernum' => $routernum,
280     );
281     last if $error;
282   }
283
284   warn "[debug]$me export '$child_export_name' returned '$error'"
285     if $DEBUG;
286
287   return $error;
288
289 }
290
291 sub _test_child_export_conditions {
292
293   my ($conditions, $svc_broadband) = (shift, shift);
294
295   my $match = 1;
296   foreach my $cond_field (keys %$conditions) {
297     my $cond_regex = $conditions->{$cond_field};
298     warn "[debug]$me Condition: $cond_field =~ /$cond_regex/" if $DEBUG;
299     unless ($svc_broadband->get($cond_field) =~ /$cond_regex/) {
300       $match = 0;
301       last;
302     }
303   }
304
305   return $match;
306
307 }
308
309
310 1;
311