FS/FS/svc_acct.pm

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