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