X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;ds=sidebyside;f=site_perl%2FCGI.pm;h=b21a88837b1d2c0111d698ec2f939fc9cb3d9055;hb=09a5eb8c6c43659d31fc043f556e404dcf322b13;hp=459c6fd49021d3260942a0c9564aa36e4a2a7522;hpb=ef142bc2988526f275ade645e3ea33d461f90cf5;p=freeside.git

diff --git a/site_perl/CGI.pm b/site_perl/CGI.pm
index 459c6fd49..b21a88837 100644
--- a/site_perl/CGI.pm
+++ b/site_perl/CGI.pm
@@ -4,11 +4,12 @@ use strict;
 use vars qw(@EXPORT_OK @ISA);
 use Exporter;
 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);
 
 =head1 NAME
 
@@ -16,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', ... ) );
@@ -24,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.
@@ -84,7 +88,7 @@ sub idiot {
   my($cgi)=FS::UID::cgi;
   if ( $cgi->isa('CGI::Base') ) {
     no strict 'subs';
-    CGI::Base::SendHeaders;
+    &CGI::Base::SendHeaders;
   } else {
     print $cgi->header;
   }
@@ -117,6 +121,34 @@ sub eidiot {
   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 {
+  "<TABLE BORDER=1>";
+}
+
 =back
 
 =head1 BUGS
@@ -141,7 +173,22 @@ lose the background, eidiot ivan@sisd.com 98-sep-2
 pod ivan@sisd.com 98-sep-12
 
 $Log: CGI.pm,v $
-Revision 1.5  1998-11-09 05:23:55  ivan
+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