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 url);
  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 url);
  21
  22   print header( 'Title', '' );
  23   print header( 'Title', menubar('item', 'URL', ... ) );
  24
  25   idiot "error message";
  26   eidiot "error message";
  27
  28   $url = url; #returns current url
  29   $url = url (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   <<END;
  49     <HTML>
  50       <HEAD>
  51         <TITLE>
  52           $title
  53         </TITLE>
  54       </HEAD>
  55       <BODY BGCOLOR="#ffffff">
  56           <FONT COLOR="#FF0000" SIZE=7>
  57             $title
  58           </FONT>
  59           <BR><BR>
  60           $menubar
  61       <BR><BR>
  62 END
  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;
  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 url LEVEL
 125
 126 Returns current URL with LEVEL levels of path removed from the end (default 0).
 127
 128 =cut
 129
 130 =item url {
 131   my($up)=@_;
 132   my($cgi)=FS::UID::cgi;
 133   my($url)=new URI::URL $cgi;
 134   my(@path)=$url->path_components;
 135   pop @path foreach ( 1.. $up );
 136   $url->path_components(@path);
 137   $url->as_string;
 138 }
 139
 140 =back
 141
 142 =head1 BUGS
 143
 144 Not OO.
 145
 146 Not complete.
 147
 148 =head1 SEE ALSO
 149
 150 L<CGI>, L<CGI::Base>
 151
 152 =head1 HISTORY
 153
 154 subroutines for the HTML/CGI GUI, not properly OO. :(
 155
 156 ivan@sisd.com 98-apr-16
 157 ivan@sisd.com 98-jun-22
 158
 159 lose the background, eidiot ivan@sisd.com 98-sep-2
 160
 161 pod ivan@sisd.com 98-sep-12
 162
 163 $Log: CGI.pm,v $
 164 Revision 1.7  1998-11-09 06:10:59  ivan
 165 added sub url
 166
 167 Revision 1.6  1998/11/09 05:44:20  ivan
 168 *** empty log message ***
 169
 170 Revision 1.4  1998/11/09 04:55:42  ivan
 171 support depriciated CGI::Base as well as CGI.pm (for now)
 172
 173 Revision 1.3  1998/11/08 10:50:19  ivan
 174 s/CGI::Base/CGI/; etc.
 175
 176
 177 =cut
 178
 179 1;
 180
 181