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
  14 @header = ( '-Expires' => '-1',
  15             '-Pragma' => 'no-cache',
  16             '-Cache-Control' => 'no-cache' );
  17
  18 =head1 NAME
  19
  20 FS::CGI - Subroutines for the web interface
  21
  22 =head1 SYNOPSIS
  23
  24   use FS::CGI qw(header menubar idiot eidiot popurl);
  25
  26   print header( 'Title', '' );
  27   print header( 'Title', menubar('item', 'URL', ... ) );
  28
  29   idiot "error message";
  30   eidiot "error message";
  31
  32   $url = popurl; #returns current url
  33   $url = popurl(3); #three levels up
  34
  35 =head1 DESCRIPTION
  36
  37 Provides a few common subroutines for the web interface.
  38
  39 =head1 SUBROUTINES
  40
  41 =over 4
  42
  43 =item header TITLE, MENUBAR
  44
  45 Returns an HTML header.
  46
  47 =cut
  48
  49 sub header {
  50   my($title,$menubar,$etc)=@_; #$etc is for things like onLoad= etc.
  51   use Carp;
  52   $etc = '' unless defined $etc;
  53
  54   my $x =  <<END;
  55     <HTML>
  56       <HEAD>
  57         <TITLE>
  58           $title
  59         </TITLE>
  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 headers and 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   </HEAD>
 109   <BODY>
 110     <CENTER>
 111     <H4>Error processing your request</H4>
 112     </CENTER>
 113     Your request could not be processed because of the following error:
 114     <P><B>$error</B>
 115   </BODY>
 116 </HTML>
 117 END
 118
 119 }
 120
 121 =item eidiot ERROR
 122
 123 This is depriciated.  Don't use it.
 124
 125 Sends headers and an HTML error message, then exits.
 126
 127 =cut
 128
 129 sub eidiot {
 130   warn "eidiot depriciated";
 131   idiot(@_);
 132   if (exists $ENV{MOD_PERL}) {
 133     $main::Response->End()
 134       if defined $main::Response
 135          && $main::Response->isa('Apache::ASP::Response');
 136     require Apache;
 137     Apache::exit();
 138   } else {
 139     exit;
 140   }
 141 }
 142
 143 =item popurl LEVEL
 144
 145 Returns current URL with LEVEL levels of path removed from the end (default 0).
 146
 147 =cut
 148
 149 sub popurl {
 150   my($up)=@_;
 151   my $cgi = &FS::UID::cgi;
 152   my $url = new URI::URL ( $cgi->isa('Apache') ? $cgi->uri : $cgi->url );
 153   my(@path)=$url->path_components;
 154   splice @path, 0-$up;
 155   $url->path_components(@path);
 156   my $x = $url->as_string;
 157   $x .= '/' unless $x =~ /\/$/;
 158   $x;
 159 }
 160
 161 =item table
 162
 163 Returns HTML tag for beginning a table.
 164
 165 =cut
 166
 167 sub table {
 168   my $col = shift;
 169   if ( $col ) {
 170     qq!<TABLE BGCOLOR="$col" BORDER=1 WIDTH="100%">!;
 171   } else {
 172     "<TABLE BORDER=1>";
 173   }
 174 }
 175
 176 =item itable
 177
 178 Returns HTML tag for beginning an (invisible) table.
 179
 180 =cut
 181
 182 sub itable {
 183   my $col = shift;
 184   my $cellspacing = shift || 0;
 185   if ( $col ) {
 186     qq!<TABLE BGCOLOR="$col" BORDER=0 CELLSPACING=$cellspacing WIDTH="100%">!;
 187   } else {
 188     qq!<TABLE BORDER=0 CELLSPACING=$cellspacing WIDTH="100%">!;
 189   }
 190 }
 191
 192 =item ntable
 193
 194 This is getting silly.
 195
 196 =cut
 197
 198 sub ntable {
 199   my $col = shift;
 200   my $cellspacing = shift || 0;
 201   if ( $col ) {
 202     qq!<TABLE BGCOLOR="$col" BORDER=0 CELLSPACING=$cellspacing>!;
 203   } else {
 204     "<TABLE BORDER>";
 205   }
 206
 207 }
 208
 209 =back
 210
 211 =head1 BUGS
 212
 213 Not OO.
 214
 215 Not complete.
 216
 217 =head1 SEE ALSO
 218
 219 L<CGI>, L<CGI::Base>
 220
 221 =cut
 222
 223 1;
 224
 225