FS/FS/CGI.pm

   1 package FS::CGI;
   2
   3 use strict;
   4 use vars qw(@EXPORT_OK @ISA);
   5 use Exporter;
   6 use CGI;
   7 use URI::URL;
   8 #use CGI::Carp qw(fatalsToBrowser);
   9 use FS::UID;
  10
  11 @ISA = qw(Exporter);
  12 @EXPORT_OK = qw(header menubar idiot eidiot popurl table itable ntable
  13                 small_custview myexit);
  14
  15 =head1 NAME
  16
  17 FS::CGI - Subroutines for the web interface
  18
  19 =head1 SYNOPSIS
  20
  21   use FS::CGI qw(header menubar idiot eidiot popurl);
  22
  23   print header( 'Title', '' );
  24   print header( 'Title', menubar('item', 'URL', ... ) );
  25
  26   idiot "error message";
  27   eidiot "error message";
  28
  29   $url = popurl; #returns current url
  30   $url = popurl(3); #three levels up
  31
  32 =head1 DESCRIPTION
  33
  34 Provides a few common subroutines for the web interface.
  35
  36 =head1 SUBROUTINES
  37
  38 =over 4
  39
  40 =item header TITLE, MENUBAR
  41
  42 Returns an HTML header.
  43
  44 =cut
  45
  46 sub header {
  47   my($title,$menubar,$etc)=@_; #$etc is for things like onLoad= etc.
  48   #use Carp;
  49   $etc = '' unless defined $etc;
  50
  51   my $x =  <<END;
  52     <HTML>
  53       <HEAD>
  54         <TITLE>
  55           $title
  56         </TITLE>
  57         <META HTTP-Equiv="Cache-Control" Content="no-cache">
  58         <META HTTP-Equiv="Pragma" Content="no-cache">
  59         <META HTTP-Equiv="Expires" Content="0">
  60       </HEAD>
  61       <BODY BGCOLOR="#e8e8e8"$etc>
  62           <FONT SIZE=7>
  63             $title
  64           </FONT>
  65           <BR><BR>
  66 END
  67   $x .=  $menubar. "<BR><BR>" if $menubar;
  68   $x;
  69 }
  70
  71 =item menubar ITEM, URL, ...
  72
  73 Returns an HTML menubar.
  74
  75 =cut
  76
  77 sub menubar { #$menubar=menubar('Main Menu', '../', 'Item', 'url', ... );
  78   my($item,$url,@html);
  79   while (@_) {
  80     ($item,$url)=splice(@_,0,2);
  81     push @html, qq!<A HREF="$url">$item</A>!;
  82   }
  83   join(' | ',@html);
  84 }
  85
  86 =item idiot ERROR
  87
  88 This is depriciated.  Don't use it.
  89
  90 Sends an HTML error message.
  91
  92 =cut
  93
  94 sub idiot {
  95   #warn "idiot depriciated";
  96   my($error)=@_;
  97 #  my $cgi = &FS::UID::cgi();
  98 #  if ( $cgi->isa('CGI::Base') ) {
  99 #    no strict 'subs';
 100 #    &CGI::Base::SendHeaders;
 101 #  } else {
 102 #    print $cgi->header( @FS::CGI::header );
 103 #  }
 104   print <<END;
 105 <HTML>
 106   <HEAD>
 107     <TITLE>Error processing your request</TITLE>
 108     <META HTTP-Equiv="Cache-Control" Content="no-cache">
 109     <META HTTP-Equiv="Pragma" Content="no-cache">
 110     <META HTTP-Equiv="Expires" Content="0">
 111   </HEAD>
 112   <BODY>
 113     <CENTER>
 114     <H4>Error processing your request</H4>
 115     </CENTER>
 116     Your request could not be processed because of the following error:
 117     <P><B>$error</B>
 118   </BODY>
 119 </HTML>
 120 END
 121
 122 }
 123
 124 =item eidiot ERROR
 125
 126 This is depriciated.  Don't use it.
 127
 128 Sends an HTML error message, then exits.
 129
 130 =cut
 131
 132 sub eidiot {
 133   warn "eidiot depriciated";
 134   $HTML::Mason::Commands::r->send_http_header
 135     if defined $HTML::Mason::Commands::r;
 136   idiot(@_);
 137   &myexit();
 138 }
 139
 140 =item myexit
 141
 142 You probably shouldn't use this; but if you must:
 143
 144 If running under mod_perl, calles Apache::exit, otherwise, calls exit.
 145
 146 =cut
 147
 148 sub myexit {
 149   if (exists $ENV{MOD_PERL}) {
 150
 151     if ( defined $main::Response
 152          && $main::Response->isa('Apache::ASP::Response') ) {  #Apache::ASP
 153       $main::Response->End();
 154       require Apache;
 155       Apache::exit();
 156     } elsif ( defined $HTML::Mason::Commands::m  ) { #Mason
 157       #$HTML::Mason::Commands::m->flush_buffer();
 158       $HTML::Mason::Commands::m->abort();
 159       die "shouldn't fall through to here (mason \$m->abort didn't)";
 160     } else {
 161       #??? well, it is $ENV{MOD_PERL}
 162       warn "running under unknown mod_perl environment; trying Apache::exit()";
 163       require Apache;
 164       Apache::exit();
 165     }
 166   } else {
 167     exit;
 168   }
 169 }
 170
 171 =item popurl LEVEL
 172
 173 Returns current URL with LEVEL levels of path removed from the end (default 0).
 174
 175 =cut
 176
 177 sub popurl {
 178   my($up)=@_;
 179   my $cgi = &FS::UID::cgi;
 180   my $url = new URI::URL ( $cgi->isa('Apache') ? $cgi->uri : $cgi->url );
 181   my(@path)=$url->path_components;
 182   splice @path, 0-$up;
 183   $url->path_components(@path);
 184   my $x = $url->as_string;
 185   $x .= '/' unless $x =~ /\/$/;
 186   $x;
 187 }
 188
 189 =item table
 190
 191 Returns HTML tag for beginning a table.
 192
 193 =cut
 194
 195 sub table {
 196   my $col = shift;
 197   if ( $col ) {
 198     qq!<TABLE BGCOLOR="$col" BORDER=1 WIDTH="100%" CELLSPACING=0 CELLPADDING=2 BORDERCOLOR="#999999">!;
 199   } else {
 200     '<TABLE BORDER=1 CELLSPACING=0 CELLPADDING=2 BORDERCOLOR="#999999">';
 201   }
 202 }
 203
 204 =item itable
 205
 206 Returns HTML tag for beginning an (invisible) table.
 207
 208 =cut
 209
 210 sub itable {
 211   my $col = shift;
 212   my $cellspacing = shift || 0;
 213   if ( $col ) {
 214     qq!<TABLE BGCOLOR="$col" BORDER=0 CELLSPACING=$cellspacing WIDTH="100%">!;
 215   } else {
 216     qq!<TABLE BORDER=0 CELLSPACING=$cellspacing WIDTH="100%">!;
 217   }
 218 }
 219
 220 =item ntable
 221
 222 This is getting silly.
 223
 224 =cut
 225
 226 sub ntable {
 227   my $col = shift;
 228   my $cellspacing = shift || 0;
 229   if ( $col ) {
 230     qq!<TABLE BGCOLOR="$col" BORDER=0 CELLSPACING=$cellspacing>!;
 231   } else {
 232     '<TABLE BORDER CELLSPACING=0 CELLPADDING=2 BORDERCOLOR="#999999">';
 233   }
 234
 235 }
 236
 237 =item small_custview CUSTNUM || CUST_MAIN_OBJECT, COUNTRYDEFAULT
 238
 239 Sheesh. I should just switch to Mason.
 240
 241 =cut
 242
 243 sub small_custview {
 244   use FS::Record qw(qsearchs);
 245   use FS::cust_main;
 246
 247   my $arg = shift;
 248   my $countrydefault = shift || 'US';
 249
 250   my $cust_main = ref($arg) ? $arg
 251                   : qsearchs('cust_main', { 'custnum' => $arg } )
 252     or die "unknown custnum $arg";
 253
 254   my $html = 'Customer #<B>'. $cust_main->custnum. '</B>'.
 255     ntable('#e8e8e8'). '<TR><TD>'. ntable("#cccccc",2).
 256     '<TR><TD ALIGN="right" VALIGN="top">Billing</TD><TD BGCOLOR="#ffffff">'.
 257     $cust_main->getfield('last'). ', '. $cust_main->first. '<BR>';
 258
 259   $html .= $cust_main->company. '<BR>' if $cust_main->company;
 260   $html .= $cust_main->address1. '<BR>';
 261   $html .= $cust_main->address2. '<BR>' if $cust_main->address2;
 262   $html .= $cust_main->city. ', '. $cust_main->state. '  '. $cust_main->zip. '<BR>';
 263   $html .= $cust_main->country. '<BR>'
 264     if $cust_main->country && $cust_main->country ne $countrydefault;
 265
 266   $html .= '</TD></TR></TABLE></TD>';
 267
 268   if ( defined $cust_main->dbdef_table->column('ship_last') ) {
 269
 270     my $pre = $cust_main->ship_last ? 'ship_' : '';
 271
 272     $html .= '<TD>'. ntable("#cccccc",2).
 273       '<TR><TD ALIGN="right" VALIGN="top">Service</TD><TD BGCOLOR="#ffffff">'.
 274       $cust_main->get("${pre}last"). ', '.
 275       $cust_main->get("${pre}first"). '<BR>';
 276     $html .= $cust_main->get("${pre}company"). '<BR>'
 277       if $cust_main->get("${pre}company");
 278     $html .= $cust_main->get("${pre}address1"). '<BR>';
 279     $html .= $cust_main->get("${pre}address2"). '<BR>'
 280       if $cust_main->get("${pre}address2");
 281     $html .= $cust_main->get("${pre}city"). ', '.
 282              $cust_main->get("${pre}state"). '  '.
 283              $cust_main->get("${pre}ship_zip"). '<BR>';
 284     $html .= $cust_main->get("${pre}country"). '<BR>'
 285       if $cust_main->get("${pre}country")
 286          && $cust_main->get("${pre}country") ne $countrydefault;
 287
 288     $html .= '</TD></TR></TABLE></TD>';
 289   }
 290
 291   $html .= '</TR></TABLE>';
 292
 293   $html;
 294 }
 295
 296 =back
 297
 298 =head1 BUGS
 299
 300 Not OO.
 301
 302 Not complete.
 303
 304 small_custview sooooo doesn't belong here.  i should just switch to Mason.
 305
 306 =head1 SEE ALSO
 307
 308 L<CGI>, L<CGI::Base>
 309
 310 =cut
 311
 312 1;
 313
 314