FS/FS/UI/Web.pm

   1 package FS::UI::Web;
   2
   3 use strict;
   4 use vars qw($DEBUG @ISA @EXPORT_OK $me);
   5 use Exporter;
   6 use Carp qw( confess );
   7 use HTML::Entities;
   8 use FS::Conf;
   9 use FS::Misc::DateTime qw( parse_datetime day_end );
  10 use FS::Record qw(dbdef);
  11 use FS::cust_main;  # are sql_balance and sql_date_balance in the right module?
  12
  13 #use vars qw(@ISA);
  14 #use FS::UI
  15 #@ISA = qw( FS::UI );
  16 @ISA = qw( Exporter );
  17
  18 @EXPORT_OK = qw( get_page_pref set_page_pref svc_url random_id );
  19
  20 $DEBUG = 0;
  21 $me = '[FS::UID::Web]';
  22
  23 our $NO_RANDOM_IDS;
  24
  25 ###
  26 # user prefs
  27 ###
  28
  29 =item get_page_pref NAME, TABLENUM
  30
  31 Returns the user's page preference named NAME for the current page. If the
  32 page is a view or edit page or otherwise shows a single record at a time,
  33 it should use TABLENUM to link the preference to that record.
  34
  35 =cut
  36
  37 sub get_page_pref {
  38   my ($prefname, $tablenum) = @_;
  39
  40   my $m = $HTML::Mason::Commands::m
  41     or die "can't get page pref when running outside the UI";
  42   # what's more useful: to tie prefs to the base_comp (usually where
  43   # code is executing right now), or to the request_comp (approximately the
  44   # one in the URL)? not sure.
  45   $FS::CurrentUser::CurrentUser->get_page_pref( $m->request_comp->path,
  46                                                 $prefname,
  47                                                 $tablenum
  48                                               );
  49 }
  50
  51 =item set_page_pref NAME, TABLENUM, VALUE
  52
  53 Sets the user's page preference named NAME for the current page. Use TABLENUM
  54 as for get_page_pref.
  55
  56 If VALUE is an empty string, the preference will be deleted (and
  57 C<get_page_pref> will return an empty string).
  58
  59   my $mypref = set_page_pref('mypref', '', 100);
  60
  61 =cut
  62
  63 sub set_page_pref {
  64   my ($prefname, $tablenum, $prefvalue) = @_;
  65
  66   my $m = $HTML::Mason::Commands::m
  67     or die "can't set page pref when running outside the UI";
  68   $FS::CurrentUser::CurrentUser->set_page_pref( $m->request_comp->path,
  69                                                 $prefname,
  70                                                 $tablenum,
  71                                                 $prefvalue );
  72 }
  73
  74 ###
  75 # date parsing
  76 ###
  77
  78 =item parse_beginning_ending CGI [, PREFIX ]
  79
  80 Parses a beginning/ending date range, as used on many reports. This function
  81 recognizes two sets of CGI params: "begin" and "end", the integer timestamp
  82 values, and "beginning" and "ending", the user-readable date fields.
  83
  84 If "begin" contains an integer, that's passed through as the beginning date.
  85 Otherwise, "beginning" is passed to L<DateTime::Format::Natural> and turned
  86 into an integer. If this fails or it doesn't have a value, zero is used as the
  87 beginning date.
  88
  89 The same happens for "end" and "ending", except that if "ending" contains a
  90 date without a time, it gets moved to the end of that day, and if there's no
  91 value, the value returned is the highest unsigned 32-bit time value (some time
  92 in 2037).
  93
  94 PREFIX is optionally a string to prepend (with '_' as a delimiter) to the form
  95 field names.
  96
  97 =cut
  98
  99 use Date::Parse;
 100 sub parse_beginning_ending {
 101   my($cgi, $prefix) = @_;
 102   $prefix .= '_' if $prefix;
 103
 104   my $beginning = 0;
 105   if ( $cgi->param($prefix.'begin') =~ /^(\d+)$/ ) {
 106     $beginning = $1;
 107   } elsif ( $cgi->param($prefix.'beginning') =~ /^([ 0-9\-\/\:]{1,64})$/ ) {
 108     $beginning = parse_datetime($1) || 0;
 109   }
 110
 111   my $ending = 4294967295; #2^32-1
 112   if ( $cgi->param($prefix.'end') =~ /^(\d+)$/ ) {
 113     $ending = $1 - 1;
 114   } elsif ( $cgi->param($prefix.'ending') =~ /^([ 0-9\-\/\:]{1,64})$/ ) {
 115     $ending = parse_datetime($1);
 116     $ending = day_end($ending) unless $ending =~ /:/;
 117   }
 118
 119   ( $beginning, $ending );
 120 }
 121
 122 =item svc_url
 123
 124 Returns a service URL, first checking to see if there is a service-specific
 125 page to link to, otherwise to a generic service handling page.  Options are
 126 passed as a list of name-value pairs, and include:
 127
 128 =over 4
 129
 130 =item * m - Mason request object ($m)
 131
 132 =item * action - The action for which to construct "edit", "view", or "search"
 133
 134 =item ** part_svc - Service definition (see L<FS::part_svc>)
 135
 136 =item ** svcdb - Service table
 137
 138 =item *** query - Query string
 139
 140 =item *** svc   - FS::cust_svc or FS::svc_* object
 141
 142 =item ahref - Optional flag, if set true returns <A HREF="$url"> instead of just the URL.
 143
 144 =back
 145
 146 * Required fields
 147
 148 ** part_svc OR svcdb is required
 149
 150 *** query OR svc is required
 151
 152 =cut
 153
 154   # ##
 155   # #required
 156   # ##
 157   #  'm'        => $m, #mason request object
 158   #  'action'   => 'edit', #or 'view'
 159   #
 160   #  'part_svc' => $part_svc, #usual
 161   #   #OR
 162   #  'svcdb'    => 'svc_table',
 163   #
 164   #  'query'    => #optional query string
 165   #                # (pass a blank string if you want a "raw" URL to add your
 166   #                #  own svcnum to)
 167   #   #OR
 168   #  'svc'      => $svc_x, #or $cust_svc, it just needs a svcnum
 169   #
 170   # ##
 171   # #optional
 172   # ##
 173   #  'ahref'    => 1, # if set true, returns <A HREF="$url">
 174
 175 use FS::CGI qw(rooturl);
 176 sub svc_url {
 177   my %opt = @_;
 178
 179   #? return '' unless ref($opt{part_svc});
 180
 181   my $svcdb = $opt{svcdb} || $opt{part_svc}->svcdb;
 182   my $query = exists($opt{query}) ? $opt{query} : $opt{svc}->svcnum;
 183   my $url;
 184   warn "$me [svc_url] checking for /$opt{action}/$svcdb.cgi component"
 185     if $DEBUG;
 186   if ( $opt{m}->interp->comp_exists("/$opt{action}/$svcdb.cgi") ) {
 187     $url = "$svcdb.cgi?";
 188   } elsif ( $opt{m}->interp->comp_exists("/$opt{action}/$svcdb.html") ) {
 189     $url = "$svcdb.html?";
 190   } else {
 191     my $generic = $opt{action} eq 'search' ? 'cust_svc' : 'svc_Common';
 192
 193     $url = "$generic.html?svcdb=$svcdb;";
 194     $url .= 'svcnum=' if $query =~ /^\d+(;|$)/ or $query eq '';
 195   }
 196
 197   my $return = FS::CGI::rooturl(). "$opt{action}/$url$query";
 198
 199   $return = qq!<A HREF="$return">! if $opt{ahref};
 200
 201   $return;
 202 }
 203
 204 sub svc_link {
 205   my($m, $part_svc, $cust_svc) = @_ or return '';
 206   svc_X_link( $part_svc->svc, @_ );
 207 }
 208
 209 sub svc_label_link {
 210   my($m, $part_svc, $cust_svc) = @_ or return '';
 211   my($svc, $label, $svcdb) = $cust_svc->label;
 212   svc_X_link( $label, @_ );
 213 }
 214
 215 sub svc_X_link {
 216   my ($x, $m, $part_svc, $cust_svc) = @_ or return '';
 217
 218   return $x
 219    unless $FS::CurrentUser::CurrentUser->access_right('View customer services');
 220
 221   confess "svc_X_link called without a service ($x, $m, $part_svc, $cust_svc)\n"
 222     unless $cust_svc;
 223
 224   my $ahref = svc_url(
 225     'ahref'    => 1,
 226     'm'        => $m,
 227     'action'   => 'view',
 228     'part_svc' => $part_svc,
 229     'svc'      => $cust_svc,
 230   );
 231
 232   "$ahref$x</A>";
 233 }
 234
 235 #this probably needs an ACL too...
 236 sub svc_export_links {
 237   my ($m, $part_svc, $cust_svc) = @_ or return '';
 238
 239   my $ahref = $cust_svc->export_links;
 240
 241   join('', @$ahref);
 242 }
 243
 244 sub parse_lt_gt {
 245   my($cgi, $field) = (shift, shift);
 246   my $table = ( @_ && length($_[0]) ) ? shift.'.' : '';
 247
 248   my @search = ();
 249
 250   my %op = (
 251     'lt' => '<',
 252     'gt' => '>',
 253   );
 254
 255   foreach my $op (keys %op) {
 256
 257     warn "checking for ${field}_$op field\n"
 258       if $DEBUG;
 259
 260     if ( $cgi->param($field."_$op") =~ /^\s*\$?\s*(-?[\d\,\s]+(\.\d\d)?)\s*$/ ) {
 261
 262       my $num = $1;
 263       $num =~ s/[\,\s]+//g;
 264       my $search = "$table$field $op{$op} $num";
 265       push @search, $search;
 266
 267       warn "found ${field}_$op field; adding search element $search\n"
 268         if $DEBUG;
 269     }
 270
 271   }
 272
 273   @search;
 274
 275 }
 276
 277 ###
 278 # cust_main report subroutines
 279 ###
 280
 281 =over 4
 282
 283 =item cust_header [ CUST_FIELDS_VALUE ]
 284
 285 Returns an array of customer information headers according to the supplied
 286 customer fields value, or if no value is supplied, the B<cust-fields>
 287 configuration value.
 288
 289 =cut
 290
 291 use vars qw( @cust_fields @cust_colors @cust_styles @cust_aligns );
 292
 293 sub cust_header {
 294
 295   warn "FS::UI:Web::cust_header called"
 296     if $DEBUG;
 297
 298   my $conf = new FS::Conf;
 299
 300   my %header2method = (
 301     'Customer'                 => 'name',
 302     'Cust. Status'             => 'cust_status_label',
 303     'Cust#'                    => 'custnum',
 304     'Name'                     => 'contact',
 305     'Company'                  => 'company',
 306
 307     # obsolete but might still be referenced in configuration
 308     '(bill) Customer'          => 'name',
 309     '(service) Customer'       => 'ship_name',
 310     '(bill) Name'              => 'contact',
 311     '(service) Name'           => 'ship_contact',
 312     '(bill) Company'           => 'company',
 313     '(service) Company'        => 'ship_company',
 314     '(bill) Day phone'         => 'daytime',
 315     '(bill) Night phone'       => 'night',
 316     '(bill) Fax number'        => 'fax',
 317
 318     'Customer'                 => 'name',
 319     'Address 1'                => 'bill_address1',
 320     'Address 2'                => 'bill_address2',
 321     'City'                     => 'bill_city',
 322     'State'                    => 'bill_state',
 323     'Zip'                      => 'bill_zip',
 324     'Country'                  => 'bill_country_full',
 325     'Day phone'                => 'daytime', # XXX should use msgcat, but how?
 326     'Night phone'              => 'night',   # XXX should use msgcat, but how?
 327     'Mobile phone'             => 'mobile',  # XXX should use msgcat, but how?
 328     'Fax number'               => 'fax',
 329     '(bill) Address 1'         => 'bill_address1',
 330     '(bill) Address 2'         => 'bill_address2',
 331     '(bill) City'              => 'bill_city',
 332     '(bill) State'             => 'bill_state',
 333     '(bill) Zip'               => 'bill_zip',
 334     '(bill) Country'           => 'bill_country_full',
 335     '(bill) Latitude'          => 'bill_latitude',
 336     '(bill) Longitude'         => 'bill_longitude',
 337     '(service) Address 1'      => 'ship_address1',
 338     '(service) Address 2'      => 'ship_address2',
 339     '(service) City'           => 'ship_city',
 340     '(service) State'          => 'ship_state',
 341     '(service) Zip'            => 'ship_zip',
 342     '(service) Country'        => 'ship_country_full',
 343     '(service) Latitude'       => 'ship_latitude',
 344     '(service) Longitude'      => 'ship_longitude',
 345     'Invoicing email(s)'       => 'invoicing_list_emailonly_scalar',
 346 # FS::Upgrade::upgrade_config removes this from existing cust-fields settings
 347 #    'Payment Type'             => 'cust_payby',
 348     'Current Balance'          => 'current_balance',
 349     'Agent Cust#'              => 'agent_custid',
 350     'Advertising Source'       => 'referral',
 351   );
 352   $header2method{'Cust#'} = 'display_custnum'
 353     if $conf->exists('cust_main-default_agent_custid');
 354
 355   my %header2colormethod = (
 356     'Cust. Status' => 'cust_statuscolor',
 357   );
 358   my %header2style = (
 359     'Cust. Status' => 'b',
 360   );
 361   my %header2align = (
 362     'Cust. Status' => 'c',
 363     'Cust#'        => 'r',
 364   );
 365
 366   my $cust_fields;
 367   my @cust_header;
 368   if ( @_ && $_[0] ) {
 369
 370     warn "  using supplied cust-fields override".
 371           " (ignoring cust-fields config file)"
 372       if $DEBUG;
 373     $cust_fields = shift;
 374
 375   } else {
 376
 377     if (    $conf->exists('cust-fields')
 378          && $conf->config('cust-fields') =~ /^([\w\. \|\#\(\)]+):?/
 379        )
 380     {
 381       warn "  found cust-fields configuration value"
 382         if $DEBUG;
 383       $cust_fields = $1;
 384     } else {
 385       warn "  no cust-fields configuration value found; using default 'Cust. Status | Customer'"
 386         if $DEBUG;
 387       $cust_fields = 'Cust. Status | Customer';
 388     }
 389
 390   }
 391
 392   @cust_header = split(/ \| /, $cust_fields);
 393   @cust_fields = map { $header2method{$_} || $_ } @cust_header;
 394   @cust_colors = map { exists $header2colormethod{$_}
 395                          ? $header2colormethod{$_}
 396                          : ''
 397                      }
 398                      @cust_header;
 399   @cust_styles = map { exists $header2style{$_} ? $header2style{$_} : '' }
 400                      @cust_header;
 401   @cust_aligns = map { exists $header2align{$_} ? $header2align{$_} : 'l' }
 402                      @cust_header;
 403
 404   #my $svc_x = shift;
 405   @cust_header;
 406 }
 407
 408 sub cust_sort_fields {
 409   cust_header(@_) if( @_ or !@cust_fields );
 410   #inefficientish, but tiny lists and only run once per page
 411
 412   map { $_ eq 'custnum' ? 'custnum' : '' } @cust_fields;
 413
 414 }
 415
 416 =item cust_sql_fields [ CUST_FIELDS_VALUE ]
 417
 418 Returns a list of fields for the SELECT portion of an SQL query.
 419
 420 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 421 defined by the supplied customer fields setting, or if no customer fields
 422 setting is supplied, the <B>cust-fields</B> configuration value.
 423
 424 =cut
 425
 426 sub cust_sql_fields {
 427
 428   my @fields = qw( last first company );
 429 #  push @fields, map "ship_$_", @fields;
 430
 431   cust_header(@_) if( @_ or !@cust_fields );
 432   #inefficientish, but tiny lists and only run once per page
 433
 434   my @location_fields;
 435   foreach my $field (qw( address1 address2 city state zip latitude longitude )) {
 436     foreach my $pre ('bill_','ship_') {
 437       if ( grep { $_ eq $pre.$field } @cust_fields ) {
 438         push @location_fields, $pre.'location.'.$field.' AS '.$pre.$field;
 439       }
 440     }
 441   }
 442   foreach my $pre ('bill_','ship_') {
 443     if ( grep { $_ eq $pre.'country_full' } @cust_fields ) {
 444       push @location_fields, $pre.'locationnum';
 445     }
 446   }
 447
 448   foreach my $field (qw(daytime night mobile fax )) {
 449     push @fields, $field if (grep { $_ eq $field } @cust_fields);
 450   }
 451   push @fields, 'agent_custid';
 452
 453   my @extra_fields = ();
 454   if (grep { $_ eq 'current_balance' } @cust_fields) {
 455     push @extra_fields, FS::cust_main->balance_sql . " AS current_balance";
 456   }
 457
 458   push @extra_fields, 'part_referral_x.referral AS referral'
 459     if grep { $_ eq 'referral' } @cust_fields;
 460
 461   map("cust_main.$_", @fields), @location_fields, @extra_fields;
 462 }
 463
 464 =item join_cust_main [ TABLE[.CUSTNUM] ] [ LOCATION_TABLE[.LOCATIONNUM] ]
 465
 466 Returns an SQL join phrase for the FROM clause so that the fields listed
 467 in L<cust_sql_fields> will be available.  Currently joins to cust_main
 468 itself, as well as cust_location (under the aliases 'bill_location' and
 469 'ship_location') if address fields are needed.  L<cust_header()> should have
 470 been called already.
 471
 472 All of these will be left joins; if you want to exclude rows with no linked
 473 cust_main record (or bill_location/ship_location), you can do so in the
 474 WHERE clause.
 475
 476 TABLE is the table containing the custnum field.  If CUSTNUM (a field name
 477 in that table) is specified, that field will be joined to cust_main.custnum.
 478 Otherwise, this function will assume the field is named "custnum".  If the
 479 argument isn't present at all, the join will just say "USING (custnum)",
 480 which might work.
 481
 482 As a special case, if TABLE is 'cust_main', only the joins to cust_location
 483 will be returned.
 484
 485 LOCATION_TABLE is an optional table name to use for joining ship_location,
 486 in case your query also includes package information and you want the
 487 "service address" columns to reflect package addresses.
 488
 489 =cut
 490
 491 sub join_cust_main {
 492   my ($cust_table, $location_table) = @_;
 493   my ($custnum, $locationnum);
 494   ($cust_table, $custnum) = split(/\./, $cust_table);
 495   $custnum ||= 'custnum';
 496   ($location_table, $locationnum) = split(/\./, $location_table);
 497   $locationnum ||= 'locationnum';
 498
 499   my $sql = '';
 500   if ( $cust_table ) {
 501     $sql = " LEFT JOIN cust_main ON (cust_main.custnum = $cust_table.$custnum)"
 502       unless $cust_table eq 'cust_main';
 503   } else {
 504     $sql = " LEFT JOIN cust_main USING (custnum)";
 505   }
 506
 507   if ( !@cust_fields or grep /^bill_/, @cust_fields ) {
 508
 509     $sql .= ' LEFT JOIN cust_location bill_location'.
 510             ' ON (bill_location.locationnum = cust_main.bill_locationnum)';
 511
 512   }
 513
 514   if ( !@cust_fields or grep /^ship_/, @cust_fields ) {
 515
 516     if (!$location_table) {
 517       $location_table = 'cust_main';
 518       $locationnum = 'ship_locationnum';
 519     }
 520
 521     $sql .= ' LEFT JOIN cust_location ship_location'.
 522             " ON (ship_location.locationnum = $location_table.$locationnum) ";
 523   }
 524
 525   if ( !@cust_fields or grep { $_ eq 'referral' } @cust_fields ) {
 526     $sql .= ' LEFT JOIN (select refnum, referral from part_referral) AS part_referral_x ON (cust_main.refnum = part_referral_x.refnum) ';
 527   }
 528
 529   $sql;
 530 }
 531
 532 =item cust_fields OBJECT [ CUST_FIELDS_VALUE ]
 533
 534 Given an object that contains fields from cust_main (say, from a
 535 JOINed search.  See httemplate/search/svc_* for examples), returns an array
 536 of customer information, or "(unlinked)" if this service is not linked to a
 537 customer.
 538
 539 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 540 defined by the supplied customer fields setting, or if no customer fields
 541 setting is supplied, the <B>cust-fields</B> configuration value.
 542
 543 =cut
 544
 545
 546 sub cust_fields {
 547   my $record = shift;
 548   warn "FS::UI::Web::cust_fields called for $record ".
 549        "(cust_fields: @cust_fields)"
 550     if $DEBUG > 1;
 551
 552   #cust_header(@_) unless @cust_fields; #now need to cache to keep cust_fields
 553   #                                     #override incase we were passed as a sub
 554
 555   my $seen_unlinked = 0;
 556
 557   map {
 558     if ( $record->custnum ) {
 559       warn "  $record -> $_" if $DEBUG > 1;
 560       encode_entities( $record->$_(@_) );
 561     } else {
 562       warn "  ($record unlinked)" if $DEBUG > 1;
 563       $seen_unlinked++ ? '' : '(unlinked)';
 564     }
 565   } @cust_fields;
 566 }
 567
 568 =item cust_fields_subs
 569
 570 Returns an array of subroutine references for returning customer field values.
 571 This is similar to cust_fields, but returns each field's sub as a distinct
 572 element.
 573
 574 =cut
 575
 576 sub cust_fields_subs {
 577   my $unlinked_warn = 0;
 578
 579   return map {
 580     my $f = $_;
 581     if ( $unlinked_warn++ ) {
 582
 583       sub {
 584         my $record = shift;
 585         if ( $record->custnum ) {
 586           encode_entities( $record->$f(@_) );
 587         } else {
 588           '(unlinked)'
 589         };
 590       };
 591
 592     } else {
 593
 594       sub {
 595         my $record = shift;
 596         $record->custnum ? encode_entities( $record->$f(@_) ) : '';
 597       };
 598
 599     }
 600
 601   } @cust_fields;
 602 }
 603
 604 =item cust_colors
 605
 606 Returns an array of subroutine references (or empty strings) for returning
 607 customer information colors.
 608
 609 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 610 defined by the supplied customer fields setting, or if no customer fields
 611 setting is supplied, the <B>cust-fields</B> configuration value.
 612
 613 =cut
 614
 615 sub cust_colors {
 616   map {
 617     my $method = $_;
 618     if ( $method ) {
 619       sub { shift->$method(@_) };
 620     } else {
 621       '';
 622     }
 623   } @cust_colors;
 624 }
 625
 626 =item cust_styles
 627
 628 Returns an array of customer information styles.
 629
 630 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 631 defined by the supplied customer fields setting, or if no customer fields
 632 setting is supplied, the <B>cust-fields</B> configuration value.
 633
 634 =cut
 635
 636 sub cust_styles {
 637   map {
 638     if ( $_ ) {
 639       $_;
 640     } else {
 641       '';
 642     }
 643   } @cust_styles;
 644 }
 645
 646 =item cust_aligns
 647
 648 Returns an array or scalar (depending on context) of customer information
 649 alignments.
 650
 651 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 652 defined by the supplied customer fields setting, or if no customer fields
 653 setting is supplied, the <B>cust-fields</B> configuration value.
 654
 655 =cut
 656
 657 sub cust_aligns {
 658   if ( wantarray ) {
 659     @cust_aligns;
 660   } else {
 661     join('', @cust_aligns);
 662   }
 663 }
 664
 665 =item cust_links
 666
 667 Returns an array of links to view/cust_main.cgi, for use with cust_fields.
 668
 669 =cut
 670
 671 sub cust_links {
 672   my $link = [ FS::CGI::rooturl().'view/cust_main.cgi?', 'custnum' ];
 673
 674   return map { $_ eq 'cust_status_label' ? '' : $link }
 675     @cust_fields;
 676 }
 677
 678 =item is_mobile
 679
 680 Utility function to determine if the client is a mobile browser.
 681
 682 =cut
 683
 684 sub is_mobile {
 685   my $ua = $ENV{'HTTP_USER_AGENT'} || '';
 686   if ( $ua =~ /(?:hiptop|Blazer|Novarra|Vagabond|SonyEricsson|Symbian|NetFront|UP.Browser|UP.Link|Windows CE|MIDP|J2ME|DoCoMo|J-PHONE|PalmOS|PalmSource|iPhone|iPod|AvantGo|Nokia|Android|WebOS|S60|Opera Mini|Opera Mobi)/io ) {
 687     return 1;
 688   }
 689   return 0;
 690 }
 691
 692 =item random_id [ DIGITS ]
 693
 694 Returns a random number of length DIGITS, or if unspecified, a long random
 695 identifier consisting of the timestamp, process ID, and a random number.
 696 Anything in the UI that needs a random identifier should use this.
 697
 698 =cut
 699
 700 sub random_id {
 701   my $digits = shift;
 702   if (!defined $NO_RANDOM_IDS) {
 703     my $conf = FS::Conf->new;
 704     $NO_RANDOM_IDS = $conf->exists('no_random_ids') ? 1 : 0;
 705     warn "TEST MODE--RANDOM ID NUMBERS DISABLED\n" if $NO_RANDOM_IDS;
 706   }
 707   if ( $NO_RANDOM_IDS ) {
 708     if ( $digits > 0 ) {
 709       return 0;
 710     } else {
 711       return '0000000000-0000-000000000.000000';
 712     }
 713   } else {
 714     if ($digits > 0) {
 715       return int(rand(10 ** $digits));
 716     } else {
 717       return time . "-$$-" . rand() * 2**32;
 718     }
 719   }
 720 }
 721
 722 =back
 723
 724 =cut
 725
 726 ###
 727 # begin JSRPC code...
 728 ###
 729
 730 package FS::UI::Web::JSRPC;
 731
 732 use strict;
 733 use vars qw($DEBUG);
 734 use Carp;
 735 use Storable qw(nfreeze);
 736 use MIME::Base64;
 737 use Cpanel::JSON::XS;
 738 use FS::CurrentUser;
 739 use FS::Record qw(qsearchs);
 740 use FS::queue;
 741 use FS::CGI qw(rooturl);
 742
 743 $DEBUG = 0;
 744
 745 sub new {
 746         my $class = shift;
 747         my $self  = {
 748                 env => {},
 749                 job => shift,
 750                 cgi => shift,
 751         };
 752
 753         bless $self, $class;
 754
 755         croak "CGI object required as second argument" unless $self->{'cgi'};
 756
 757         return $self;
 758 }
 759
 760 sub process {
 761
 762   my $self = shift;
 763
 764   my $cgi = $self->{'cgi'};
 765
 766   # XXX this should parse JSON foo and build a proper data structure
 767   my @args = $cgi->param('arg');
 768
 769   #work around konqueror bug!
 770   @args = map { s/\x00$//; $_; } @args;
 771
 772   my $sub = $cgi->param('sub'); #????
 773
 774   warn "FS::UI::Web::JSRPC::process:\n".
 775        "  cgi=$cgi\n".
 776        "  sub=$sub\n".
 777        "  args=".join(', ',@args)."\n"
 778     if $DEBUG;
 779
 780   if ( $sub eq 'start_job' ) {
 781
 782     $self->start_job(@args);
 783
 784   } elsif ( $sub eq 'job_status' ) {
 785
 786     $self->job_status(@args);
 787
 788   } else {
 789
 790     die "unknown sub $sub";
 791
 792   }
 793
 794 }
 795
 796 sub start_job {
 797   my $self = shift;
 798
 799   warn "FS::UI::Web::start_job: ". join(', ', @_) if $DEBUG;
 800 #  my %param = @_;
 801   my %param = ();
 802   while ( @_ ) {
 803     my( $field, $value ) = splice(@_, 0, 2);
 804     unless ( exists( $param{$field} ) ) {
 805       $param{$field} = $value;
 806     } elsif ( ! ref($param{$field}) ) {
 807       $param{$field} = [ $param{$field}, $value ];
 808     } else {
 809       push @{$param{$field}}, $value;
 810     }
 811   }
 812   $param{CurrentUser} = $FS::CurrentUser::CurrentUser->username;
 813   $param{RootURL} = rooturl($self->{cgi}->self_url);
 814   warn "FS::UI::Web::start_job\n".
 815        join('', map {
 816                       if ( ref($param{$_}) ) {
 817                         "  $_ => [ ". join(', ', @{$param{$_}}). " ]\n";
 818                       } else {
 819                         "  $_ => $param{$_}\n";
 820                       }
 821                     } keys %param )
 822     if $DEBUG;
 823
 824   #first get the CGI params shipped off to a job ASAP so an id can be returned
 825   #to the caller
 826
 827   my $job = new FS::queue { 'job' => $self->{'job'} };
 828
 829   #too slow to insert all the cgi params as individual args..,?
 830   #my $error = $queue->insert('_JOB', $cgi->Vars);
 831
 832   #rely on FS::queue smartness to freeze/encode the param hash
 833
 834   my $error = $job->insert( '_JOB', \%param );
 835
 836   if ( $error ) {
 837
 838     warn "job not inserted: $error\n"
 839       if $DEBUG;
 840
 841     $error;  #this doesn't seem to be handled well,
 842              # will trigger "illegal jobnum" below?
 843              # (should never be an error inserting the job, though, only thing
 844              #  would be Pg f%*kage)
 845   } else {
 846
 847     warn "job inserted successfully with jobnum ". $job->jobnum. "\n"
 848       if $DEBUG;
 849
 850     $job->jobnum;
 851   }
 852
 853 }
 854
 855 sub job_status {
 856   my( $self, $jobnum ) = @_; #$url ???
 857
 858   sleep 1; # XXX could use something better...
 859
 860   my $job;
 861   if ( $jobnum =~ /^(\d+)$/ ) {
 862     $job = qsearchs('queue', { 'jobnum' => $jobnum } );
 863   } else {
 864     die "FS::UI::Web::job_status: illegal jobnum $jobnum\n";
 865   }
 866
 867   my @return;
 868   if ( $job && $job->status ne 'failed' && $job->status ne 'done' ) {
 869     my ($progress, $action) = split ',', $job->statustext, 2;
 870     $action ||= 'Server processing job';
 871     @return = ( 'progress', $progress, $action );
 872   } elsif ( !$job ) { #handle job gone case : job successful
 873                       # so close popup, redirect parent window...
 874     @return = ( 'complete' );
 875   } elsif ( $job->status eq 'done' ) {
 876     @return = ( 'done', $job->statustext, '' );
 877   } else {
 878     @return = ( 'error', $job ? $job->statustext : $jobnum );
 879   }
 880
 881   encode_json \@return;
 882
 883 }
 884
 885 1;
 886