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