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