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