FS/FS/svc_acct.pm

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