+ $recref->{_password} =
+ join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
+ $recref->{_password_encoding} = 'plain';
+
+ } else {
+
+ #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
+ if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
+ $recref->{_password} = $1.$3;
+ $recref->{_password_encoding} = 'plain';
+ } elsif ( $recref->{_password} =~
+ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
+ ) {
+ $recref->{_password} = $1.$3;
+ $recref->{_password_encoding} = 'crypt';
+ } elsif ( $recref->{_password} eq '*' ) {
+ $recref->{_password} = '*';
+ $recref->{_password_encoding} = 'crypt';
+ } elsif ( $recref->{_password} eq '!' ) {
+ $recref->{_password_encoding} = 'crypt';
+ $recref->{_password} = '!';
+ } elsif ( $recref->{_password} eq '!!' ) {
+ $recref->{_password} = '!!';
+ $recref->{_password_encoding} = 'crypt';
+ } else {
+ #return "Illegal password";
+ return gettext('illegal_password'). " $passwordmin-$passwordmax ".
+ FS::Msgcat::_gettext('illegal_password_characters').
+ ": ". $recref->{_password};
+ }
+
+ }
+
+ }
+
+ $self->SUPER::check;
+
+}
+
+=item _check_system
+
+Internal function to check the username against the list of system usernames
+from the I<system_usernames> configuration value. Returns true if the username
+is listed on the system username list.
+
+=cut
+
+sub _check_system {
+ my $self = shift;
+ scalar( grep { $self->username eq $_ || $self->email eq $_ }
+ $conf->config('system_usernames')
+ );
+}
+
+=item _check_duplicate
+
+Internal function to check for duplicates usernames, username@domain pairs and
+uids.
+
+If the I<global_unique-username> configuration value is set to B<username> or
+B<username@domain>, enforces global username or username@domain uniqueness.
+
+In all cases, check for duplicate uids and usernames or username@domain pairs
+per export and with identical I<svcpart> values.
+
+=cut
+
+sub _check_duplicate {
+ my $self = shift;
+
+ my $global_unique = $conf->config('global_unique-username') || 'none';
+ return '' if $global_unique eq 'disabled';
+
+ #this is Pg-specific. what to do for mysql etc?
+ # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
+ warn "$me locking svc_acct table for duplicate search" if $DEBUG;
+ dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
+ or die dbh->errstr;
+ warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
+
+ my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
+ unless ( $part_svc ) {
+ return 'unknown svcpart '. $self->svcpart;
+ }
+
+ my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
+ qsearch( 'svc_acct', { 'username' => $self->username } );
+ return gettext('username_in_use')
+ if $global_unique eq 'username' && @dup_user;
+
+ my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
+ qsearch( 'svc_acct', { 'username' => $self->username,
+ 'domsvc' => $self->domsvc } );
+ return gettext('username_in_use')
+ if $global_unique eq 'username@domain' && @dup_userdomain;
+
+ my @dup_uid;
+ if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
+ && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
+ @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
+ qsearch( 'svc_acct', { 'uid' => $self->uid } );
+ } else {
+ @dup_uid = ();
+ }
+
+ if ( @dup_user || @dup_userdomain || @dup_uid ) {
+ my $exports = FS::part_export::export_info('svc_acct');
+ my %conflict_user_svcpart;
+ my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
+
+ foreach my $part_export ( $part_svc->part_export ) {
+
+ #this will catch to the same exact export
+ my @svcparts = map { $_->svcpart } $part_export->export_svc;
+
+ #this will catch to exports w/same exporthost+type ???
+ #my @other_part_export = qsearch('part_export', {
+ # 'machine' => $part_export->machine,
+ # 'exporttype' => $part_export->exporttype,
+ #} );
+ #foreach my $other_part_export ( @other_part_export ) {
+ # push @svcparts, map { $_->svcpart }
+ # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
+ #}
+
+ #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
+ #silly kludge to avoid uninitialized value errors
+ my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
+ ? $exports->{$part_export->exporttype}{'nodomain'}
+ : '';
+ if ( $nodomain =~ /^Y/i ) {
+ $conflict_user_svcpart{$_} = $part_export->exportnum
+ foreach @svcparts;
+ } else {
+ $conflict_userdomain_svcpart{$_} = $part_export->exportnum
+ foreach @svcparts;
+ }
+ }
+
+ foreach my $dup_user ( @dup_user ) {
+ my $dup_svcpart = $dup_user->cust_svc->svcpart;
+ if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
+ return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
+ " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
+ }
+ }
+
+ foreach my $dup_userdomain ( @dup_userdomain ) {
+ my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
+ if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
+ return "duplicate username\@domain: conflicts with svcnum ".
+ $dup_userdomain->svcnum. " via exportnum ".
+ $conflict_userdomain_svcpart{$dup_svcpart};
+ }
+ }
+
+ foreach my $dup_uid ( @dup_uid ) {
+ my $dup_svcpart = $dup_uid->cust_svc->svcpart;
+ if ( exists($conflict_user_svcpart{$dup_svcpart})
+ || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
+ return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
+ " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
+ || $conflict_userdomain_svcpart{$dup_svcpart};
+ }
+ }
+
+ }
+
+ return '';
+
+}
+
+=item radius
+
+Depriciated, use radius_reply instead.
+
+=cut
+
+sub radius {
+ carp "FS::svc_acct::radius depriciated, use radius_reply";
+ $_[0]->radius_reply;
+}
+
+=item radius_reply
+
+Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
+reply 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_reply {
+ my $self = shift;
+
+ return %{ $self->{'radius_reply'} }
+ if exists $self->{'radius_reply'};
+
+ my %reply =
+ map {
+ /^(radius_(.*))$/;
+ my($column, $attrib) = ($1, $2);
+ #$attrib =~ s/_/\-/g;
+ ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
+ } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
+
+ if ( $self->slipip && $self->slipip ne '0e0' ) {
+ $reply{$radius_ip} = $self->slipip;
+ }
+
+ if ( $self->seconds !~ /^$/ ) {
+ $reply{'Session-Timeout'} = $self->seconds;
+ }
+
+ %reply;
+}
+
+=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 $password = $self->_password;
+ my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; $check{$pw_attrib} = $password;
+
+ my $cust_svc = $self->cust_svc;
+ die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
+ unless $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
+ }
+
+ %check;
+
+}
+
+=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 svc_domain
+
+Returns the FS::svc_domain record for this account's domain (see
+L<FS::svc_domain>).
+
+=cut
+
+# FS::h_svc_acct has a history-aware svc_domain override
+
+sub svc_domain {
+ my $self = shift;
+ $self->{'_domsvc'}
+ ? $self->{'_domsvc'}
+ : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
+}
+
+=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 + $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 + $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;
+
+ my $action = $op2action{$op};
+
+ if ( &{$op2condition{$op}}($self, $column, $amount) ) {
+ foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
+ if ($part_export->option('overlimit_groups')) {
+ my ($new,$old);
+ my $other = new FS::svc_acct $self->hashref;
+ my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
+ ($self, $part_export->option('overlimit_groups'));
+ $other->usergroup( $groups );
+ if ($action eq 'suspend'){
+ $new = $other; $old = $self;
+ }else{
+ $new = $self; $old = $other;
+ }
+ my $error = $part_export->export_replace($new, $old);
+ $error ||= $self->overlimit($action);
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "Error replacing radius groups in export, ${op}: $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 set_usage {
+ my( $self, $valueref ) = @_;
+
+ warn "$me set_usage called for svcnum ". $self->svcnum.
+ ' ('. $self->email. "): ".
+ join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
+ if $DEBUG;
+
+ local $SIG{HUP} = 'IGNORE';
+ local $SIG{INT} = 'IGNORE';
+ local $SIG{QUIT} = 'IGNORE';
+ local $SIG{TERM} = 'IGNORE';
+ local $SIG{TSTP} = 'IGNORE';
+ local $SIG{PIPE} = 'IGNORE';
+
+ local $FS::svc_Common::noexport_hack = 1;
+ my $oldAutoCommit = $FS::UID::AutoCommit;
+ local $FS::UID::AutoCommit = 0;
+ my $dbh = dbh;
+
+ my $reset = 0;
+ my %handyhash = ();
+ foreach my $field (keys %$valueref){
+ $reset = 1 if $valueref->{$field};
+ $self->setfield($field, $valueref->{$field});
+ $self->setfield( $field.'_threshold',
+ int($self->getfield($field)
+ * ( $conf->exists('svc_acct-usage_threshold')
+ ? 1 - $conf->config('svc_acct-usage_threshold')/100
+ : 0.20
+ )
+ )
+ );
+ $handyhash{$field} = $self->getfield($field);
+ $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
+ }
+ #my $error = $self->replace; #NO! we avoid the call to ->check for
+ #die $error if $error; #services not explicity changed via the UI
+
+ my $sql = "UPDATE svc_acct SET " .
+ join (',', map { "$_ = ?" } (keys %handyhash) ).
+ " WHERE svcnum = ?";
+
+ warn "$me $sql\n"
+ if $DEBUG;
+
+ if (scalar(keys %handyhash)) {
+ my $sth = $dbh->prepare( $sql )
+ or die "Error preparing $sql: ". $dbh->errstr;
+ my $rv = $sth->execute((grep{$_} values %handyhash), $self->svcnum);
+ die "Error executing $sql: ". $sth->errstr
+ unless defined($rv);
+ die "Can't update usage for svcnum ". $self->svcnum
+ if $rv == 0;
+ }
+
+ if ( $reset ) {
+ my $error = $self->overlimit('unsuspend');
+
+ foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
+ if ($part_export->option('overlimit_groups')) {
+ my $old = new FS::svc_acct $self->hashref;
+ my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
+ ($self, $part_export->option('overlimit_groups'));
+ $old->usergroup( $groups );
+ $error ||= $part_export->export_replace($self, $old);
+ }
+ }
+
+ if ( $conf->exists("svc_acct-usage_unsuspend")) {
+ $error ||= $self->cust_svc->cust_pkg->unsuspend;
+ }
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "Error unsuspending: $error";
+ }
+ }
+
+ warn "$me update successful; committing\n"
+ if $DEBUG;
+ $dbh->commit or die $dbh->errstr if $oldAutoCommit;
+ '';
+
+}
+
+
+=item recharge HASHREF
+
+ Increments usage columns by the amount specified in HASHREF as
+ column=>amount pairs.