+=item radius_check
+
+Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
+check attributes of this record.
+
+Note that this is now the preferred method for reading RADIUS attributes -
+accessing the columns directly is discouraged, as the column names are
+expected to change in the future.
+
+=cut
+
+sub radius_check {
+ my $self = shift;
+
+ return %{ $self->{'radius_check'} }
+ if exists $self->{'radius_check'};
+
+ my %check =
+ map {
+ /^(rc_(.*))$/;
+ my($column, $attrib) = ($1, $2);
+ #$attrib =~ s/_/\-/g;
+ ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
+ } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
+
+
+ my($pw_attrib, $password) = $self->radius_password;
+ $check{$pw_attrib} = $password;
+
+ my $cust_svc = $self->cust_svc;
+ if ( $cust_svc ) {
+ my $cust_pkg = $cust_svc->cust_pkg;
+ if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
+ $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
+ }
+ } else {
+ warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
+ "; can't set Expiration\n"
+ unless $cust_svc;
+ }
+
+ %check;
+
+}
+
+=item radius_password
+
+Returns a key/value pair containing the RADIUS attribute name and value
+for the password.
+
+=cut
+
+sub radius_password {
+ my $self = shift;
+
+ my $pw_attrib;
+ if ( $self->_password_encoding eq 'ldap' ) {
+ $pw_attrib = 'Password-With-Header';
+ } elsif ( $self->_password_encoding eq 'crypt' ) {
+ $pw_attrib = 'Crypt-Password';
+ } elsif ( $self->_password_encoding eq 'plain' ) {
+ $pw_attrib = $radius_password;
+ } else {
+ $pw_attrib = length($self->_password) <= 12
+ ? $radius_password
+ : 'Crypt-Password';
+ }
+
+ ($pw_attrib, $self->_password);
+
+}
+
+=item snapshot
+
+This method instructs the object to "snapshot" or freeze RADIUS check and
+reply attributes to the current values.
+
+=cut
+
+#bah, my english is too broken this morning
+#Of note is the "Expiration" attribute, which, for accounts in prepaid packages, is typically defined on-the-fly as the associated packages cust_pkg.bill. (This is used by
+#the FS::cust_pkg's replace method to trigger the correct export updates when
+#package dates change)
+
+sub snapshot {
+ my $self = shift;
+
+ $self->{$_} = { $self->$_() }
+ foreach qw( radius_reply radius_check );
+
+}
+
+=item forget_snapshot
+
+This methos instructs the object to forget any previously snapshotted
+RADIUS check and reply attributes.
+
+=cut
+
+sub forget_snapshot {
+ my $self = shift;
+
+ delete $self->{$_}
+ foreach qw( radius_reply radius_check );
+
+}
+
+=item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
+
+Returns the domain associated with this account.
+
+END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
+history records.
+
+=cut
+
+sub domain {
+ my $self = shift;
+ die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
+ my $svc_domain = $self->svc_domain(@_)
+ or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
+ $svc_domain->domain;
+}
+
+=item cust_svc
+
+Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
+
+=cut
+
+#inherited from svc_Common
+
+=item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
+
+Returns an email address associated with the account.
+
+END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
+history records.
+
+=cut
+
+sub email {
+ my $self = shift;
+ $self->username. '@'. $self->domain(@_);
+}
+
+=item acct_snarf
+
+Returns an array of FS::acct_snarf records associated with the account.
+If the acct_snarf table does not exist or there are no associated records,
+an empty list is returned
+
+=cut
+
+sub acct_snarf {
+ my $self = shift;
+ return () unless dbdef->table('acct_snarf');
+ eval "use FS::acct_snarf;";
+ die $@ if $@;
+ qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
+}
+
+=item decrement_upbytes OCTETS
+
+Decrements the I<upbytes> field of this record by the given amount. If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub decrement_upbytes {
+ shift->_op_usage('-', 'upbytes', @_);
+}
+
+=item increment_upbytes OCTETS
+
+Increments the I<upbytes> field of this record by the given amount. If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub increment_upbytes {
+ shift->_op_usage('+', 'upbytes', @_);
+}
+
+=item decrement_downbytes OCTETS
+
+Decrements the I<downbytes> field of this record by the given amount. If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub decrement_downbytes {
+ shift->_op_usage('-', 'downbytes', @_);
+}
+
+=item increment_downbytes OCTETS
+
+Increments the I<downbytes> field of this record by the given amount. If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub increment_downbytes {
+ shift->_op_usage('+', 'downbytes', @_);
+}
+
+=item decrement_totalbytes OCTETS
+
+Decrements the I<totalbytes> field of this record by the given amount. If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub decrement_totalbytes {
+ shift->_op_usage('-', 'totalbytes', @_);
+}
+
+=item increment_totalbytes OCTETS
+
+Increments the I<totalbytes> field of this record by the given amount. If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub increment_totalbytes {
+ shift->_op_usage('+', 'totalbytes', @_);
+}
+
+=item decrement_seconds SECONDS
+
+Decrements the I<seconds> field of this record by the given amount. If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub decrement_seconds {
+ shift->_op_usage('-', 'seconds', @_);
+}
+
+=item increment_seconds SECONDS
+
+Increments the I<seconds> field of this record by the given amount. If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub increment_seconds {
+ shift->_op_usage('+', 'seconds', @_);
+}
+
+
+my %op2action = (
+ '-' => 'suspend',
+ '+' => 'unsuspend',
+);
+my %op2condition = (
+ '-' => sub { my($self, $column, $amount) = @_;
+ $self->$column - $amount <= 0;
+ },
+ '+' => sub { my($self, $column, $amount) = @_;
+ ($self->$column || 0) + $amount > 0;
+ },
+);
+my %op2warncondition = (
+ '-' => sub { my($self, $column, $amount) = @_;
+ my $threshold = $column . '_threshold';
+ $self->$column - $amount <= $self->$threshold + 0;
+ },
+ '+' => sub { my($self, $column, $amount) = @_;
+ ($self->$column || 0) + $amount > 0;
+ },
+);
+
+sub _op_usage {
+ my( $self, $op, $column, $amount ) = @_;
+
+ warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
+ ' ('. $self->email. "): $op $amount\n"
+ if $DEBUG;
+
+ return '' unless $amount;
+
+ local $SIG{HUP} = 'IGNORE';
+ local $SIG{INT} = 'IGNORE';
+ local $SIG{QUIT} = 'IGNORE';
+ local $SIG{TERM} = 'IGNORE';
+ local $SIG{TSTP} = 'IGNORE';
+ local $SIG{PIPE} = 'IGNORE';
+
+ my $oldAutoCommit = $FS::UID::AutoCommit;
+ local $FS::UID::AutoCommit = 0;
+ my $dbh = dbh;
+
+ my $sql = "UPDATE svc_acct SET $column = ".
+ " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
+ " $op ? WHERE svcnum = ?";
+ warn "$me $sql\n"
+ if $DEBUG;
+
+ my $sth = $dbh->prepare( $sql )
+ or die "Error preparing $sql: ". $dbh->errstr;
+ my $rv = $sth->execute($amount, $self->svcnum);
+ die "Error executing $sql: ". $sth->errstr
+ unless defined($rv);
+ die "Can't update $column for svcnum". $self->svcnum
+ if $rv == 0;
+
+ #$self->snapshot; #not necessary, we retain the old values
+ #create an object with the updated usage values
+ my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
+ #call exports
+ my $error = $new->replace($self);
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "Error replacing: $error";
+ }
+
+ #overlimit_action eq 'cancel' handling
+ my $cust_pkg = $self->cust_svc->cust_pkg;
+ if ( $cust_pkg
+ && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
+ && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
+ )
+ {
+
+ my $error = $cust_pkg->cancel; #XXX should have a reason
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "Error cancelling: $error";
+ }
+
+ #nothing else is relevant if we're cancelling, so commit & return success
+ warn "$me update successful; committing\n"
+ if $DEBUG;
+ $dbh->commit or die $dbh->errstr if $oldAutoCommit;
+ return '';
+
+ }
+
+ my $action = $op2action{$op};
+
+ if ( &{$op2condition{$op}}($self, $column, $amount) &&
+ ( $action eq 'suspend' && !$self->overlimit
+ || $action eq 'unsuspend' && $self->overlimit )
+ ) {
+
+ my $error = $self->_op_overlimit($action);
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return $error;
+ }
+
+ }
+
+ if ( $conf->exists("svc_acct-usage_$action")
+ && &{$op2condition{$op}}($self, $column, $amount) ) {
+ #my $error = $self->$action();
+ my $error = $self->cust_svc->cust_pkg->$action();
+ # $error ||= $self->overlimit($action);
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "Error ${action}ing: $error";
+ }
+ }
+
+ if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
+ my $wqueue = new FS::queue {
+ 'svcnum' => $self->svcnum,
+ 'job' => 'FS::svc_acct::reached_threshold',
+ };
+
+ my $to = '';
+ if ($op eq '-'){
+ $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
+ }
+
+ # x_threshold race
+ my $error = $wqueue->insert(
+ 'svcnum' => $self->svcnum,
+ 'op' => $op,
+ 'column' => $column,
+ 'to' => $to,
+ );
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "Error queuing threshold activity: $error";
+ }
+ }
+
+ warn "$me update successful; committing\n"
+ if $DEBUG;
+ $dbh->commit or die $dbh->errstr if $oldAutoCommit;
+ '';
+
+}
+
+sub _op_overlimit {
+ my( $self, $action ) = @_;
+
+ local $SIG{HUP} = 'IGNORE';
+ local $SIG{INT} = 'IGNORE';
+ local $SIG{QUIT} = 'IGNORE';
+ local $SIG{TERM} = 'IGNORE';
+ local $SIG{TSTP} = 'IGNORE';
+ local $SIG{PIPE} = 'IGNORE';
+
+ my $oldAutoCommit = $FS::UID::AutoCommit;
+ local $FS::UID::AutoCommit = 0;
+ my $dbh = dbh;
+
+ my $cust_pkg = $self->cust_svc->cust_pkg;
+
+ my $conf_overlimit =
+ $cust_pkg
+ ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
+ : $conf->config('overlimit_groups');
+
+ foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
+
+ my $groups = $conf_overlimit || $part_export->option('overlimit_groups');
+ next unless $groups;
+
+ my $gref = &{ $self->_fieldhandlers->{'usergroup'} }( $self, $groups );
+
+ my $other = new FS::svc_acct $self->hashref;
+ $other->usergroup( $gref );
+
+ my($new,$old);
+ if ($action eq 'suspend') {
+ $new = $other;
+ $old = $self;
+ } else { # $action eq 'unsuspend'
+ $new = $self;
+ $old = $other;
+ }
+
+ my $error = $part_export->export_replace($new, $old)
+ || $self->overlimit($action);
+
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "Error replacing radius groups: $error";
+ }
+
+ }
+
+ $dbh->commit or die $dbh->errstr if $oldAutoCommit;
+ '';
+
+}
+
+sub set_usage {
+ my( $self, $valueref, %options ) = @_;
projects / freeside.git / blobdiff