path: root/FS/FS/part_export/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;