popurl always has trailing slash

[freeside.git] / site_perl / CGI.pm
diff --git a/site_perl/CGI.pm b/site_perl/CGI.pm

index d2ed521..b21a888 100644 (file)
--- 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);
  
  =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.
@@ -47,14 +52,13 @@ sub header {
            $title
          </TITLE>
        </HEAD>
-      <BODY>
-        <CENTER>
-          <H1>
+      <BODY BGCOLOR="#ffffff">
+          <FONT COLOR="#FF0000" SIZE=7>
              $title
-          </H1>
+          </FONT>
+          <BR><BR>
            $menubar
-        </CENTER>
-      <HR>
+      <BR><BR>
  END
  }
  
@@ -81,7 +85,13 @@ Sends headers and an HTML error message.
  
  sub idiot {
    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;
+  }
    print <<END;
  <HTML>
    <HEAD>
@@ -111,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
@@ -119,11 +157,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 +172,32 @@ lose the background, eidiot ivan@sisd.com 98-sep-2
  
  pod ivan@sisd.com 98-sep-12
  
+$Log: CGI.pm,v $
+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;