diff options
Diffstat (limited to 'site_perl/CGI.pm')
| -rw-r--r-- | site_perl/CGI.pm | 150 |
1 files changed, 134 insertions, 16 deletions
diff --git a/site_perl/CGI.pm b/site_perl/CGI.pm index d2ed52122..723d7f4ec 100644 --- a/site_perl/CGI.pm +++ b/site_perl/CGI.pm @@ -3,11 +3,13 @@ package FS::CGI; use strict; use vars qw(@EXPORT_OK @ISA); use Exporter; -use CGI::Base; +use CGI; +use URI::URL; use CGI::Carp qw(fatalsToBrowser); +use FS::UID; @ISA = qw(Exporter); -@EXPORT_OK = qw(header menubar idiot eidiot); +@EXPORT_OK = qw(header menubar idiot eidiot popurl table itable ntable); =head1 NAME @@ -15,7 +17,7 @@ FS::CGI - Subroutines for the web interface =head1 SYNOPSIS - use FS::CGI qw(header menubar idiot eidiot); + use FS::CGI qw(header menubar idiot eidiot popurl); print header( 'Title', '' ); print header( 'Title', menubar('item', 'URL', ... ) ); @@ -23,6 +25,9 @@ FS::CGI - Subroutines for the web interface idiot "error message"; eidiot "error message"; + $url = popurl; #returns current url + $url = popurl(3); #three levels up + =head1 DESCRIPTION Provides a few common subroutines for the web interface. @@ -40,22 +45,21 @@ Returns an HTML header. sub header { my($title,$menubar)=@_; - <<END; + my $x = <<END; <HTML> <HEAD> <TITLE> $title </TITLE> </HEAD> - <BODY> - <CENTER> - <H1> + <BODY BGCOLOR="#e8e8e8"> + <FONT SIZE=7> $title - </H1> - $menubar - </CENTER> - <HR> + </FONT> + <BR><BR> END + $x .= $menubar. "<BR><BR>" if $menubar; + $x; } =item menubar ITEM, URL, ... @@ -75,13 +79,22 @@ sub menubar { #$menubar=menubar('Main Menu', '../', 'Item', 'url', ... ); =item idiot ERROR +This is depriciated. Don't use it. + Sends headers and an HTML error message. =cut sub idiot { + #warn "idiot depriciated"; my($error)=@_; - CGI::Base::SendHeaders(); + my($cgi)=FS::UID::cgi; + if ( $cgi->isa('CGI::Base') ) { + no strict 'subs'; + &CGI::Base::SendHeaders; + } else { + print $cgi->header( '-expires' => 'now' ); + } print <<END; <HTML> <HEAD> @@ -93,7 +106,6 @@ sub idiot { </CENTER> Your request could not be processed because of the following error: <P><B>$error</B> - <P>Hit the <I>Back</I> button in your web browser, correct this mistake, and try again. </BODY> </HTML> END @@ -102,15 +114,84 @@ END =item eidiot ERROR +This is depriciated. Don't use it. + Sends headers and an HTML error message, then exits. =cut sub eidiot { + #warn "eidiot depriciated"; idiot(@_); exit; } +=item popurl LEVEL + +Returns current URL with LEVEL levels of path removed from the end (default 0). + +=cut + +sub popurl { + my($up)=@_; + my($cgi)=&FS::UID::cgi; + my($url)=new URI::URL $cgi->url; + my(@path)=$url->path_components; + splice @path, 0-$up; + $url->path_components(@path); + my $x = $url->as_string; + $x .= '/' unless $x =~ /\/$/; + $x; +} + +=item table + +Returns HTML tag for beginning a table. + +=cut + +sub table { + my $col = shift; + if ( $col ) { + qq!<TABLE BGCOLOR="$col" BORDER=1 WIDTH="100%">!; + } else { + "<TABLE BORDER=1>"; + } +} + +=item itable + +Returns HTML tag for beginning an (invisible) table. + +=cut + +sub itable { + my $col = shift; + my $cellspacing = shift || 0; + if ( $col ) { + qq!<TABLE BGCOLOR="$col" BORDER=0 CELLSPACING=$cellspacing WIDTH="100%">!; + } else { + qq!<TABLE BORDER=0 CELLSPACING=$cellspacing WIDTH="100%">!; + } +} + +=item ntable + +This is getting silly. + +=cut + +sub ntable { + my $col = shift; + my $cellspacing = shift || 0; + if ( $col ) { + qq!<TABLE BGCOLOR="$col" BORDER=0 CELLSPACING=$cellspacing>!; + } else { + "<TABLE BORDER>"; + } + +} + =back =head1 BUGS @@ -119,11 +200,9 @@ Not OO. Not complete. -Uses CGI-modules instead of CGI.pm - =head1 SEE ALSO -L<CGI::Base> +L<CGI>, L<CGI::Base> =head1 HISTORY @@ -136,6 +215,45 @@ lose the background, eidiot ivan@sisd.com 98-sep-2 pod ivan@sisd.com 98-sep-12 +$Log: CGI.pm,v $ +Revision 1.17 1999-02-07 09:59:43 ivan +more mod_perl fixes, and bugfixes Peter Wemm sent via email + +Revision 1.16 1999/01/25 12:26:05 ivan +yet more mod_perl stuff + +Revision 1.15 1999/01/18 09:41:48 ivan +all $cgi->header calls now include ( '-expires' => 'now' ) for mod_perl +(good idea anyway) + +Revision 1.14 1999/01/18 09:22:37 ivan +changes to track email addresses for email invoicing + +Revision 1.12 1998/12/23 02:23:16 ivan +popurl always has trailing slash + +Revision 1.11 1998/11/12 07:43:54 ivan +*** empty log message *** + +Revision 1.10 1998/11/12 01:53:47 ivan +added table command + +Revision 1.9 1998/11/09 08:51:49 ivan +bug squash + +Revision 1.7 1998/11/09 06:10:59 ivan +added sub url + +Revision 1.6 1998/11/09 05:44:20 ivan +*** empty log message *** + +Revision 1.4 1998/11/09 04:55:42 ivan +support depriciated CGI::Base as well as CGI.pm (for now) + +Revision 1.3 1998/11/08 10:50:19 ivan +s/CGI::Base/CGI/; etc. + + =cut 1; |