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'             => 'ucfirst_cust_status',
 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     'Payment Type'             => 'cust_payby',
 347     'Current Balance'          => 'current_balance',
 348     'Agent Cust#'              => 'agent_custid',
 349     'Agent'                    => 'agent_name',
 350     'Agent Cust# or Cust#'     => 'display_custnum',
 351     'Advertising Source'       => 'referral',
 352   );
 353   $header2method{'Cust#'} = 'display_custnum'
 354     if $conf->exists('cust_main-default_agent_custid');
 355
 356   my %header2colormethod = (
 357     'Cust. Status' => 'cust_statuscolor',
 358   );
 359   my %header2style = (
 360     'Cust. Status' => 'b',
 361   );
 362   my %header2align = (
 363     'Cust. Status' => 'c',
 364     'Cust#'        => 'r',
 365   );
 366
 367   my $cust_fields;
 368   my @cust_header;
 369   if ( @_ && $_[0] ) {
 370
 371     warn "  using supplied cust-fields override".
 372           " (ignoring cust-fields config file)"
 373       if $DEBUG;
 374     $cust_fields = shift;
 375
 376   } else {
 377
 378     if (    $conf->exists('cust-fields')
 379          && $conf->config('cust-fields') =~ /^([\w\. \|\#\(\)]+):?/
 380        )
 381     {
 382       warn "  found cust-fields configuration value"
 383         if $DEBUG;
 384       $cust_fields = $1;
 385     } else {
 386       warn "  no cust-fields configuration value found; using default 'Cust. Status | Customer'"
 387         if $DEBUG;
 388       $cust_fields = 'Cust. Status | Customer';
 389     }
 390
 391   }
 392
 393   @cust_header = split(/ \| /, $cust_fields);
 394   @cust_fields = map { $header2method{$_} || $_ } @cust_header;
 395   @cust_colors = map { exists $header2colormethod{$_}
 396                          ? $header2colormethod{$_}
 397                          : ''
 398                      }
 399                      @cust_header;
 400   @cust_styles = map { exists $header2style{$_} ? $header2style{$_} : '' }
 401                      @cust_header;
 402   @cust_aligns = map { exists $header2align{$_} ? $header2align{$_} : 'l' }
 403                      @cust_header;
 404
 405   #my $svc_x = shift;
 406   @cust_header;
 407 }
 408
 409 sub cust_sort_fields {
 410   cust_header(@_) if( @_ or !@cust_fields );
 411   #inefficientish, but tiny lists and only run once per page
 412
 413   map { $_ eq 'custnum' ? 'custnum' : '' } @cust_fields;
 414
 415 }
 416
 417 =item cust_sql_fields [ CUST_FIELDS_VALUE ]
 418
 419 Returns a list of fields for the SELECT portion of an SQL query.
 420
 421 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 422 defined by the supplied customer fields setting, or if no customer fields
 423 setting is supplied, the <B>cust-fields</B> configuration value.
 424
 425 =cut
 426
 427 sub cust_sql_fields {
 428
 429   my @fields = qw( last first company );
 430 #  push @fields, map "ship_$_", @fields;
 431
 432   cust_header(@_) if( @_ or !@cust_fields );
 433   #inefficientish, but tiny lists and only run once per page
 434
 435   my @location_fields;
 436   foreach my $field (qw( address1 address2 city state zip latitude longitude )) {
 437     foreach my $pre ('bill_','ship_') {
 438       if ( grep { $_ eq $pre.$field } @cust_fields ) {
 439         push @location_fields, $pre.'location.'.$field.' AS '.$pre.$field;
 440       }
 441     }
 442   }
 443   foreach my $pre ('bill_','ship_') {
 444     if ( grep { $_ eq $pre.'country_full' } @cust_fields ) {
 445       push @location_fields, $pre.'locationnum';
 446     }
 447   }
 448
 449   foreach my $field (qw(daytime night mobile fax )) {
 450     push @fields, $field if (grep { $_ eq $field } @cust_fields);
 451   }
 452   push @fields, "payby AS cust_payby"
 453     if grep { $_ eq 'cust_payby' } @cust_fields;
 454   push @fields, 'agent_custid';
 455
 456   push @fields, 'agentnum' if grep { $_ eq 'agent_name' } @cust_fields;
 457
 458   my @extra_fields = ();
 459   if (grep { $_ eq 'current_balance' } @cust_fields) {
 460     push @extra_fields, FS::cust_main->balance_sql . " AS current_balance";
 461   }
 462
 463   push @extra_fields, 'part_referral_x.referral AS referral'
 464     if grep { $_ eq 'referral' } @cust_fields;
 465
 466   map("cust_main.$_", @fields), @location_fields, @extra_fields;
 467 }
 468
 469 =item join_cust_main [ TABLE[.CUSTNUM] ] [ LOCATION_TABLE[.LOCATIONNUM] ]
 470
 471 Returns an SQL join phrase for the FROM clause so that the fields listed
 472 in L</cust_sql_fields> will be available.  Currently joins to cust_main
 473 itself, as well as cust_location (under the aliases 'bill_location' and
 474 'ship_location') if address fields are needed.  L</cust_header> should have
 475 been called already.
 476
 477 All of these will be left joins; if you want to exclude rows with no linked
 478 cust_main record (or bill_location/ship_location), you can do so in the
 479 WHERE clause.
 480
 481 TABLE is the table containing the custnum field.  If CUSTNUM (a field name
 482 in that table) is specified, that field will be joined to cust_main.custnum.
 483 Otherwise, this function will assume the field is named "custnum".  If the
 484 argument isn't present at all, the join will just say "USING (custnum)",
 485 which might work.
 486
 487 As a special case, if TABLE is 'cust_main', only the joins to cust_location
 488 will be returned.
 489
 490 LOCATION_TABLE is an optional table name to use for joining ship_location,
 491 in case your query also includes package information and you want the
 492 "service address" columns to reflect package addresses.
 493
 494 =cut
 495
 496 sub join_cust_main {
 497   my ($cust_table, $location_table) = @_;
 498   my ($custnum, $locationnum);
 499   ($cust_table, $custnum) = split(/\./, $cust_table);
 500   $custnum ||= 'custnum';
 501   ($location_table, $locationnum) = split(/\./, $location_table);
 502   $locationnum ||= 'locationnum';
 503
 504   my $sql = '';
 505   if ( $cust_table ) {
 506     $sql = " LEFT JOIN cust_main ON (cust_main.custnum = $cust_table.$custnum)"
 507       unless $cust_table eq 'cust_main';
 508   } else {
 509     $sql = " LEFT JOIN cust_main USING (custnum)";
 510   }
 511
 512   if ( !@cust_fields or grep /^bill_/, @cust_fields ) {
 513
 514     $sql .= ' LEFT JOIN cust_location bill_location'.
 515             ' ON (bill_location.locationnum = cust_main.bill_locationnum)';
 516
 517   }
 518
 519   if ( !@cust_fields or grep /^ship_/, @cust_fields ) {
 520
 521     if (!$location_table) {
 522       $location_table = 'cust_main';
 523       $locationnum = 'ship_locationnum';
 524     }
 525
 526     $sql .= ' LEFT JOIN cust_location ship_location'.
 527             " ON (ship_location.locationnum = $location_table.$locationnum) ";
 528   }
 529
 530   if ( !@cust_fields or grep { $_ eq 'referral' } @cust_fields ) {
 531     $sql .= ' LEFT JOIN (select refnum, referral from part_referral) AS part_referral_x ON (cust_main.refnum = part_referral_x.refnum) ';
 532   }
 533
 534   $sql;
 535 }
 536
 537 =item cust_fields OBJECT [ CUST_FIELDS_VALUE ]
 538
 539 Given an object that contains fields from cust_main (say, from a
 540 JOINed search.  See httemplate/search/svc_* for examples), returns an array
 541 of customer information, or "(unlinked)" if this service is not linked to a
 542 customer.
 543
 544 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 545 defined by the supplied customer fields setting, or if no customer fields
 546 setting is supplied, the <B>cust-fields</B> configuration value.
 547
 548 =cut
 549
 550
 551 sub cust_fields {
 552   my $record = shift;
 553   warn "FS::UI::Web::cust_fields called for $record ".
 554        "(cust_fields: @cust_fields)"
 555     if $DEBUG > 1;
 556
 557   #cust_header(@_) unless @cust_fields; #now need to cache to keep cust_fields
 558   #                                     #override incase we were passed as a sub
 559
 560   my $seen_unlinked = 0;
 561
 562   map {
 563     if ( $record->custnum ) {
 564       warn "  $record -> $_" if $DEBUG > 1;
 565       encode_entities( $record->$_(@_) );
 566     } else {
 567       warn "  ($record unlinked)" if $DEBUG > 1;
 568       $seen_unlinked++ ? '' : '(unlinked)';
 569     }
 570   } @cust_fields;
 571 }
 572
 573 =item cust_fields_subs
 574
 575 Returns an array of subroutine references for returning customer field values.
 576 This is similar to cust_fields, but returns each field's sub as a distinct
 577 element.
 578
 579 =cut
 580
 581 sub cust_fields_subs {
 582   my $unlinked_warn = 0;
 583
 584   return map {
 585     my $f = $_;
 586     if ( $unlinked_warn++ ) {
 587
 588       sub {
 589         my $record = shift;
 590         if ( $record->custnum ) {
 591           encode_entities( $record->$f(@_) );
 592         } else {
 593           '(unlinked)'
 594         };
 595       };
 596
 597     } else {
 598
 599       sub {
 600         my $record = shift;
 601         $record->custnum ? encode_entities( $record->$f(@_) ) : '';
 602       };
 603
 604     }
 605
 606   } @cust_fields;
 607 }
 608
 609 =item cust_colors
 610
 611 Returns an array of subroutine references (or empty strings) for returning
 612 customer information colors.
 613
 614 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 615 defined by the supplied customer fields setting, or if no customer fields
 616 setting is supplied, the <B>cust-fields</B> configuration value.
 617
 618 =cut
 619
 620 sub cust_colors {
 621   map {
 622     my $method = $_;
 623     if ( $method ) {
 624       sub { shift->$method(@_) };
 625     } else {
 626       '';
 627     }
 628   } @cust_colors;
 629 }
 630
 631 =item cust_styles
 632
 633 Returns an array of customer information styles.
 634
 635 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 636 defined by the supplied customer fields setting, or if no customer fields
 637 setting is supplied, the <B>cust-fields</B> configuration value.
 638
 639 =cut
 640
 641 sub cust_styles {
 642   map {
 643     if ( $_ ) {
 644       $_;
 645     } else {
 646       '';
 647     }
 648   } @cust_styles;
 649 }
 650
 651 =item cust_aligns
 652
 653 Returns an array or scalar (depending on context) of customer information
 654 alignments.
 655
 656 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 657 defined by the supplied customer fields setting, or if no customer fields
 658 setting is supplied, the <B>cust-fields</B> configuration value.
 659
 660 =cut
 661
 662 sub cust_aligns {
 663   if ( wantarray ) {
 664     @cust_aligns;
 665   } else {
 666     join('', @cust_aligns);
 667   }
 668 }
 669
 670 =item cust_links
 671
 672 Returns an array of links to view/cust_main.cgi, for use with cust_fields.
 673
 674 =cut
 675
 676 sub cust_links {
 677   my $link = [ FS::CGI::rooturl().'view/cust_main.cgi?', 'custnum' ];
 678
 679   return map { $_ eq 'cust_status_label' ? '' : $link }
 680     @cust_fields;
 681 }
 682
 683 =item is_mobile
 684
 685 Utility function to determine if the client is a mobile browser.
 686
 687 =cut
 688
 689 sub is_mobile {
 690   my $ua = $ENV{'HTTP_USER_AGENT'} || '';
 691   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 ) {
 692     return 1;
 693   }
 694   return 0;
 695 }
 696
 697 =item random_id [ DIGITS ]
 698
 699 Returns a random number of length DIGITS, or if unspecified, a long random
 700 identifier consisting of the timestamp, process ID, and a random number.
 701 Anything in the UI that needs a random identifier should use this.
 702
 703 =cut
 704
 705 sub random_id {
 706   my $digits = shift;
 707   if (!defined $NO_RANDOM_IDS) {
 708     my $conf = FS::Conf->new;
 709     $NO_RANDOM_IDS = $conf->exists('no_random_ids') ? 1 : 0;
 710     warn "TEST MODE--RANDOM ID NUMBERS DISABLED\n" if $NO_RANDOM_IDS;
 711   }
 712   if ( $NO_RANDOM_IDS ) {
 713     if ( $digits > 0 ) {
 714       return 0;
 715     } else {
 716       return '0000000000-0000-000000000.000000';
 717     }
 718   } else {
 719     if ($digits > 0) {
 720       return int(rand(10 ** $digits));
 721     } else {
 722       return time . "-$$-" . rand() * 2**32;
 723     }
 724   }
 725 }
 726
 727 =back
 728
 729 =cut
 730
 731 ###
 732 # begin JSRPC code...
 733 ###
 734
 735 package FS::UI::Web::JSRPC;
 736
 737 use strict;
 738 use vars qw($DEBUG);
 739 use Carp;
 740 use Storable qw(nfreeze);
 741 use MIME::Base64;
 742 use Cpanel::JSON::XS;
 743 use FS::UID qw(getotaker);
 744 use FS::Record qw(qsearchs);
 745 use FS::queue;
 746 use FS::CGI qw(rooturl);
 747
 748 $DEBUG = 0;
 749
 750 sub new {
 751         my $class = shift;
 752         my $self  = {
 753                 env => {},
 754                 job => shift,
 755                 cgi => shift,
 756         };
 757
 758         bless $self, $class;
 759
 760         croak "CGI object required as second argument" unless $self->{'cgi'};
 761
 762         return $self;
 763 }
 764
 765 sub process {
 766
 767   my $self = shift;
 768
 769   my $cgi = $self->{'cgi'};
 770
 771   # XXX this should parse JSON foo and build a proper data structure
 772   my @args = $cgi->param('arg');
 773
 774   #work around konqueror bug!
 775   @args = map { s/\x00$//; $_; } @args;
 776
 777   my $sub = $cgi->param('sub'); #????
 778
 779   warn "FS::UI::Web::JSRPC::process:\n".
 780        "  cgi=$cgi\n".
 781        "  sub=$sub\n".
 782        "  args=".join(', ',@args)."\n"
 783     if $DEBUG;
 784
 785   if ( $sub eq 'start_job' ) {
 786
 787     $self->start_job(@args);
 788
 789   } elsif ( $sub eq 'job_status' ) {
 790
 791     $self->job_status(@args);
 792
 793   } else {
 794
 795     die "unknown sub $sub";
 796
 797   }
 798
 799 }
 800
 801 sub start_job {
 802   my $self = shift;
 803
 804   warn "FS::UI::Web::start_job: ". join(', ', @_) if $DEBUG;
 805 #  my %param = @_;
 806   my %param = ();
 807   while ( @_ ) {
 808     my( $field, $value ) = splice(@_, 0, 2);
 809     unless ( exists( $param{$field} ) ) {
 810       $param{$field} = $value;
 811     } elsif ( ! ref($param{$field}) ) {
 812       $param{$field} = [ $param{$field}, $value ];
 813     } else {
 814       push @{$param{$field}}, $value;
 815     }
 816   }
 817   $param{CurrentUser} = getotaker();
 818   $param{RootURL} = rooturl($self->{cgi}->self_url);
 819   warn "FS::UI::Web::start_job\n".
 820        join('', map {
 821                       if ( ref($param{$_}) ) {
 822                         "  $_ => [ ". join(', ', @{$param{$_}}). " ]\n";
 823                       } else {
 824                         "  $_ => $param{$_}\n";
 825                       }
 826                     } keys %param )
 827     if $DEBUG;
 828
 829   #first get the CGI params shipped off to a job ASAP so an id can be returned
 830   #to the caller
 831
 832   my $job = new FS::queue { 'job' => $self->{'job'} };
 833
 834   #too slow to insert all the cgi params as individual args..,?
 835   #my $error = $queue->insert('_JOB', $cgi->Vars);
 836
 837   #warn 'froze string of size '. length(nfreeze(\%param)). " for job args\n"
 838   #  if $DEBUG;
 839   #
 840   #  XXX FS::queue::insert knows how to do this.
 841   #  not changing it here because that requires changing it everywhere else,
 842   #  too, but we should eventually fix it
 843
 844   my $error = $job->insert( '_JOB', encode_base64(nfreeze(\%param)) );
 845
 846   if ( $error ) {
 847
 848     warn "job not inserted: $error\n"
 849       if $DEBUG;
 850
 851     $error;  #this doesn't seem to be handled well,
 852              # will trigger "illegal jobnum" below?
 853              # (should never be an error inserting the job, though, only thing
 854              #  would be Pg f%*kage)
 855   } else {
 856
 857     warn "job inserted successfully with jobnum ". $job->jobnum. "\n"
 858       if $DEBUG;
 859
 860     $job->jobnum;
 861   }
 862
 863 }
 864
 865 sub job_status {
 866   my( $self, $jobnum ) = @_; #$url ???
 867
 868   sleep 1; # XXX could use something better...
 869
 870   my $job;
 871   if ( $jobnum =~ /^(\d+)$/ ) {
 872     $job = qsearchs('queue', { 'jobnum' => $jobnum } );
 873   } else {
 874     die "FS::UI::Web::job_status: illegal jobnum $jobnum\n";
 875   }
 876
 877   my @return;
 878   if ( $job && $job->status ne 'failed' && $job->status ne 'done' ) {
 879     my ($progress, $action) = split ',', $job->statustext, 2;
 880     $action ||= 'Server processing job';
 881     @return = ( 'progress', $progress, $action );
 882   } elsif ( !$job ) { #handle job gone case : job successful
 883                       # so close popup, redirect parent window...
 884     @return = ( 'complete' );
 885   } elsif ( $job->status eq 'done' ) {
 886     @return = ( 'done', $job->statustext, '' );
 887   } else {
 888     @return = ( 'error', $job ? $job->statustext : $jobnum );
 889   }
 890
 891   encode_json \@return;
 892
 893 }
 894
 895 1;