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