FS/FS/svc_acct.pm

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