FS/FS/UI/CGI.pm

   1 package FS::UI::CGI;
   2
   3 use strict;
   4 use CGI;
   5 #use CGI::Switch;  #when FS::UID user and preference callback stuff is fixed
   6 use CGI::Carp qw(fatalsToBrowser);
   7 use HTML::Table;
   8 use FS::UID qw(adminsuidsetup);
   9 #use FS::Record qw( qsearch fields );
  10
  11 die "Can't initialize CGI interface; $FS::UI::Base::_lock used"
  12   if $FS::UI::Base::_lock;
  13 $FS::UI::Base::_lock = "FS::UI::CGI";
  14
  15 =head1 NAME
  16
  17 FS::UI::CGI - Base class for CGI user-interface objects
  18
  19 =head1 SYNOPSIS
  20
  21   use FS::UI::CGI;
  22   use FS::UI::some_table;
  23
  24   $interface = new FS::UI::some_table;
  25
  26   $error = $interface->browse;
  27   $error = $interface->search;
  28   $error = $interface->view;
  29   $error = $interface->edit;
  30   $error = $interface->process;
  31
  32 =head1 DESCRIPTION
  33
  34 An FS::UI::CGI object represents a CGI interface object.
  35
  36 =head1 METHODS
  37
  38 =over 4
  39
  40 =item new
  41
  42 =cut
  43
  44 sub new {
  45   my $proto = shift;
  46   my $class = ref($proto) || $proto;
  47   my $self = { @_ };
  48
  49   $self->{'_cgi'} = new CGI;
  50   $self->{'_user'} = $self->{'_cgi'}->remote_user;
  51   $self->{'_dbh'} = FS::UID::adminsuidsetup $self->{'_user'};
  52
  53   bless ( $self, $class);
  54 }
  55
  56 sub activate {
  57   my $self = shift;
  58   print $self->_header,
  59         join ( "<BR>", map $_->sprint, @{ $self->{'Widgets'} } ),
  60         $self->_footer,
  61   ;
  62 }
  63
  64 =item _header
  65
  66 =cut
  67
  68 sub _header {
  69   my $self = shift;
  70   my $cgi = $self->{'_cgi'};
  71
  72   $cgi->header( '-expires' => 'now' ), '<HTML>',
  73     '<HEAD><TITLE>', $self->title, '</TITLE></HEAD>',
  74     '<BODY BGCOLOR="#ffffff">',
  75     '<FONT COLOR="#ff0000" SIZE=7>', $self->title, '</FONT><BR><BR>',
  76   ;
  77 }
  78
  79 =item _footer
  80
  81 =cut
  82
  83 sub _footer {
  84   "</BODY></HTML>";
  85 }
  86
  87 =item interface
  88
  89 Returns the string `CGI'.  Useful for the author of a table-specific UI class
  90 to conditionally specify certain behaviour.
  91
  92 =cut
  93
  94 sub interface { 'CGI'; }
  95
  96 =back
  97
  98 =cut
  99
 100 package FS::UI::_Widget;
 101
 102 use vars qw( $AUTOLOAD );
 103
 104 sub new {
 105   my $proto = shift;
 106   my $class = ref($proto) || $proto;
 107   my $self = { @_ };
 108   bless ( $self, $class );
 109 }
 110
 111 sub AUTOLOAD {
 112   my $self = shift;
 113   my $value = shift;
 114   my($field)=$AUTOLOAD;
 115   $field =~ s/.*://;
 116   if ( defined($value) ) {
 117     $self->{$field} = $value;
 118   } else {
 119     $self->{$field};
 120   }
 121 }
 122
 123 package FS::UI::_Text;
 124
 125 use vars qw ( @ISA );
 126
 127 @ISA = qw ( FS::UI::_Widget);
 128
 129 sub new {
 130   my $proto = shift;
 131   my $class = ref($proto) || $proto;
 132   my $self = {};
 133   $self->{'_text'} = shift;
 134   bless ( $self, $class );
 135 }
 136
 137 sub sprint {
 138   my $self = shift;
 139   $self->{'_text'};
 140 }
 141
 142 package FS::UI::_Link;
 143
 144 use vars qw ( @ISA $BASE_URL );
 145
 146 @ISA = qw ( FS::UI::_Widget);
 147 $BASE_URL = "http://rootwood.sisd.com/freeside";
 148
 149 sub sprint {
 150   my $self = shift;
 151   my $table = $self->{'table'};
 152   my $method = $self->{'method'};
 153
 154   # i will be cleaned up when we're done moving from the old webinterface!
 155   my @arg = @{$self->{'arg'}};
 156   my $yuck = join( "&", @arg);
 157   qq(<A HREF="$BASE_URL/$method/$table.cgi?$yuck">). $self->{'text'}. "<\A>";
 158 }
 159
 160 package FS::UI::_Table;
 161
 162 use vars qw ( @ISA );
 163
 164 @ISA = qw ( FS::UI::_Widget);
 165
 166 sub new {
 167   my $proto = shift;
 168   my $class = ref($proto) || $proto;
 169   my $self = $class eq $proto ? { @_ } : $proto;
 170   bless ( $self, $class );
 171   $self->{'_table'} = new HTML::Table ( $self->rows, $self->columns );
 172   $self;
 173 }
 174
 175 sub attach {
 176   my $self = shift;
 177   my ( $row, $column, $widget, $rowspan, $colspan ) = @_;
 178   $self->{"_table"}->setCell( $row+1, $column+1, $widget->sprint );
 179   $self->{"_table"}->setCellRowSpan( $row+1, $column+1, $rowspan ) if $rowspan;
 180   $self->{"_table"}->setCellColSpan( $row+1, $column+1, $colspan ) if $colspan;
 181 }
 182
 183 sub sprint {
 184   my $self = shift;
 185   $self->{'_table'}->getTable;
 186 }
 187
 188 package FS::UI::_Tableborder;
 189
 190 use vars qw ( @ISA );
 191
 192 @ISA = qw ( FS::UI::_Table );
 193
 194 sub new {
 195   my $proto = shift;
 196   my $class = ref($proto) || $proto;
 197   my $self = $class eq $proto ? { @_ } : $proto;
 198   bless ( $self, $class );
 199   $self->SUPER::new(@_);
 200   $self->{'_table'}->setBorder;
 201   $self;
 202 }
 203
 204 =head1 VERSION
 205
 206 $Id: CGI.pm,v 1.1 1999-08-04 09:03:53 ivan Exp $
 207
 208 =head1 BUGS
 209
 210 This documentation is incomplete.
 211
 212 In _Tableborder, headers should be links that sort on their fields.
 213
 214 _Link uses a constant $BASE_URL
 215
 216 _Link passes the arguments as a manually-constructed GET string instead
 217 of POSTing, for compatability while the web interface is upgraded.  Once
 218 this is done it should pass arguements properly (i.e. as a POST, 8-bit clean)
 219
 220 Still some small bits of widget code same as FS::UI::Gtk.
 221
 222 =head1 SEE ALSO
 223
 224 L<FS::UI::Base>
 225
 226 =head1 HISTORY
 227
 228 $Log: CGI.pm,v $
 229 Revision 1.1  1999-08-04 09:03:53  ivan
 230 initial checkin of module files for proper perl installation
 231
 232 Revision 1.1  1999/01/20 09:30:36  ivan
 233 skeletal cross-UI UI code.
 234
 235
 236 =cut
 237
 238 1;
 239