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