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