+++ /dev/null
-package FS::UI::Base;
-
-use strict;
-use vars qw ( @ISA );
-use FS::Record qw( fields qsearch );
-
-@ISA = ( $FS::UI::Base::_lock );
-
-=head1 NAME
-
-FS::UI::Base - Base class for all user-interface objects
-
-=head1 SYNOPSIS
-
- use FS::UI::SomeInterface;
- use FS::UI::some_table;
-
- $interface = new FS::UI::some_table;
-
- $error = $interface->browse;
- $error = $interface->search;
- $error = $interface->view;
- $error = $interface->edit;
- $error = $interface->process;
-
-=head1 DESCRIPTION
-
-An FS::UI::Base object represents a user interface object. FS::UI::Base
-is intended as a base class for table-specfic classes to inherit from, i.e.
-FS::UI::cust_main. The simplest case, which will provide a default UI for your
-new table, is as follows:
-
- package FS::UI::table_name;
- use vars qw ( @ISA );
- use FS::UI::Base;
- @ISA = qw( FS::UI::Base );
- sub db_table { 'table_name'; }
-
-Currently available interfaces are:
- FS::UI::Gtk, an X-Windows UI implemented using the Gtk+ toolkit
- FS::UI::CGI, a web interface implemented using CGI.pm, etc.
-
-=head1 METHODS
-
-=over 4
-
-=item new
-
-=cut
-
-=item browse
-
-=cut
-
-sub browse {
- my $self = shift;
-
- my @fields = $self->list_fields;
-
- #begin browse-specific stuff
-
- $self->title( "Browse ". $self->db_names ) unless $self->title;
- my @records = qsearch ( $self->db_table, {} );
-
- #end browse-specific stuff
-
- $self->addwidget ( new FS::UI::_Text ( $self->db_description ) );
-
- my @header = $self->list_header;
- my @headerspan = $self->list_headerspan;
- my %callback = $self->db_callback;
-
- my $columns;
-
- my $table = new FS::UI::_Tableborder (
- 'rows' => 1 + scalar(@records),
- 'columns' => $columns || scalar(@fields),
- );
-
- my $c = 0;
- foreach my $header ( @header ) {
- my $headerspan = shift(@headerspan) || 1;
- $table->attach(
- 0, $c, new FS::UI::_Text ( $header ), 1, $headerspan
- );
- $c += $headerspan;
- }
-
- my $r = 1;
-
- foreach my $record ( @records ) {
- $c = 0;
- foreach my $field ( @fields ) {
- my $value = $record->getfield($field);
- my $widget;
- if ( $callback{$field} ) {
- $widget = &{ $callback{$field} }( $value, $record );
- } else {
- $widget = new FS::UI::_Text ( $value );
- }
- $table->attach( $r, $c++, $widget, 1, 1 );
- }
- $r++;
- }
-
- $self->addwidget( $table );
-
- $self->activate;
-
-}
-
-=item title
-
-=cut
-
-sub title {
- my $self = shift;
- my $value = shift;
- if ( defined($value) ) {
- $self->{'title'} = $value;
- } else {
- $self->{'title'};
- }
-}
-
-=item addwidget
-
-=cut
-
-sub addwidget {
- my $self = shift;
- my $widget = shift;
- push @{ $self->{'Widgets'} }, $widget;
-}
-
-#fallback methods
-
-sub db_description {}
-
-sub db_name {}
-
-sub db_names {
- my $self = shift;
- $self->db_name. 's';
-}
-
-sub list_fields {
- my $self = shift;
- fields( $self->db_table );
-}
-
-sub list_header {
- my $self = shift;
- $self->list_fields
-}
-
-sub list_headerspan {
- my $self = shift;
- map 1, $self->list_header;
-}
-
-sub db_callback {}
-
-=back
-
-=head1 VERSION
-
-$Id: Base.pm,v 1.1 1999-08-04 09:03:53 ivan Exp $
-
-=head1 BUGS
-
-This documentation is incomplete.
-
-There should be some sort of per-(freeside)-user preferences and the ability
-for specific FS::UI:: modules to put their own values there as well.
-
-=head1 SEE ALSO
-
-L<FS::UI::Gtk>, L<FS::UI::CGI>
-
-=head1 HISTORY
-
-$Log: Base.pm,v $
-Revision 1.1 1999-08-04 09:03:53 ivan
-initial checkin of module files for proper perl installation
-
-Revision 1.1 1999/01/20 09:30:36 ivan
-skeletal cross-UI UI code.
-
-
-=cut
-
-1;
-
+++ /dev/null
-package FS::UI::CGI;
-
-use strict;
-use CGI;
-#use CGI::Switch; #when FS::UID user and preference callback stuff is fixed
-use CGI::Carp qw(fatalsToBrowser);
-use HTML::Table;
-use FS::UID qw(adminsuidsetup);
-#use FS::Record qw( qsearch fields );
-
-die "Can't initialize CGI interface; $FS::UI::Base::_lock used"
- if $FS::UI::Base::_lock;
-$FS::UI::Base::_lock = "FS::UI::CGI";
-
-=head1 NAME
-
-FS::UI::CGI - Base class for CGI user-interface objects
-
-=head1 SYNOPSIS
-
- use FS::UI::CGI;
- use FS::UI::some_table;
-
- $interface = new FS::UI::some_table;
-
- $error = $interface->browse;
- $error = $interface->search;
- $error = $interface->view;
- $error = $interface->edit;
- $error = $interface->process;
-
-=head1 DESCRIPTION
-
-An FS::UI::CGI object represents a CGI interface object.
-
-=head1 METHODS
-
-=over 4
-
-=item new
-
-=cut
-
-sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $self = { @_ };
-
- $self->{'_cgi'} = new CGI;
- $self->{'_user'} = $self->{'_cgi'}->remote_user;
- $self->{'_dbh'} = FS::UID::adminsuidsetup $self->{'_user'};
-
- bless ( $self, $class);
-}
-
-sub activate {
- my $self = shift;
- print $self->_header,
- join ( "<BR>", map $_->sprint, @{ $self->{'Widgets'} } ),
- $self->_footer,
- ;
-}
-
-=item _header
-
-=cut
-
-sub _header {
- my $self = shift;
- my $cgi = $self->{'_cgi'};
-
- $cgi->header( '-expires' => 'now' ), '<HTML>',
- '<HEAD><TITLE>', $self->title, '</TITLE></HEAD>',
- '<BODY BGCOLOR="#ffffff">',
- '<FONT COLOR="#ff0000" SIZE=7>', $self->title, '</FONT><BR><BR>',
- ;
-}
-
-=item _footer
-
-=cut
-
-sub _footer {
- "</BODY></HTML>";
-}
-
-=item interface
-
-Returns the string `CGI'. Useful for the author of a table-specific UI class
-to conditionally specify certain behaviour.
-
-=cut
-
-sub interface { 'CGI'; }
-
-=back
-
-=cut
-
-package FS::UI::_Widget;
-
-use vars qw( $AUTOLOAD );
-
-sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $self = { @_ };
- bless ( $self, $class );
-}
-
-sub AUTOLOAD {
- my $self = shift;
- my $value = shift;
- my($field)=$AUTOLOAD;
- $field =~ s/.*://;
- if ( defined($value) ) {
- $self->{$field} = $value;
- } else {
- $self->{$field};
- }
-}
-
-package FS::UI::_Text;
-
-use vars qw ( @ISA );
-
-@ISA = qw ( FS::UI::_Widget);
-
-sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $self = {};
- $self->{'_text'} = shift;
- bless ( $self, $class );
-}
-
-sub sprint {
- my $self = shift;
- $self->{'_text'};
-}
-
-package FS::UI::_Link;
-
-use vars qw ( @ISA $BASE_URL );
-
-@ISA = qw ( FS::UI::_Widget);
-$BASE_URL = "http://rootwood.sisd.com/freeside";
-
-sub sprint {
- my $self = shift;
- my $table = $self->{'table'};
- my $method = $self->{'method'};
-
- # i will be cleaned up when we're done moving from the old webinterface!
- my @arg = @{$self->{'arg'}};
- my $yuck = join( "&", @arg);
- qq(<A HREF="$BASE_URL/$method/$table.cgi?$yuck">). $self->{'text'}. "<\A>";
-}
-
-package FS::UI::_Table;
-
-use vars qw ( @ISA );
-
-@ISA = qw ( FS::UI::_Widget);
-
-sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $self = $class eq $proto ? { @_ } : $proto;
- bless ( $self, $class );
- $self->{'_table'} = new HTML::Table ( $self->rows, $self->columns );
- $self;
-}
-
-sub attach {
- my $self = shift;
- my ( $row, $column, $widget, $rowspan, $colspan ) = @_;
- $self->{"_table"}->setCell( $row+1, $column+1, $widget->sprint );
- $self->{"_table"}->setCellRowSpan( $row+1, $column+1, $rowspan ) if $rowspan;
- $self->{"_table"}->setCellColSpan( $row+1, $column+1, $colspan ) if $colspan;
-}
-
-sub sprint {
- my $self = shift;
- $self->{'_table'}->getTable;
-}
-
-package FS::UI::_Tableborder;
-
-use vars qw ( @ISA );
-
-@ISA = qw ( FS::UI::_Table );
-
-sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $self = $class eq $proto ? { @_ } : $proto;
- bless ( $self, $class );
- $self->SUPER::new(@_);
- $self->{'_table'}->setBorder;
- $self;
-}
-
-=head1 VERSION
-
-$Id: CGI.pm,v 1.1 1999-08-04 09:03:53 ivan Exp $
-
-=head1 BUGS
-
-This documentation is incomplete.
-
-In _Tableborder, headers should be links that sort on their fields.
-
-_Link uses a constant $BASE_URL
-
-_Link passes the arguments as a manually-constructed GET string instead
-of POSTing, for compatability while the web interface is upgraded. Once
-this is done it should pass arguements properly (i.e. as a POST, 8-bit clean)
-
-Still some small bits of widget code same as FS::UI::Gtk.
-
-=head1 SEE ALSO
-
-L<FS::UI::Base>
-
-=head1 HISTORY
-
-$Log: CGI.pm,v $
-Revision 1.1 1999-08-04 09:03:53 ivan
-initial checkin of module files for proper perl installation
-
-Revision 1.1 1999/01/20 09:30:36 ivan
-skeletal cross-UI UI code.
-
-
-=cut
-
-1;
-
+++ /dev/null
-package FS::UI::Gtk;
-
-use strict;
-use Gtk;
-use FS::UID qw(adminsuidsetup);
-
-die "Can't initialize Gtk interface; $FS::UI::Base::_lock used"
- if $FS::UI::Base::_lock;
-$FS::UI::Base::_lock = "FS::UI::Gtk";
-
-=head1 NAME
-
-FS::UI::Gtk - Base class for Gtk user-interface objects
-
-=head1 SYNOPSIS
-
- use FS::UI::Gtk;
- use FS::UI::some_table;
-
- $interface = new FS::UI::some_table;
-
- $error = $interface->browse;
- $error = $interface->search;
- $error = $interface->view;
- $error = $interface->edit;
- $error = $interface->process;
-
-=head1 DESCRIPTION
-
-An FS::UI::Gtk object represents a Gtk user interface object.
-
-=head1 METHODS
-
-=over 4
-
-=item new
-
-=cut
-
-sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $self = { @_ };
-
- bless ( $self, $class );
-
- $self->{'_user'} = 'ivan'; #Pop up login window?
- $self->{'_dbh'} = FS::UID::adminsuidsetup $self->{'_user'};
-
-
-
- $self;
-}
-
-sub activate {
- my $self = shift;
-
- my $vbox = new Gtk::VBox ( 0, 4 );
-
- foreach my $widget ( @{ $self->{'Widgets'} } ) {
- $widget->_gtk->show;
- $vbox->pack_start ( $widget->_gtk, 1, 1, 4 );
- }
- $vbox->show;
-
- my $window = new Gtk::Window "toplevel";
- $self->{'_gtk'} = $window;
- $window->set_title( $self->title );
- $window->add ( $vbox );
- $window->show;
- main Gtk;
-}
-
-=item interface
-
-Returns the string `Gtk'. Useful for the author of a table-specific UI class
-to conditionally specify certain behaviour.
-
-=cut
-
-sub interface { 'Gtk'; }
-
-=back
-
-=cut
-
-package FS::UI::_Widget;
-
-use vars qw( $AUTOLOAD );
-
-sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $self = { @_ };
- bless ( $self, $class );
-}
-
-sub _gtk {
- my $self = shift;
- $self->{'_gtk'};
-}
-
-sub AUTOLOAD {
- my $self = shift;
- my $value = shift;
- my($field)=$AUTOLOAD;
- $field =~ s/.*://;
- if ( defined($value) ) {
- $self->{$field} = $value;
- } else {
- $self->{$field};
- }
-}
-
-package FS::UI::_Text;
-
-use vars qw ( @ISA );
-
-@ISA = qw ( FS::UI::_Widget );
-
-sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $self = {};
- $self->{'_gtk'} = new Gtk::Label ( shift );
- bless ( $self, $class );
-}
-
-package FS::UI::_Link;
-
-use vars qw ( @ISA );
-
-@ISA = qw ( FS::UI::_Widget );
-
-sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $self = { @_ };
- $self->{'_gtk'} = new_with_label Gtk::Button ( $self->{'text'} );
- $self->{'_gtk'}->signal_connect( 'clicked', sub {
- print "STUB: (Gtk) FS::UI::_Link";
- }, "hi", "there" );
- bless ( $self, $class );
-}
-
-
-package FS::UI::_Table;
-
-use vars qw ( @ISA );
-
-@ISA = qw ( FS::UI::_Widget );
-
-sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $self = { @_ };
- bless ( $self, $class );
-
- $self->{'_gtk'} = new Gtk::Table (
- $self->rows,
- $self->columns,
- 0, #homogeneous
- );
-
- $self;
-}
-
-sub attach {
- my $self = shift;
- my ( $row, $column, $widget, $rowspan, $colspan ) = @_;
- $rowspan ||= 1;
- $colspan ||= 1;
- $self->_gtk->attach_defaults(
- $widget->_gtk,
- $column,
- $column + $colspan,
- $row,
- $row + $rowspan,
- );
- $widget->_gtk->show;
-}
-
-package FS::UI::_Tableborder;
-
-use vars qw ( @ISA );
-
-@ISA = qw ( FS::UI::_Table );
-
-=head1 VERSION
-
-$Id: Gtk.pm,v 1.1 1999-08-04 09:03:53 ivan Exp $
-
-=head1 BUGS
-
-This documentation is incomplete.
-
-_Tableborder is just a _Table now. _Tableborders should scroll (but not the
-headers) and need and need more decoration. (data in white section ala gtksql
-and sliding field widths) headers should be buttons that callback to sort on
-their fields.
-
-There should be a persistant, per-(freeside)-user store for window positions
-and sizes and sort fields etc (see L<FS::UI::CGI/BUGS>.
-
-Still some small bits of widget code same as FS::UI::CGI.
-
-=head1 SEE ALSO
-
-L<FS::UI::Base>
-
-=head1 HISTORY
-
-$Log: Gtk.pm,v $
-Revision 1.1 1999-08-04 09:03:53 ivan
-initial checkin of module files for proper perl installation
-
-Revision 1.1 1999/01/20 09:30:36 ivan
-skeletal cross-UI UI code.
-
-
-=cut
-
-1;
-
+++ /dev/null
-package FS::UI::agent;
-
-use strict;
-use vars qw ( @ISA );
-use FS::UI::Base;
-use FS::Record qw( qsearchs );
-use FS::agent;
-use FS::agent_type;
-
-@ISA = qw ( FS::UI::Base );
-
-sub db_table { 'agent' };
-
-sub db_name { 'Agent' };
-
-sub db_description { <<END;
-Agents are resellers of your service. Agents may be limited to a subset of your
-full offerings (via their type).
-END
-}
-
-sub list_fields {
- 'agentnum',
- 'typenum',
-# 'freq',
-# 'prog',
-; }
-
-sub list_header {
- 'Agent',
- 'Type',
-# 'Freq (n/a)',
-# 'Prog (n/a)',
-; }
-
-sub db_callback {
- 'agentnum' =>
- sub {
- my ( $agentnum, $record ) = @_;
- my $agent = $record->agent;
- new FS::UI::_Link (
- 'table' => 'agent',
- 'method' => 'edit',
- 'arg' => [ $agentnum ],
- 'text' => "$agentnum: $agent",
- );
- },
- 'typenum' =>
- sub {
- my $typenum = shift;
- my $agent_type = qsearchs( 'agent_type', { 'typenum' => $typenum } );
- my $atype = $agent_type->atype;
- new FS::UI::_Link (
- 'table' => 'agent_type',
- 'method' => 'edit',
- 'arg' => [ $typenum ],
- 'text' => "$typenum: $atype"
- );
- },
-}
-
-1;
projects / freeside.git / commitdiff