FS/FS/svc_acct.pm

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