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