FS/FS/svc_acct.pm

   1 package FS::svc_acct;
   2
   3 use strict;
   4 use base qw( FS::svc_Domain_Mixin FS::svc_CGP_Mixin FS::svc_CGPRule_Mixin
   5              FS::svc_Common );
   6 use vars qw( $DEBUG $me $conf $skip_fuzzyfiles
   7              $dir_prefix @shells $usernamemin
   8              $usernamemax $passwordmin $passwordmax
   9              $username_ampersand $username_letter $username_letterfirst
  10              $username_noperiod $username_nounderscore $username_nodash
  11              $username_uppercase $username_percent $username_colon
  12              $password_noampersand $password_noexclamation
  13              $warning_template $warning_from $warning_subject $warning_mimetype
  14              $warning_cc
  15              $smtpmachine
  16              $radius_password $radius_ip
  17              $dirhash
  18              @saltset @pw_set );
  19 use Scalar::Util qw( blessed );
  20 use Math::BigInt;
  21 use Carp;
  22 use Fcntl qw(:flock);
  23 use Date::Format;
  24 use Crypt::PasswdMD5 1.2;
  25 use Digest::SHA1 'sha1_base64';
  26 use Digest::MD5 'md5_base64';
  27 use Data::Dumper;
  28 use Text::Template;
  29 use Authen::Passphrase;
  30 use FS::UID qw( datasrc driver_name );
  31 use FS::Conf;
  32 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
  33 use FS::Msgcat qw(gettext);
  34 use FS::UI::bytecount;
  35 use FS::UI::Web;
  36 use FS::part_pkg;
  37 use FS::part_svc;
  38 use FS::svc_acct_pop;
  39 use FS::cust_main_invoice;
  40 use FS::svc_domain;
  41 use FS::svc_pbx;
  42 use FS::raddb;
  43 use FS::queue;
  44 use FS::radius_usergroup;
  45 use FS::export_svc;
  46 use FS::part_export;
  47 use FS::svc_forward;
  48 use FS::svc_www;
  49 use FS::cdr;
  50
  51 $DEBUG = 0;
  52 $me = '[FS::svc_acct]';
  53
  54 #ask FS::UID to run this stuff for us later
  55 FS::UID->install_callback( sub {
  56   $conf = new FS::Conf;
  57   $dir_prefix = $conf->config('home');
  58   @shells = $conf->config('shells');
  59   $usernamemin = $conf->config('usernamemin') || 2;
  60   $usernamemax = $conf->config('usernamemax');
  61   $passwordmin = $conf->config('passwordmin'); # || 6;
  62   #blank->6, keep 0
  63   $passwordmin = ( defined($passwordmin) && $passwordmin =~ /\d+/ )
  64                    ? $passwordmin
  65                    : 6;
  66   $passwordmax = $conf->config('passwordmax') || 8;
  67   $username_letter = $conf->exists('username-letter');
  68   $username_letterfirst = $conf->exists('username-letterfirst');
  69   $username_noperiod = $conf->exists('username-noperiod');
  70   $username_nounderscore = $conf->exists('username-nounderscore');
  71   $username_nodash = $conf->exists('username-nodash');
  72   $username_uppercase = $conf->exists('username-uppercase');
  73   $username_ampersand = $conf->exists('username-ampersand');
  74   $username_percent = $conf->exists('username-percent');
  75   $username_colon = $conf->exists('username-colon');
  76   $password_noampersand = $conf->exists('password-noexclamation');
  77   $password_noexclamation = $conf->exists('password-noexclamation');
  78   $dirhash = $conf->config('dirhash') || 0;
  79   if ( $conf->exists('warning_email') ) {
  80     $warning_template = new Text::Template (
  81       TYPE   => 'ARRAY',
  82       SOURCE => [ map "$_\n", $conf->config('warning_email') ]
  83     ) or warn "can't create warning email template: $Text::Template::ERROR";
  84     $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
  85     $warning_subject = $conf->config('warning_email-subject') || 'Warning';
  86     $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
  87     $warning_cc = $conf->config('warning_email-cc');
  88   } else {
  89     $warning_template = '';
  90     $warning_from = '';
  91     $warning_subject = '';
  92     $warning_mimetype = '';
  93     $warning_cc = '';
  94   }
  95   $smtpmachine = $conf->config('smtpmachine');
  96   $radius_password = $conf->config('radius-password') || 'Password';
  97   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
  98   @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
  99 }
 100 );
 101
 102 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
 103 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
 104
 105 sub _cache {
 106   my $self = shift;
 107   my ( $hashref, $cache ) = @_;
 108   if ( $hashref->{'svc_acct_svcnum'} ) {
 109     $self->{'_domsvc'} = FS::svc_domain->new( {
 110       'svcnum'   => $hashref->{'domsvc'},
 111       'domain'   => $hashref->{'svc_acct_domain'},
 112       'catchall' => $hashref->{'svc_acct_catchall'},
 113     } );
 114   }
 115 }
 116
 117 =head1 NAME
 118
 119 FS::svc_acct - Object methods for svc_acct records
 120
 121 =head1 SYNOPSIS
 122
 123   use FS::svc_acct;
 124
 125   $record = new FS::svc_acct \%hash;
 126   $record = new FS::svc_acct { 'column' => 'value' };
 127
 128   $error = $record->insert;
 129
 130   $error = $new_record->replace($old_record);
 131
 132   $error = $record->delete;
 133
 134   $error = $record->check;
 135
 136   $error = $record->suspend;
 137
 138   $error = $record->unsuspend;
 139
 140   $error = $record->cancel;
 141
 142   %hash = $record->radius;
 143
 144   %hash = $record->radius_reply;
 145
 146   %hash = $record->radius_check;
 147
 148   $domain = $record->domain;
 149
 150   $svc_domain = $record->svc_domain;
 151
 152   $email = $record->email;
 153
 154   $seconds_since = $record->seconds_since($timestamp);
 155
 156 =head1 DESCRIPTION
 157
 158 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 159 FS::svc_Common.  The following fields are currently supported:
 160
 161 =over 4
 162
 163 =item svcnum
 164
 165 Primary key (assigned automatcially for new accounts)
 166
 167 =item username
 168
 169 =item _password
 170
 171 generated if blank
 172
 173 =item _password_encoding
 174
 175 plain, crypt, ldap (or empty for autodetection)
 176
 177 =item sec_phrase
 178
 179 security phrase
 180
 181 =item popnum
 182
 183 Point of presence (see L<FS::svc_acct_pop>)
 184
 185 =item uid
 186
 187 =item gid
 188
 189 =item finger
 190
 191 GECOS
 192
 193 =item dir
 194
 195 set automatically if blank (and uid is not)
 196
 197 =item shell
 198
 199 =item quota
 200
 201 =item slipip
 202
 203 IP address
 204
 205 =item seconds
 206
 207 =item upbytes
 208
 209 =item downbyte
 210
 211 =item totalbytes
 212
 213 =item domsvc
 214
 215 svcnum from svc_domain
 216
 217 =item pbxsvc
 218
 219 Optional svcnum from svc_pbx
 220
 221 =item radius_I<Radius_Attribute>
 222
 223 I<Radius-Attribute> (reply)
 224
 225 =item rc_I<Radius_Attribute>
 226
 227 I<Radius-Attribute> (check)
 228
 229 =back
 230
 231 =head1 METHODS
 232
 233 =over 4
 234
 235 =item new HASHREF
 236
 237 Creates a new account.  To add the account to the database, see L<"insert">.
 238
 239 =cut
 240
 241 sub table_info {
 242   {
 243     'name'   => 'Account',
 244     'longname_plural' => 'Access accounts and mailboxes',
 245     'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
 246     'display_weight' => 10,
 247     'cancel_weight'  => 50,
 248     'fields' => {
 249         'dir'       => 'Home directory',
 250         'uid'       => {
 251                          label    => 'UID',
 252                          def_info => 'set to fixed and blank for no UIDs',
 253                          type     => 'text',
 254                        },
 255         'slipip'    => 'IP address',
 256     #    'popnum'    => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
 257         'popnum'    => {
 258                          label => 'Access number',
 259                          type => 'select',
 260                          select_table => 'svc_acct_pop',
 261                          select_key   => 'popnum',
 262                          select_label => 'city',
 263                          disable_select => 1,
 264                        },
 265         'username'  => {
 266                          label => 'Username',
 267                          type => 'text',
 268                          disable_default => 1,
 269                          disable_fixed => 1,
 270                          disable_select => 1,
 271                        },
 272         'password_selfchange' => { label => 'Password modification',
 273                                    type  => 'checkbox',
 274                                  },
 275         'password_recover'    => { label => 'Password recovery',
 276                                    type  => 'checkbox',
 277                                  },
 278         'quota'     => {
 279                          label => 'Quota', #Mail storage limit
 280                          type => 'text',
 281                          disable_inventory => 1,
 282                          disable_select => 1,
 283                        },
 284         'file_quota'=> {
 285                          label => 'File storage limit',
 286                          type => 'text',
 287                          disable_inventory => 1,
 288                          disable_select => 1,
 289                        },
 290         'file_maxnum'=> {
 291                          label => 'Number of files limit',
 292                          type => 'text',
 293                          disable_inventory => 1,
 294                          disable_select => 1,
 295                        },
 296         'file_maxsize'=> {
 297                          label => 'File size limit',
 298                          type => 'text',
 299                          disable_inventory => 1,
 300                          disable_select => 1,
 301                        },
 302         '_password' => 'Password',
 303         'gid'       => {
 304                          label    => 'GID',
 305                          def_info => 'when blank, defaults to UID',
 306                          type     => 'text',
 307                        },
 308         'shell'     => {
 309                          label    => 'Shell',
 310                          def_info => 'set to blank for no shell tracking',
 311                          type     => 'select',
 312                          #select_list => [ $conf->config('shells') ],
 313                          select_list => [ $conf ? $conf->config('shells') : () ],
 314                          disable_inventory => 1,
 315                          disable_select => 1,
 316                        },
 317         'finger'    => 'Real name', # (GECOS)',
 318         'domsvc'    => {
 319                          label     => 'Domain',
 320                          type      => 'select',
 321                          select_table => 'svc_domain',
 322                          select_key   => 'svcnum',
 323                          select_label => 'domain',
 324                          disable_inventory => 1,
 325                        },
 326         'pbxsvc'    => { label => 'PBX',
 327                          type  => 'select-svc_pbx.html',
 328                          disable_inventory => 1,
 329                          disable_select => 1, #UI wonky, pry works otherwise
 330                        },
 331         'usergroup' => {
 332                          label => 'RADIUS groups',
 333                          type  => 'radius_usergroup_selector',
 334                          disable_inventory => 1,
 335                          disable_select => 1,
 336                        },
 337         'seconds'   => { label => 'Seconds',
 338                          label_sort => 'with Time Remaining',
 339                          type  => 'text',
 340                          disable_inventory => 1,
 341                          disable_select => 1,
 342                          disable_part_svc_column => 1,
 343                        },
 344         'upbytes'   => { label => 'Upload',
 345                          type  => 'text',
 346                          disable_inventory => 1,
 347                          disable_select => 1,
 348                          'format' => \&FS::UI::bytecount::display_bytecount,
 349                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 350                          disable_part_svc_column => 1,
 351                        },
 352         'downbytes' => { label => 'Download',
 353                          type  => 'text',
 354                          disable_inventory => 1,
 355                          disable_select => 1,
 356                          'format' => \&FS::UI::bytecount::display_bytecount,
 357                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 358                          disable_part_svc_column => 1,
 359                        },
 360         'totalbytes'=> { label => 'Total up and download',
 361                          type  => 'text',
 362                          disable_inventory => 1,
 363                          disable_select => 1,
 364                          'format' => \&FS::UI::bytecount::display_bytecount,
 365                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 366                          disable_part_svc_column => 1,
 367                        },
 368         'seconds_threshold'   => { label => 'Seconds threshold',
 369                                    type  => 'text',
 370                                    disable_inventory => 1,
 371                                    disable_select => 1,
 372                                    disable_part_svc_column => 1,
 373                                  },
 374         'upbytes_threshold'   => { label => 'Upload threshold',
 375                                    type  => 'text',
 376                                    disable_inventory => 1,
 377                                    disable_select => 1,
 378                                    'format' => \&FS::UI::bytecount::display_bytecount,
 379                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 380                                    disable_part_svc_column => 1,
 381                                  },
 382         'downbytes_threshold' => { label => 'Download threshold',
 383                                    type  => 'text',
 384                                    disable_inventory => 1,
 385                                    disable_select => 1,
 386                                    'format' => \&FS::UI::bytecount::display_bytecount,
 387                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 388                                    disable_part_svc_column => 1,
 389                                  },
 390         'totalbytes_threshold'=> { label => 'Total up and download threshold',
 391                                    type  => 'text',
 392                                    disable_inventory => 1,
 393                                    disable_select => 1,
 394                                    'format' => \&FS::UI::bytecount::display_bytecount,
 395                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 396                                    disable_part_svc_column => 1,
 397                                  },
 398         'last_login'=>           {
 399                                    label     => 'Last login',
 400                                    type      => 'disabled',
 401                                  },
 402         'last_logout'=>          {
 403                                    label     => 'Last logout',
 404                                    type      => 'disabled',
 405                                  },
 406
 407         'cgp_aliases' => {
 408                            label => 'Communigate aliases',
 409                            type  => 'text',
 410                            disable_inventory => 1,
 411                            disable_select    => 1,
 412                          },
 413         #settings
 414         'cgp_type'=> {
 415                        label => 'Communigate account type',
 416                        type => 'select',
 417                        select_list => [qw( MultiMailbox TextMailbox MailDirMailbox AGrade BGrade CGrade )],
 418                        disable_inventory => 1,
 419                        disable_select    => 1,
 420                      },
 421         'cgp_accessmodes' => {
 422                                label => 'Communigate enabled services',
 423                                type  => 'communigate_pro-accessmodes',
 424                                disable_inventory => 1,
 425                                disable_select    => 1,
 426                              },
 427         'cgp_rulesallowed'   => {
 428           label       => 'Allowed mail rules',
 429           type        => 'select',
 430           select_list => [ '', 'No', 'Filter Only', 'All But Exec', 'Any' ],
 431           disable_inventory => 1,
 432           disable_select    => 1,
 433         },
 434         'cgp_rpopallowed'    => { label => 'RPOP modifications',
 435                                   type  => 'checkbox',
 436                                 },
 437         'cgp_mailtoall'      => { label => 'Accepts mail to "all"',
 438                                   type  => 'checkbox',
 439                                 },
 440         'cgp_addmailtrailer' => { label => 'Add trailer to sent mail',
 441                                   type  => 'checkbox',
 442                                 },
 443         #XXX archive messages, mailing lists
 444
 445         #preferences
 446         'cgp_deletemode' => {
 447                               label => 'Communigate message delete method',
 448                               type  => 'select',
 449                               select_list => [ 'Move To Trash', 'Immediately', 'Mark' ],
 450                               disable_inventory => 1,
 451                               disable_select    => 1,
 452                             },
 453         'cgp_emptytrash' => {
 454                               label     => 'Communigate on logout remove trash',
 455                               type        => 'select',
 456                               select_list => __PACKAGE__->cgp_emptytrash_values,
 457                               disable_inventory => 1,
 458                               disable_select    => 1,
 459                             },
 460         'cgp_language' => {
 461                             label => 'Communigate language',
 462                             type  => 'select',
 463                             select_list => [ '', qw( English Arabic Chinese Dutch French German Hebrew Italian Japanese Portuguese Russian Slovak Spanish Thai ) ],
 464                             disable_inventory => 1,
 465                             disable_select    => 1,
 466                           },
 467         'cgp_timezone' => {
 468                             label       => 'Communigate time zone',
 469                             type        => 'select',
 470                             select_list => __PACKAGE__->cgp_timezone_values,
 471                             disable_inventory => 1,
 472                             disable_select    => 1,
 473                           },
 474         'cgp_skinname' => {
 475                             label => 'Communigate layout',
 476                             type  => 'select',
 477                             select_list => [ '', '***', 'GoldFleece', 'Skin2' ],
 478                             disable_inventory => 1,
 479                             disable_select    => 1,
 480                           },
 481         'cgp_prontoskinname' => {
 482                             label => 'Communigate Pronto style',
 483                             type  => 'select',
 484                             select_list => [ '', 'Pronto', 'Pronto-darkflame', 'Pronto-steel', 'Pronto-twilight', ],
 485                             disable_inventory => 1,
 486                             disable_select    => 1,
 487                           },
 488         'cgp_sendmdnmode' => {
 489           label => 'Communigate send read receipts',
 490           type  => 'select',
 491           select_list => [ '', 'Never', 'Manually', 'Automatically' ],
 492           disable_inventory => 1,
 493           disable_select    => 1,
 494         },
 495
 496         #mail
 497         #XXX vacation message, redirect all mail, mail rules
 498         #XXX RPOP settings
 499
 500     },
 501   };
 502 }
 503
 504 sub table { 'svc_acct'; }
 505
 506 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
 507
 508 sub _fieldhandlers {
 509   {
 510     #false laziness with edit/svc_acct.cgi
 511     'usergroup' => sub {
 512                          my( $self, $groups ) = @_;
 513                          if ( ref($groups) eq 'ARRAY' ) {
 514                            $groups;
 515                          } elsif ( length($groups) ) {
 516                            [ split(/\s*,\s*/, $groups) ];
 517                          } else {
 518                            [];
 519                          }
 520                        },
 521   };
 522 }
 523
 524 sub last_login {
 525   shift->_lastlog('in', @_);
 526 }
 527
 528 sub last_logout {
 529   shift->_lastlog('out', @_);
 530 }
 531
 532 sub _lastlog {
 533   my( $self, $op, $time ) = @_;
 534
 535   if ( defined($time) ) {
 536     warn "$me last_log$op called on svcnum ". $self->svcnum.
 537          ' ('. $self->email. "): $time\n"
 538       if $DEBUG;
 539
 540     my $dbh = dbh;
 541
 542     my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
 543     warn "$me $sql\n"
 544       if $DEBUG;
 545
 546     my $sth = $dbh->prepare( $sql )
 547       or die "Error preparing $sql: ". $dbh->errstr;
 548     my $rv = $sth->execute($time, $self->svcnum);
 549     die "Error executing $sql: ". $sth->errstr
 550       unless defined($rv);
 551     die "Can't update last_log$op for svcnum". $self->svcnum
 552       if $rv == 0;
 553
 554     $self->{'Hash'}->{"last_log$op"} = $time;
 555   }else{
 556     $self->getfield("last_log$op");
 557   }
 558 }
 559
 560 =item search_sql STRING
 561
 562 Class method which returns an SQL fragment to search for the given string.
 563
 564 =cut
 565
 566 sub search_sql {
 567   my( $class, $string ) = @_;
 568   if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
 569     my( $username, $domain ) = ( $1, $2 );
 570     my $q_username = dbh->quote($username);
 571     my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
 572     if ( @svc_domain ) {
 573       "svc_acct.username = $q_username AND ( ".
 574         join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
 575       " )";
 576     } else {
 577       '1 = 0'; #false
 578     }
 579   } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
 580     ' ( '.
 581       $class->search_sql_field('slipip',   $string ).
 582     ' OR '.
 583       $class->search_sql_field('username', $string ).
 584     ' ) ';
 585   } else {
 586     $class->search_sql_field('username', $string);
 587   }
 588 }
 589
 590 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
 591
 592 Returns the "username@domain" string for this account.
 593
 594 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
 595 history records.
 596
 597 =cut
 598
 599 sub label {
 600   my $self = shift;
 601   $self->email(@_);
 602 }
 603
 604 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
 605
 606 Returns a longer string label for this acccount ("Real Name <username@domain>"
 607 if available, or "username@domain").
 608
 609 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
 610 history records.
 611
 612 =cut
 613
 614 sub label_long {
 615   my $self = shift;
 616   my $label = $self->label(@_);
 617   my $finger = $self->finger;
 618   return $label unless $finger =~ /\S/;
 619   my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
 620   $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
 621   "$finger <$label>";
 622 }
 623
 624 =item insert [ , OPTION => VALUE ... ]
 625
 626 Adds this account to the database.  If there is an error, returns the error,
 627 otherwise returns false.
 628
 629 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 630 defined.  An FS::cust_svc record will be created and inserted.
 631
 632 The additional field I<usergroup> can optionally be defined; if so it should
 633 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 634
 635 The additional field I<child_objects> can optionally be defined; if so it
 636 should contain an arrayref of FS::tablename objects.  They will have their
 637 svcnum fields set and will be inserted after this record, but before any
 638 exports are run.  Each element of the array can also optionally be a
 639 two-element array reference containing the child object and the name of an
 640 alternate field to be filled in with the newly-inserted svcnum, for example
 641 C<[ $svc_forward, 'srcsvc' ]>
 642
 643 Currently available options are: I<depend_jobnum>
 644
 645 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
 646 jobnums), all provisioning jobs will have a dependancy on the supplied
 647 jobnum(s) (they will not run until the specific job(s) complete(s)).
 648
 649 (TODOC: L<FS::queue> and L<freeside-queued>)
 650
 651 (TODOC: new exports!)
 652
 653 =cut
 654
 655 sub insert {
 656   my $self = shift;
 657   my %options = @_;
 658
 659   if ( $DEBUG ) {
 660     warn "[$me] insert called on $self: ". Dumper($self).
 661          "\nwith options: ". Dumper(%options);
 662   }
 663
 664   local $SIG{HUP} = 'IGNORE';
 665   local $SIG{INT} = 'IGNORE';
 666   local $SIG{QUIT} = 'IGNORE';
 667   local $SIG{TERM} = 'IGNORE';
 668   local $SIG{TSTP} = 'IGNORE';
 669   local $SIG{PIPE} = 'IGNORE';
 670
 671   my $oldAutoCommit = $FS::UID::AutoCommit;
 672   local $FS::UID::AutoCommit = 0;
 673   my $dbh = dbh;
 674
 675   my @jobnums;
 676   my $error = $self->SUPER::insert(
 677     'jobnums'       => \@jobnums,
 678     'child_objects' => $self->child_objects,
 679     %options,
 680   );
 681   if ( $error ) {
 682     $dbh->rollback if $oldAutoCommit;
 683     return $error;
 684   }
 685
 686   if ( $self->usergroup ) {
 687     foreach my $groupname ( @{$self->usergroup} ) {
 688       my $radius_usergroup = new FS::radius_usergroup ( {
 689         svcnum    => $self->svcnum,
 690         groupname => $groupname,
 691       } );
 692       my $error = $radius_usergroup->insert;
 693       if ( $error ) {
 694         $dbh->rollback if $oldAutoCommit;
 695         return $error;
 696       }
 697     }
 698   }
 699
 700   unless ( $skip_fuzzyfiles ) {
 701     $error = $self->queue_fuzzyfiles_update;
 702     if ( $error ) {
 703       $dbh->rollback if $oldAutoCommit;
 704       return "updating fuzzy search cache: $error";
 705     }
 706   }
 707
 708   my $cust_pkg = $self->cust_svc->cust_pkg;
 709
 710   if ( $cust_pkg ) {
 711     my $cust_main = $cust_pkg->cust_main;
 712     my $agentnum = $cust_main->agentnum;
 713
 714     if (   $conf->exists('emailinvoiceautoalways')
 715         || $conf->exists('emailinvoiceauto')
 716         && ! $cust_main->invoicing_list_emailonly
 717        ) {
 718       my @invoicing_list = $cust_main->invoicing_list;
 719       push @invoicing_list, $self->email;
 720       $cust_main->invoicing_list(\@invoicing_list);
 721     }
 722
 723     #welcome email
 724     my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
 725       = ('','','','','','');
 726
 727     if ( $conf->exists('welcome_email', $agentnum) ) {
 728       $welcome_template = new Text::Template (
 729         TYPE   => 'ARRAY',
 730         SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
 731       ) or warn "can't create welcome email template: $Text::Template::ERROR";
 732       $welcome_from = $conf->config('welcome_email-from', $agentnum);
 733         # || 'your-isp-is-dum'
 734       $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
 735         || 'Welcome';
 736       $welcome_subject_template = new Text::Template (
 737         TYPE   => 'STRING',
 738         SOURCE => $welcome_subject,
 739       ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
 740       $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
 741         || 'text/plain';
 742     }
 743     if ( $welcome_template && $cust_pkg ) {
 744       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
 745       if ( $to ) {
 746
 747         my %hash = (
 748                      'custnum'  => $self->custnum,
 749                      'username' => $self->username,
 750                      'password' => $self->_password,
 751                      'first'    => $cust_main->first,
 752                      'last'     => $cust_main->getfield('last'),
 753                      'pkg'      => $cust_pkg->part_pkg->pkg,
 754                    );
 755         my $wqueue = new FS::queue {
 756           'svcnum' => $self->svcnum,
 757           'job'    => 'FS::svc_acct::send_email'
 758         };
 759         my $error = $wqueue->insert(
 760           'to'       => $to,
 761           'from'     => $welcome_from,
 762           'subject'  => $welcome_subject_template->fill_in( HASH => \%hash, ),
 763           'mimetype' => $welcome_mimetype,
 764           'body'     => $welcome_template->fill_in( HASH => \%hash, ),
 765         );
 766         if ( $error ) {
 767           $dbh->rollback if $oldAutoCommit;
 768           return "error queuing welcome email: $error";
 769         }
 770
 771         if ( $options{'depend_jobnum'} ) {
 772           warn "$me depend_jobnum found; adding to welcome email dependancies"
 773             if $DEBUG;
 774           if ( ref($options{'depend_jobnum'}) ) {
 775             warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
 776                  "to welcome email dependancies"
 777               if $DEBUG;
 778             push @jobnums, @{ $options{'depend_jobnum'} };
 779           } else {
 780             warn "$me adding job $options{'depend_jobnum'} ".
 781                  "to welcome email dependancies"
 782               if $DEBUG;
 783             push @jobnums, $options{'depend_jobnum'};
 784           }
 785         }
 786
 787         foreach my $jobnum ( @jobnums ) {
 788           my $error = $wqueue->depend_insert($jobnum);
 789           if ( $error ) {
 790             $dbh->rollback if $oldAutoCommit;
 791             return "error queuing welcome email job dependancy: $error";
 792           }
 793         }
 794
 795       }
 796
 797     }
 798
 799   } # if ( $cust_pkg )
 800
 801   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 802   ''; #no error
 803 }
 804
 805 # set usage fields and thresholds if unset but set in a package def
 806 # AND the package already has a last bill date (otherwise they get double added)
 807 sub preinsert_hook_first {
 808   my $self = shift;
 809
 810   return '' unless $self->pkgnum;
 811
 812   my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
 813   return '' unless $cust_pkg && $cust_pkg->last_bill;
 814
 815   my $part_pkg = $cust_pkg->part_pkg;
 816   return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
 817
 818   my %values = $part_pkg->usage_valuehash;
 819   my $multiplier = $conf->exists('svc_acct-usage_threshold')
 820                      ? 1 - $conf->config('svc_acct-usage_threshold')/100
 821                      : 0.20; #doesn't matter
 822
 823   foreach ( keys %values ) {
 824     next if $self->getfield($_);
 825     $self->setfield( $_, $values{$_} );
 826     $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
 827       if $conf->exists('svc_acct-usage_threshold');
 828   }
 829
 830   ''; #no error
 831 }
 832
 833 =item delete
 834
 835 Deletes this account from the database.  If there is an error, returns the
 836 error, otherwise returns false.
 837
 838 The corresponding FS::cust_svc record will be deleted as well.
 839
 840 (TODOC: new exports!)
 841
 842 =cut
 843
 844 sub delete {
 845   my $self = shift;
 846
 847   return "can't delete system account" if $self->_check_system;
 848
 849   return "Can't delete an account which is a (svc_forward) source!"
 850     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 851
 852   return "Can't delete an account which is a (svc_forward) destination!"
 853     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 854
 855   return "Can't delete an account with (svc_www) web service!"
 856     if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
 857
 858   # what about records in session ? (they should refer to history table)
 859
 860   local $SIG{HUP} = 'IGNORE';
 861   local $SIG{INT} = 'IGNORE';
 862   local $SIG{QUIT} = 'IGNORE';
 863   local $SIG{TERM} = 'IGNORE';
 864   local $SIG{TSTP} = 'IGNORE';
 865   local $SIG{PIPE} = 'IGNORE';
 866
 867   my $oldAutoCommit = $FS::UID::AutoCommit;
 868   local $FS::UID::AutoCommit = 0;
 869   my $dbh = dbh;
 870
 871   foreach my $cust_main_invoice (
 872     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 873   ) {
 874     unless ( defined($cust_main_invoice) ) {
 875       warn "WARNING: something's wrong with qsearch";
 876       next;
 877     }
 878     my %hash = $cust_main_invoice->hash;
 879     $hash{'dest'} = $self->email;
 880     my $new = new FS::cust_main_invoice \%hash;
 881     my $error = $new->replace($cust_main_invoice);
 882     if ( $error ) {
 883       $dbh->rollback if $oldAutoCommit;
 884       return $error;
 885     }
 886   }
 887
 888   foreach my $svc_domain (
 889     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 890   ) {
 891     my %hash = new FS::svc_domain->hash;
 892     $hash{'catchall'} = '';
 893     my $new = new FS::svc_domain \%hash;
 894     my $error = $new->replace($svc_domain);
 895     if ( $error ) {
 896       $dbh->rollback if $oldAutoCommit;
 897       return $error;
 898     }
 899   }
 900
 901   my $error = $self->SUPER::delete;
 902   if ( $error ) {
 903     $dbh->rollback if $oldAutoCommit;
 904     return $error;
 905   }
 906
 907   foreach my $radius_usergroup (
 908     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 909   ) {
 910     my $error = $radius_usergroup->delete;
 911     if ( $error ) {
 912       $dbh->rollback if $oldAutoCommit;
 913       return $error;
 914     }
 915   }
 916
 917   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 918   '';
 919 }
 920
 921 =item replace OLD_RECORD
 922
 923 Replaces OLD_RECORD with this one in the database.  If there is an error,
 924 returns the error, otherwise returns false.
 925
 926 The additional field I<usergroup> can optionally be defined; if so it should
 927 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 928
 929
 930 =cut
 931
 932 sub replace {
 933   my $new = shift;
 934
 935   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 936               ? shift
 937               : $new->replace_old;
 938
 939   warn "$me replacing $old with $new\n" if $DEBUG;
 940
 941   my $error;
 942
 943   return "can't modify system account" if $old->_check_system;
 944
 945   {
 946     #no warnings 'numeric';  #alas, a 5.006-ism
 947     local($^W) = 0;
 948
 949     foreach my $xid (qw( uid gid )) {
 950
 951       return "Can't change $xid!"
 952         if ! $conf->exists("svc_acct-edit_$xid")
 953            && $old->$xid() != $new->$xid()
 954            && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
 955     }
 956
 957   }
 958
 959   #change homdir when we change username
 960   $new->setfield('dir', '') if $old->username ne $new->username;
 961
 962   local $SIG{HUP} = 'IGNORE';
 963   local $SIG{INT} = 'IGNORE';
 964   local $SIG{QUIT} = 'IGNORE';
 965   local $SIG{TERM} = 'IGNORE';
 966   local $SIG{TSTP} = 'IGNORE';
 967   local $SIG{PIPE} = 'IGNORE';
 968
 969   my $oldAutoCommit = $FS::UID::AutoCommit;
 970   local $FS::UID::AutoCommit = 0;
 971   my $dbh = dbh;
 972
 973   # redundant, but so $new->usergroup gets set
 974   $error = $new->check;
 975   return $error if $error;
 976
 977   $old->usergroup( [ $old->radius_groups ] );
 978   if ( $DEBUG ) {
 979     warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
 980     warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
 981   }
 982   if ( $new->usergroup ) {
 983     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 984     my @newgroups = @{$new->usergroup};
 985     foreach my $oldgroup ( @{$old->usergroup} ) {
 986       if ( grep { $oldgroup eq $_ } @newgroups ) {
 987         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 988         next;
 989       }
 990       my $radius_usergroup = qsearchs('radius_usergroup', {
 991         svcnum    => $old->svcnum,
 992         groupname => $oldgroup,
 993       } );
 994       my $error = $radius_usergroup->delete;
 995       if ( $error ) {
 996         $dbh->rollback if $oldAutoCommit;
 997         return "error deleting radius_usergroup $oldgroup: $error";
 998       }
 999     }
1000
1001     foreach my $newgroup ( @newgroups ) {
1002       my $radius_usergroup = new FS::radius_usergroup ( {
1003         svcnum    => $new->svcnum,
1004         groupname => $newgroup,
1005       } );
1006       my $error = $radius_usergroup->insert;
1007       if ( $error ) {
1008         $dbh->rollback if $oldAutoCommit;
1009         return "error adding radius_usergroup $newgroup: $error";
1010       }
1011     }
1012
1013   }
1014
1015   $error = $new->SUPER::replace($old, @_);
1016   if ( $error ) {
1017     $dbh->rollback if $oldAutoCommit;
1018     return $error if $error;
1019   }
1020
1021   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
1022     $error = $new->queue_fuzzyfiles_update;
1023     if ( $error ) {
1024       $dbh->rollback if $oldAutoCommit;
1025       return "updating fuzzy search cache: $error";
1026     }
1027   }
1028
1029   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1030   ''; #no error
1031 }
1032
1033 =item queue_fuzzyfiles_update
1034
1035 Used by insert & replace to update the fuzzy search cache
1036
1037 =cut
1038
1039 sub queue_fuzzyfiles_update {
1040   my $self = shift;
1041
1042   local $SIG{HUP} = 'IGNORE';
1043   local $SIG{INT} = 'IGNORE';
1044   local $SIG{QUIT} = 'IGNORE';
1045   local $SIG{TERM} = 'IGNORE';
1046   local $SIG{TSTP} = 'IGNORE';
1047   local $SIG{PIPE} = 'IGNORE';
1048
1049   my $oldAutoCommit = $FS::UID::AutoCommit;
1050   local $FS::UID::AutoCommit = 0;
1051   my $dbh = dbh;
1052
1053   my $queue = new FS::queue {
1054     'svcnum' => $self->svcnum,
1055     'job'    => 'FS::svc_acct::append_fuzzyfiles'
1056   };
1057   my $error = $queue->insert($self->username);
1058   if ( $error ) {
1059     $dbh->rollback if $oldAutoCommit;
1060     return "queueing job (transaction rolled back): $error";
1061   }
1062
1063   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1064   '';
1065
1066 }
1067
1068
1069 =item suspend
1070
1071 Suspends this account by calling export-specific suspend hooks.  If there is
1072 an error, returns the error, otherwise returns false.
1073
1074 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1075
1076 =cut
1077
1078 sub suspend {
1079   my $self = shift;
1080   return "can't suspend system account" if $self->_check_system;
1081   $self->SUPER::suspend(@_);
1082 }
1083
1084 =item unsuspend
1085
1086 Unsuspends this account by by calling export-specific suspend hooks.  If there
1087 is an error, returns the error, otherwise returns false.
1088
1089 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1090
1091 =cut
1092
1093 sub unsuspend {
1094   my $self = shift;
1095   my %hash = $self->hash;
1096   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
1097     $hash{_password} = $1;
1098     my $new = new FS::svc_acct ( \%hash );
1099     my $error = $new->replace($self);
1100     return $error if $error;
1101   }
1102
1103   $self->SUPER::unsuspend(@_);
1104 }
1105
1106 =item cancel
1107
1108 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
1109
1110 If the B<auto_unset_catchall> configuration option is set, this method will
1111 automatically remove any references to the canceled service in the catchall
1112 field of svc_domain.  This allows packages that contain both a svc_domain and
1113 its catchall svc_acct to be canceled in one step.
1114
1115 =cut
1116
1117 sub cancel {
1118   # Only one thing to do at this level
1119   my $self = shift;
1120   foreach my $svc_domain (
1121       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
1122     if($conf->exists('auto_unset_catchall')) {
1123       my %hash = $svc_domain->hash;
1124       $hash{catchall} = '';
1125       my $new = new FS::svc_domain ( \%hash );
1126       my $error = $new->replace($svc_domain);
1127       return $error if $error;
1128     } else {
1129       return "cannot unprovision svc_acct #".$self->svcnum.
1130           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
1131     }
1132   }
1133
1134   $self->SUPER::cancel(@_);
1135 }
1136
1137
1138 =item check
1139
1140 Checks all fields to make sure this is a valid service.  If there is an error,
1141 returns the error, otherwise returns false.  Called by the insert and replace
1142 methods.
1143
1144 Sets any fixed values; see L<FS::part_svc>.
1145
1146 =cut
1147
1148 sub check {
1149   my $self = shift;
1150
1151   my($recref) = $self->hashref;
1152
1153   my $x = $self->setfixed( $self->_fieldhandlers );
1154   return $x unless ref($x);
1155   my $part_svc = $x;
1156
1157   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1158     $self->usergroup(
1159       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1160   }
1161
1162   my $error = $self->ut_numbern('svcnum')
1163               #|| $self->ut_number('domsvc')
1164               || $self->ut_foreign_key( 'domsvc', 'svc_domain', 'svcnum' )
1165               || $self->ut_foreign_keyn('pbxsvc', 'svc_pbx',    'svcnum' )
1166               || $self->ut_textn('sec_phrase')
1167               || $self->ut_snumbern('seconds')
1168               || $self->ut_snumbern('upbytes')
1169               || $self->ut_snumbern('downbytes')
1170               || $self->ut_snumbern('totalbytes')
1171               || $self->ut_snumbern('seconds_threshold')
1172               || $self->ut_snumbern('upbytes_threshold')
1173               || $self->ut_snumbern('downbytes_threshold')
1174               || $self->ut_snumbern('totalbytes_threshold')
1175               || $self->ut_enum('_password_encoding', ['',qw(plain crypt ldap)])
1176               || $self->ut_enum('password_selfchange', [ '', 'Y' ])
1177               || $self->ut_enum('password_recover',    [ '', 'Y' ])
1178               || $self->ut_textn('cgp_accessmodes')
1179               || $self->ut_alphan('cgp_type')
1180               || $self->ut_textn('cgp_aliases' ) #well
1181               #settings
1182               || $self->ut_alphasn('cgp_rulesallowed')
1183               || $self->ut_enum('cgp_rpopallowed', [ '', 'Y' ])
1184               || $self->ut_enum('cgp_mailtoall', [ '', 'Y' ])
1185               || $self->ut_enum('cgp_addmailtrailer', [ '', 'Y' ])
1186               #preferences
1187               || $self->ut_alphasn('cgp_deletemode')
1188               || $self->ut_enum('cgp_emptytrash', $self->cgp_emptytrash_values)
1189               || $self->ut_alphan('cgp_language')
1190               || $self->ut_textn('cgp_timezone')
1191               || $self->ut_textn('cgp_skinname')
1192               || $self->ut_textn('cgp_prontoskinname')
1193               || $self->ut_alphan('cgp_sendmdnmode')
1194               #XXX vacation message, redirect all mail, mail rules
1195               #XXX RPOP settings
1196   ;
1197   return $error if $error;
1198
1199   my $cust_pkg;
1200   local $username_letter = $username_letter;
1201   if ($self->svcnum) {
1202     my $cust_svc = $self->cust_svc
1203       or return "no cust_svc record found for svcnum ". $self->svcnum;
1204     my $cust_pkg = $cust_svc->cust_pkg;
1205   }
1206   if ($self->pkgnum) {
1207     $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1208   }
1209   if ($cust_pkg) {
1210     $username_letter =
1211       $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1212   }
1213
1214   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1215   if ( $username_uppercase ) {
1216     $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/i
1217       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1218     $recref->{username} = $1;
1219   } else {
1220     $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/
1221       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1222     $recref->{username} = $1;
1223   }
1224
1225   if ( $username_letterfirst ) {
1226     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1227   } elsif ( $username_letter ) {
1228     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1229   }
1230   if ( $username_noperiod ) {
1231     $recref->{username} =~ /\./ and return gettext('illegal_username');
1232   }
1233   if ( $username_nounderscore ) {
1234     $recref->{username} =~ /_/ and return gettext('illegal_username');
1235   }
1236   if ( $username_nodash ) {
1237     $recref->{username} =~ /\-/ and return gettext('illegal_username');
1238   }
1239   unless ( $username_ampersand ) {
1240     $recref->{username} =~ /\&/ and return gettext('illegal_username');
1241   }
1242   unless ( $username_percent ) {
1243     $recref->{username} =~ /\%/ and return gettext('illegal_username');
1244   }
1245   unless ( $username_colon ) {
1246     $recref->{username} =~ /\:/ and return gettext('illegal_username');
1247   }
1248
1249   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1250   $recref->{popnum} = $1;
1251   return "Unknown popnum" unless
1252     ! $recref->{popnum} ||
1253     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1254
1255   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1256
1257     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1258     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1259
1260     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1261     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1262     #not all systems use gid=uid
1263     #you can set a fixed gid in part_svc
1264
1265     return "Only root can have uid 0"
1266       if $recref->{uid} == 0
1267          && $recref->{username} !~ /^(root|toor|smtp)$/;
1268
1269     unless ( $recref->{username} eq 'sync' ) {
1270       if ( grep $_ eq $recref->{shell}, @shells ) {
1271         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1272       } else {
1273         return "Illegal shell \`". $self->shell. "\'; ".
1274                "shells configuration value contains: @shells";
1275       }
1276     } else {
1277       $recref->{shell} = '/bin/sync';
1278     }
1279
1280   } else {
1281     $recref->{gid} ne '' ?
1282       return "Can't have gid without uid" : ( $recref->{gid}='' );
1283     #$recref->{dir} ne '' ?
1284     #  return "Can't have directory without uid" : ( $recref->{dir}='' );
1285     $recref->{shell} ne '' ?
1286       return "Can't have shell without uid" : ( $recref->{shell}='' );
1287   }
1288
1289   unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1290
1291     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1292       or return "Illegal directory: ". $recref->{dir};
1293     $recref->{dir} = $1;
1294     return "Illegal directory"
1295       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1296     return "Illegal directory"
1297       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1298     unless ( $recref->{dir} ) {
1299       $recref->{dir} = $dir_prefix . '/';
1300       if ( $dirhash > 0 ) {
1301         for my $h ( 1 .. $dirhash ) {
1302           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1303         }
1304       } elsif ( $dirhash < 0 ) {
1305         for my $h ( reverse $dirhash .. -1 ) {
1306           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1307         }
1308       }
1309       $recref->{dir} .= $recref->{username};
1310     ;
1311     }
1312
1313   }
1314
1315   #  $error = $self->ut_textn('finger');
1316   #  return $error if $error;
1317   if ( $self->getfield('finger') eq '' ) {
1318     my $cust_pkg = $self->svcnum
1319       ? $self->cust_svc->cust_pkg
1320       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1321     if ( $cust_pkg ) {
1322       my $cust_main = $cust_pkg->cust_main;
1323       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1324     }
1325   }
1326   $self->getfield('finger') =~
1327     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1328       or return "Illegal finger: ". $self->getfield('finger');
1329   $self->setfield('finger', $1);
1330
1331   for (qw( quota file_quota file_maxsize )) {
1332     $recref->{$_} =~ /^(\w*)$/ or return "Illegal $_";
1333     $recref->{$_} = $1;
1334   }
1335   $recref->{file_maxnum} =~ /^\s*(\d*)\s*$/ or return "Illegal file_maxnum";
1336   $recref->{file_maxnum} = $1;
1337
1338   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1339     if ( $recref->{slipip} eq '' ) {
1340       $recref->{slipip} = '';
1341     } elsif ( $recref->{slipip} eq '0e0' ) {
1342       $recref->{slipip} = '0e0';
1343     } else {
1344       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1345         or return "Illegal slipip: ". $self->slipip;
1346       $recref->{slipip} = $1;
1347     }
1348
1349   }
1350
1351   #arbitrary RADIUS stuff; allow ut_textn for now
1352   foreach ( grep /^radius_/, fields('svc_acct') ) {
1353     $self->ut_textn($_);
1354   }
1355
1356   # First, if _password is blank, generate one and set default encoding.
1357   if ( ! $recref->{_password} ) {
1358     $error = $self->set_password('');
1359   }
1360   # But if there's a _password but no encoding, assume it's plaintext and
1361   # set it to default encoding.
1362   elsif ( ! $recref->{_password_encoding} ) {
1363     $error = $self->set_password($recref->{_password});
1364   }
1365   return $error if $error;
1366
1367   # Next, check _password to ensure compliance with the encoding.
1368   if ( $recref->{_password_encoding} eq 'ldap' ) {
1369
1370     if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1371       $recref->{_password} = uc($1).$2;
1372     } else {
1373       return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1374     }
1375
1376   } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1377
1378     if ( $recref->{_password} =~
1379            #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1380            /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1381        ) {
1382
1383       $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1384
1385     } else {
1386       return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1387     }
1388
1389   } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1390     # Password randomization is now in set_password.
1391     # Strip whitespace characters, check length requirements, etc.
1392     if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1393       $recref->{_password} = $1;
1394     } else {
1395       return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1396              FS::Msgcat::_gettext('illegal_password_characters').
1397              ": ". $recref->{_password};
1398     }
1399
1400     if ( $password_noampersand ) {
1401       $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1402     }
1403     if ( $password_noexclamation ) {
1404       $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1405     }
1406   }
1407   else {
1408     return "invalid password encoding ('".$recref->{_password_encoding}."'";
1409   }
1410   $self->SUPER::check;
1411
1412 }
1413
1414
1415 sub _password_encryption {
1416   my $self = shift;
1417   my $encoding = lc($self->_password_encoding);
1418   return if !$encoding;
1419   return 'plain' if $encoding eq 'plain';
1420   if($encoding eq 'crypt') {
1421     my $pass = $self->_password;
1422     $pass =~ s/^\*SUSPENDED\* //;
1423     $pass =~ s/^!!?//;
1424     return 'md5' if $pass =~ /^\$1\$/;
1425     #return 'blowfish' if $self->_password =~ /^\$2\$/;
1426     return 'des' if length($pass) == 13;
1427     return;
1428   }
1429   if($encoding eq 'ldap') {
1430     uc($self->_password) =~ /^\{([\w-]+)\}/;
1431     return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1432     return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1433     return 'md5' if $1 eq 'MD5';
1434     return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1435
1436     return;
1437   }
1438   return;
1439 }
1440
1441 sub get_cleartext_password {
1442   my $self = shift;
1443   if($self->_password_encryption eq 'plain') {
1444     if($self->_password_encoding eq 'ldap') {
1445       $self->_password =~ /\{\w+\}(.*)$/;
1446       return $1;
1447     }
1448     else {
1449       return $self->_password;
1450     }
1451   }
1452   return;
1453 }
1454
1455
1456 =item set_password
1457
1458 Set the cleartext password for the account.  If _password_encoding is set, the
1459 new password will be encoded according to the existing method (including
1460 encryption mode, if it can be determined).  Otherwise,
1461 config('default-password-encoding') is used.
1462
1463 If no password is supplied (or a zero-length password when minimum password length
1464 is >0), one will be generated randomly.
1465
1466 =cut
1467
1468 sub set_password {
1469   my( $self, $pass ) = ( shift, shift );
1470
1471   warn "[$me] set_password (to $pass) called on $self: ". Dumper($self)
1472      if $DEBUG;
1473
1474   my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1475                 FS::Msgcat::_gettext('illegal_password_characters').
1476                 ": ". $pass;
1477
1478   my( $encoding, $encryption ) = ('', '');
1479
1480   if ( $self->_password_encoding ) {
1481     $encoding = $self->_password_encoding;
1482     # identify existing encryption method, try to use it.
1483     $encryption = $self->_password_encryption;
1484     if (!$encryption) {
1485       # use the system default
1486       undef $encoding;
1487     }
1488   }
1489
1490   if ( !$encoding ) {
1491     # set encoding to system default
1492     ($encoding, $encryption) =
1493       split(/-/, lc($conf->config('default-password-encoding')));
1494     $encoding ||= 'legacy';
1495     $self->_password_encoding($encoding);
1496   }
1497
1498   if ( $encoding eq 'legacy' ) {
1499
1500     # The legacy behavior from check():
1501     # If the password is blank, randomize it and set encoding to 'plain'.
1502     if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1503       $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1504       $self->_password_encoding('plain');
1505     } else {
1506       # Prefix + valid-length password
1507       if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1508         $pass = $1.$3;
1509         $self->_password_encoding('plain');
1510       # Prefix + crypt string
1511       } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1512         $pass = $1.$3;
1513         $self->_password_encoding('crypt');
1514       # Various disabled crypt passwords
1515       } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) {
1516         $self->_password_encoding('crypt');
1517       } else {
1518         return $failure;
1519       }
1520     }
1521
1522     $self->_password($pass);
1523     return;
1524
1525   }
1526
1527   return $failure
1528     if $passwordmin && length($pass) < $passwordmin
1529     or $passwordmax && length($pass) > $passwordmax;
1530
1531   if ( $encoding eq 'crypt' ) {
1532     if ($encryption eq 'md5') {
1533       $pass = unix_md5_crypt($pass);
1534     } elsif ($encryption eq 'des') {
1535       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1536     }
1537
1538   } elsif ( $encoding eq 'ldap' ) {
1539     if ($encryption eq 'md5') {
1540       $pass = md5_base64($pass);
1541     } elsif ($encryption eq 'sha1') {
1542       $pass = sha1_base64($pass);
1543     } elsif ($encryption eq 'crypt') {
1544       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1545     }
1546     # else $encryption eq 'plain', do nothing
1547     $pass = '{'.uc($encryption).'}'.$pass;
1548   }
1549   # else encoding eq 'plain'
1550
1551   $self->_password($pass);
1552   return;
1553 }
1554
1555 =item _check_system
1556
1557 Internal function to check the username against the list of system usernames
1558 from the I<system_usernames> configuration value.  Returns true if the username
1559 is listed on the system username list.
1560
1561 =cut
1562
1563 sub _check_system {
1564   my $self = shift;
1565   scalar( grep { $self->username eq $_ || $self->email eq $_ }
1566                $conf->config('system_usernames')
1567         );
1568 }
1569
1570 =item _check_duplicate
1571
1572 Internal method to check for duplicates usernames, username@domain pairs and
1573 uids.
1574
1575 If the I<global_unique-username> configuration value is set to B<username> or
1576 B<username@domain>, enforces global username or username@domain uniqueness.
1577
1578 In all cases, check for duplicate uids and usernames or username@domain pairs
1579 per export and with identical I<svcpart> values.
1580
1581 =cut
1582
1583 sub _check_duplicate {
1584   my $self = shift;
1585
1586   my $global_unique = $conf->config('global_unique-username') || 'none';
1587   return '' if $global_unique eq 'disabled';
1588
1589   $self->lock_table;
1590
1591   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1592   unless ( $part_svc ) {
1593     return 'unknown svcpart '. $self->svcpart;
1594   }
1595
1596   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1597                  qsearch( 'svc_acct', { 'username' => $self->username } );
1598   return gettext('username_in_use')
1599     if $global_unique eq 'username' && @dup_user;
1600
1601   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1602                        qsearch( 'svc_acct', { 'username' => $self->username,
1603                                               'domsvc'   => $self->domsvc } );
1604   return gettext('username_in_use')
1605     if $global_unique eq 'username@domain' && @dup_userdomain;
1606
1607   my @dup_uid;
1608   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1609        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
1610     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1611                qsearch( 'svc_acct', { 'uid' => $self->uid } );
1612   } else {
1613     @dup_uid = ();
1614   }
1615
1616   if ( @dup_user || @dup_userdomain || @dup_uid ) {
1617     my $exports = FS::part_export::export_info('svc_acct');
1618     my %conflict_user_svcpart;
1619     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1620
1621     foreach my $part_export ( $part_svc->part_export ) {
1622
1623       #this will catch to the same exact export
1624       my @svcparts = map { $_->svcpart } $part_export->export_svc;
1625
1626       #this will catch to exports w/same exporthost+type ???
1627       #my @other_part_export = qsearch('part_export', {
1628       #  'machine'    => $part_export->machine,
1629       #  'exporttype' => $part_export->exporttype,
1630       #} );
1631       #foreach my $other_part_export ( @other_part_export ) {
1632       #  push @svcparts, map { $_->svcpart }
1633       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1634       #}
1635
1636       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1637       #silly kludge to avoid uninitialized value errors
1638       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1639                      ? $exports->{$part_export->exporttype}{'nodomain'}
1640                      : '';
1641       if ( $nodomain =~ /^Y/i ) {
1642         $conflict_user_svcpart{$_} = $part_export->exportnum
1643           foreach @svcparts;
1644       } else {
1645         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1646           foreach @svcparts;
1647       }
1648     }
1649
1650     foreach my $dup_user ( @dup_user ) {
1651       my $dup_svcpart = $dup_user->cust_svc->svcpart;
1652       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1653         return "duplicate username ". $self->username.
1654                ": conflicts with svcnum ". $dup_user->svcnum.
1655                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1656       }
1657     }
1658
1659     foreach my $dup_userdomain ( @dup_userdomain ) {
1660       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1661       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1662         return "duplicate username\@domain ". $self->email.
1663                ": conflicts with svcnum ". $dup_userdomain->svcnum.
1664                " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1665       }
1666     }
1667
1668     foreach my $dup_uid ( @dup_uid ) {
1669       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1670       if ( exists($conflict_user_svcpart{$dup_svcpart})
1671            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1672         return "duplicate uid ". $self->uid.
1673                ": conflicts with svcnum ". $dup_uid->svcnum.
1674                " via exportnum ".
1675                ( $conflict_user_svcpart{$dup_svcpart}
1676                  || $conflict_userdomain_svcpart{$dup_svcpart} );
1677       }
1678     }
1679
1680   }
1681
1682   return '';
1683
1684 }
1685
1686 =item radius
1687
1688 Depriciated, use radius_reply instead.
1689
1690 =cut
1691
1692 sub radius {
1693   carp "FS::svc_acct::radius depriciated, use radius_reply";
1694   $_[0]->radius_reply;
1695 }
1696
1697 =item radius_reply
1698
1699 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1700 reply attributes of this record.
1701
1702 Note that this is now the preferred method for reading RADIUS attributes -
1703 accessing the columns directly is discouraged, as the column names are
1704 expected to change in the future.
1705
1706 =cut
1707
1708 sub radius_reply {
1709   my $self = shift;
1710
1711   return %{ $self->{'radius_reply'} }
1712     if exists $self->{'radius_reply'};
1713
1714   my %reply =
1715     map {
1716       /^(radius_(.*))$/;
1717       my($column, $attrib) = ($1, $2);
1718       #$attrib =~ s/_/\-/g;
1719       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1720     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1721
1722   if ( $self->slipip && $self->slipip ne '0e0' ) {
1723     $reply{$radius_ip} = $self->slipip;
1724   }
1725
1726   if ( $self->seconds !~ /^$/ ) {
1727     $reply{'Session-Timeout'} = $self->seconds;
1728   }
1729
1730   if ( $conf->exists('radius-chillispot-max') ) {
1731     #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1732
1733     #hmm.  just because sqlradius.pm says so?
1734     my %whatis = (
1735       'input'  => 'up',
1736       'output' => 'down',
1737       'total'  => 'total',
1738     );
1739
1740     foreach my $what (qw( input output total )) {
1741       my $is = $whatis{$what}.'bytes';
1742       if ( $self->$is() =~ /\d/ ) {
1743         my $big = new Math::BigInt $self->$is();
1744         $big = new Math::BigInt '0' if $big->is_neg();
1745         my $att = "Chillispot-Max-\u$what";
1746         $reply{"$att-Octets"}    = $big->copy->band(0xffffffff)->bstr;
1747         $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1748       }
1749     }
1750
1751   }
1752
1753   %reply;
1754 }
1755
1756 =item radius_check
1757
1758 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1759 check attributes of this record.
1760
1761 Note that this is now the preferred method for reading RADIUS attributes -
1762 accessing the columns directly is discouraged, as the column names are
1763 expected to change in the future.
1764
1765 =cut
1766
1767 sub radius_check {
1768   my $self = shift;
1769
1770   return %{ $self->{'radius_check'} }
1771     if exists $self->{'radius_check'};
1772
1773   my %check =
1774     map {
1775       /^(rc_(.*))$/;
1776       my($column, $attrib) = ($1, $2);
1777       #$attrib =~ s/_/\-/g;
1778       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1779     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1780
1781
1782   my($pw_attrib, $password) = $self->radius_password;
1783   $check{$pw_attrib} = $password;
1784
1785   my $cust_svc = $self->cust_svc;
1786   if ( $cust_svc ) {
1787     my $cust_pkg = $cust_svc->cust_pkg;
1788     if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1789       $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1790     }
1791   } else {
1792     warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1793          "; can't set Expiration\n"
1794       unless $cust_svc;
1795   }
1796
1797   %check;
1798
1799 }
1800
1801 =item radius_password
1802
1803 Returns a key/value pair containing the RADIUS attribute name and value
1804 for the password.
1805
1806 =cut
1807
1808 sub radius_password {
1809   my $self = shift;
1810
1811   my $pw_attrib;
1812   if ( $self->_password_encoding eq 'ldap' ) {
1813     $pw_attrib = 'Password-With-Header';
1814   } elsif ( $self->_password_encoding eq 'crypt' ) {
1815     $pw_attrib = 'Crypt-Password';
1816   } elsif ( $self->_password_encoding eq 'plain' ) {
1817     $pw_attrib = $radius_password;
1818   } else {
1819     $pw_attrib = length($self->_password) <= 12
1820                    ? $radius_password
1821                    : 'Crypt-Password';
1822   }
1823
1824   ($pw_attrib, $self->_password);
1825
1826 }
1827
1828 =item snapshot
1829
1830 This method instructs the object to "snapshot" or freeze RADIUS check and
1831 reply attributes to the current values.
1832
1833 =cut
1834
1835 #bah, my english is too broken this morning
1836 #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
1837 #the FS::cust_pkg's replace method to trigger the correct export updates when
1838 #package dates change)
1839
1840 sub snapshot {
1841   my $self = shift;
1842
1843   $self->{$_} = { $self->$_() }
1844     foreach qw( radius_reply radius_check );
1845
1846 }
1847
1848 =item forget_snapshot
1849
1850 This methos instructs the object to forget any previously snapshotted
1851 RADIUS check and reply attributes.
1852
1853 =cut
1854
1855 sub forget_snapshot {
1856   my $self = shift;
1857
1858   delete $self->{$_}
1859     foreach qw( radius_reply radius_check );
1860
1861 }
1862
1863 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1864
1865 Returns the domain associated with this account.
1866
1867 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1868 history records.
1869
1870 =cut
1871
1872 sub domain {
1873   my $self = shift;
1874   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1875   my $svc_domain = $self->svc_domain(@_)
1876     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1877   $svc_domain->domain;
1878 }
1879
1880 =item cust_svc
1881
1882 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1883
1884 =cut
1885
1886 #inherited from svc_Common
1887
1888 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1889
1890 Returns an email address associated with the account.
1891
1892 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1893 history records.
1894
1895 =cut
1896
1897 sub email {
1898   my $self = shift;
1899   $self->username. '@'. $self->domain(@_);
1900 }
1901
1902 =item acct_snarf
1903
1904 Returns an array of FS::acct_snarf records associated with the account.
1905 If the acct_snarf table does not exist or there are no associated records,
1906 an empty list is returned
1907
1908 =cut
1909
1910 sub acct_snarf {
1911   my $self = shift;
1912   return () unless dbdef->table('acct_snarf');
1913   eval "use FS::acct_snarf;";
1914   die $@ if $@;
1915   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1916 }
1917
1918 =item decrement_upbytes OCTETS
1919
1920 Decrements the I<upbytes> field of this record by the given amount.  If there
1921 is an error, returns the error, otherwise returns false.
1922
1923 =cut
1924
1925 sub decrement_upbytes {
1926   shift->_op_usage('-', 'upbytes', @_);
1927 }
1928
1929 =item increment_upbytes OCTETS
1930
1931 Increments the I<upbytes> field of this record by the given amount.  If there
1932 is an error, returns the error, otherwise returns false.
1933
1934 =cut
1935
1936 sub increment_upbytes {
1937   shift->_op_usage('+', 'upbytes', @_);
1938 }
1939
1940 =item decrement_downbytes OCTETS
1941
1942 Decrements the I<downbytes> field of this record by the given amount.  If there
1943 is an error, returns the error, otherwise returns false.
1944
1945 =cut
1946
1947 sub decrement_downbytes {
1948   shift->_op_usage('-', 'downbytes', @_);
1949 }
1950
1951 =item increment_downbytes OCTETS
1952
1953 Increments the I<downbytes> field of this record by the given amount.  If there
1954 is an error, returns the error, otherwise returns false.
1955
1956 =cut
1957
1958 sub increment_downbytes {
1959   shift->_op_usage('+', 'downbytes', @_);
1960 }
1961
1962 =item decrement_totalbytes OCTETS
1963
1964 Decrements the I<totalbytes> field of this record by the given amount.  If there
1965 is an error, returns the error, otherwise returns false.
1966
1967 =cut
1968
1969 sub decrement_totalbytes {
1970   shift->_op_usage('-', 'totalbytes', @_);
1971 }
1972
1973 =item increment_totalbytes OCTETS
1974
1975 Increments the I<totalbytes> field of this record by the given amount.  If there
1976 is an error, returns the error, otherwise returns false.
1977
1978 =cut
1979
1980 sub increment_totalbytes {
1981   shift->_op_usage('+', 'totalbytes', @_);
1982 }
1983
1984 =item decrement_seconds SECONDS
1985
1986 Decrements the I<seconds> field of this record by the given amount.  If there
1987 is an error, returns the error, otherwise returns false.
1988
1989 =cut
1990
1991 sub decrement_seconds {
1992   shift->_op_usage('-', 'seconds', @_);
1993 }
1994
1995 =item increment_seconds SECONDS
1996
1997 Increments the I<seconds> field of this record by the given amount.  If there
1998 is an error, returns the error, otherwise returns false.
1999
2000 =cut
2001
2002 sub increment_seconds {
2003   shift->_op_usage('+', 'seconds', @_);
2004 }
2005
2006
2007 my %op2action = (
2008   '-' => 'suspend',
2009   '+' => 'unsuspend',
2010 );
2011 my %op2condition = (
2012   '-' => sub { my($self, $column, $amount) = @_;
2013                $self->$column - $amount <= 0;
2014              },
2015   '+' => sub { my($self, $column, $amount) = @_;
2016                ($self->$column || 0) + $amount > 0;
2017              },
2018 );
2019 my %op2warncondition = (
2020   '-' => sub { my($self, $column, $amount) = @_;
2021                my $threshold = $column . '_threshold';
2022                $self->$column - $amount <= $self->$threshold + 0;
2023              },
2024   '+' => sub { my($self, $column, $amount) = @_;
2025                ($self->$column || 0) + $amount > 0;
2026              },
2027 );
2028
2029 sub _op_usage {
2030   my( $self, $op, $column, $amount ) = @_;
2031
2032   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
2033        ' ('. $self->email. "): $op $amount\n"
2034     if $DEBUG;
2035
2036   return '' unless $amount;
2037
2038   local $SIG{HUP} = 'IGNORE';
2039   local $SIG{INT} = 'IGNORE';
2040   local $SIG{QUIT} = 'IGNORE';
2041   local $SIG{TERM} = 'IGNORE';
2042   local $SIG{TSTP} = 'IGNORE';
2043   local $SIG{PIPE} = 'IGNORE';
2044
2045   my $oldAutoCommit = $FS::UID::AutoCommit;
2046   local $FS::UID::AutoCommit = 0;
2047   my $dbh = dbh;
2048
2049   my $sql = "UPDATE svc_acct SET $column = ".
2050             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
2051             " $op ? WHERE svcnum = ?";
2052   warn "$me $sql\n"
2053     if $DEBUG;
2054
2055   my $sth = $dbh->prepare( $sql )
2056     or die "Error preparing $sql: ". $dbh->errstr;
2057   my $rv = $sth->execute($amount, $self->svcnum);
2058   die "Error executing $sql: ". $sth->errstr
2059     unless defined($rv);
2060   die "Can't update $column for svcnum". $self->svcnum
2061     if $rv == 0;
2062
2063   #$self->snapshot; #not necessary, we retain the old values
2064   #create an object with the updated usage values
2065   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2066   #call exports
2067   my $error = $new->replace($self);
2068   if ( $error ) {
2069     $dbh->rollback if $oldAutoCommit;
2070     return "Error replacing: $error";
2071   }
2072
2073   #overlimit_action eq 'cancel' handling
2074   my $cust_pkg = $self->cust_svc->cust_pkg;
2075   if ( $cust_pkg
2076        && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
2077        && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
2078      )
2079   {
2080
2081     my $error = $cust_pkg->cancel; #XXX should have a reason
2082     if ( $error ) {
2083       $dbh->rollback if $oldAutoCommit;
2084       return "Error cancelling: $error";
2085     }
2086
2087     #nothing else is relevant if we're cancelling, so commit & return success
2088     warn "$me update successful; committing\n"
2089       if $DEBUG;
2090     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2091     return '';
2092
2093   }
2094
2095   my $action = $op2action{$op};
2096
2097   if ( &{$op2condition{$op}}($self, $column, $amount) &&
2098         ( $action eq 'suspend'   && !$self->overlimit
2099        || $action eq 'unsuspend' &&  $self->overlimit )
2100      ) {
2101
2102     my $error = $self->_op_overlimit($action);
2103     if ( $error ) {
2104       $dbh->rollback if $oldAutoCommit;
2105       return $error;
2106     }
2107
2108   }
2109
2110   if ( $conf->exists("svc_acct-usage_$action")
2111        && &{$op2condition{$op}}($self, $column, $amount)    ) {
2112     #my $error = $self->$action();
2113     my $error = $self->cust_svc->cust_pkg->$action();
2114     # $error ||= $self->overlimit($action);
2115     if ( $error ) {
2116       $dbh->rollback if $oldAutoCommit;
2117       return "Error ${action}ing: $error";
2118     }
2119   }
2120
2121   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
2122     my $wqueue = new FS::queue {
2123       'svcnum' => $self->svcnum,
2124       'job'    => 'FS::svc_acct::reached_threshold',
2125     };
2126
2127     my $to = '';
2128     if ($op eq '-'){
2129       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
2130     }
2131
2132     # x_threshold race
2133     my $error = $wqueue->insert(
2134       'svcnum' => $self->svcnum,
2135       'op'     => $op,
2136       'column' => $column,
2137       'to'     => $to,
2138     );
2139     if ( $error ) {
2140       $dbh->rollback if $oldAutoCommit;
2141       return "Error queuing threshold activity: $error";
2142     }
2143   }
2144
2145   warn "$me update successful; committing\n"
2146     if $DEBUG;
2147   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2148   '';
2149
2150 }
2151
2152 sub _op_overlimit {
2153   my( $self, $action ) = @_;
2154
2155   local $SIG{HUP} = 'IGNORE';
2156   local $SIG{INT} = 'IGNORE';
2157   local $SIG{QUIT} = 'IGNORE';
2158   local $SIG{TERM} = 'IGNORE';
2159   local $SIG{TSTP} = 'IGNORE';
2160   local $SIG{PIPE} = 'IGNORE';
2161
2162   my $oldAutoCommit = $FS::UID::AutoCommit;
2163   local $FS::UID::AutoCommit = 0;
2164   my $dbh = dbh;
2165
2166   my $cust_pkg = $self->cust_svc->cust_pkg;
2167
2168   my $conf_overlimit =
2169     $cust_pkg
2170       ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2171       : $conf->config('overlimit_groups');
2172
2173   foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2174
2175     my $groups = $conf_overlimit || $part_export->option('overlimit_groups');
2176     next unless $groups;
2177
2178     my $gref = &{ $self->_fieldhandlers->{'usergroup'} }( $self, $groups );
2179
2180     my $other = new FS::svc_acct $self->hashref;
2181     $other->usergroup( $gref );
2182
2183     my($new,$old);
2184     if ($action eq 'suspend') {
2185       $new = $other;
2186       $old = $self;
2187     } else { # $action eq 'unsuspend'
2188       $new = $self;
2189       $old = $other;
2190     }
2191
2192     my $error = $part_export->export_replace($new, $old)
2193                 || $self->overlimit($action);
2194
2195     if ( $error ) {
2196       $dbh->rollback if $oldAutoCommit;
2197       return "Error replacing radius groups: $error";
2198     }
2199
2200   }
2201
2202   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2203   '';
2204
2205 }
2206
2207 sub set_usage {
2208   my( $self, $valueref, %options ) = @_;
2209
2210   warn "$me set_usage called for svcnum ". $self->svcnum.
2211        ' ('. $self->email. "): ".
2212        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2213     if $DEBUG;
2214
2215   local $SIG{HUP} = 'IGNORE';
2216   local $SIG{INT} = 'IGNORE';
2217   local $SIG{QUIT} = 'IGNORE';
2218   local $SIG{TERM} = 'IGNORE';
2219   local $SIG{TSTP} = 'IGNORE';
2220   local $SIG{PIPE} = 'IGNORE';
2221
2222   local $FS::svc_Common::noexport_hack = 1;
2223   my $oldAutoCommit = $FS::UID::AutoCommit;
2224   local $FS::UID::AutoCommit = 0;
2225   my $dbh = dbh;
2226
2227   my $reset = 0;
2228   my %handyhash = ();
2229   if ( $options{null} ) {
2230     %handyhash = ( map { ( $_ => undef, $_."_threshold" => undef ) }
2231                    qw( seconds upbytes downbytes totalbytes )
2232                  );
2233   }
2234   foreach my $field (keys %$valueref){
2235     $reset = 1 if $valueref->{$field};
2236     $self->setfield($field, $valueref->{$field});
2237     $self->setfield( $field.'_threshold',
2238                      int($self->getfield($field)
2239                          * ( $conf->exists('svc_acct-usage_threshold')
2240                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
2241                              : 0.20
2242                            )
2243                        )
2244                      );
2245     $handyhash{$field} = $self->getfield($field);
2246     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2247   }
2248   #my $error = $self->replace;   #NO! we avoid the call to ->check for
2249   #die $error if $error;         #services not explicity changed via the UI
2250
2251   my $sql = "UPDATE svc_acct SET " .
2252     join (',', map { "$_ =  ?" } (keys %handyhash) ).
2253     " WHERE svcnum = ". $self->svcnum;
2254
2255   warn "$me $sql\n"
2256     if $DEBUG;
2257
2258   if (scalar(keys %handyhash)) {
2259     my $sth = $dbh->prepare( $sql )
2260       or die "Error preparing $sql: ". $dbh->errstr;
2261     my $rv = $sth->execute(values %handyhash);
2262     die "Error executing $sql: ". $sth->errstr
2263       unless defined($rv);
2264     die "Can't update usage for svcnum ". $self->svcnum
2265       if $rv == 0;
2266   }
2267
2268   #$self->snapshot; #not necessary, we retain the old values
2269   #create an object with the updated usage values
2270   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2271   local($FS::Record::nowarn_identical) = 1;
2272   my $error = $new->replace($self); #call exports
2273   if ( $error ) {
2274     $dbh->rollback if $oldAutoCommit;
2275     return "Error replacing: $error";
2276   }
2277
2278   if ( $reset ) {
2279
2280     my $error = '';
2281
2282     $error = $self->_op_overlimit('unsuspend')
2283       if $self->overlimit;;
2284
2285     $error ||= $self->cust_svc->cust_pkg->unsuspend
2286       if $conf->exists("svc_acct-usage_unsuspend");
2287
2288     if ( $error ) {
2289       $dbh->rollback if $oldAutoCommit;
2290       return "Error unsuspending: $error";
2291     }
2292
2293   }
2294
2295   warn "$me update successful; committing\n"
2296     if $DEBUG;
2297   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2298   '';
2299
2300 }
2301
2302
2303 =item recharge HASHREF
2304
2305   Increments usage columns by the amount specified in HASHREF as
2306   column=>amount pairs.
2307
2308 =cut
2309
2310 sub recharge {
2311   my ($self, $vhash) = @_;
2312
2313   if ( $DEBUG ) {
2314     warn "[$me] recharge called on $self: ". Dumper($self).
2315          "\nwith vhash: ". Dumper($vhash);
2316   }
2317
2318   my $oldAutoCommit = $FS::UID::AutoCommit;
2319   local $FS::UID::AutoCommit = 0;
2320   my $dbh = dbh;
2321   my $error = '';
2322
2323   foreach my $column (keys %$vhash){
2324     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2325   }
2326
2327   if ( $error ) {
2328     $dbh->rollback if $oldAutoCommit;
2329   }else{
2330     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2331   }
2332   return $error;
2333 }
2334
2335 =item is_rechargeable
2336
2337 Returns true if this svc_account can be "recharged" and false otherwise.
2338
2339 =cut
2340
2341 sub is_rechargable {
2342   my $self = shift;
2343   $self->seconds ne ''
2344     || $self->upbytes ne ''
2345     || $self->downbytes ne ''
2346     || $self->totalbytes ne '';
2347 }
2348
2349 =item seconds_since TIMESTAMP
2350
2351 Returns the number of seconds this account has been online since TIMESTAMP,
2352 according to the session monitor (see L<FS::Session>).
2353
2354 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2355 L<Time::Local> and L<Date::Parse> for conversion functions.
2356
2357 =cut
2358
2359 #note: POD here, implementation in FS::cust_svc
2360 sub seconds_since {
2361   my $self = shift;
2362   $self->cust_svc->seconds_since(@_);
2363 }
2364
2365 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2366
2367 Returns the numbers of seconds this account has been online between
2368 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2369 external SQL radacct table, specified via sqlradius export.  Sessions which
2370 started in the specified range but are still open are counted from session
2371 start to the end of the range (unless they are over 1 day old, in which case
2372 they are presumed missing their stop record and not counted).  Also, sessions
2373 which end in the range but started earlier are counted from the start of the
2374 range to session end.  Finally, sessions which start before the range but end
2375 after are counted for the entire range.
2376
2377 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2378 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2379 functions.
2380
2381 =cut
2382
2383 #note: POD here, implementation in FS::cust_svc
2384 sub seconds_since_sqlradacct {
2385   my $self = shift;
2386   $self->cust_svc->seconds_since_sqlradacct(@_);
2387 }
2388
2389 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2390
2391 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2392 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2393 TIMESTAMP_END (exclusive).
2394
2395 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2396 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2397 functions.
2398
2399 =cut
2400
2401 #note: POD here, implementation in FS::cust_svc
2402 sub attribute_since_sqlradacct {
2403   my $self = shift;
2404   $self->cust_svc->attribute_since_sqlradacct(@_);
2405 }
2406
2407 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2408
2409 Returns an array of hash references of this customers login history for the
2410 given time range.  (document this better)
2411
2412 =cut
2413
2414 sub get_session_history {
2415   my $self = shift;
2416   $self->cust_svc->get_session_history(@_);
2417 }
2418
2419 =item last_login_text
2420
2421 Returns text describing the time of last login.
2422
2423 =cut
2424
2425 sub last_login_text {
2426   my $self = shift;
2427   $self->last_login ? ctime($self->last_login) : 'unknown';
2428 }
2429
2430 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2431
2432 =cut
2433
2434 sub get_cdrs {
2435   my($self, $start, $end, %opt ) = @_;
2436
2437   my $did = $self->username; #yup
2438
2439   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2440
2441   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2442
2443   #SELECT $for_update * FROM cdr
2444   #  WHERE calldate >= $start #need a conversion
2445   #    AND calldate <  $end   #ditto
2446   #    AND (    charged_party = "$did"
2447   #          OR charged_party = "$prefix$did" #if length($prefix);
2448   #          OR ( ( charged_party IS NULL OR charged_party = '' )
2449   #               AND
2450   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2451   #             )
2452   #        )
2453   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
2454
2455   my $charged_or_src;
2456   if ( length($prefix) ) {
2457     $charged_or_src =
2458       " AND (    charged_party = '$did'
2459               OR charged_party = '$prefix$did'
2460               OR ( ( charged_party IS NULL OR charged_party = '' )
2461                    AND
2462                    ( src = '$did' OR src = '$prefix$did' )
2463                  )
2464             )
2465       ";
2466   } else {
2467     $charged_or_src =
2468       " AND (    charged_party = '$did'
2469               OR ( ( charged_party IS NULL OR charged_party = '' )
2470                    AND
2471                    src = '$did'
2472                  )
2473             )
2474       ";
2475
2476   }
2477
2478   qsearch(
2479     'select'    => "$for_update *",
2480     'table'     => 'cdr',
2481     'hashref'   => {
2482                      #( freesidestatus IS NULL OR freesidestatus = '' )
2483                      'freesidestatus' => '',
2484                    },
2485     'extra_sql' => $charged_or_src,
2486
2487   );
2488
2489 }
2490
2491 =item radius_groups
2492
2493 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2494
2495 =cut
2496
2497 sub radius_groups {
2498   my $self = shift;
2499   if ( $self->usergroup ) {
2500     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2501       unless ref($self->usergroup) eq 'ARRAY';
2502     #when provisioning records, export callback runs in svc_Common.pm before
2503     #radius_usergroup records can be inserted...
2504     @{$self->usergroup};
2505   } else {
2506     map { $_->groupname }
2507       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2508   }
2509 }
2510
2511 =item clone_suspended
2512
2513 Constructor used by FS::part_export::_export_suspend fallback.  Document
2514 better.
2515
2516 =cut
2517
2518 sub clone_suspended {
2519   my $self = shift;
2520   my %hash = $self->hash;
2521   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2522   new FS::svc_acct \%hash;
2523 }
2524
2525 =item clone_kludge_unsuspend
2526
2527 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2528 better.
2529
2530 =cut
2531
2532 sub clone_kludge_unsuspend {
2533   my $self = shift;
2534   my %hash = $self->hash;
2535   $hash{_password} = '';
2536   new FS::svc_acct \%hash;
2537 }
2538
2539 =item check_password
2540
2541 Checks the supplied password against the (possibly encrypted) password in the
2542 database.  Returns true for a successful authentication, false for no match.
2543
2544 Currently supported encryptions are: classic DES crypt() and MD5
2545
2546 =cut
2547
2548 sub check_password {
2549   my($self, $check_password) = @_;
2550
2551   #remove old-style SUSPENDED kludge, they should be allowed to login to
2552   #self-service and pay up
2553   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2554
2555   if ( $self->_password_encoding eq 'ldap' ) {
2556
2557     my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2558     return $auth->match($check_password);
2559
2560   } elsif ( $self->_password_encoding eq 'crypt' ) {
2561
2562     my $auth = from_crypt Authen::Passphrase $self->_password;
2563     return $auth->match($check_password);
2564
2565   } elsif ( $self->_password_encoding eq 'plain' ) {
2566
2567     return $check_password eq $password;
2568
2569   } else {
2570
2571     #XXX this could be replaced with Authen::Passphrase stuff
2572
2573     if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2574       return 0;
2575     } elsif ( length($password) < 13 ) { #plaintext
2576       $check_password eq $password;
2577     } elsif ( length($password) == 13 ) { #traditional DES crypt
2578       crypt($check_password, $password) eq $password;
2579     } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2580       unix_md5_crypt($check_password, $password) eq $password;
2581     } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2582       warn "Can't check password: Blowfish encryption not yet supported, ".
2583            "svcnum ".  $self->svcnum. "\n";
2584       0;
2585     } else {
2586       warn "Can't check password: Unrecognized encryption for svcnum ".
2587            $self->svcnum. "\n";
2588       0;
2589     }
2590
2591   }
2592
2593 }
2594
2595 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2596
2597 Returns an encrypted password, either by passing through an encrypted password
2598 in the database or by encrypting a plaintext password from the database.
2599
2600 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2601 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2602 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2603 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2604 encryption type is only used if the password is not already encrypted in the
2605 database.
2606
2607 =cut
2608
2609 sub crypt_password {
2610   my $self = shift;
2611
2612   if ( $self->_password_encoding eq 'ldap' ) {
2613
2614     if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2615       my $plain = $2;
2616
2617       #XXX this could be replaced with Authen::Passphrase stuff
2618
2619       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2620       if ( $encryption eq 'crypt' ) {
2621         crypt(
2622           $self->_password,
2623           $saltset[int(rand(64))].$saltset[int(rand(64))]
2624         );
2625       } elsif ( $encryption eq 'md5' ) {
2626         unix_md5_crypt( $self->_password );
2627       } elsif ( $encryption eq 'blowfish' ) {
2628         croak "unknown encryption method $encryption";
2629       } else {
2630         croak "unknown encryption method $encryption";
2631       }
2632
2633     } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2634       $1;
2635     }
2636
2637   } elsif ( $self->_password_encoding eq 'crypt' ) {
2638
2639     return $self->_password;
2640
2641   } elsif ( $self->_password_encoding eq 'plain' ) {
2642
2643     #XXX this could be replaced with Authen::Passphrase stuff
2644
2645     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2646     if ( $encryption eq 'crypt' ) {
2647       crypt(
2648         $self->_password,
2649         $saltset[int(rand(64))].$saltset[int(rand(64))]
2650       );
2651     } elsif ( $encryption eq 'md5' ) {
2652       unix_md5_crypt( $self->_password );
2653     } elsif ( $encryption eq 'blowfish' ) {
2654       croak "unknown encryption method $encryption";
2655     } else {
2656       croak "unknown encryption method $encryption";
2657     }
2658
2659   } else {
2660
2661     if ( length($self->_password) == 13
2662          || $self->_password =~ /^\$(1|2a?)\$/
2663          || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2664        )
2665     {
2666       $self->_password;
2667     } else {
2668
2669       #XXX this could be replaced with Authen::Passphrase stuff
2670
2671       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2672       if ( $encryption eq 'crypt' ) {
2673         crypt(
2674           $self->_password,
2675           $saltset[int(rand(64))].$saltset[int(rand(64))]
2676         );
2677       } elsif ( $encryption eq 'md5' ) {
2678         unix_md5_crypt( $self->_password );
2679       } elsif ( $encryption eq 'blowfish' ) {
2680         croak "unknown encryption method $encryption";
2681       } else {
2682         croak "unknown encryption method $encryption";
2683       }
2684
2685     }
2686
2687   }
2688
2689 }
2690
2691 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2692
2693 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2694 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2695 "{MD5}5426824942db4253f87a1009fd5d2d4".
2696
2697 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2698 to work the same as the B</crypt_password> method.
2699
2700 =cut
2701
2702 sub ldap_password {
2703   my $self = shift;
2704   #eventually should check a "password-encoding" field
2705
2706   if ( $self->_password_encoding eq 'ldap' ) {
2707
2708     return $self->_password;
2709
2710   } elsif ( $self->_password_encoding eq 'crypt' ) {
2711
2712     if ( length($self->_password) == 13 ) { #crypt
2713       return '{CRYPT}'. $self->_password;
2714     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2715       return '{MD5}'. $1;
2716     #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2717     #  die "Blowfish encryption not supported in this context, svcnum ".
2718     #      $self->svcnum. "\n";
2719     } else {
2720       warn "encryption method not (yet?) supported in LDAP context";
2721       return '{CRYPT}*'; #unsupported, should not auth
2722     }
2723
2724   } elsif ( $self->_password_encoding eq 'plain' ) {
2725
2726     return '{PLAIN}'. $self->_password;
2727
2728     #return '{CLEARTEXT}'. $self->_password; #?
2729
2730   } else {
2731
2732     if ( length($self->_password) == 13 ) { #crypt
2733       return '{CRYPT}'. $self->_password;
2734     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2735       return '{MD5}'. $1;
2736     } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2737       warn "Blowfish encryption not supported in this context, svcnum ".
2738           $self->svcnum. "\n";
2739       return '{CRYPT}*';
2740
2741     #are these two necessary anymore?
2742     } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2743       return '{SSHA}'. $1;
2744     } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2745       return '{NS-MTA-MD5}'. $1;
2746
2747     } else { #plaintext
2748       return '{PLAIN}'. $self->_password;
2749
2750       #return '{CLEARTEXT}'. $self->_password; #?
2751
2752       #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2753       #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2754       #if ( $encryption eq 'crypt' ) {
2755       #  return '{CRYPT}'. crypt(
2756       #    $self->_password,
2757       #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2758       #  );
2759       #} elsif ( $encryption eq 'md5' ) {
2760       #  unix_md5_crypt( $self->_password );
2761       #} elsif ( $encryption eq 'blowfish' ) {
2762       #  croak "unknown encryption method $encryption";
2763       #} else {
2764       #  croak "unknown encryption method $encryption";
2765       #}
2766     }
2767
2768   }
2769
2770 }
2771
2772 =item domain_slash_username
2773
2774 Returns $domain/$username/
2775
2776 =cut
2777
2778 sub domain_slash_username {
2779   my $self = shift;
2780   $self->domain. '/'. $self->username. '/';
2781 }
2782
2783 =item virtual_maildir
2784
2785 Returns $domain/maildirs/$username/
2786
2787 =cut
2788
2789 sub virtual_maildir {
2790   my $self = shift;
2791   $self->domain. '/maildirs/'. $self->username. '/';
2792 }
2793
2794 =back
2795
2796 =head1 CLASS METHODS
2797
2798 =over 4
2799
2800 =item search HASHREF
2801
2802 Class method which returns a qsearch hash expression to search for parameters
2803 specified in HASHREF.  Valid parameters are
2804
2805 =over 4
2806
2807 =item domain
2808
2809 =item domsvc
2810
2811 =item unlinked
2812
2813 =item agentnum
2814
2815 =item pkgpart
2816
2817 Arrayref of pkgparts
2818
2819 =item pkgpart
2820
2821 =item where
2822
2823 Arrayref of additional WHERE clauses, will be ANDed together.
2824
2825 =item order_by
2826
2827 =item cust_fields
2828
2829 =back
2830
2831 =cut
2832
2833 sub search {
2834   my ($class, $params) = @_;
2835
2836   my @where = ();
2837
2838   # domain
2839   if ( $params->{'domain'} ) {
2840     my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2841     #preserve previous behavior & bubble up an error if $svc_domain not found?
2842     push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2843   }
2844
2845   # domsvc
2846   if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2847     push @where, "domsvc = $1";
2848   }
2849
2850   #unlinked
2851   push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2852
2853   #agentnum
2854   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2855     push @where, "agentnum = $1";
2856   }
2857
2858   #custnum
2859   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2860     push @where, "custnum = $1";
2861   }
2862
2863   #pkgpart
2864   if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2865     #XXX untaint or sql quote
2866     push @where,
2867       'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2868   }
2869
2870   # popnum
2871   if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2872     push @where, "popnum = $1";
2873   }
2874
2875   # svcpart
2876   if ( $params->{'svcpart'} =~ /^(\d+)$/ ) {
2877     push @where, "svcpart = $1";
2878   }
2879
2880
2881   # here is the agent virtualization
2882   #if ($params->{CurrentUser}) {
2883   #  my $access_user =
2884   #    qsearchs('access_user', { username => $params->{CurrentUser} });
2885   #
2886   #  if ($access_user) {
2887   #    push @where, $access_user->agentnums_sql('table'=>'cust_main');
2888   #  }else{
2889   #    push @where, "1=0";
2890   #  }
2891   #} else {
2892     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2893                    'table'      => 'cust_main',
2894                    'null_right' => 'View/link unlinked services',
2895                  );
2896   #}
2897
2898   push @where, @{ $params->{'where'} } if $params->{'where'};
2899
2900   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2901
2902   my $addl_from = ' LEFT JOIN cust_svc  USING ( svcnum  ) '.
2903                   ' LEFT JOIN part_svc  USING ( svcpart ) '.
2904                   ' LEFT JOIN cust_pkg  USING ( pkgnum  ) '.
2905                   ' LEFT JOIN cust_main USING ( custnum ) ';
2906
2907   my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2908   #if ( keys %svc_acct ) {
2909   #  $count_query .= ' WHERE '.
2910   #                    join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2911   #                                      keys %svc_acct
2912   #                        );
2913   #}
2914
2915   my $sql_query = {
2916     'table'       => 'svc_acct',
2917     'hashref'     => {}, # \%svc_acct,
2918     'select'      => join(', ',
2919                        'svc_acct.*',
2920                        'part_svc.svc',
2921                        'cust_main.custnum',
2922                        FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2923                      ),
2924     'addl_from'   => $addl_from,
2925     'extra_sql'   => $extra_sql,
2926     'order_by'    => $params->{'order_by'},
2927     'count_query' => $count_query,
2928   };
2929
2930 }
2931
2932 =back
2933
2934 =head1 SUBROUTINES
2935
2936 =over 4
2937
2938 =item send_email
2939
2940 This is the FS::svc_acct job-queue-able version.  It still uses
2941 FS::Misc::send_email under-the-hood.
2942
2943 =cut
2944
2945 sub send_email {
2946   my %opt = @_;
2947
2948   eval "use FS::Misc qw(send_email)";
2949   die $@ if $@;
2950
2951   $opt{mimetype} ||= 'text/plain';
2952   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2953
2954   my $error = send_email(
2955     'from'         => $opt{from},
2956     'to'           => $opt{to},
2957     'subject'      => $opt{subject},
2958     'content-type' => $opt{mimetype},
2959     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2960   );
2961   die $error if $error;
2962 }
2963
2964 =item check_and_rebuild_fuzzyfiles
2965
2966 =cut
2967
2968 sub check_and_rebuild_fuzzyfiles {
2969   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2970   -e "$dir/svc_acct.username"
2971     or &rebuild_fuzzyfiles;
2972 }
2973
2974 =item rebuild_fuzzyfiles
2975
2976 =cut
2977
2978 sub rebuild_fuzzyfiles {
2979
2980   use Fcntl qw(:flock);
2981
2982   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2983
2984   #username
2985
2986   open(USERNAMELOCK,">>$dir/svc_acct.username")
2987     or die "can't open $dir/svc_acct.username: $!";
2988   flock(USERNAMELOCK,LOCK_EX)
2989     or die "can't lock $dir/svc_acct.username: $!";
2990
2991   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2992
2993   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2994     or die "can't open $dir/svc_acct.username.tmp: $!";
2995   print USERNAMECACHE join("\n", @all_username), "\n";
2996   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2997
2998   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2999   close USERNAMELOCK;
3000
3001 }
3002
3003 =item all_username
3004
3005 =cut
3006
3007 sub all_username {
3008   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3009   open(USERNAMECACHE,"<$dir/svc_acct.username")
3010     or die "can't open $dir/svc_acct.username: $!";
3011   my @array = map { chomp; $_; } <USERNAMECACHE>;
3012   close USERNAMECACHE;
3013   \@array;
3014 }
3015
3016 =item append_fuzzyfiles USERNAME
3017
3018 =cut
3019
3020 sub append_fuzzyfiles {
3021   my $username = shift;
3022
3023   &check_and_rebuild_fuzzyfiles;
3024
3025   use Fcntl qw(:flock);
3026
3027   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3028
3029   open(USERNAME,">>$dir/svc_acct.username")
3030     or die "can't open $dir/svc_acct.username: $!";
3031   flock(USERNAME,LOCK_EX)
3032     or die "can't lock $dir/svc_acct.username: $!";
3033
3034   print USERNAME "$username\n";
3035
3036   flock(USERNAME,LOCK_UN)
3037     or die "can't unlock $dir/svc_acct.username: $!";
3038   close USERNAME;
3039
3040   1;
3041 }
3042
3043
3044
3045 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
3046
3047 =cut
3048
3049 sub radius_usergroup_selector {
3050   my $sel_groups = shift;
3051   my %sel_groups = map { $_=>1 } @$sel_groups;
3052
3053   my $selectname = shift || 'radius_usergroup';
3054
3055   my $dbh = dbh;
3056   my $sth = $dbh->prepare(
3057     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
3058   ) or die $dbh->errstr;
3059   $sth->execute() or die $sth->errstr;
3060   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
3061
3062   my $html = <<END;
3063     <SCRIPT>
3064     function ${selectname}_doadd(object) {
3065       var myvalue = object.${selectname}_add.value;
3066       var optionName = new Option(myvalue,myvalue,false,true);
3067       var length = object.$selectname.length;
3068       object.$selectname.options[length] = optionName;
3069       object.${selectname}_add.value = "";
3070     }
3071     </SCRIPT>
3072     <SELECT MULTIPLE NAME="$selectname">
3073 END
3074
3075   foreach my $group ( @all_groups ) {
3076     $html .= qq(<OPTION VALUE="$group");
3077     if ( $sel_groups{$group} ) {
3078       $html .= ' SELECTED';
3079       $sel_groups{$group} = 0;
3080     }
3081     $html .= ">$group</OPTION>\n";
3082   }
3083   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
3084     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
3085   };
3086   $html .= '</SELECT>';
3087
3088   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
3089            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
3090
3091   $html;
3092 }
3093
3094 =item reached_threshold
3095
3096 Performs some activities when svc_acct thresholds (such as number of seconds
3097 remaining) are reached.
3098
3099 =cut
3100
3101 sub reached_threshold {
3102   my %opt = @_;
3103
3104   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
3105   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
3106
3107   if ( $opt{'op'} eq '+' ){
3108     $svc_acct->setfield( $opt{'column'}.'_threshold',
3109                          int($svc_acct->getfield($opt{'column'})
3110                              * ( $conf->exists('svc_acct-usage_threshold')
3111                                  ? $conf->config('svc_acct-usage_threshold')/100
3112                                  : 0.80
3113                                )
3114                          )
3115                        );
3116     my $error = $svc_acct->replace;
3117     die $error if $error;
3118   }elsif ( $opt{'op'} eq '-' ){
3119
3120     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
3121     return '' if ($threshold eq '' );
3122
3123     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
3124     my $error = $svc_acct->replace;
3125     die $error if $error; # email next time, i guess
3126
3127     if ( $warning_template ) {
3128       eval "use FS::Misc qw(send_email)";
3129       die $@ if $@;
3130
3131       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
3132       my $cust_main = $cust_pkg->cust_main;
3133
3134       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
3135                                $cust_main->invoicing_list,
3136                                ($opt{'to'} ? $opt{'to'} : ())
3137                    );
3138
3139       my $mimetype = $warning_mimetype;
3140       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3141
3142       my $body       =  $warning_template->fill_in( HASH => {
3143                         'custnum'   => $cust_main->custnum,
3144                         'username'  => $svc_acct->username,
3145                         'password'  => $svc_acct->_password,
3146                         'first'     => $cust_main->first,
3147                         'last'      => $cust_main->getfield('last'),
3148                         'pkg'       => $cust_pkg->part_pkg->pkg,
3149                         'column'    => $opt{'column'},
3150                         'amount'    => $opt{'column'} =~/bytes/
3151                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3152                                        : $svc_acct->getfield($opt{'column'}),
3153                         'threshold' => $opt{'column'} =~/bytes/
3154                                        ? FS::UI::bytecount::display_bytecount($threshold)
3155                                        : $threshold,
3156                       } );
3157
3158
3159       my $error = send_email(
3160         'from'         => $warning_from,
3161         'to'           => $to,
3162         'subject'      => $warning_subject,
3163         'content-type' => $mimetype,
3164         'body'         => [ map "$_\n", split("\n", $body) ],
3165       );
3166       die $error if $error;
3167     }
3168   }else{
3169     die "unknown op: " . $opt{'op'};
3170   }
3171 }
3172
3173 =back
3174
3175 =head1 BUGS
3176
3177 The $recref stuff in sub check should be cleaned up.
3178
3179 The suspend, unsuspend and cancel methods update the database, but not the
3180 current object.  This is probably a bug as it's unexpected and
3181 counterintuitive.
3182
3183 radius_usergroup_selector?  putting web ui components in here?  they should
3184 probably live somewhere else...
3185
3186 insertion of RADIUS group stuff in insert could be done with child_objects now
3187 (would probably clean up export of them too)
3188
3189 _op_usage and set_usage bypass the history... maybe they shouldn't
3190
3191 =head1 SEE ALSO
3192
3193 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3194 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3195 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3196 L<freeside-queued>), L<FS::svc_acct_pop>,
3197 schema.html from the base documentation.
3198
3199 =cut
3200
3201 1;