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 );
  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     #probably need an option to turn off the + 86399
  44     $ending = parse_datetime($1) + 86399;
  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   } else {
 117
 118     my $generic = $opt{action} eq 'search' ? 'cust_svc' : 'svc_Common';
 119
 120     $url = "$generic.html?svcdb=$svcdb;";
 121     $url .= 'svcnum=' if $query =~ /^\d+(;|$)/ or $query eq '';
 122   }
 123
 124   import FS::CGI 'rooturl'; #WTF!  why is this necessary
 125   my $return = 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'             => 'ucfirst_cust_status',
 229     'Cust#'                    => 'custnum',
 230     'Name'                     => 'contact',
 231     'Company'                  => 'company',
 232     '(bill) Customer'          => 'name',
 233     '(service) Customer'       => 'ship_name',
 234     '(bill) Name'              => 'contact',
 235     '(service) Name'           => 'ship_contact',
 236     '(bill) Company'           => 'company',
 237     '(service) Company'        => 'ship_company',
 238     'Address 1'                => 'address1',
 239     'Address 2'                => 'address2',
 240     'City'                     => 'city',
 241     'State'                    => 'state',
 242     'Zip'                      => 'zip',
 243     'Country'                  => 'country_full',
 244     'Day phone'                => 'daytime', # XXX should use msgcat, but how?
 245     'Night phone'              => 'night',   # XXX should use msgcat, but how?
 246     'Fax number'               => 'fax',
 247     '(bill) Address 1'         => 'address1',
 248     '(bill) Address 2'         => 'address2',
 249     '(bill) City'              => 'city',
 250     '(bill) State'             => 'state',
 251     '(bill) Zip'               => 'zip',
 252     '(bill) Country'           => 'country_full',
 253     '(bill) Day phone'         => 'daytime', # XXX should use msgcat, but how?
 254     '(bill) Night phone'       => 'night',   # XXX should use msgcat, but how?
 255     '(bill) Fax number'        => 'fax',
 256     '(service) Address 1'      => 'ship_address1',
 257     '(service) Address 2'      => 'ship_address2',
 258     '(service) City'           => 'ship_city',
 259     '(service) State'          => 'ship_state',
 260     '(service) Zip'            => 'ship_zip',
 261     '(service) Country'        => 'ship_country_full',
 262     '(service) Day phone'      => 'ship_daytime', # XXX should use msgcat, how?
 263     '(service) Night phone'    => 'ship_night',   # XXX should use msgcat, how?
 264     '(service) Fax number'     => 'ship_fax',
 265     'Invoicing email(s)'       => 'invoicing_list_emailonly_scalar',
 266     'Payment Type'             => 'payby',
 267     'Current Balance'          => 'current_balance',
 268   );
 269   $header2method{'Cust#'} = 'display_custnum'
 270     if $conf->exists('cust_main-default_agent_custid');
 271
 272   my %header2colormethod = (
 273     'Cust. Status' => 'cust_statuscolor',
 274   );
 275   my %header2style = (
 276     'Cust. Status' => 'b',
 277   );
 278   my %header2align = (
 279     'Cust. Status' => 'c',
 280     'Cust#'        => 'r',
 281   );
 282
 283   my $cust_fields;
 284   my @cust_header;
 285   if ( @_ && $_[0] ) {
 286
 287     warn "  using supplied cust-fields override".
 288           " (ignoring cust-fields config file)"
 289       if $DEBUG;
 290     $cust_fields = shift;
 291
 292   } else {
 293
 294     if (    $conf->exists('cust-fields')
 295          && $conf->config('cust-fields') =~ /^([\w\. \|\#\(\)]+):?/
 296        )
 297     {
 298       warn "  found cust-fields configuration value"
 299         if $DEBUG;
 300       $cust_fields = $1;
 301     } else {
 302       warn "  no cust-fields configuration value found; using default 'Cust. Status | Customer'"
 303         if $DEBUG;
 304       $cust_fields = 'Cust. Status | Customer';
 305     }
 306
 307   }
 308
 309   @cust_header = split(/ \| /, $cust_fields);
 310   @cust_fields = map { $header2method{$_} || $_ } @cust_header;
 311   @cust_colors = map { exists $header2colormethod{$_}
 312                          ? $header2colormethod{$_}
 313                          : ''
 314                      }
 315                      @cust_header;
 316   @cust_styles = map { exists $header2style{$_} ? $header2style{$_} : '' }
 317                      @cust_header;
 318   @cust_aligns = map { exists $header2align{$_} ? $header2align{$_} : 'l' }
 319                      @cust_header;
 320
 321   #my $svc_x = shift;
 322   @cust_header;
 323 }
 324
 325 =item cust_sql_fields [ CUST_FIELDS_VALUE ]
 326
 327 Returns a list of fields for the SELECT portion of an SQL query.
 328
 329 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 330 defined by the supplied customer fields setting, or if no customer fields
 331 setting is supplied, the <B>cust-fields</B> configuration value.
 332
 333 =cut
 334
 335 sub cust_sql_fields {
 336
 337   my @fields = qw( last first company );
 338   push @fields, map "ship_$_", @fields;
 339   push @fields, 'country';
 340
 341   cust_header(@_);
 342   #inefficientish, but tiny lists and only run once per page
 343
 344   my @add_fields = qw( address1 address2 city state zip daytime night fax );
 345   push @fields,
 346     grep { my $field = $_; grep { $_ eq $field } @cust_fields }
 347          ( @add_fields, ( map "ship_$_", @add_fields ), 'payby' );
 348
 349   push @fields, 'agent_custid';
 350
 351   my @extra_fields = ();
 352   if (grep { $_ eq 'current_balance' } @cust_fields) {
 353     push @extra_fields, FS::cust_main->balance_sql . " AS current_balance";
 354   }
 355
 356   map("cust_main.$_", @fields), @extra_fields;
 357 }
 358
 359 =item cust_fields OBJECT [ CUST_FIELDS_VALUE ]
 360
 361 Given an object that contains fields from cust_main (say, from a
 362 JOINed search.  See httemplate/search/svc_* for examples), returns an array
 363 of customer information, or "(unlinked)" if this service is not linked to a
 364 customer.
 365
 366 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 367 defined by the supplied customer fields setting, or if no customer fields
 368 setting is supplied, the <B>cust-fields</B> configuration value.
 369
 370 =cut
 371
 372
 373 sub cust_fields {
 374   my $record = shift;
 375   warn "FS::UI::Web::cust_fields called for $record ".
 376        "(cust_fields: @cust_fields)"
 377     if $DEBUG > 1;
 378
 379   #cust_header(@_) unless @cust_fields; #now need to cache to keep cust_fields
 380   #                                     #override incase we were passed as a sub
 381
 382   my $seen_unlinked = 0;
 383
 384   map {
 385     if ( $record->custnum ) {
 386       warn "  $record -> $_" if $DEBUG > 1;
 387       encode_entities( $record->$_(@_) );
 388     } else {
 389       warn "  ($record unlinked)" if $DEBUG > 1;
 390       $seen_unlinked++ ? '' : '(unlinked)';
 391     }
 392   } @cust_fields;
 393 }
 394
 395 =item cust_fields_subs
 396
 397 Returns an array of subroutine references for returning customer field values.
 398 This is similar to cust_fields, but returns each field's sub as a distinct
 399 element.
 400
 401 =cut
 402
 403 sub cust_fields_subs {
 404   my $unlinked_warn = 0;
 405   return map {
 406     my $f = $_;
 407     if( $unlinked_warn++ ) {
 408       sub {
 409         my $record = shift;
 410         if( $record->custnum ) {
 411           $record->$f(@_);
 412         }
 413         else {
 414           '(unlinked)'
 415         };
 416       }
 417     }
 418     else {
 419       sub {
 420         my $record = shift;
 421         $record->$f(@_) if $record->custnum;
 422       }
 423     }
 424   } @cust_fields;
 425 }
 426
 427 =item cust_colors
 428
 429 Returns an array of subroutine references (or empty strings) for returning
 430 customer information colors.
 431
 432 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 433 defined by the supplied customer fields setting, or if no customer fields
 434 setting is supplied, the <B>cust-fields</B> configuration value.
 435
 436 =cut
 437
 438 sub cust_colors {
 439   map {
 440     my $method = $_;
 441     if ( $method ) {
 442       sub { shift->$method(@_) };
 443     } else {
 444       '';
 445     }
 446   } @cust_colors;
 447 }
 448
 449 =item cust_styles
 450
 451 Returns an array of customer information styles.
 452
 453 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 454 defined by the supplied customer fields setting, or if no customer fields
 455 setting is supplied, the <B>cust-fields</B> configuration value.
 456
 457 =cut
 458
 459 sub cust_styles {
 460   map {
 461     if ( $_ ) {
 462       $_;
 463     } else {
 464       '';
 465     }
 466   } @cust_styles;
 467 }
 468
 469 =item cust_aligns
 470
 471 Returns an array or scalar (depending on context) of customer information
 472 alignments.
 473
 474 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 475 defined by the supplied customer fields setting, or if no customer fields
 476 setting is supplied, the <B>cust-fields</B> configuration value.
 477
 478 =cut
 479
 480 sub cust_aligns {
 481   if ( wantarray ) {
 482     @cust_aligns;
 483   } else {
 484     join('', @cust_aligns);
 485   }
 486 }
 487
 488 =item is_mobile
 489
 490 Utility function to determine if the client is a mobile browser.
 491
 492 =cut
 493
 494 sub is_mobile {
 495   my $ua = $ENV{'HTTP_USER_AGENT'} || '';
 496   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 ) {
 497     return 1;
 498   }
 499   return 0;
 500 }
 501
 502 ###
 503 # begin JSRPC code...
 504 ###
 505
 506 package FS::UI::Web::JSRPC;
 507
 508 use strict;
 509 use vars qw($DEBUG);
 510 use Carp;
 511 use Storable qw(nfreeze);
 512 use MIME::Base64;
 513 use JSON;
 514 use FS::UID qw(getotaker);
 515 use FS::Record qw(qsearchs);
 516 use FS::queue;
 517 use FS::CGI qw(rooturl);
 518
 519 $DEBUG = 0;
 520
 521 sub new {
 522         my $class = shift;
 523         my $self  = {
 524                 env => {},
 525                 job => shift,
 526                 cgi => shift,
 527         };
 528
 529         bless $self, $class;
 530
 531         croak "CGI object required as second argument" unless $self->{'cgi'};
 532
 533         return $self;
 534 }
 535
 536 sub process {
 537
 538   my $self = shift;
 539
 540   my $cgi = $self->{'cgi'};
 541
 542   # XXX this should parse JSON foo and build a proper data structure
 543   my @args = $cgi->param('arg');
 544
 545   #work around konqueror bug!
 546   @args = map { s/\x00$//; $_; } @args;
 547
 548   my $sub = $cgi->param('sub'); #????
 549
 550   warn "FS::UI::Web::JSRPC::process:\n".
 551        "  cgi=$cgi\n".
 552        "  sub=$sub\n".
 553        "  args=".join(', ',@args)."\n"
 554     if $DEBUG;
 555
 556   if ( $sub eq 'start_job' ) {
 557
 558     $self->start_job(@args);
 559
 560   } elsif ( $sub eq 'job_status' ) {
 561
 562     $self->job_status(@args);
 563
 564   } else {
 565
 566     die "unknown sub $sub";
 567
 568   }
 569
 570 }
 571
 572 sub start_job {
 573   my $self = shift;
 574
 575   warn "FS::UI::Web::start_job: ". join(', ', @_) if $DEBUG;
 576 #  my %param = @_;
 577   my %param = ();
 578   while ( @_ ) {
 579     my( $field, $value ) = splice(@_, 0, 2);
 580     unless ( exists( $param{$field} ) ) {
 581       $param{$field} = $value;
 582     } elsif ( ! ref($param{$field}) ) {
 583       $param{$field} = [ $param{$field}, $value ];
 584     } else {
 585       push @{$param{$field}}, $value;
 586     }
 587   }
 588   $param{CurrentUser} = getotaker();
 589   $param{RootURL} = rooturl($self->{cgi}->self_url);
 590   warn "FS::UI::Web::start_job\n".
 591        join('', map {
 592                       if ( ref($param{$_}) ) {
 593                         "  $_ => [ ". join(', ', @{$param{$_}}). " ]\n";
 594                       } else {
 595                         "  $_ => $param{$_}\n";
 596                       }
 597                     } keys %param )
 598     if $DEBUG;
 599
 600   #first get the CGI params shipped off to a job ASAP so an id can be returned
 601   #to the caller
 602
 603   my $job = new FS::queue { 'job' => $self->{'job'} };
 604
 605   #too slow to insert all the cgi params as individual args..,?
 606   #my $error = $queue->insert('_JOB', $cgi->Vars);
 607
 608   #warn 'froze string of size '. length(nfreeze(\%param)). " for job args\n"
 609   #  if $DEBUG;
 610
 611   my $error = $job->insert( '_JOB', encode_base64(nfreeze(\%param)) );
 612
 613   if ( $error ) {
 614
 615     warn "job not inserted: $error\n"
 616       if $DEBUG;
 617
 618     $error;  #this doesn't seem to be handled well,
 619              # will trigger "illegal jobnum" below?
 620              # (should never be an error inserting the job, though, only thing
 621              #  would be Pg f%*kage)
 622   } else {
 623
 624     warn "job inserted successfully with jobnum ". $job->jobnum. "\n"
 625       if $DEBUG;
 626
 627     $job->jobnum;
 628   }
 629
 630 }
 631
 632 sub job_status {
 633   my( $self, $jobnum ) = @_; #$url ???
 634
 635   sleep 1; # XXX could use something better...
 636
 637   my $job;
 638   if ( $jobnum =~ /^(\d+)$/ ) {
 639     $job = qsearchs('queue', { 'jobnum' => $jobnum } );
 640   } else {
 641     die "FS::UI::Web::job_status: illegal jobnum $jobnum\n";
 642   }
 643
 644   my @return;
 645   if ( $job && $job->status ne 'failed' && $job->status ne 'done' ) {
 646     my ($progress, $action) = split ',', $job->statustext, 2;
 647     $action ||= 'Server processing job';
 648     @return = ( 'progress', $progress, $action );
 649   } elsif ( !$job ) { #handle job gone case : job successful
 650                       # so close popup, redirect parent window...
 651     @return = ( 'complete' );
 652   } elsif ( $job->status eq 'done' ) {
 653     @return = ( 'done', $job->statustext, '' );
 654   } else {
 655     @return = ( 'error', $job ? $job->statustext : $jobnum );
 656   }
 657
 658   #to_json(\@return);  #waiting on deb 5.0 for new JSON.pm?
 659   #silence the warning though
 660   my $to_json = JSON->can('to_json') || JSON->can('objToJson');
 661   &$to_json(\@return);
 662
 663 }
 664
 665 1;
 666