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)=@_;
  47
  48   my $x =  <<END;
  49     <HTML>
  50       <HEAD>
  51         <TITLE>
  52           $title
  53         </TITLE>
  54       </HEAD>
  55       <BODY BGCOLOR="#e8e8e8">
  56           <FONT 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 This is depriciated.  Don't use it.
  83
  84 Sends headers and an HTML error message.
  85
  86 =cut
  87
  88 sub idiot {
  89   #warn "idiot depriciated";
  90   my($error)=@_;
  91   my $cgi = &FS::UID::cgi();
  92   if ( $cgi->isa('CGI::Base') ) {
  93     no strict 'subs';
  94     &CGI::Base::SendHeaders;
  95   } else {
  96     print $cgi->header( '-expires' => 'now' );
  97   }
  98   print <<END;
  99 <HTML>
 100   <HEAD>
 101     <TITLE>Error processing your request</TITLE>
 102   </HEAD>
 103   <BODY>
 104     <CENTER>
 105     <H4>Error processing your request</H4>
 106     </CENTER>
 107     Your request could not be processed because of the following error:
 108     <P><B>$error</B>
 109   </BODY>
 110 </HTML>
 111 END
 112
 113 }
 114
 115 =item eidiot ERROR
 116
 117 This is depriciated.  Don't use it.
 118
 119 Sends headers and an HTML error message, then exits.
 120
 121 =cut
 122
 123 sub eidiot {
 124   warn "eidiot depriciated";
 125   idiot(@_);
 126   if (exists $ENV{MOD_PERL}) {
 127     require Apache;
 128     Apache::exit();
 129   } else {
 130     exit;
 131   }
 132 }
 133
 134 =item popurl LEVEL
 135
 136 Returns current URL with LEVEL levels of path removed from the end (default 0).
 137
 138 =cut
 139
 140 sub popurl {
 141   my($up)=@_;
 142   my $cgi = &FS::UID::cgi;
 143   my $url = new URI::URL ( $cgi->isa('Apache') ? $cgi->uri : $cgi->url );
 144   my(@path)=$url->path_components;
 145   splice @path, 0-$up;
 146   $url->path_components(@path);
 147   my $x = $url->as_string;
 148   $x .= '/' unless $x =~ /\/$/;
 149   $x;
 150 }
 151
 152 =item table
 153
 154 Returns HTML tag for beginning a table.
 155
 156 =cut
 157
 158 sub table {
 159   my $col = shift;
 160   if ( $col ) {
 161     qq!<TABLE BGCOLOR="$col" BORDER=1 WIDTH="100%">!;
 162   } else {
 163     "<TABLE BORDER=1>";
 164   }
 165 }
 166
 167 =item itable
 168
 169 Returns HTML tag for beginning an (invisible) table.
 170
 171 =cut
 172
 173 sub itable {
 174   my $col = shift;
 175   my $cellspacing = shift || 0;
 176   if ( $col ) {
 177     qq!<TABLE BGCOLOR="$col" BORDER=0 CELLSPACING=$cellspacing WIDTH="100%">!;
 178   } else {
 179     qq!<TABLE BORDER=0 CELLSPACING=$cellspacing WIDTH="100%">!;
 180   }
 181 }
 182
 183 =item ntable
 184
 185 This is getting silly.
 186
 187 =cut
 188
 189 sub ntable {
 190   my $col = shift;
 191   my $cellspacing = shift || 0;
 192   if ( $col ) {
 193     qq!<TABLE BGCOLOR="$col" BORDER=0 CELLSPACING=$cellspacing>!;
 194   } else {
 195     "<TABLE BORDER>";
 196   }
 197
 198 }
 199
 200 =back
 201
 202 =head1 BUGS
 203
 204 Not OO.
 205
 206 Not complete.
 207
 208 =head1 SEE ALSO
 209
 210 L<CGI>, L<CGI::Base>
 211
 212 =cut
 213
 214 1;
 215
 216