4 use vars qw($DEBUG @ISA @EXPORT_OK $me);
6 use Carp qw( confess );
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?
16 @ISA = qw( Exporter );
18 @EXPORT_OK = qw( svc_url );
21 $me = '[FS::UID::Web]';
28 sub parse_beginning_ending {
29 my($cgi, $prefix) = @_;
30 $prefix .= '_' if $prefix;
33 if ( $cgi->param($prefix.'begin') =~ /^(\d+)$/ ) {
35 } elsif ( $cgi->param($prefix.'beginning') =~ /^([ 0-9\-\/\:]{1,64})$/ ) {
36 $beginning = parse_datetime($1) || 0;
39 my $ending = 4294967295; #2^32-1
40 if ( $cgi->param($prefix.'end') =~ /^(\d+)$/ ) {
42 } elsif ( $cgi->param($prefix.'ending') =~ /^([ 0-9\-\/\:]{1,64})$/ ) {
43 #probably need an option to turn off the + 86399
45 #no, this should be add one day minus one second...
46 # 86399 is wrong twice a year when daylight savings time changes
47 # and leap seconds too but only a second rather than an hour..
48 $ending = parse_datetime($1) + 86399;
51 ( $beginning, $ending );
56 Returns a service URL, first checking to see if there is a service-specific
57 page to link to, otherwise to a generic service handling page. Options are
58 passed as a list of name-value pairs, and include:
62 =item * m - Mason request object ($m)
64 =item * action - The action for which to construct "edit", "view", or "search"
66 =item ** part_svc - Service definition (see L<FS::part_svc>)
68 =item ** svcdb - Service table
70 =item *** query - Query string
72 =item *** svc - FS::cust_svc or FS::svc_* object
74 =item ahref - Optional flag, if set true returns <A HREF="$url"> instead of just the URL.
80 ** part_svc OR svcdb is required
82 *** query OR svc is required
89 # 'm' => $m, #mason request object
90 # 'action' => 'edit', #or 'view'
92 # 'part_svc' => $part_svc, #usual
94 # 'svcdb' => 'svc_table',
96 # 'query' => #optional query string
97 # # (pass a blank string if you want a "raw" URL to add your
100 # 'svc' => $svc_x, #or $cust_svc, it just needs a svcnum
105 # 'ahref' => 1, # if set true, returns <A HREF="$url">
107 use FS::CGI qw(rooturl);
111 #? return '' unless ref($opt{part_svc});
113 my $svcdb = $opt{svcdb} || $opt{part_svc}->svcdb;
114 my $query = exists($opt{query}) ? $opt{query} : $opt{svc}->svcnum;
116 warn "$me [svc_url] checking for /$opt{action}/$svcdb.cgi component"
118 if ( $opt{m}->interp->comp_exists("/$opt{action}/$svcdb.cgi") ) {
119 $url = "$svcdb.cgi?";
122 my $generic = $opt{action} eq 'search' ? 'cust_svc' : 'svc_Common';
124 $url = "$generic.html?svcdb=$svcdb;";
125 $url .= 'svcnum=' if $query =~ /^\d+(;|$)/ or $query eq '';
128 import FS::CGI 'rooturl'; #WTF! why is this necessary
129 my $return = rooturl(). "$opt{action}/$url$query";
131 $return = qq!<A HREF="$return">! if $opt{ahref};
137 my($m, $part_svc, $cust_svc) = @_ or return '';
138 svc_X_link( $part_svc->svc, @_ );
142 my($m, $part_svc, $cust_svc) = @_ or return '';
143 my($svc, $label, $svcdb) = $cust_svc->label;
144 svc_X_link( $label, @_ );
148 my ($x, $m, $part_svc, $cust_svc) = @_ or return '';
151 unless $FS::CurrentUser::CurrentUser->access_right('View customer services');
153 confess "svc_X_link called without a service ($x, $m, $part_svc, $cust_svc)\n"
160 'part_svc' => $part_svc,
167 #this probably needs an ACL too...
168 sub svc_export_links {
169 my ($m, $part_svc, $cust_svc) = @_ or return '';
171 my $ahref = $cust_svc->export_links;
177 my($cgi, $field) = @_;
186 foreach my $op (keys %op) {
188 warn "checking for ${field}_$op field\n"
191 if ( $cgi->param($field."_$op") =~ /^\s*\$?\s*(-?[\d\,\s]+(\.\d\d)?)\s*$/ ) {
194 $num =~ s/[\,\s]+//g;
195 my $search = "$field $op{$op} $num";
196 push @search, $search;
198 warn "found ${field}_$op field; adding search element $search\n"
209 # cust_main report subroutines
213 =item cust_header [ CUST_FIELDS_VALUE ]
215 Returns an array of customer information headers according to the supplied
216 customer fields value, or if no value is supplied, the B<cust-fields>
221 use vars qw( @cust_fields @cust_colors @cust_styles @cust_aligns );
225 warn "FS::UI:Web::cust_header called"
228 my $conf = new FS::Conf;
230 my %header2method = (
231 'Customer' => 'name',
232 'Cust. Status' => 'ucfirst_cust_status',
233 'Cust#' => 'custnum',
235 'Company' => 'company',
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 'Address 1' => 'bill_address1',
243 'Address 2' => 'bill_address2',
244 'City' => 'bill_city',
245 'State' => 'bill_state',
247 'Country' => 'country_full',
248 'Day phone' => 'daytime', # XXX should use msgcat, but how?
249 'Night phone' => 'night', # XXX should use msgcat, but how?
250 'Fax number' => 'fax',
251 '(bill) Address 1' => 'bill_address1',
252 '(bill) Address 2' => 'bill_address2',
253 '(bill) City' => 'bill_city',
254 '(bill) State' => 'bill_state',
255 '(bill) Zip' => 'bill_zip',
256 '(bill) Country' => 'country_full',
257 '(bill) Day phone' => 'daytime', # XXX should use msgcat, but how?
258 '(bill) Night phone' => 'night', # XXX should use msgcat, but how?
259 '(bill) Fax number' => 'fax',
260 '(service) Address 1' => 'ship_address1',
261 '(service) Address 2' => 'ship_address2',
262 '(service) City' => 'ship_city',
263 '(service) State' => 'ship_state',
264 '(service) Zip' => 'ship_zip',
265 '(service) Country' => 'ship_country_full',
266 '(service) Day phone' => 'ship_daytime', # XXX should use msgcat, how?
267 '(service) Night phone' => 'ship_night', # XXX should use msgcat, how?
268 '(service) Fax number' => 'ship_fax',
269 'Invoicing email(s)' => 'invoicing_list_emailonly_scalar',
270 'Payment Type' => 'payby',
271 'Current Balance' => 'current_balance',
273 $header2method{'Cust#'} = 'display_custnum'
274 if $conf->exists('cust_main-default_agent_custid');
276 my %header2colormethod = (
277 'Cust. Status' => 'cust_statuscolor',
280 'Cust. Status' => 'b',
283 'Cust. Status' => 'c',
291 warn " using supplied cust-fields override".
292 " (ignoring cust-fields config file)"
294 $cust_fields = shift;
298 if ( $conf->exists('cust-fields')
299 && $conf->config('cust-fields') =~ /^([\w\. \|\#\(\)]+):?/
302 warn " found cust-fields configuration value"
306 warn " no cust-fields configuration value found; using default 'Cust. Status | Customer'"
308 $cust_fields = 'Cust. Status | Customer';
313 @cust_header = split(/ \| /, $cust_fields);
314 @cust_fields = map { $header2method{$_} || $_ } @cust_header;
315 @cust_colors = map { exists $header2colormethod{$_}
316 ? $header2colormethod{$_}
320 @cust_styles = map { exists $header2style{$_} ? $header2style{$_} : '' }
322 @cust_aligns = map { exists $header2align{$_} ? $header2align{$_} : 'l' }
329 =item cust_sql_fields [ CUST_FIELDS_VALUE ]
331 Returns a list of fields for the SELECT portion of an SQL query.
333 As with L<the cust_header subroutine|/cust_header>, the fields returned are
334 defined by the supplied customer fields setting, or if no customer fields
335 setting is supplied, the <B>cust-fields</B> configuration value.
339 sub cust_sql_fields {
341 my @fields = qw( last first company );
342 # push @fields, map "ship_$_", @fields;
345 #inefficientish, but tiny lists and only run once per page
348 foreach my $field (qw( address1 address2 city state zip )) {
349 foreach my $pre ('bill_','ship_') {
350 if ( grep { $_ eq $pre.$field } @cust_fields ) {
351 push @location_fields, $pre.'location.'.$field.' AS '.$pre.$field;
356 push @fields, 'payby' if grep { $_ eq 'payby'} @cust_fields;
357 push @fields, 'agent_custid';
359 my @extra_fields = ();
360 if (grep { $_ eq 'current_balance' } @cust_fields) {
361 push @extra_fields, FS::cust_main->balance_sql . " AS current_balance";
364 map("cust_main.$_", @fields), @location_fields, @extra_fields;
367 =item join_cust_main [ TABLE[.CUSTNUM] ] [ LOCATION_TABLE[.LOCATIONNUM] ]
369 Returns an SQL join phrase for the FROM clause so that the fields listed
370 in L<cust_sql_fields> will be available. Currently joins to cust_main
371 itself, as well as cust_location (under the aliases 'bill_location' and
372 'ship_location') if address fields are needed. L<cust_header()> should have
375 All of these will be left joins; if you want to exclude rows with no linked
376 cust_main record (or bill_location/ship_location), you can do so in the
379 TABLE is the table containing the custnum field. If CUSTNUM (a field name
380 in that table) is specified, that field will be joined to cust_main.custnum.
381 Otherwise, this function will assume the field is named "custnum". If the
382 argument isn't present at all, the join will just say "USING (custnum)",
385 As a special case, if TABLE is 'cust_main', only the joins to cust_location
388 LOCATION_TABLE is an optional table name to use for joining ship_location,
389 in case your query also includes package information and you want the
390 "service address" columns to reflect package addresses.
395 my ($cust_table, $location_table) = @_;
396 my ($custnum, $locationnum);
397 ($cust_table, $custnum) = split(/\./, $cust_table);
398 $custnum ||= 'custnum';
399 ($location_table, $locationnum) = split(/\./, $location_table);
400 $locationnum ||= 'locationnum';
404 $sql = " LEFT JOIN cust_main ON (cust_main.custnum = $cust_table.$custnum)"
405 unless $cust_table eq 'cust_main';
407 $sql = " LEFT JOIN cust_main USING (custnum)";
410 if ( !@cust_fields or grep /^bill_/, @cust_fields ) {
412 $sql .= ' LEFT JOIN cust_location bill_location'.
413 ' ON (bill_location.locationnum = cust_main.bill_locationnum)';
417 if ( !@cust_fields or grep /^ship_/, @cust_fields ) {
419 if (!$location_table) {
420 $location_table = 'cust_main';
421 $locationnum = 'ship_locationnum';
424 $sql .= ' LEFT JOIN cust_location ship_location'.
425 " ON (ship_location.locationnum = $location_table.$locationnum) ";
431 =item cust_fields OBJECT [ CUST_FIELDS_VALUE ]
433 Given an object that contains fields from cust_main (say, from a
434 JOINed search. See httemplate/search/svc_* for examples), returns an array
435 of customer information, or "(unlinked)" if this service is not linked to a
438 As with L<the cust_header subroutine|/cust_header>, the fields returned are
439 defined by the supplied customer fields setting, or if no customer fields
440 setting is supplied, the <B>cust-fields</B> configuration value.
447 warn "FS::UI::Web::cust_fields called for $record ".
448 "(cust_fields: @cust_fields)"
451 #cust_header(@_) unless @cust_fields; #now need to cache to keep cust_fields
452 # #override incase we were passed as a sub
454 my $seen_unlinked = 0;
457 if ( $record->custnum ) {
458 warn " $record -> $_" if $DEBUG > 1;
459 encode_entities( $record->$_(@_) );
461 warn " ($record unlinked)" if $DEBUG > 1;
462 $seen_unlinked++ ? '' : '(unlinked)';
467 =item cust_fields_subs
469 Returns an array of subroutine references for returning customer field values.
470 This is similar to cust_fields, but returns each field's sub as a distinct
475 sub cust_fields_subs {
476 my $unlinked_warn = 0;
479 if( $unlinked_warn++ ) {
482 if( $record->custnum ) {
493 $record->$f(@_) if $record->custnum;
501 Returns an array of subroutine references (or empty strings) for returning
502 customer information colors.
504 As with L<the cust_header subroutine|/cust_header>, the fields returned are
505 defined by the supplied customer fields setting, or if no customer fields
506 setting is supplied, the <B>cust-fields</B> configuration value.
514 sub { shift->$method(@_) };
523 Returns an array of customer information styles.
525 As with L<the cust_header subroutine|/cust_header>, the fields returned are
526 defined by the supplied customer fields setting, or if no customer fields
527 setting is supplied, the <B>cust-fields</B> configuration value.
543 Returns an array or scalar (depending on context) of customer information
546 As with L<the cust_header subroutine|/cust_header>, the fields returned are
547 defined by the supplied customer fields setting, or if no customer fields
548 setting is supplied, the <B>cust-fields</B> configuration value.
556 join('', @cust_aligns);
562 Utility function to determine if the client is a mobile browser.
567 my $ua = $ENV{'HTTP_USER_AGENT'} || '';
568 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 ) {
575 # begin JSRPC code...
578 package FS::UI::Web::JSRPC;
583 use Storable qw(nfreeze);
586 use FS::UID qw(getotaker);
587 use FS::Record qw(qsearchs);
589 use FS::CGI qw(rooturl);
603 croak "CGI object required as second argument" unless $self->{'cgi'};
612 my $cgi = $self->{'cgi'};
614 # XXX this should parse JSON foo and build a proper data structure
615 my @args = $cgi->param('arg');
617 #work around konqueror bug!
618 @args = map { s/\x00$//; $_; } @args;
620 my $sub = $cgi->param('sub'); #????
622 warn "FS::UI::Web::JSRPC::process:\n".
625 " args=".join(', ',@args)."\n"
628 if ( $sub eq 'start_job' ) {
630 $self->start_job(@args);
632 } elsif ( $sub eq 'job_status' ) {
634 $self->job_status(@args);
638 die "unknown sub $sub";
647 warn "FS::UI::Web::start_job: ". join(', ', @_) if $DEBUG;
651 my( $field, $value ) = splice(@_, 0, 2);
652 unless ( exists( $param{$field} ) ) {
653 $param{$field} = $value;
654 } elsif ( ! ref($param{$field}) ) {
655 $param{$field} = [ $param{$field}, $value ];
657 push @{$param{$field}}, $value;
660 $param{CurrentUser} = getotaker();
661 $param{RootURL} = rooturl($self->{cgi}->self_url);
662 warn "FS::UI::Web::start_job\n".
664 if ( ref($param{$_}) ) {
665 " $_ => [ ". join(', ', @{$param{$_}}). " ]\n";
667 " $_ => $param{$_}\n";
672 #first get the CGI params shipped off to a job ASAP so an id can be returned
675 my $job = new FS::queue { 'job' => $self->{'job'} };
677 #too slow to insert all the cgi params as individual args..,?
678 #my $error = $queue->insert('_JOB', $cgi->Vars);
680 #warn 'froze string of size '. length(nfreeze(\%param)). " for job args\n"
683 my $error = $job->insert( '_JOB', encode_base64(nfreeze(\%param)) );
687 warn "job not inserted: $error\n"
690 $error; #this doesn't seem to be handled well,
691 # will trigger "illegal jobnum" below?
692 # (should never be an error inserting the job, though, only thing
693 # would be Pg f%*kage)
696 warn "job inserted successfully with jobnum ". $job->jobnum. "\n"
705 my( $self, $jobnum ) = @_; #$url ???
707 sleep 1; # XXX could use something better...
710 if ( $jobnum =~ /^(\d+)$/ ) {
711 $job = qsearchs('queue', { 'jobnum' => $jobnum } );
713 die "FS::UI::Web::job_status: illegal jobnum $jobnum\n";
717 if ( $job && $job->status ne 'failed' && $job->status ne 'done' ) {
718 my ($progress, $action) = split ',', $job->statustext, 2;
719 $action ||= 'Server processing job';
720 @return = ( 'progress', $progress, $action );
721 } elsif ( !$job ) { #handle job gone case : job successful
722 # so close popup, redirect parent window...
723 @return = ( 'complete' );
724 } elsif ( $job->status eq 'done' ) {
725 @return = ( 'done', $job->statustext, '' );
727 @return = ( 'error', $job ? $job->statustext : $jobnum );
730 #to_json(\@return); #waiting on deb 5.0 for new JSON.pm?
731 #silence the warning though
732 my $to_json = JSON->can('to_json') || JSON->can('objToJson');