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