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 qsearch);
  11 use FS::cust_main;  # are sql_balance and sql_date_balance in the right module?
  12
  13 #use vars qw(@ISA);
  14 #use FS::UI
  15 #@ISA = qw( FS::UI );
  16 @ISA = qw( Exporter );
  17
  18 @EXPORT_OK = qw( get_page_pref set_page_pref svc_url random_id );
  19
  20 $DEBUG = 0;
  21 $me = '[FS::UID::Web]';
  22
  23 our $NO_RANDOM_IDS;
  24
  25 ###
  26 # user prefs
  27 ###
  28
  29 =item get_page_pref NAME, TABLENUM
  30
  31 Returns the user's page preference named NAME for the current page. If the
  32 page is a view or edit page or otherwise shows a single record at a time,
  33 it should use TABLENUM to link the preference to that record.
  34
  35 =cut
  36
  37 sub get_page_pref {
  38   my ($prefname, $tablenum) = @_;
  39
  40   my $m = $HTML::Mason::Commands::m
  41     or die "can't get page pref when running outside the UI";
  42   # what's more useful: to tie prefs to the base_comp (usually where
  43   # code is executing right now), or to the request_comp (approximately the
  44   # one in the URL)? not sure.
  45   $FS::CurrentUser::CurrentUser->get_page_pref( $m->request_comp->path,
  46                                                 $prefname,
  47                                                 $tablenum
  48                                               );
  49 }
  50
  51 =item set_page_pref NAME, TABLENUM, VALUE
  52
  53 Sets the user's page preference named NAME for the current page. Use TABLENUM
  54 as for get_page_pref.
  55
  56 If VALUE is an empty string, the preference will be deleted (and
  57 C<get_page_pref> will return an empty string).
  58
  59   my $mypref = set_page_pref('mypref', '', 100);
  60
  61 =cut
  62
  63 sub set_page_pref {
  64   my ($prefname, $tablenum, $prefvalue) = @_;
  65
  66   my $m = $HTML::Mason::Commands::m
  67     or die "can't set page pref when running outside the UI";
  68   $FS::CurrentUser::CurrentUser->set_page_pref( $m->request_comp->path,
  69                                                 $prefname,
  70                                                 $tablenum,
  71                                                 $prefvalue );
  72 }
  73
  74 ###
  75 # date parsing
  76 ###
  77
  78 =item parse_beginning_ending CGI [, PREFIX ]
  79
  80 Parses a beginning/ending date range, as used on many reports. This function
  81 recognizes two sets of CGI params: "begin" and "end", the integer timestamp
  82 values, and "beginning" and "ending", the user-readable date fields.
  83
  84 If "begin" contains an integer, that's passed through as the beginning date.
  85 Otherwise, "beginning" is passed to L<DateTime::Format::Natural> and turned
  86 into an integer. If this fails or it doesn't have a value, zero is used as the
  87 beginning date.
  88
  89 The same happens for "end" and "ending", except that if "ending" contains a
  90 date without a time, it gets moved to the end of that day, and if there's no
  91 value, the value returned is the highest unsigned 32-bit time value (some time
  92 in 2037).
  93
  94 PREFIX is optionally a string to prepend (with '_' as a delimiter) to the form
  95 field names.
  96
  97 =cut
  98
  99 use Date::Parse;
 100 sub parse_beginning_ending {
 101   my($cgi, $prefix) = @_;
 102   $prefix .= '_' if $prefix;
 103
 104   my $beginning = 0;
 105   if ( $cgi->param($prefix.'begin') =~ /^(\d+)$/ ) {
 106     $beginning = $1;
 107   } elsif ( $cgi->param($prefix.'beginning') =~ /^([ 0-9\-\/\:]{1,64})$/ ) {
 108     $beginning = parse_datetime($1) || 0;
 109   }
 110
 111   my $ending = 4294967295; #2^32-1
 112   if ( $cgi->param($prefix.'end') =~ /^(\d+)$/ ) {
 113     $ending = $1 - 1;
 114   } elsif ( $cgi->param($prefix.'ending') =~ /^([ 0-9\-\/\:]{1,64})$/ ) {
 115     $ending = parse_datetime($1);
 116     $ending = day_end($ending) unless $ending =~ /:/;
 117   }
 118
 119   ( $beginning, $ending );
 120 }
 121
 122 =item svc_url
 123
 124 Returns a service URL, first checking to see if there is a service-specific
 125 page to link to, otherwise to a generic service handling page.  Options are
 126 passed as a list of name-value pairs, and include:
 127
 128 =over 4
 129
 130 =item * m - Mason request object ($m)
 131
 132 =item * action - The action for which to construct "edit", "view", or "search"
 133
 134 =item ** part_svc - Service definition (see L<FS::part_svc>)
 135
 136 =item ** svcdb - Service table
 137
 138 =item *** query - Query string
 139
 140 =item *** svc   - FS::cust_svc or FS::svc_* object
 141
 142 =item ahref - Optional flag, if set true returns <A HREF="$url"> instead of just the URL.
 143
 144 =back
 145
 146 * Required fields
 147
 148 ** part_svc OR svcdb is required
 149
 150 *** query OR svc is required
 151
 152 =cut
 153
 154   # ##
 155   # #required
 156   # ##
 157   #  'm'        => $m, #mason request object
 158   #  'action'   => 'edit', #or 'view'
 159   #
 160   #  'part_svc' => $part_svc, #usual
 161   #   #OR
 162   #  'svcdb'    => 'svc_table',
 163   #
 164   #  'query'    => #optional query string
 165   #                # (pass a blank string if you want a "raw" URL to add your
 166   #                #  own svcnum to)
 167   #   #OR
 168   #  'svc'      => $svc_x, #or $cust_svc, it just needs a svcnum
 169   #
 170   # ##
 171   # #optional
 172   # ##
 173   #  'ahref'    => 1, # if set true, returns <A HREF="$url">
 174
 175 use FS::CGI qw(rooturl);
 176 sub svc_url {
 177   my %opt = @_;
 178
 179   #? return '' unless ref($opt{part_svc});
 180
 181   my $svcdb = $opt{svcdb} || $opt{part_svc}->svcdb;
 182   my $query = exists($opt{query}) ? $opt{query} : $opt{svc}->svcnum;
 183   my $url;
 184   warn "$me [svc_url] checking for /$opt{action}/$svcdb.cgi component"
 185     if $DEBUG;
 186   if ( $opt{m}->interp->comp_exists("/$opt{action}/$svcdb.cgi") ) {
 187     $url = "$svcdb.cgi?";
 188   } elsif ( $opt{m}->interp->comp_exists("/$opt{action}/$svcdb.html") ) {
 189     $url = "$svcdb.html?";
 190   } else {
 191     my $generic = $opt{action} eq 'search' ? 'cust_svc' : 'svc_Common';
 192
 193     $url = "$generic.html?svcdb=$svcdb;";
 194     $url .= 'svcnum=' if $query =~ /^\d+(;|$)/ or $query eq '';
 195   }
 196
 197   my $return = FS::CGI::rooturl(). "$opt{action}/$url$query";
 198
 199   $return = qq!<A HREF="$return">! if $opt{ahref};
 200
 201   $return;
 202 }
 203
 204 sub svc_link {
 205   my($m, $part_svc, $cust_svc) = @_ or return '';
 206   svc_X_link( $part_svc->svc, @_ );
 207 }
 208
 209 sub svc_label_link {
 210   my($m, $part_svc, $cust_svc) = @_ or return '';
 211   my($svc, $label, $svcdb) = $cust_svc->label;
 212   svc_X_link( $label, @_ );
 213 }
 214
 215 sub svc_X_link {
 216   my ($x, $m, $part_svc, $cust_svc) = @_ or return '';
 217
 218   return $x
 219    unless $FS::CurrentUser::CurrentUser->access_right('View customer services');
 220
 221   confess "svc_X_link called without a service ($x, $m, $part_svc, $cust_svc)\n"
 222     unless $cust_svc;
 223
 224   my $ahref = svc_url(
 225     'ahref'    => 1,
 226     'm'        => $m,
 227     'action'   => 'view',
 228     'part_svc' => $part_svc,
 229     'svc'      => $cust_svc,
 230   );
 231
 232   "$ahref$x</A>";
 233 }
 234
 235 #this probably needs an ACL too...
 236 sub svc_export_links {
 237   my ($m, $part_svc, $cust_svc) = @_ or return '';
 238
 239   my $ahref = $cust_svc->export_links;
 240
 241   join('', @$ahref);
 242 }
 243
 244 sub parse_lt_gt {
 245   my($cgi, $field) = (shift, shift);
 246   my $table = ( @_ && length($_[0]) ) ? shift.'.' : '';
 247
 248   my @search = ();
 249
 250   my %op = (
 251     'lt' => '<',
 252     'gt' => '>',
 253   );
 254
 255   foreach my $op (keys %op) {
 256
 257     warn "checking for ${field}_$op field\n"
 258       if $DEBUG;
 259
 260     if ( $cgi->param($field."_$op") =~ /^\s*\$?\s*(-?[\d\,\s]+(\.\d\d)?)\s*$/ ) {
 261
 262       my $num = $1;
 263       $num =~ s/[\,\s]+//g;
 264       my $search = "$table$field $op{$op} $num";
 265       push @search, $search;
 266
 267       warn "found ${field}_$op field; adding search element $search\n"
 268         if $DEBUG;
 269     }
 270
 271   }
 272
 273   @search;
 274
 275 }
 276
 277 ###
 278 # cust_main report subroutines
 279 ###
 280
 281 =over 4
 282
 283 =item cust_header [ CUST_FIELDS_VALUE ]
 284
 285 Returns an array of customer information headers according to the supplied
 286 customer fields value, or if no value is supplied, the B<cust-fields>
 287 configuration value.
 288
 289 =cut
 290
 291 use vars qw( @cust_fields @cust_colors @cust_styles @cust_aligns );
 292
 293 sub cust_header {
 294
 295   warn "FS::UI:Web::cust_header called"
 296     if $DEBUG;
 297
 298   my $conf = new FS::Conf;
 299
 300   my %header2method = (
 301     'Customer'                 => 'name',
 302     'Cust. Status'             => 'ucfirst_cust_status',
 303     'Cust#'                    => 'custnum',
 304     'Name'                     => 'contact',
 305     'Company'                  => 'company',
 306
 307     # obsolete but might still be referenced in configuration
 308     '(bill) Customer'          => 'name',
 309     '(service) Customer'       => 'ship_name',
 310     '(bill) Name'              => 'contact',
 311     '(service) Name'           => 'ship_contact',
 312     '(bill) Company'           => 'company',
 313     '(service) Company'        => 'ship_company',
 314     '(bill) Day phone'         => 'daytime',
 315     '(bill) Night phone'       => 'night',
 316     '(bill) Fax number'        => 'fax',
 317
 318     'Customer'                 => 'name',
 319     'Address 1'                => 'bill_address1',
 320     'Address 2'                => 'bill_address2',
 321     'City'                     => 'bill_city',
 322     'State'                    => 'bill_state',
 323     'Zip'                      => 'bill_zip',
 324     'Country'                  => 'bill_country_full',
 325     'Day phone'                => 'daytime', # XXX should use msgcat, but how?
 326     'Night phone'              => 'night',   # XXX should use msgcat, but how?
 327     'Mobile phone'             => 'mobile',  # XXX should use msgcat, but how?
 328     'Fax number'               => 'fax',
 329     '(bill) Address 1'         => 'bill_address1',
 330     '(bill) Address 2'         => 'bill_address2',
 331     '(bill) City'              => 'bill_city',
 332     '(bill) State'             => 'bill_state',
 333     '(bill) Zip'               => 'bill_zip',
 334     '(bill) Country'           => 'bill_country_full',
 335     '(bill) Latitude'          => 'bill_latitude',
 336     '(bill) Longitude'         => 'bill_longitude',
 337     '(service) Address 1'      => 'ship_address1',
 338     '(service) Address 2'      => 'ship_address2',
 339     '(service) City'           => 'ship_city',
 340     '(service) State'          => 'ship_state',
 341     '(service) Zip'            => 'ship_zip',
 342     '(service) Country'        => 'ship_country_full',
 343     '(service) Latitude'       => 'ship_latitude',
 344     '(service) Longitude'      => 'ship_longitude',
 345     'Invoicing email(s)'       => 'invoicing_list_emailonly_scalar',
 346     'Payment Type'             => 'cust_payby',
 347     'Current Balance'          => 'current_balance',
 348     'Agent Cust#'              => 'agent_custid',
 349     'Agent'                    => 'agent_name',
 350     'Agent Cust# or Cust#'     => 'display_custnum',
 351     'Advertising Source'       => 'referral',
 352   );
 353   $header2method{'Cust#'} = 'display_custnum'
 354     if $conf->exists('cust_main-default_agent_custid');
 355
 356 foreach my $phone_type ( qsearch({table=>'phone_type', order_by=>'weight'}) ) {
 357   $header2method{'Contact '.$phone_type->typename.' phone(s)'} = sub {
 358     my $self = shift;
 359     my $num = $phone_type->phonetypenum;
 360
 361     my @phones;
 362     foreach ($self->contact_list_name_phones) {
 363       my $data = [
 364         {
 365           'data'  => $_->first.' '.$_->last.' '.FS::contact_phone::phonenum_pretty($_),
 366         },
 367       ];
 368       push @phones, $data if $_->phonetypenum eq $phone_type->phonetypenum;
 369     }
 370   return \@phones;
 371   };
 372
 373 }
 374
 375   my %header2colormethod = (
 376     'Cust. Status' => 'cust_statuscolor',
 377   );
 378   my %header2style = (
 379     'Cust. Status' => 'b',
 380   );
 381   my %header2align = (
 382     'Cust. Status' => 'c',
 383     'Cust#'        => 'r',
 384   );
 385
 386   my $cust_fields;
 387   my @cust_header;
 388   if ( @_ && $_[0] ) {
 389
 390     warn "  using supplied cust-fields override".
 391           " (ignoring cust-fields config file)"
 392       if $DEBUG;
 393     $cust_fields = shift;
 394
 395   } else {
 396
 397     if (    $conf->exists('cust-fields')
 398          && $conf->config('cust-fields') =~ /^([\w\. \|\#\(\)]+):?/
 399        )
 400     {
 401       warn "  found cust-fields configuration value"
 402         if $DEBUG;
 403       $cust_fields = $1;
 404     } else {
 405       warn "  no cust-fields configuration value found; using default 'Cust. Status | Customer'"
 406         if $DEBUG;
 407       $cust_fields = 'Cust. Status | Customer';
 408     }
 409
 410   }
 411
 412   @cust_header = split(/ \| /, $cust_fields);
 413   @cust_fields = map { $header2method{$_} || $_ } @cust_header;
 414   @cust_colors = map { exists $header2colormethod{$_}
 415                          ? $header2colormethod{$_}
 416                          : ''
 417                      }
 418                      @cust_header;
 419   @cust_styles = map { exists $header2style{$_} ? $header2style{$_} : '' }
 420                      @cust_header;
 421   @cust_aligns = map { exists $header2align{$_} ? $header2align{$_} : 'l' }
 422                      @cust_header;
 423
 424   #my $svc_x = shift;
 425   @cust_header;
 426 }
 427
 428 sub cust_sort_fields {
 429   cust_header(@_) if( @_ or !@cust_fields );
 430   #inefficientish, but tiny lists and only run once per page
 431
 432   my @sort_fields;
 433   foreach (@cust_fields) {
 434     if ($_ eq "custnum") { push @sort_fields, 'custnum'; }
 435     elsif ($_ eq "contact" || $_ eq "name") { push @sort_fields, '(last, first)'; }
 436     elsif ($_ eq "company") { push @sort_fields, 'company'; }
 437     else { push @sort_fields, ''; }
 438   }
 439   return @sort_fields;
 440
 441 }
 442
 443 =item cust_sql_fields [ CUST_FIELDS_VALUE ]
 444
 445 Returns a list of fields for the SELECT portion of an SQL query.
 446
 447 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 448 defined by the supplied customer fields setting, or if no customer fields
 449 setting is supplied, the <B>cust-fields</B> configuration value.
 450
 451 =cut
 452
 453 sub cust_sql_fields {
 454
 455   my @fields = qw( last first company );
 456 #  push @fields, map "ship_$_", @fields;
 457
 458   cust_header(@_) if( @_ or !@cust_fields );
 459   #inefficientish, but tiny lists and only run once per page
 460
 461   my @location_fields;
 462   foreach my $field (qw( address1 address2 city state zip latitude longitude )) {
 463     foreach my $pre ('bill_','ship_') {
 464       if ( grep { $_ eq $pre.$field } @cust_fields ) {
 465         push @location_fields, $pre.'location.'.$field.' AS '.$pre.$field;
 466       }
 467     }
 468   }
 469   foreach my $pre ('bill_','ship_') {
 470     if ( grep { $_ eq $pre.'country_full' } @cust_fields ) {
 471       push @location_fields, $pre.'locationnum';
 472     }
 473   }
 474
 475   foreach my $field (qw(daytime night mobile fax )) {
 476     push @fields, $field if (grep { $_ eq $field } @cust_fields);
 477   }
 478   push @fields, "payby AS cust_payby"
 479     if grep { $_ eq 'cust_payby' } @cust_fields;
 480   push @fields, 'agent_custid';
 481
 482   push @fields, 'agentnum' if grep { $_ eq 'agent_name' } @cust_fields;
 483
 484   my @extra_fields = ();
 485   if (grep { $_ eq 'current_balance' } @cust_fields) {
 486     push @extra_fields, FS::cust_main->balance_sql . " AS current_balance";
 487   }
 488
 489   push @extra_fields, 'part_referral_x.referral AS referral'
 490     if grep { $_ eq 'referral' } @cust_fields;
 491
 492   map("cust_main.$_", @fields), @location_fields, @extra_fields;
 493 }
 494
 495 =item join_cust_main [ TABLE[.CUSTNUM] ] [ LOCATION_TABLE[.LOCATIONNUM] ]
 496
 497 Returns an SQL join phrase for the FROM clause so that the fields listed
 498 in L</cust_sql_fields> will be available.  Currently joins to cust_main
 499 itself, as well as cust_location (under the aliases 'bill_location' and
 500 'ship_location') if address fields are needed.  L</cust_header> should have
 501 been called already.
 502
 503 All of these will be left joins; if you want to exclude rows with no linked
 504 cust_main record (or bill_location/ship_location), you can do so in the
 505 WHERE clause.
 506
 507 TABLE is the table containing the custnum field.  If CUSTNUM (a field name
 508 in that table) is specified, that field will be joined to cust_main.custnum.
 509 Otherwise, this function will assume the field is named "custnum".  If the
 510 argument isn't present at all, the join will just say "USING (custnum)",
 511 which might work.
 512
 513 As a special case, if TABLE is 'cust_main', only the joins to cust_location
 514 will be returned.
 515
 516 LOCATION_TABLE is an optional table name to use for joining ship_location,
 517 in case your query also includes package information and you want the
 518 "service address" columns to reflect package addresses.
 519
 520 =cut
 521
 522 sub join_cust_main {
 523   my ($cust_table, $location_table) = @_;
 524   my ($custnum, $locationnum);
 525   ($cust_table, $custnum) = split(/\./, $cust_table);
 526   $custnum ||= 'custnum';
 527   ($location_table, $locationnum) = split(/\./, $location_table);
 528   $locationnum ||= 'locationnum';
 529
 530   my $sql = '';
 531   if ( $cust_table ) {
 532     $sql = " LEFT JOIN cust_main ON (cust_main.custnum = $cust_table.$custnum)"
 533       unless $cust_table eq 'cust_main';
 534   } else {
 535     $sql = " LEFT JOIN cust_main USING (custnum)";
 536   }
 537
 538   if ( !@cust_fields or grep /^bill_/, @cust_fields ) {
 539
 540     $sql .= ' LEFT JOIN cust_location bill_location'.
 541             ' ON (bill_location.locationnum = cust_main.bill_locationnum)';
 542
 543   }
 544
 545   if ( !@cust_fields or grep /^ship_/, @cust_fields ) {
 546
 547     if (!$location_table) {
 548       $location_table = 'cust_main';
 549       $locationnum = 'ship_locationnum';
 550     }
 551
 552     $sql .= ' LEFT JOIN cust_location ship_location'.
 553             " ON (ship_location.locationnum = $location_table.$locationnum) ";
 554   }
 555
 556   if ( !@cust_fields or grep { $_ eq 'referral' } @cust_fields ) {
 557     $sql .= ' LEFT JOIN (select refnum, referral from part_referral) AS part_referral_x ON (cust_main.refnum = part_referral_x.refnum) ';
 558   }
 559
 560   $sql;
 561 }
 562
 563 =item cust_fields OBJECT [ CUST_FIELDS_VALUE ]
 564
 565 Given an object that contains fields from cust_main (say, from a
 566 JOINed search.  See httemplate/search/svc_* for examples), returns an array
 567 of customer information, or "(unlinked)" if this service is not linked to a
 568 customer.
 569
 570 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 571 defined by the supplied customer fields setting, or if no customer fields
 572 setting is supplied, the <B>cust-fields</B> configuration value.
 573
 574 =cut
 575
 576
 577 sub cust_fields {
 578   my $record = shift;
 579   warn "FS::UI::Web::cust_fields called for $record ".
 580        "(cust_fields: @cust_fields)"
 581     if $DEBUG > 1;
 582
 583   #cust_header(@_) unless @cust_fields; #now need to cache to keep cust_fields
 584   #                                     #override incase we were passed as a sub
 585
 586   my $seen_unlinked = 0;
 587
 588   map {
 589     if ( $record->custnum ) {
 590       warn "  $record -> $_" if $DEBUG > 1;
 591       encode_entities( $record->$_(@_) );
 592     } else {
 593       warn "  ($record unlinked)" if $DEBUG > 1;
 594       $seen_unlinked++ ? '' : '(unlinked)';
 595     }
 596   } @cust_fields;
 597 }
 598
 599 =item cust_fields_subs
 600
 601 Returns an array of subroutine references for returning customer field values.
 602 This is similar to cust_fields, but returns each field's sub as a distinct
 603 element.
 604
 605 =cut
 606
 607 sub cust_fields_subs {
 608   my $unlinked_warn = 0;
 609
 610   return map {
 611     my $f = $_;
 612     if ( $unlinked_warn++ ) {
 613
 614       sub {
 615         my $record = shift;
 616         if ( $record->custnum ) {
 617           encode_entities( $record->$f(@_) );
 618         } else {
 619           '(unlinked)'
 620         };
 621       };
 622
 623     } else {
 624
 625       sub {
 626         my $record = shift;
 627         $record->custnum ? encode_entities( $record->$f(@_) ) : '';
 628       };
 629
 630     }
 631
 632   } @cust_fields;
 633 }
 634
 635 =item cust_colors
 636
 637 Returns an array of subroutine references (or empty strings) for returning
 638 customer information colors.
 639
 640 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 641 defined by the supplied customer fields setting, or if no customer fields
 642 setting is supplied, the <B>cust-fields</B> configuration value.
 643
 644 =cut
 645
 646 sub cust_colors {
 647   map {
 648     my $method = $_;
 649     if ( $method ) {
 650       sub { shift->$method(@_) };
 651     } else {
 652       '';
 653     }
 654   } @cust_colors;
 655 }
 656
 657 =item cust_styles
 658
 659 Returns an array of customer information styles.
 660
 661 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 662 defined by the supplied customer fields setting, or if no customer fields
 663 setting is supplied, the <B>cust-fields</B> configuration value.
 664
 665 =cut
 666
 667 sub cust_styles {
 668   map {
 669     if ( $_ ) {
 670       $_;
 671     } else {
 672       '';
 673     }
 674   } @cust_styles;
 675 }
 676
 677 =item cust_aligns
 678
 679 Returns an array or scalar (depending on context) of customer information
 680 alignments.
 681
 682 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 683 defined by the supplied customer fields setting, or if no customer fields
 684 setting is supplied, the <B>cust-fields</B> configuration value.
 685
 686 =cut
 687
 688 sub cust_aligns {
 689   if ( wantarray ) {
 690     @cust_aligns;
 691   } else {
 692     join('', @cust_aligns);
 693   }
 694 }
 695
 696 =item cust_links
 697
 698 Returns an array of links to view/cust_main.cgi, for use with cust_fields.
 699
 700 =cut
 701
 702 sub cust_links {
 703   my $link = [ FS::CGI::rooturl().'view/cust_main.cgi?', 'custnum' ];
 704
 705   return map { $_ eq 'cust_status_label' ? '' : $link }
 706     @cust_fields;
 707 }
 708
 709 =item is_mobile
 710
 711 Utility function to determine if the client is a mobile browser.
 712
 713 =cut
 714
 715 sub is_mobile {
 716   my $ua = $ENV{'HTTP_USER_AGENT'} || '';
 717   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 ) {
 718     return 1;
 719   }
 720   return 0;
 721 }
 722
 723 =item random_id [ DIGITS ]
 724
 725 Returns a random number of length DIGITS, or if unspecified, a long random
 726 identifier consisting of the timestamp, process ID, and a random number.
 727 Anything in the UI that needs a random identifier should use this.
 728
 729 =cut
 730
 731 sub random_id {
 732   my $digits = shift;
 733   if (!defined $NO_RANDOM_IDS) {
 734     my $conf = FS::Conf->new;
 735     $NO_RANDOM_IDS = $conf->exists('no_random_ids') ? 1 : 0;
 736     warn "TEST MODE--RANDOM ID NUMBERS DISABLED\n" if $NO_RANDOM_IDS;
 737   }
 738   if ( $NO_RANDOM_IDS ) {
 739     if ( $digits > 0 ) {
 740       return 0;
 741     } else {
 742       return '0000000000-0000-000000000.000000';
 743     }
 744   } else {
 745     if ($digits > 0) {
 746       return int(rand(10 ** $digits));
 747     } else {
 748       return time . "-$$-" . rand() * 2**32;
 749     }
 750   }
 751 }
 752
 753 =back
 754
 755 =cut
 756
 757 ###
 758 # begin JSRPC code...
 759 ###
 760
 761 package FS::UI::Web::JSRPC;
 762
 763 use strict;
 764 use vars qw($DEBUG);
 765 use Carp;
 766 use Storable qw(nfreeze);
 767 use MIME::Base64;
 768 use Cpanel::JSON::XS;
 769 use FS::UID qw(getotaker);
 770 use FS::Record qw(qsearchs);
 771 use FS::queue;
 772 use FS::CGI qw(rooturl);
 773
 774 $DEBUG = 0;
 775
 776 sub new {
 777         my $class = shift;
 778         my $self  = {
 779                 env => {},
 780                 job => shift,
 781                 cgi => shift,
 782         };
 783
 784         bless $self, $class;
 785
 786         croak "CGI object required as second argument" unless $self->{'cgi'};
 787
 788         return $self;
 789 }
 790
 791 sub process {
 792
 793   my $self = shift;
 794
 795   my $cgi = $self->{'cgi'};
 796
 797   # XXX this should parse JSON foo and build a proper data structure
 798   my @args = $cgi->param('arg');
 799
 800   #work around konqueror bug!
 801   @args = map { s/\x00$//; $_; } @args;
 802
 803   my $sub = $cgi->param('sub'); #????
 804
 805   warn "FS::UI::Web::JSRPC::process:\n".
 806        "  cgi=$cgi\n".
 807        "  sub=$sub\n".
 808        "  args=".join(', ',@args)."\n"
 809     if $DEBUG;
 810
 811   if ( $sub eq 'start_job' ) {
 812
 813     $self->start_job(@args);
 814
 815   } elsif ( $sub eq 'job_status' ) {
 816
 817     $self->job_status(@args);
 818
 819   } else {
 820
 821     die "unknown sub $sub";
 822
 823   }
 824
 825 }
 826
 827 sub start_job {
 828   my $self = shift;
 829
 830   warn "FS::UI::Web::start_job: ". join(', ', @_) if $DEBUG;
 831 #  my %param = @_;
 832   my %param = ();
 833   while ( @_ ) {
 834     my( $field, $value ) = splice(@_, 0, 2);
 835     unless ( exists( $param{$field} ) ) {
 836       $param{$field} = $value;
 837     } elsif ( ! ref($param{$field}) ) {
 838       $param{$field} = [ $param{$field}, $value ];
 839     } else {
 840       push @{$param{$field}}, $value;
 841     }
 842   }
 843   $param{CurrentUser} = getotaker();
 844   $param{RootURL} = rooturl($self->{cgi}->self_url);
 845   warn "FS::UI::Web::start_job\n".
 846        join('', map {
 847                       if ( ref($param{$_}) ) {
 848                         "  $_ => [ ". join(', ', @{$param{$_}}). " ]\n";
 849                       } else {
 850                         "  $_ => $param{$_}\n";
 851                       }
 852                     } keys %param )
 853     if $DEBUG;
 854
 855   #first get the CGI params shipped off to a job ASAP so an id can be returned
 856   #to the caller
 857
 858   my $job = new FS::queue { 'job' => $self->{'job'} };
 859
 860   #too slow to insert all the cgi params as individual args..,?
 861   #my $error = $queue->insert('_JOB', $cgi->Vars);
 862
 863   #warn 'froze string of size '. length(nfreeze(\%param)). " for job args\n"
 864   #  if $DEBUG;
 865   #
 866   #  XXX FS::queue::insert knows how to do this.
 867   #  not changing it here because that requires changing it everywhere else,
 868   #  too, but we should eventually fix it
 869
 870   my $error = $job->insert( '_JOB', encode_base64(nfreeze(\%param)) );
 871
 872   if ( $error ) {
 873
 874     warn "job not inserted: $error\n"
 875       if $DEBUG;
 876
 877     $error;  #this doesn't seem to be handled well,
 878              # will trigger "illegal jobnum" below?
 879              # (should never be an error inserting the job, though, only thing
 880              #  would be Pg f%*kage)
 881   } else {
 882
 883     warn "job inserted successfully with jobnum ". $job->jobnum. "\n"
 884       if $DEBUG;
 885
 886     $job->jobnum;
 887   }
 888
 889 }
 890
 891 sub job_status {
 892   my( $self, $jobnum ) = @_; #$url ???
 893
 894   sleep 1; # XXX could use something better...
 895
 896   my $job;
 897   if ( $jobnum =~ /^(\d+)$/ ) {
 898     $job = qsearchs('queue', { 'jobnum' => $jobnum } );
 899   } else {
 900     die "FS::UI::Web::job_status: illegal jobnum $jobnum\n";
 901   }
 902
 903   my @return;
 904   if ( $job && $job->status ne 'failed' && $job->status ne 'done' ) {
 905     my ($progress, $action) = split ',', $job->statustext, 2;
 906     $action ||= 'Server processing job';
 907     @return = ( 'progress', $progress, $action );
 908   } elsif ( !$job ) { #handle job gone case : job successful
 909                       # so close popup, redirect parent window...
 910     @return = ( 'complete' );
 911   } elsif ( $job->status eq 'done' ) {
 912     @return = ( 'done', $job->statustext, '' );
 913   } else {
 914     @return = ( 'error', $job ? $job->statustext : $jobnum );
 915   }
 916
 917   encode_json \@return;
 918
 919 }
 920
 921 1;