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