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