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