FS/FS/CGI.pm

   1 package FS::CGI;
   2
   3 use strict;
   4 use vars qw(@EXPORT_OK @ISA @header);
   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   idiot(@_);
 135   &myexit();
 136 }
 137
 138 =item myexit
 139
 140 You probably shouldn't use this; but if you must:
 141
 142 If running under mod_perl, calles Apache::exit, otherwise, calls exit.
 143
 144 =cut
 145
 146 sub myexit {
 147   if (exists $ENV{MOD_PERL}) {
 148     $main::Response->End()
 149       if defined $main::Response
 150          && $main::Response->isa('Apache::ASP::Response');
 151     require Apache;
 152     Apache::exit();
 153   } else {
 154     exit;
 155   }
 156 }
 157
 158 =item popurl LEVEL
 159
 160 Returns current URL with LEVEL levels of path removed from the end (default 0).
 161
 162 =cut
 163
 164 sub popurl {
 165   my($up)=@_;
 166   my $cgi = &FS::UID::cgi;
 167   my $url = new URI::URL ( $cgi->isa('Apache') ? $cgi->uri : $cgi->url );
 168   my(@path)=$url->path_components;
 169   splice @path, 0-$up;
 170   $url->path_components(@path);
 171   my $x = $url->as_string;
 172   $x .= '/' unless $x =~ /\/$/;
 173   $x;
 174 }
 175
 176 =item table
 177
 178 Returns HTML tag for beginning a table.
 179
 180 =cut
 181
 182 sub table {
 183   my $col = shift;
 184   if ( $col ) {
 185     qq!<TABLE BGCOLOR="$col" BORDER=1 WIDTH="100%" CELLSPACING=0 CELLPADDING=2 BORDERCOLOR="#999999">!;
 186   } else {
 187     '<TABLE BORDER=1 CELLSPACING=0 CELLPADDING=2 BORDERCOLOR="#999999">';
 188   }
 189 }
 190
 191 =item itable
 192
 193 Returns HTML tag for beginning an (invisible) table.
 194
 195 =cut
 196
 197 sub itable {
 198   my $col = shift;
 199   my $cellspacing = shift || 0;
 200   if ( $col ) {
 201     qq!<TABLE BGCOLOR="$col" BORDER=0 CELLSPACING=$cellspacing WIDTH="100%">!;
 202   } else {
 203     qq!<TABLE BORDER=0 CELLSPACING=$cellspacing WIDTH="100%">!;
 204   }
 205 }
 206
 207 =item ntable
 208
 209 This is getting silly.
 210
 211 =cut
 212
 213 sub ntable {
 214   my $col = shift;
 215   my $cellspacing = shift || 0;
 216   if ( $col ) {
 217     qq!<TABLE BGCOLOR="$col" BORDER=0 CELLSPACING=$cellspacing>!;
 218   } else {
 219     '<TABLE BORDER CELLSPACING=0 CELLPADDING=2 BORDERCOLOR="#999999">';
 220   }
 221
 222 }
 223
 224 =item small_custview CUSTNUM || CUST_MAIN_OBJECT, COUNTRYDEFAULT
 225
 226 Sheesh. I should just switch to Mason.
 227
 228 =cut
 229
 230 sub small_custview {
 231   use FS::Record qw(qsearchs);
 232   use FS::cust_main;
 233
 234   my $arg = shift;
 235   my $countrydefault = shift || 'US';
 236
 237   my $cust_main = ref($arg) ? $arg
 238                   : qsearchs('cust_main', { 'custnum' => $arg } )
 239     or die "unknown custnum $arg";
 240
 241   my $html = 'Customer #<B>'. $cust_main->custnum. '</B>'.
 242     ntable('#e8e8e8'). '<TR><TD>'. ntable("#cccccc",2).
 243     '<TR><TD ALIGN="right" VALIGN="top">Billing</TD><TD BGCOLOR="#ffffff">'.
 244     $cust_main->getfield('last'). ', '. $cust_main->first. '<BR>';
 245
 246   $html .= $cust_main->company. '<BR>' if $cust_main->company;
 247   $html .= $cust_main->address1. '<BR>';
 248   $html .= $cust_main->address2. '<BR>' if $cust_main->address2;
 249   $html .= $cust_main->city. ', '. $cust_main->state. '  '. $cust_main->zip. '<BR>';
 250   $html .= $cust_main->country. '<BR>'
 251     if $cust_main->country && $cust_main->country ne $countrydefault;
 252
 253   $html .= '</TD></TR></TABLE></TD>';
 254
 255   if ( defined $cust_main->dbdef_table->column('ship_last') ) {
 256
 257     my $pre = $cust_main->ship_last ? 'ship_' : '';
 258
 259     $html .= '<TD>'. ntable("#cccccc",2).
 260       '<TR><TD ALIGN="right" VALIGN="top">Service</TD><TD BGCOLOR="#ffffff">'.
 261       $cust_main->get("${pre}last"). ', '.
 262       $cust_main->get("${pre}first"). '<BR>';
 263     $html .= $cust_main->get("${pre}company"). '<BR>'
 264       if $cust_main->get("${pre}company");
 265     $html .= $cust_main->get("${pre}address1"). '<BR>';
 266     $html .= $cust_main->get("${pre}address2"). '<BR>'
 267       if $cust_main->get("${pre}address2");
 268     $html .= $cust_main->get("${pre}city"). ', '.
 269              $cust_main->get("${pre}state"). '  '.
 270              $cust_main->get("${pre}ship_zip"). '<BR>';
 271     $html .= $cust_main->get("${pre}country"). '<BR>'
 272       if $cust_main->get("${pre}country")
 273          && $cust_main->get("${pre}country") ne $countrydefault;
 274
 275     $html .= '</TD></TR></TABLE></TD>';
 276   }
 277
 278   $html .= '</TR></TABLE>';
 279
 280   $html;
 281 }
 282
 283 =back
 284
 285 =head1 BUGS
 286
 287 Not OO.
 288
 289 Not complete.
 290
 291 small_custview sooooo doesn't belong here.  i should just switch to Mason.
 292
 293 =head1 SEE ALSO
 294
 295 L<CGI>, L<CGI::Base>
 296
 297 =cut
 298
 299 1;
 300
 301