site_perl/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);
  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)=@_;
  47
  48   my $x =  <<END;
  49     <HTML>
  50       <HEAD>
  51         <TITLE>
  52           $title
  53         </TITLE>
  54       </HEAD>
  55       <BODY BGCOLOR="#e8e8e8">
  56           <FONT COLOR="#FF0000" SIZE=7>
  57             $title
  58           </FONT>
  59           <BR><BR>
  60 END
  61   $x .=  $menubar. "<BR><BR>" if $menubar;
  62   $x;
  63 }
  64
  65 =item menubar ITEM, URL, ...
  66
  67 Returns an HTML menubar.
  68
  69 =cut
  70
  71 sub menubar { #$menubar=menubar('Main Menu', '../', 'Item', 'url', ... );
  72   my($item,$url,@html);
  73   while (@_) {
  74     ($item,$url)=splice(@_,0,2);
  75     push @html, qq!<A HREF="$url">$item</A>!;
  76   }
  77   join(' | ',@html);
  78 }
  79
  80 =item idiot ERROR
  81
  82 Sends headers and an HTML error message.
  83
  84 =cut
  85
  86 sub idiot {
  87   my($error)=@_;
  88   my($cgi)=FS::UID::cgi;
  89   if ( $cgi->isa('CGI::Base') ) {
  90     no strict 'subs';
  91     &CGI::Base::SendHeaders;
  92   } else {
  93     print $cgi->header( '-expires' => 'now' );
  94   }
  95   print <<END;
  96 <HTML>
  97   <HEAD>
  98     <TITLE>Error processing your request</TITLE>
  99   </HEAD>
 100   <BODY>
 101     <CENTER>
 102     <H4>Error processing your request</H4>
 103     </CENTER>
 104     Your request could not be processed because of the following error:
 105     <P><B>$error</B>
 106     <P>Hit the <I>Back</I> button in your web browser, correct this mistake, and try again.
 107   </BODY>
 108 </HTML>
 109 END
 110
 111 }
 112
 113 =item eidiot ERROR
 114
 115 Sends headers and an HTML error message, then exits.
 116
 117 =cut
 118
 119 sub eidiot {
 120   idiot(@_);
 121   exit;
 122 }
 123
 124 =item popurl LEVEL
 125
 126 Returns current URL with LEVEL levels of path removed from the end (default 0).
 127
 128 =cut
 129
 130 sub popurl {
 131   my($up)=@_;
 132   my($cgi)=&FS::UID::cgi;
 133   my($url)=new URI::URL $cgi->url;
 134   my(@path)=$url->path_components;
 135   splice @path, 0-$up;
 136   $url->path_components(@path);
 137   my $x = $url->as_string;
 138   $x .= '/' unless $x =~ /\/$/;
 139   $x;
 140 }
 141
 142 =item table
 143
 144 Returns HTML tag for beginning a table.
 145
 146 =cut
 147
 148 sub table {
 149   my $col = shift;
 150   if ( $col ) {
 151     "<TABLE BGCOLOR=$col BORDER=1 WIDTH=\"100%\">";
 152   } else {
 153     "<TABLE BORDER=1>";
 154   }
 155 }
 156
 157 =item itable
 158
 159 Returns HTML tag for beginning an (invisible) table.
 160
 161 =cut
 162
 163 sub itable {
 164   my $col = shift;
 165   if ( $col ) {
 166     qq!<TABLE BGCOLOR=$col BORDER=0 CELLSPACING=0 WIDTH=\"100%\">!;
 167   } else {
 168     "<TABLE>";
 169   }
 170 }
 171
 172 =back
 173
 174 =head1 BUGS
 175
 176 Not OO.
 177
 178 Not complete.
 179
 180 =head1 SEE ALSO
 181
 182 L<CGI>, L<CGI::Base>
 183
 184 =head1 HISTORY
 185
 186 subroutines for the HTML/CGI GUI, not properly OO. :(
 187
 188 ivan@sisd.com 98-apr-16
 189 ivan@sisd.com 98-jun-22
 190
 191 lose the background, eidiot ivan@sisd.com 98-sep-2
 192
 193 pod ivan@sisd.com 98-sep-12
 194
 195 $Log: CGI.pm,v $
 196 Revision 1.15  1999-01-18 09:41:48  ivan
 197 all $cgi->header calls now include ( '-expires' => 'now' ) for mod_perl
 198 (good idea anyway)
 199
 200 Revision 1.14  1999/01/18 09:22:37  ivan
 201 changes to track email addresses for email invoicing
 202
 203 Revision 1.12  1998/12/23 02:23:16  ivan
 204 popurl always has trailing slash
 205
 206 Revision 1.11  1998/11/12 07:43:54  ivan
 207 *** empty log message ***
 208
 209 Revision 1.10  1998/11/12 01:53:47  ivan
 210 added table command
 211
 212 Revision 1.9  1998/11/09 08:51:49  ivan
 213 bug squash
 214
 215 Revision 1.7  1998/11/09 06:10:59  ivan
 216 added sub url
 217
 218 Revision 1.6  1998/11/09 05:44:20  ivan
 219 *** empty log message ***
 220
 221 Revision 1.4  1998/11/09 04:55:42  ivan
 222 support depriciated CGI::Base as well as CGI.pm (for now)
 223
 224 Revision 1.3  1998/11/08 10:50:19  ivan
 225 s/CGI::Base/CGI/; etc.
 226
 227
 228 =cut
 229
 230 1;
 231
 232