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