[freeside-commits] freeside/FS/FS/part_export nas_wrapper.pm, NONE,
1.1.2.1 snmp.pm, NONE, 1.2.2.1 trango.pm, NONE, 1.1.2.1
Kristian Hoffmann,420,,
khoff at wavetail.420.am
Thu Apr 5 16:59:09 PDT 2007
Update of /home/cvs/cvsroot/freeside/FS/FS/part_export
In directory wavetail:/tmp/cvs-serv23259
Added Files:
Tag: FREESIDE_1_7_BRANCH
nas_wrapper.pm snmp.pm trango.pm
Log Message:
Backporting FS::part_export::(nas_wrapper|snmp|trango) to FREESIDE_1_7_BRANCH
--- NEW FILE: trango.pm ---
package FS::part_export::trango;
=head1 FS::part_export::trango
This export sends SNMP SETs to a router using the Net::SNMP package. It requires the following custom fields to be defined on a router. If any of the required custom fields are not present, then the export will exit quietly.
=head1 Required custom fields
=over 4
=item trango_address - IP address (or hostname) of the Trango AP.
=item trango_comm - R/W SNMP community of the Trango AP.
=item trango_ap_type - Trango AP Model. Currently 'access5830' is the only supported option.
=back
=head1 Optional custom fields
=over 4
=item trango_baseid - Base ID of the Trango AP. See L</"Generating SU IDs">.
=item trango_apid - AP ID of the Trango AP. See L</"Generating SU IDs">.
=back
=head1 Generating SU IDs
This export will/must generate a unique SU ID for each service exported to a Trango AP. It can be done such that SU IDs are globally unique, unique per Base ID, or unique per Base ID/AP ID pair. This is accomplished by setting neither trango_baseid and trango_apid, only trango_baseid, or both trango_baseid and trango_apid, respectively. An SU ID will be generated if the FS::svc_broadband virtual field specified by suid_field export option is unset, otherwise the existing value will be used.
=head1 Device Support
This export has been tested with the Trango Access5830 AP.
=cut
use strict;
use vars qw(@ISA %info $me $DEBUG $trango_mib $counter_dir);
use FS::UID qw(dbh datasrc);
use FS::Record qw(qsearch qsearchs);
use FS::part_export::snmp;
use Tie::IxHash;
use File::CounterFile;
use Data::Dumper qw(Dumper);
@ISA = qw(FS::part_export::snmp);
tie my %options, 'Tie::IxHash', (
'suid_field' => {
'label' => 'Trango SU ID field',
'default' => 'trango_suid',
'notes' => 'Name of the FS::svc_broadband virtual field that will contain the SU ID.',
},
'mac_field' => {
'label' => 'Trango MAC address field',
'default' => '',
'notes' => 'Name of the FS::svc_broadband virtual field that will contain the SU\'s MAC address.',
},
);
%info = (
'svc' => 'svc_broadband',
'desc' => 'Sends SNMP SETs to a Trango AP.',
'options' => \%options,
'notes' => 'Requires Net::SNMP. See the documentation for FS::part_export::trango for required virtual fields and usage information.',
);
$me= '[' . __PACKAGE__ . ']';
$DEBUG = 1;
$trango_mib = {
'access5830' => {
'snmpversion' => 'snmpv1',
'varbinds' => {
'insert' => [
{ # sudbDeleteOrAddID
'oid' => '1.3.6.1.4.1.5454.1.20.3.5.1',
'type' => 'INTEGER',
'value' => \&_trango_access5830_sudbDeleteOrAddId,
},
{ # sudbAddMac
'oid' => '1.3.6.1.4.1.5454.1.20.3.5.2',
'type' => 'HEX_STRING',
'value' => \&_trango_access5830_sudbAddMac,
},
{ # sudbAddSU
'oid' => '1.3.6.1.4.1.5454.1.20.3.5.7',
'type' => 'INTEGER',
'value' => 1,
},
],
'delete' => [
{ # sudbDeleteOrAddID
'oid' => '1.3.6.1.4.1.5454.1.20.3.5.1',
'type' => 'INTEGER',
'value' => \&_trango_access5830_sudbDeleteOrAddId,
},
{ # sudbDeleteSU
'oid' => '1.3.6.1.4.1.5454.1.20.3.5.8',
'type' => 'INTEGER',
'value' => 1,
},
],
'replace' => [
{ # sudbDeleteOrAddID
'oid' => '1.3.6.1.4.1.5454.1.20.3.5.1',
'type' => 'INTEGER',
'value' => \&_trango_access5830_sudbDeleteOrAddId,
},
{ # sudbDeleteSU
'oid' => '1.3.6.1.4.1.5454.1.20.3.5.8',
'type' => 'INTEGER',
'value' => 1,
},
{ # sudbDeleteOrAddID
'oid' => '1.3.6.1.4.1.5454.1.20.3.5.1',
'type' => 'INTEGER',
'value' => \&_trango_access5830_sudbDeleteOrAddId,
},
{ # sudbAddMac
'oid' => '1.3.6.1.4.1.5454.1.20.3.5.2',
'type' => 'HEX_STRING',
'value' => \&_trango_access5830_sudbAddMac,
},
{ # sudbAddSU
'oid' => '1.3.6.1.4.1.5454.1.20.3.5.7',
'type' => 'INTEGER',
'value' => 1,
},
],
'suspend' => [
{ # sudbDeleteOrAddID
'oid' => '1.3.6.1.4.1.5454.1.20.3.5.1',
'type' => 'INTEGER',
'value' => \&_trango_access5830_sudbDeleteOrAddId,
},
{ # sudbDeleteSU
'oid' => '1.3.6.1.4.1.5454.1.20.3.5.8',
'type' => 'INTEGER',
'value' => 1,
},
],
'unsuspend' => [
{ # sudbDeleteOrAddID
'oid' => '1.3.6.1.4.1.5454.1.20.3.5.1',
'type' => 'INTEGER',
'value' => \&_trango_access5830_sudbDeleteOrAddId,
},
{ # sudbAddMac
'oid' => '1.3.6.1.4.1.5454.1.20.3.5.2',
'type' => 'HEX_STRING',
'value' => \&_trango_access5830_sudbAddMac,
},
{ # sudbAddSU
'oid' => '1.3.6.1.4.1.5454.1.20.3.5.7',
'type' => 'INTEGER',
'value' => 1,
},
],
},
},
};
sub _field_prefix { 'trango'; }
sub _req_router_fields {
map {
$_[0]->_field_prefix . '_' . $_
} (qw(address comm ap_type suid_field));
}
sub _get_cmd_sub {
return('FS::part_export::snmp::snmp_cmd');
}
sub _prepare_args {
my ($self, $action, $router) = (shift, shift, shift);
my ($svc_broadband) = shift;
my $old = shift if $action eq 'replace';
my $field_prefix = $self->_field_prefix;
my $error;
my $ap_type = $router->getfield($field_prefix . '_ap_type');
unless (exists $trango_mib->{$ap_type}) {
return "Unsupported Trango AP type '$ap_type'";
}
$error = $self->_check_suid(
$action, $router, $svc_broadband, ($old) ? $old : ()
);
return $error if $error;
$error = $self->_check_mac(
$action, $router, $svc_broadband, ($old) ? $old : ()
);
return $error if $error;
my $ap_mib = $trango_mib->{$ap_type};
my $args = [
'-hostname' => $router->getfield($field_prefix.'_address'),
'-version' => $ap_mib->{'snmpversion'},
'-community' => $router->getfield($field_prefix.'_comm'),
];
my @varbindlist = ();
foreach my $oid (@{$ap_mib->{'varbinds'}->{$action}}) {
warn "[debug]$me Processing OID '" . $oid->{'oid'} . "'" if $DEBUG;
my $value;
if (ref($oid->{'value'}) eq 'CODE') {
eval {
$value = &{$oid->{'value'}}(
$self, $action, $router, $svc_broadband,
(($old) ? $old : ()),
);
};
return "While processing OID '" . $oid->{'oid'} . "':" . $@
if $@;
} else {
$value = $oid->{'value'};
}
warn "[debug]$me Value for OID '" . $oid->{'oid'} . "': " if $DEBUG;
if (defined $value) { # Skip OIDs with undefined values.
push @varbindlist, ($oid->{'oid'}, $oid->{'type'}, $value);
}
}
push @$args, ('-varbindlist', @varbindlist);
return('', $args);
}
sub _check_suid {
my ($self, $action, $router, $svc_broadband) = (shift, shift, shift, shift);
my $old = shift if $action eq 'replace';
my $error;
my $suid_field = $self->option('suid_field');
unless (grep {$_ eq $suid_field} $svc_broadband->fields) {
return "Missing Trango SU ID field. "
. "See the trango export options for more info.";
}
my $suid = $svc_broadband->getfield($suid_field);
if ($action eq 'replace') {
my $old_suid = $old->getfield($suid_field);
if ($old_suid ne '' and $old_suid ne $suid) {
return 'Cannot change Trango SU ID';
}
}
if (not $suid =~ /^\d+$/ and $action ne 'delete') {
my $new_suid = eval { $self->_get_next_suid($router); };
return "Error while getting next Trango SU ID: $@" if ($@);
warn "[debug]$me Got new SU ID: $new_suid" if $DEBUG;
$svc_broadband->set($suid_field, $new_suid);
#FIXME: Probably a bad hack.
# We need to update the SU ID field in the database.
my $oldAutoCommit = $FS::UID::AutoCommit;
local $FS::svc_Common::noexport_hack = 1;
local $FS::UID::AutoCommit = 0;
my $dbh = dbh;
my $svcnum = $svc_broadband->svcnum;
my $old_svc = qsearchs('svc_broadband', { svcnum => $svcnum });
unless ($old_svc) {
return "Unable to retrieve svc_broadband with svcnum '$svcnum";
}
my $svcpart = $svc_broadband->svcpart
? $svc_broadband->svcpart
: $svc_broadband->cust_svc->svcpart;
my $new_svc = new FS::svc_broadband {
$old_svc->hash,
$suid_field => $new_suid,
svcpart => $svcpart,
};
$error = $new_svc->check;
if ($error) {
$dbh->rollback if $oldAutoCommit;
return "Error while updating the Trango SU ID: $error" if $error;
}
warn "[debug]$me Updating svc_broadband with SU ID '$new_suid'...\n" .
&Dumper($new_svc) if $DEBUG;
$error = eval { $new_svc->replace($old_svc); };
if ($@ or $error) {
$error ||= $@;
$dbh->rollback if $oldAutoCommit;
return "Error while updating the Trango SU ID: $error" if $error;
}
$dbh->commit or die $dbh->errstr if $oldAutoCommit;
}
return '';
}
sub _check_mac {
my ($self, $action, $router, $svc_broadband) = (shift, shift, shift, shift);
my $old = shift if $action eq 'replace';
my $mac_field = $self->option('mac_field');
unless (grep {$_ eq $mac_field} $svc_broadband->fields) {
return "Missing Trango MAC address field. "
. "See the trango export options for more info.";
}
my $mac_addr = $svc_broadband->getfield($mac_field);
unless (length(join('', $mac_addr =~ /[0-9a-fA-F]/g)) == 12) {
return "Invalid Trango MAC address: $mac_addr";
}
return('');
}
sub _get_next_suid {
my ($self, $router) = (shift, shift);
my $counter_dir = '/usr/local/etc/freeside/export.'. datasrc . '/trango';
my $baseid = $router->getfield('trango_baseid');
my $apid = $router->getfield('trango_apid');
my $counter_file_suffix = '';
if ($baseid ne '') {
$counter_file_suffix .= "_B$baseid";
if ($apid ne '') {
$counter_file_suffix .= "_A$apid";
}
}
my $counter_file = $counter_dir . '/SUID' . $counter_file_suffix;
warn "[debug]$me Using SUID counter file '$counter_file'";
my $suid = eval {
mkdir $counter_dir, 0700 unless -d $counter_dir;
my $cf = new File::CounterFile($counter_file, 0);
$cf->inc;
};
die "Error generating next Trango SU ID: $@" if (not $suid or $@);
return($suid);
}
# Trango-specific subroutines for generating varbind values.
#
# All subs should die on error, and return undef to decline. OIDs that
# decline will not be added to varbinds.
sub _trango_access5830_sudbDeleteOrAddId {
my ($self, $action, $router) = (shift, shift, shift);
my ($svc_broadband) = shift;
my $old = shift if $action eq 'replace';
my $suid = $svc_broadband->getfield($self->option('suid_field'));
# Sanity check.
unless ($suid =~ /^\d+$/) {
if ($action eq 'delete') {
# Silently ignore. If we don't have a valid SU ID now, we probably
# never did.
return undef;
} else {
die "Invalid Trango SU ID '$suid'";
}
}
return ($suid);
}
sub _trango_access5830_sudbAddMac {
my ($self, $action, $router) = (shift, shift, shift);
my ($svc_broadband) = shift;
my $old = shift if $action eq 'replace';
my $mac_addr = $svc_broadband->getfield($self->option('mac_field'));
$mac_addr = join('', $mac_addr =~ /[0-9a-fA-F]/g);
# Sanity check.
die "Invalid Trango MAC address '$mac_addr'" unless (length($mac_addr)==12);
return($mac_addr);
}
=head1 BUGS
Plenty, I'm sure.
=cut
1;
--- NEW FILE: snmp.pm ---
package FS::part_export::snmp;
=head1 FS::part_export::snmp
This export sends SNMP SETs to a router using the Net::SNMP package. It requires the following custom fields to be defined on a router. If any of the required custom fields are not present, then the export will exit quietly.
=head1 Required custom fields
=over 4
=item snmp_address - IP address (or hostname) of the router/agent
=item snmp_comm - R/W SNMP community of the router/agent
=item snmp_version - SNMP version of the router/agent
=back
=head1 Optional custom fields
=over 4
=item snmp_cmd_insert - SNMP SETs to perform on insert. See L</Formatting>
=item snmp_cmd_replace - SNMP SETs to perform on replace. See L</Formatting>
=item snmp_cmd_delete - SNMP SETs to perform on delete. See L</Formatting>
=item snmp_cmd_suspend - SNMP SETs to perform on suspend. See L</Formatting>
=item snmp_cmd_unsuspend - SNMP SETs to perform on unsuspend. See L</Formatting>
=back
=head1 Formatting
The values for the snmp_cmd_* fields should be formatted as follows:
<OID>|<Data Type>|<expr>[||<OID>|<Data Type>|<expr>[...]]
=over 4
=item OID - SNMP object ID (ex. 1.3.6.1.4.1.1.20). If the OID string starts with a '.', then the Private Enterprise OID (1.3.6.1.4.1) is prepended.
=item Data Type - SNMP data types understood by L<Net::SNMP>, as well as HEX_STRING for convenience. ex. INTEGER, OCTET_STRING, IPADDRESS, ...
=item expr - Expression to be eval'd by freeside. By default, the expression is double quoted and eval'd with all FS::svc_broadband fields available as scalars (ex. $svcnum, $ip_addr, $speed_up). However, if the expression contains a non-escaped double quote, the expression is eval'd without being double quoted. In this case, the expression must be a block of valid perl code that returns the desired value.
You must escape non-delimiter pipes ("|") with a backslash.
=back
=head1 Examples
This is an example for exporting to a Trango Access5830 AP. Newlines inserted for clarity.
=over 4
=item snmp_cmd_delete -
1.3.6.1.4.1.5454.1.20.3.5.1|INTEGER|50||
1.3.6.1.4.1.5454.1.20.3.5.8|INTEGER|1|
=item snmp_cmd_insert -
1.3.6.1.4.1.5454.1.20.3.5.1|INTEGER|50||
1.3.6.1.4.1.5454.1.20.3.5.2|HEX_STRING|join("",$radio_addr =~ /[0-9a-fA-F]{2}/g)||
1.3.6.1.4.1.5454.1.20.3.5.7|INTEGER|1|
=item snmp_cmd_replace -
1.3.6.1.4.1.5454.1.20.3.5.1|INTEGER|50||
1.3.6.1.4.1.5454.1.20.3.5.8|INTEGER|1||1.3.6.1.4.1.5454.1.20.3.5.1|INTEGER|50||
1.3.6.1.4.1.5454.1.20.3.5.2|HEX_STRING|join("",$new_radio_addr =~ /[0-9a-fA-F]{2}/g)||
1.3.6.1.4.1.5454.1.20.3.5.7|INTEGER|1|
=back
=cut
use strict;
use vars qw(@ISA %info $me $DEBUG);
use Tie::IxHash;
use FS::Record qw(qsearch qsearchs);
use FS::part_export;
use FS::part_export::router;
@ISA = qw(FS::part_export::router);
tie my %options, 'Tie::IxHash', ();
%info = (
'svc' => 'svc_broadband',
'desc' => 'Sends SNMP SETs to an SNMP agent.',
'options' => \%options,
'notes' => 'Requires Net::SNMP. See the documentation for FS::part_export::snmp for required virtual fields and usage information.',
);
$me= '[' . __PACKAGE__ . ']';
$DEBUG = 1;
sub _field_prefix { 'snmp'; }
sub _req_router_fields {
map {
$_[0]->_field_prefix . '_' . $_
} (qw(address comm version));
}
sub _get_cmd_sub {
my ($self, $svc_broadband, $router) = (shift, shift, shift);
return(ref($self) . '::snmp_cmd');
}
sub _prepare_args {
my ($self, $action, $router) = (shift, shift, shift);
my ($svc_broadband) = shift;
my $old;
my $field_prefix = $self->_field_prefix;
if ($action eq 'replace') { $old = shift; }
my $raw_cmd = $router->getfield("${field_prefix}_cmd_${action}");
unless ($raw_cmd) {
warn "[debug]$me router custom field '${field_prefix}_cmd_$action' "
. "is not defined." if $DEBUG;
return '';
}
my $args = [
'-hostname' => $router->getfield($field_prefix.'_address'),
'-version' => $router->getfield($field_prefix.'_version'),
'-community' => $router->getfield($field_prefix.'_comm'),
];
my @varbindlist = ();
foreach my $snmp_cmd ($raw_cmd =~ m/(.*?[^\\])(?:\|\||$)/g) {
warn "[debug]$me snmp_cmd is '$snmp_cmd'" if $DEBUG;
my ($oid, $type, $expr) = $snmp_cmd =~ m/(.*?[^\\])(?:\||$)/g;
if ($oid =~ /^([\d\.]+)$/) {
$oid = $1;
$oid = ($oid =~ /^\./) ? '1.3.6.1.4.1' . $oid : $oid;
} else {
return "Invalid SNMP OID '$oid'";
}
if ($type =~ /^([A-Z_\d]+)$/) {
$type = $1;
} else {
return "Invalid SNMP ASN.1 type '$type'";
}
if ($expr =~ /^(.*)$/) {
$expr = $1;
} else {
return "Invalid expression '$expr'";
}
{
no strict 'vars';
no strict 'refs';
if ($action eq 'replace') {
${"old_$_"} = $old->getfield($_) foreach $old->fields;
${"new_$_"} = $svc_broadband->getfield($_) foreach $svc_broadband->fields;
$expr = ($expr =~/[^\\]"/) ? eval($expr) : eval(qq("$expr"));
} else {
${$_} = $svc_broadband->getfield($_) foreach $svc_broadband->fields;
$expr = ($expr =~/[^\\]"/) ? eval($expr) : eval(qq("$expr"));
}
return $@ if $@;
}
push @varbindlist, ($oid, $type, $expr);
}
push @$args, ('-varbindlist', @varbindlist);
return('', $args);
}
sub snmp_cmd {
eval "use Net::SNMP;";
die $@ if $@;
my %args = ();
my @varbindlist = ();
while (scalar(@_)) {
my $key = shift;
if ($key eq '-varbindlist') {
push @varbindlist, @_;
last;
} else {
$args{$key} = shift;
}
}
my $i = 0;
while ($i*3 < scalar(@varbindlist)) {
my $type_index = ($i*3)+1;
my $type_name = $varbindlist[$type_index];
# Implementing HEX_STRING outselves since Net::SNMP doesn't. Ewwww!
if ($type_name eq 'HEX_STRING') {
my $value_index = $type_index + 1;
$type_name = 'OCTET_STRING';
$varbindlist[$value_index] = pack('H*', $varbindlist[$value_index]);
}
my $type = eval "Net::SNMP::$type_name";
if ($@ or not defined $type) {
warn $@ if $DEBUG;
die "snmp_cmd error: Unable to lookup type '$type_name'";
}
$varbindlist[$type_index] = $type;
} continue {
$i++;
}
my ($snmp, $error) = Net::SNMP->session(%args);
die "snmp_cmd error: $error" unless($snmp);
my $res = $snmp->set_request('-varbindlist' => \@varbindlist);
unless($res) {
$error = $snmp->error;
$snmp->close;
die "snmp_cmd error: " . $error;
}
$snmp->close;
return '';
}
=head1 BUGS
Plenty, I'm sure.
=cut
1;
--- NEW FILE: nas_wrapper.pm ---
package FS::part_export::nas_wrapper;
=head1 FS::part_export::nas_wrapper
This is a meta-export that triggers other exports for FS::svc_broadband objects
based on a set of configurable conditions. These conditions are defined by the
following FS::router virtual fields:
=over 4
=item nas_conf - Per-router meta-export configuration. See L</"nas_conf Syntax">.
=back
=head2 nas_conf Syntax
export_name|routernum[,routernum]|[field,condition[,field,condition]][||...]
=over 4
=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).
=item routernum - FS::router routernum corresponding to the desired FS::router for which this export will be run.
=item field - FS::svc_broadband field (real or virtual). The following condition (regex) will be matched against the value of this field.
=item condition - A regular expression to be match against the value of the previously listed FS::svc_broadband field.
=back
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.
You can specify multiple export/router/condition sets by concatenating them with '||'.
=cut
use strict;
use vars qw(@ISA %info $me $DEBUG);
use FS::Record qw(qsearchs);
use FS::part_export;
use Tie::IxHash;
use Data::Dumper qw(Dumper);
@ISA = qw(FS::part_export);
$me = '[' . __PACKAGE__ . ']';
$DEBUG = 0;
%info = (
'svc' => 'svc_broadband',
'desc' => 'A meta-export that triggers other svc_broadband exports.',
'options' => {},
'notes' => '',
);
sub rebless { shift; }
sub _export_insert {
my($self) = shift;
$self->_export_command('insert', @_);
}
sub _export_delete {
my($self) = shift;
$self->_export_command('delete', @_);
}
sub _export_suspend {
my($self) = shift;
$self->_export_command('suspend', @_);
}
sub _export_unsuspend {
my($self) = shift;
$self->_export_command('unsuspend', @_);
}
sub _export_replace {
my($self) = shift;
$self->_export_command('replace', @_);
}
sub _export_command {
my ( $self, $action, $svc_broadband) = (shift, shift, shift);
my ($new, $old);
if ($action eq 'replace') {
$new = $svc_broadband;
$old = shift;
}
my $router = $svc_broadband->addr_block->router;
return '' unless grep(/^nas_conf$/, $router->fields);
my $nas_conf = $router->nas_conf;
my $child_exports = &_parse_nas_conf($nas_conf);
my $error = '';
my $queue_child_exports = {};
# Similar to FS::svc_Common::replace, calling insert, delete, and replace
# exports where necessary depending on which conditions match.
if ($action eq 'replace') {
my @new_child_exports = ();
my @old_child_exports = ();
# Find all the matching "new" child exports.
foreach my $child_export (@$child_exports) {
my $match = &_test_child_export_conditions(
$child_export->{'conditions'},
$new,
);
if ($match) {
push @new_child_exports, $child_export;
}
}
# Find all the matching "old" child exports.
foreach my $child_export (@$child_exports) {
my $match = &_test_child_export_conditions(
$child_export->{'conditions'},
$old,
);
if ($match) {
push @old_child_exports, $child_export;
}
}
# Insert exports for new.
push @{$queue_child_exports->{'insert'}}, (
map {
my $new_child_export = $_;
if (! grep { $new_child_export eq $_ } @old_child_exports) {
$new_child_export->{'args'} = [ $new ];
$new_child_export;
} else {
();
}
} @new_child_exports
);
# Replace exports for new and old.
push @{$queue_child_exports->{'replace'}}, (
map {
my $new_child_export = $_;
if (grep { $new_child_export eq $_ } @old_child_exports) {
$new_child_export->{'args'} = [ $new, $old ];
$new_child_export;
} else {
();
}
} @new_child_exports
);
# Delete exports for old.
push @{$queue_child_exports->{'delete'}}, (
grep {
my $old_child_export = $_;
if (! grep { $old_child_export eq $_ } @new_child_exports) {
$old_child_export->{'args'} = [ $old ];
$old_child_export;
} else {
();
}
} @old_child_exports
);
} else {
foreach my $child_export (@$child_exports) {
my $match = &_test_child_export_conditions(
$child_export->{'conditions'},
$svc_broadband,
);
if ($match) {
$child_export->{'args'} = [ $svc_broadband ];
push @{$queue_child_exports->{$action}}, $child_export;
}
}
}
warn "[debug]$me Dispatching child exports... "
. &Dumper($queue_child_exports) if $DEBUG;
# Actually call the child exports now, with their preset action and arguments.
foreach my $_action (keys(%$queue_child_exports)) {
foreach my $_child_export (@{$queue_child_exports->{$_action}}) {
$error = &_dispatch_child_export(
$_child_export,
$_action,
@{$_child_export->{'args'}},
@_,
);
# Bail if there's an error queueing one of the exports.
# This will all get rolled-back.
return $error if $error;
}
}
return '';
}
sub _parse_nas_conf {
my $nas_conf = shift;
my @child_exports = ();
foreach my $cond_set ($nas_conf =~ m/(.*?[^\\])(?:\|\||$)/g) {
warn "[debug]$me cond_set is '$cond_set'" if $DEBUG;
my @args = $cond_set =~ m/(.*?[^\\])(?:\||$)/g;
my %child_export = (
'export' => $args[0],
'routernum' => [ split(/,\s*/, $args[1]) ],
'conditions' => { @args[2..$#args] },
);
warn "[debug]$me " . Dumper(\%child_export) if $DEBUG;
push @child_exports, { %child_export };
}
return \@child_exports;
}
sub _dispatch_child_export {
my ($child_export, $action, @args) = (shift, shift, @_);
my $child_export_name = $child_export->{'export'};
my @routernums = @{$child_export->{'routernum'}};
my $error = '';
# And the real hack begins...
my $child_part_export;
if ($child_export_name =~ /^(\d+)$/) {
my $exportnum = $1;
$child_part_export = qsearchs('part_export', { exportnum => $exportnum });
unless ($child_part_export) {
return "No such FS::part_export with exportnum '$exportnum'";
}
$child_export_name = $child_part_export->exporttype;
} else {
$child_part_export = new FS::part_export {
'exporttype' => $child_export_name,
'machine' => 'bogus',
};
}
warn "[debug]$me running export '$child_export_name' for routernum(s) '"
. join(',', @routernums) . "'" if $DEBUG;
my $cmd_method = "_export_$action";
foreach my $routernum (@routernums) {
$error ||= $child_part_export->$cmd_method(
@args,
'routernum' => $routernum,
);
last if $error;
}
warn "[debug]$me export '$child_export_name' returned '$error'"
if $DEBUG;
return $error;
}
sub _test_child_export_conditions {
my ($conditions, $svc_broadband) = (shift, shift);
my $match = 1;
foreach my $cond_field (keys %$conditions) {
my $cond_regex = $conditions->{$cond_field};
warn "[debug]$me Condition: $cond_field =~ /$cond_regex/" if $DEBUG;
unless ($svc_broadband->get($cond_field) =~ /$cond_regex/) {
$match = 0;
last;
}
}
return $match;
}
1;
More information about the freeside-commits
mailing list