BingoX::Chromium - Generic BingoX Admin module
Index
DISPLAY METHODS
DATA METHODS
CLASS VARIABLE METHODS
OBJECT METHODS
HTML DISPLAY METHODS
SANITY METHODS
REVISION HISTORY
SEE ALSO
KNOWN BUGS
TODO
COPYRIGHT
AUTHORS
Code Index:
NAME
BingoX::Chromium - Generic BingoX Admin module
SYNOPSIS
use BingoX::Chromium;
# $BR - Blessed Reference
# $SV - Scalar Value
# @AV - Array Value
# $HR - Hash Ref
# $AR - Array Ref
# $SR - Stream Ref
# $proto - BingoX::Chromium object OR sub-class
# $object - BingoX::Chromium object
CONSTRUCTORS
$BR = $proto->new( $r, [ $conf ] );
DISPLAY METHODS
$SV = $proto->postmodify_handler();
$SV = $proto->postadd_handler();
$SV = $object->display_list();
$SV = $object->display_view();
$SV = $object->display_modify();
$SV = $object->display_search(); - Not Implemented Yet!
$SV = $object->display_row( $field );
$SV = $object->display_list_buttons();
$SV = $object->display_modify_buttons();
$SV = $object->displat_start_html();
$SV = $object->hidden_fields();
DATA METHODS
$SV = $object->save_data();
$HR = $object->get_data( [ $data, ] [ $fields ] );
$SV = $object->sanity();
$BR = $proto->dbh();
$BR = $object->db_obj();
$HR = $object->get_list_hash();
CLASS VARIABLE METHODS
$SV = $proto->data_class();
$SV = $proto->data_class_name();
$SV = $proto->adminuri();
$SV = $proto->classdesc();
$SV = $proto->qfd();
$SV = $proto->pkd();
$SV = $proto->prefix();
$SV = $proto->cpkey_params($pcpkey);
$AR = $proto->fieldlist();
$HR = $proto->ui();
$AR = $proto->parents();
$AR = $proto->children();
$HR = $proto->fields();
$SV = $proto->fieldname( $field );
$SV = $proto->fieldtype( $field );
$HR = $proto->fieldhtmloptions( $field );
$SV = $proto->fieldrelclass( $field );
$SV = $proto->fieldrelclasstype( $field );
$HR = $proto->fieldoptions( $field );
$HR = $proto->fieldsanity( $field );
OBJECT METHODS
$SV = $object->flow();
$SV = $object->cpkey();
$SV = $object->pcpkey();
$SV = $object->parent_class();
$BR = $object->cgi();
$SV = $object->uri();
$SV = $object->displaymode();
$SV = $object->section();
$BR = $object->conf();
$BR = $object->r();
HTML DISPLAY METHODS
$SV = $object->HTML_date( $fieldname );
$SV = $object->HTML_view( $fieldname );
$SV = $object->HTML_hidden( $fieldname );
$SV = $object->HTML_text( $fieldname );
$SV = $object->HTML_textarea( $fieldname );
$SV = $object->HTML_popup( $fieldname ); - Not Finished!
$SV = $object->HTML_scrolling( $fieldname );
$SV = $object->HTML_checkbox( $fieldname );
$SV = $object->HTML_file( $fieldname );
REQUIRES
Time::Object, Apache, CGI, Carp
EXPORTS
DESCRIPTION
BingoX::Chromium provides the generic API for BingoX admin classes.
BingoX::Chromium uses admin objects that wrap Carbon data objects
CLASS VARIABLES
Classes that inherit from BingoX::Chromium should have the following class variables:
- * @fieldlist
-
The order in which to display fields (if one so chose to display them ;)
- * %fields
-
A hash whose keys are columns (same as in the fieldlist array) and whose values
are complex arrays. Each array index is described below.
- [0] Descriptive Title
-
A string describing the field
- [1] HTML Entity Type
-
A string that contains one of the following HTML etity types:
view
text
textarea
datetime
popup
reference
FIXME: more!!!
- [2] HTML Options
-
A hash reference containing options for creating the HTML form field for
this field.
- [3] Related Classes
-
FIXME: I dunno
- [4] Field Options
-
A hash reference containing special options for this field. The options include:
not_null - this field cannot be NULL
- [5] Sanity Methods
-
This is a list reference. Each item in the list is either a string with a
sanity method name, or a list ref containing the method name, then any parameters
that need to be passed to it. An example:
[
'sane_foo',
['sane_bar', 'baz'],
]
For more info, see "SANITY METHODS".
- * $adminuri
-
An optional class variable, corresponds to the adminuri() method.
FIXME: Can someone who knows more about this elaborate?
- * $classdesc
-
A simple one- or two-word description of the class being administered.
The name of the data class that corresponds to the admin class. If this
value is not defined, it will default to the name of the admin class, with
the first instance of "::Admin::" changed to "::Data::".
METHODS
Apache handler gets a new display object object of the class it was called
as and calls flow against it.
CONSTRUCTORS
Given an apache request object, returns an Admin object of the class
it was called as. It also sets the data_class, data_class_name, cgi,
uri, displaymode (from $q), and section (from $q).
FLOW
Decides what display method (or save_data) to call based on the displaymode,
and submit_type (found in the query object).
?? Is this the best order to check ??
This method decides what happens after you leave the "Modify"
screen. It normally works by passing a method that gets called, but
it's meant to be overloaded as a hook when flow() finishes saving data
(or if you hit Cancel). That way you can save something and go
somewhere else besides display_view(). It currently will always call
$method against $self, so no static methods, please...
Behaves exactly like postmodify_handler() (see above), but is called after
the user exits the "Add a new <whatever>" screen.
DISPLAY METHODS
Prints an HTML page meant for listing all objects in class.
Displays the buttons for display_list().
Easy to overload if you want more buttons!
Displays the buttons for display_modify().
Easy to overload if you want more buttons!
Just like display_list buttons.
Prints an HTML page meant for viewing an object. Itterates through fieldlist
calling display_row for each element.
Displays the buttons for display_view().
Easy to overload if you want more buttons!
Just like display_list buttons.
Prints an HTML page meant for modifying an object. Itterates through fieldlist
calling display_row for each element.
Returns class defined Class description as a string.
A stub called by display_view() and display_modify()
that you can overload in your subclass if you want
the view or modify/add screens to have a custom title.
A stub called by display_view() and display_modify()
that you can overload in your subclass if you want
the view or modify/add screens to have extra hidden fields.
Or you can pass it a hash ref of hidden fields,
were key = field name and value = field value
Accessor method to $self->cgi->start_html();
Put into params exactly what you'd put in CGI::start_html().
Overload this in your admin class if you want to set any special
BG,text,link colors, or anything else you want to pass to start_html()
Prints an HTML page meant for limiting what appears on the display_list page.
Not Implimented Yet.
Takes a column (field) name and prints a 2 columned table row where the left
column has the fields descriptive name ($self->fieldname($field)) and the right
column has the output of that fields method ($self->$field)
DATA METHODS
Goes through the process of calling sanity, then get_data (to get the data out
of the query object) and then db_obj->modify.
Optionally takes data hashref as returned by get_data(), otherwise calls get_data() itself. (This makes extension of save_data() possible without having to call get_data() twice.)
Takes the fields hash (returned by $self->fields()) and the CGI object and
returns a data hashref which can be sent to Carbon's new or modify
You can optionaly pass a $data hash and a $fields hash which it will use.
OPTIMIZE
Populates the _errors data instance in the case that the data does not conform
to what is allowed to be entered into the database.
Returns a string representing a single composite primary key joined by $self->qfd.
Returns a params hash from the cpkey string passed.
Returns a cpkey with a class name + $qfd in front of it.
Returns the object's database handle.
OPTIMIZE Needs work. Doesn't appear to use Carboniums dbh method thus
thus doesn't use cached dbh.
*** NEEDS TO BE REMOVED ***
Returns a hash ref of all the objects in the class it was called against.
The hash is built from the pcpkey, and the data class' title_field,
substr()'d to the data class' title_size or by default 80 chars.
OPTIMIZE
Retrieves and caches encapsolated DATA object based on whats in the query
obect. Looks for pcpkey query param first and then for each primary
key individually.
OPTIMIZE
CLASS VARIABLE METHODS
Returns the data class for the current display class (from the class
variable $data_class).
Returns the rightmost part of the db_class name (thats the text right of the ::)
This method is a fallback method for the user interface for BingoX::Chromium.
ui() contains the default colors for the forms created by BingoX::Chromium.
To create a custom color scheme for a specific class or entire admin area
create a ui() method in either the Admin class or the subclass
and modify the details to your preference.
Returns class defined children as an arrayref.
Returns class defined parents as an arrayref.
Returns cached parent class
Returns class defined URI as a string.
Returns class defined Class description as a string.
NEEDS POD
Returns the class defined fieldlist as an arrayref.
Returns class defined fields hashref.
Takes a column name and returns a string with that field's pretty
name as defined in the class defined field hash. This is the [0]
element of that keys array value.
Takes a column name and returns a string with that field's HTML
type as defined in the class defined field hash. This is the [1]
element of that keys array value.
Takes a column name and returns a hashref with that field's HTML
options as defined in the class defined field hash. This is the
[2] element of that keys array value.
Takes a column name and returns a string with that field's related
class (if it exists) as defined in the class defined field hash.
This is the [3] element of that keys array value.
Takes a column name and returns a string with that field's related
class (if it exists) as defined in the class defined field hash.
This is the [3] element of that keys array value.
Takes a column name and returns a hashref with that field's options
information as defined in the class defined field hash.
This is the [4] element of that keys array value.
Takes a column name and returns a listref with that field's sanity
information as defined in the class defined field hash.
This is the [5] element of that keys array value.
OBJECT METHODS
Returns the cached uri object.
Returns the cached cgi object.
Returns the cached conf object (set in new).
Returns the cached section (set in new).
Returns the cached uri displaymode (set in new).
Object Method:
Returns Apache Request object.
Returns a hash reference containing the parameters that specify the current
selection. If a new value is passed, it sets the selection to that value.
HTML DISPLAY METHODS
Object Method:
Returns the fieldname to be used in the FORM INPUT NAME field. When
overloading Administration field variables, use this to get the INPUT TYPE NAME.
ie. <INPUT TYPE="text" NAME="$self->qfieldname('username')">
Object Method:
Returns the Main Index Path.
Object Method:
Generic Hours Form Tag. Called by AUTOLOAD.
Gets the default field params based on the fieldname and returns a
set of date form fields or in viewable format if the displaymode is 'view'.
Object Method:
Generic Day Form Tag. Called by AUTOLOAD.
Gets the default field params based on the fieldname and returns a
set of date form fields or in viewable format if the displaymode is 'view'.
Object Method:
Generic Month Form Tag. Called by AUTOLOAD.
Gets the default field params based on the fieldname and returns a
set of date form fields or in viewable format if the displaymode is 'view'.
Object Method:
Generic Year Form Tag. Called by AUTOLOAD.
Gets the default field params based on the fieldname and returns a
set of date form fields or in viewable format if the displaymode is 'view'.
Object Method:
Generic form field method called by AUTOLOAD.
Gets the default field params based on the fieldname and returns a
set of date form fields or in viewable format if the displaymode is 'view'.
Needs to be less Sybase Dependant and handle Time
Object Method:
Generic form field method called by AUTOLOAD.
Gets the default field params based on the fieldname and returns the value
in viewable format.
Object Method:
Generic form field method called by AUTOLOAD.
Gets the default field params based on the fieldname and returns the value
as a hidden input field.
Object Method:
Generic form field method called by AUTOLOAD.
Gets the default field params based on the fieldname and returns the value
in a text input field or in viewable format if the displaymode is 'view'.
Object Method:
Generic form field method called by AUTOLOAD.
Gets the default field params based on the fieldname and returns the value
in a password input field with a corresponding or in an obscured format if the displaymode is 'view'.
Object Method:
Generic form field method called by AUTOLOAD.
Gets the default field params based on the fieldname and returns
the value in a text input field or in viewable format if the
displaymode is 'view'.
Object Method:
Generic form field method called by AUTOLOAD.
Gets the default field params based on the fieldname and returns the value
in a popup field or in viewable format if the displaymode is 'view'.
Note: Not used yet because its not easy to populate the
vaules & labels fields. USually always overloaded in the subclasses.
OPTIMIZE
Object Method:
Generic form field method called by AUTOLOAD.
Gets the default field params based on the fieldname and returns the value
in a group of radio buttons or in viewable format if the displaymode is 'view'.
Object Method:
Generic form field method called by AUTOLOAD.
Gets the default field params based on the fieldname and returns the value
in a scrolling list field or in viewable format if the displaymode is 'view'.
Note: Not used yet because its not easy to populate the
vaules & labels fields. USually always overloaded in the subclasses.
OPTIMIZE
Object Method:
Generic form field method called by AUTOLOAD.
Gets the default field params based on the fieldname and returns the value
in a checkbox field or in viewable format if the displaymode is 'view'.
Note: Not used yet because its not easy to populate the
vaules & labels fields. USually always overloaded in the subclasses.
Object Method:
Generic form field method called by AUTOLOAD.
Gets the default field params based on the fieldname and returns the value
in a form file upload field or in viewable format if the displaymode is 'view'.
SANITY METHODS
These methods can be overridden at any level to provide customized sanity
checking. These methods always return an error message on failure, and an
empty string on success.
If $data matches the regular expression in $regex, returns an empty
string. Otherwise, returns $error or a default error message.
Makes sure that $data is no more than $length characters long. Returns
an error message on failure, an empty string on success.
Makes sure that $data is at least $length characters long. Returns an
error message on failure, an empty string on success.
AUTOLOAD method - Figures out what method was being called by stripping the
fully qualified portion of $AUTOLOAD out as $name. This method is expected to be
a column name (an element of fieldlist). It then figures out what that
columns fieldtype is from fieldtype($name). It then calls that type
of HTML display method and passed $name to it.
REVISION HISTORY
$Log: Chromium.pm,v $
Revision 2.36 2001/11/14 23:12:26 gefilte
save_data() - now optionally takes \%data, the result of get_data().
RATIONALE :
Consider a case when you want to override save_data() in a method which
calls SUPER::save_data() (arguably a very useful feature.) Now suppose that
your save_data() method needs to see the result of get_data(), or possibly even
manipulate those results (although that should be accomplished by overriding
get_data()), before calling SUPER::save_data(). Before this change, the
(arguably expensive) call to get_data() would need to be repeated. With this
change, passing a \%data to save_data() will circumvent the need for the
second call.
I considered using instance data to cache the results of get_data(), but
since get_data() can be optionally called with a preset \%data hash this
feature, while solving the efficiency problem, would open the door to more bugs.
"Did you make sure the NO_BUGS flag is on? Well that's your problem!"
- Colin Bielen (paraphrase)
Revision 2.35 2001/11/14 22:53:49 gefilte
Fixed some POD
Revision 2.34 2001/10/19 22:23:54 gefilte
HTML_scrolling() - now sets -DEFAULT properly to what is in the database
(don't know if this ever worked right, but it didn't when I tried it. check out the tiny diff :-)
Revision 2.33 2001/10/12 00:50:34 gefilte
display_modify() - fixed output of 'li' tags (cosmetic)
Added support for fields of type 'password' :
- added method HTML_password()
- added special case to display_row() which displays the password field twice (for verification purposes) unless displaymode is 'view'
- get_data() verifies that the two fields are alike, otherwise it sets and _error and blanks the field out (so it doesn't persist)
- sanity() doesn't set the 'required' error if an error is already set
N.B. - get_data() is setting an error state, normally only done by sanity(). This may not be the right approach, but I couldn't think of a more efficient one than this, since the field being verified (essentially the second password field) will not be examined by sanity().
Revision 2.32 2001/10/05 01:31:31 gefilte
HTML_checkbox() - made slightly MORE useful than the last revision!
Revision 2.31 2001/10/04 23:28:00 gefilte
get_data()
- fixed procedures for parsing dates and checkboxes so that they
do NOT add to the %$data hashref unless the data has in fact changed
from what is in the $db_obj.
HTML_checkbox() - made more usable :-)
"If only there were evil people somewhere insidiously committing evil deeds and it were necessary only to separate them from the rest of us and destroy them. But the line dividing good and evil cuts through the heart of every human being. And who is willing to destroy a piece of his own heart?"
- Aleksandr Isaevich Solzhenitsyn, novelist, Nobel laureate (1918-)
Revision 2.30 2001/09/29 00:29:22 gefilte
db_class(), db_class_name() - renamed to data_class(), data_class_name()
- this is consistent with Cobalt's naming scheme
- left symbolrefs to old names for backward compatibility
- changed ALL calls and documentary references to these methods to new names
- changed procedure to ascertain data_class to FIRST look at new class data member (below), then try using the standard BingoX class naming scheme
added class data $data_class so that you can set an arbitrary class as your Carbon-based data class
new() - uses data_class() methods to populate class data instead of figuring it out on its own
fieldname(), fieldtype(), fieldhtmloptions(), fieldsrelclass(), rieldrelclasstype(), fieldoptions(), fieldsanity()
- now verify the existence of array elements before attempting to read them (who thought you could get away with not doing this????)
HTML_time(), HTML_day(), HTML_month(), HTML_year(), HTML_date()
- now return undef if displaymode() is 'view' and referenced datetime field is empty
fixed some documentation typos
Revision 2.29 2001/09/27 18:10:22 gefilte
save_data() - cleaned up $data prep
($data was verified twice! sanity() was being called twice! INSANITY!)
Revision 2.28 2000/12/12 18:51:57 useevil
- updated version for new release: 1.92
Revision 2.27 2000/10/20 00:24:15 zhobson
Minor changes to synopsis of new() in the docs
Revision 2.26 2000/10/17 00:57:47 dweimer
- corrected POD for main_index()
- changed main_index()
Revision 2.25 2000/09/20 21:03:27 dweimer
Merged one last portion from the old tree.
Revision 2.24 2000/09/20 21:00:22 dweimer
Merged David's changes.
His comment:
handler() method now sets up Apache response settings instead of display_*() methods.
Revision 2.23 2000/09/20 00:31:59 zhobson
Fixed a scope warning in flow() (used "my $other_class" twice in the same scope)
Revision 2.22 2000/09/19 23:40:59 dweimer
Version update 1.91
Revision 2.21 2000/09/13 20:58:27 adam
- in get_data, changed how dates are handled if SHOW_24HOURS is off
Revision 2.20 2000/09/12 16:03:35 david
Made Data::Dumper optional -- only called when $debug is activated. Changed all of its calls to Data::Dumper::Dumper().
Caused handler to return result of flow(), flow ends up returning results of display_*(), display_*() methods now return Apache response constants.
Revision 2.19 2000/09/08 22:06:24 colin
- get_data - if the field is a date it makes sure there is at least
the year in the query object. Before it would break if you had a year
in your %fields hash, but were not submitting that datefield in your
add or modify form. get_data would blindly try and build a date.
Revision 2.18 2000/09/08 21:31:23 thai
- cleaned up the code
Revision 2.17 2000/09/08 05:19:38 thai
- turned off debug
Revision 2.16 2000/09/08 03:19:09 adam
GENERAL
Added parent/child relationship functionality, where each class can
specify parent and child classes. These are used to display buttons
at the bottom of the display list screens to access your parents or
children based on the selected item in the list.
- updated POD
- new
- now accepts a CGI as an optional 4th param.
- sets the selection from the $q->param('parent_pcpkey');
- sets the parent_class object var from the $q->param('parent_pcpkey')
- flow
- checks to see if you are entering from a parent or child and sets
$q->param('parent_pcpkey') with whats passed.
- Gets the desired child or parent admin object and calls flow against it.
- added debugging
- changed all occurances of $q->startform to try and print $self->adminuri
as the ACTION. If there is no adminuri it uses uri as before.
- display_list
- displays information at the top of the page about what parent you
came from (if there is a parent)
- all forms now include hidden for parent_pcpkey
- display_list_buttoms
- displays buttons to view the display list page of any child or
parent classes you might have.
- pcpkey
- renamed qkey to pcpkey
- changed all occurances of qkey to pcpkey
- cpkey
- cpkey now just calls cpkey against the db_obj
- cpkey_params
- calls cpkey_params against your data_class
- added children and parents class var accessor methods
- HTML_popup
- if your displaymode is add and you have a parent_pcpkey it attempts to
select the parent in the pop-up menu.
Revision 2.15 2000/09/07 22:49:03 thai
- changed line 1200 to use BingoX::Time
Revision 2.14 2000/09/07 20:00:02 thai
- changed all occurances of DateTime::Date to BingoX::Time
Revision 2.13 2000/08/31 21:54:18 greg
Added COPYRIGHT information.
Added file COPYING (LGPL).
Cleaned up POD.
Moved into BingoX namespace.
References to Bingo::XPP now point to Apache::XPP.
"To the first approximation, syntactic sugar is trivial to implement.
To the second approximation, the first approximation is totally bogus."
-Larry Wall
Revision 2.12 2000/08/10 21:10:55 thai
- added qkey() to get the prefix and the cpkey
- changed occurrances where primary keys were being iterated to use
cpkey()
- added prefix() method to return the correct prefix combination
Revision 2.11 2000/08/09 21:25:03 thai
- changed get_list_hash() to be more Carbon friendly
Revision 2.10 2000/08/07 23:10:25 thai
- added main_index() method to return the main index url
- changed regex pattern for HTML_textarea()
Revision 2.9 2000/08/07 17:59:32 thai
- added remove and modify to the display_list_buttons() method
and to flow
Revision 2.8 2000/08/03 20:48:09 thai
- addd qfd() method to handle qfds
- fixed bug in HTML_date() that would create a new date object when
displaymode was 'view'
- the sub pkd() now calls data_class->pkd()
Revision 2.7 2000/08/01 00:43:51 thai
- changed db_obj->errstr to dbh->errstr on line 305
- moved all the $qfieldname stuff to the qfieldname() method
- removed the fieldtype eq 'custom' from line 1174 in get_data()
Revision 2.6 2000/07/14 19:27:05 dougw
save_data returns undef if it can't ref get_data's return value, should be a hashref.
Small typo fix, hidden_fields returns a string as it should.
Revision 2.5 2000/07/12 19:30:17 thai
- fixed POD, cleaned up code
Revision 2.4 2000/07/07 01:20:43 dougw
- Added 1 instead of Turned On for the check box value. Who ever thought
of that? Changed the comparisons for hashrefs. Beware !%$hashref is
different than ref $hashref ne 'HASH'
Revision 2.3 2000/05/31 02:39:20 greg
changed use of s/.*:// to substr(...) in AUTOLOAD for efficiency.
Revision 2.2 2000/05/24 20:47:25 thai
- added more sanity when dereferencing, @{ $code->() || [ ] }
- added warning when creating new date objects fail
Revision 2.1 2000/05/19 01:25:11 thai
- cleaned up code
- is now part of the Bingo user space
Revision 2.0 2000/05/02 00:54:33 thai
- committed as 2.0
Revision 1.38 2000/03/21 02:00:23 dougw
Fixed a bug introduced recently that broke adding new object when
the identity key was in the fields list. This is so wierd. (zack)
Revision 1.37 2000/03/17 21:09:00 dougw
Allowed hidden values to be used in HTML_date for -TYPE=>'view'
Fixed checkbox undef error
Revision 1.36 2000/03/15 22:26:17 zack
Added HTML_radio() and modified new() to allow passing a display mode.
Revision 1.35 2000/03/15 19:25:43 colin
-HTML_popup now sorts options alphabetically
Revision 1.34 2000/03/14 21:45:08 dougw
Fixed get_data->save_data problems (thanks dave).
Removed spurious comments.
Revision 1.33 2000/03/14 20:58:10 dougw
Modified HTML_popup to allow a NULL selection. Use the fieldoption -null_label
to specify what you want the option to be named. The option must not have the
-not_null option set for obvious reasons.
Revision 1.32 2000/03/10 01:57:54 colin
made display_list()'s hash sorter even cooler (thanks doug)
Revision 1.31 2000/03/10 01:18:02 colin
-display_list() now sorts its entries alphabetically.
Revision 1.30 2000/03/09 18:58:23 colin
-fixed a bug in HTML_date() where $qfieldname was being used as a global.
-fixed similar bugs in HTML_day(),HTML_month(),and HTML_year()
-one can now pass a hashref to hidden_fields(). If one wanted to.
Revision 1.29 2000/03/09 00:45:32 colin
-(thai) fixed a bug in HTML_date() where it wasn't passing fieldnames to its helper methods.
-HTML_date() now checks the -TYPE it's passed in fieldoptions
Revision 1.28 2000/03/08 03:09:32 thai
- parsed out HTML_date() to HTML_day(), HTML_month(), HTML_year(),
and HTML_time()
Revision 1.27 2000/02/25 20:24:17 colin
corrected some minor ui bugs in display_list() and display_modify()
Revision 1.26 2000/02/18 23:38:56 colin
- altered sanity() so that it now accepts a passed \%data hashref instead
of looking for things in the query object. this way the data is already
formatted and we don't have to format data again (especially useful because
we don't have to re-sort all the date fields, etc)
Revision 1.25 2000/02/17 23:37:43 colin
-get_data() now gives meaningful error messages when users enter invalid info in date fields
Revision 1.24 2000/02/17 03:46:27 dougw
Small modifications to take advantage of DateTime changes.
Using $obj instead of $obj->time_local;
Revision 1.23 2000/02/11 18:52:00 colin
- (doug) HTML_* methods now use DateTime to manage date info.
- (colin) Changed ui() so that a) it caches the hasref if called as an object method and b)
allows you to override default settings (and add others) when calling the method, as
opposed to calling SUPER::ui() and then re-setting the resulting hashref.
Revision 1.22 2000/02/08 03:34:31 zack
- documented the %fields class variable
- added not_null to field options (index [4])
- implemented flexible sanity checking
- added sane_regex()
- added sane_minlength() and sane_maxlength()
- updated docs for fieldoptions() and fieldsanity()
- HTML_textarea(): 'WRAP' defaults to 'VIRTUAL'
Revision 1.21 2000/02/04 19:48:28 derek
- Fixed two instances where $ui wasn't being accessed to include font tags
Revision 1.20 2000/02/04 19:28:45 derek
- Changed Cancel button on View page to Return to List and modified flow
to reflect the change
- Added tons of CGI HTML code to make the Chromium interface look better
- Added ui method that has defaults for colors and fonts that are used
in the newly designed skin-like interfaces
- Added Greg's adminclass method to return the project specific admin
super class
- Fixed display bug in HTML_textarea where content fields weren't being
broken up into paragraphs in View mode
- Added flow to display_row method to check for content fields and break
them into two rows for the key/value pair
Revision 1.19 2000/02/03 03:42:35 zack
Documentation fixes and updates
Revision 1.18 2000/01/31 02:00:19 adam
- dbh was using a GLOBAL flag to see if had already set the
$r->register_cleanup. That was bad since the global was living beyond
each hit. In the end, the DBH wasn't being cleared after every hit.
So now it uses the Apache notes to store the flag.
- display_row() - oops... thats not the variable name!
"The best laid plans..."
Revision 1.17 2000/01/30 04:30:46 adam
- using an HTMl fieldtype of 'row' makes display_row() not print table
tags, it just prints the results of the method $_().
Revision 1.16 2000/01/27 22:12:17 colin
Added cgi() and marked CGI_obj() as deprecated (evil music here).
Added some \%qoptions to HTML_file
Revision 1.15 2000/01/27 01:17:14 colin
- finished HTML_file(). Also, due to popular request, display_modify() now uses
$q->start_multipart_form() instead of $q->startform().
- Well, it actually wasn't a *popular* request, but when the email went out asking
if anyone had problems with it there was no response.
Ever. And that's good enough for me!
Revision 1.14 2000/01/25 20:55:48 colin
added:
postmodify_handler()
postadd_handler()
hidden_fields()
display_list_buttons()
display_modify_buttons()
HooHah!
Revision 1.13 2000/01/24 22:19:39 dougw
Adam added adminuri
Revision 1.12 2000/01/24 22:11:03 colin
added some Center tags.
Revision 1.11 2000/01/21 22:08:24 colin
added display_start_html().
Revision 1.9 2000/01/21 21:35:26 colin
took out an extra warn(). my bad.
Revision 1.6 2000/01/12 22:43:35 adam
- removed Carbon::debug
Revision 1.5 2000/01/11 02:30:19 zack
HTML_textarea() now accepts a -WRAP option (default 'NONE')
HTML_checkbox() works with "add" functionality
Revision 1.4 1999/12/21 00:51:57 zack
implemented selections. added selection()
Revision 1.3 1999/12/05 04:05:38 greg
new - fixed _db_class to be generic instead of hard coded to 'Mogwai'
dbh - now handles the cleanup of cached dbh instead of Data
Revision 1.2 1999/12/04 23:48:08 greg
fixed POD errors
Revision 1.1.1.1 1999/12/03 20:10:40 adam
START
SEE ALSO
KNOWN BUGS
TODO
COPYRIGHT
Copyright (c) 2000, Cnation Inc. All Rights Reserved. This module is free
software. It may be used, redistributed and/or modified under the terms
of the GNU Lesser General Public License as published by the Free Software
Foundation.
You should have received a copy of the GNU Lesser General Public License
along with this library; if not, write to the Free Software Foundation, Inc.,
59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
AUTHORS
Adam Pisoni <adam@cnation.com>
# BingoX::Chromium
# -----------------
# $Revision: 2.36 $
# $Date: 2001/11/14 23:12:26 $
# ---------------------------------------------------------
package BingoX::Chromium;
use Apache;
use Apache::Constants qw(:response);
use BingoX::Time;
use Carp;
use strict;
use vars qw($AUTOLOAD $debug);
BEGIN {
$BingoX::Chromium::REVISION = (qw$Revision: 2.36 $)[-1];
$BingoX::Chromium::VERSION = '1.92';
$debug = undef;
if ($debug) {
require Data::Dumper;
}
}
sub handler ($$) {
warn "\n******************** BEGIN CLICK ************************\n\n" if ($debug);
my $class = shift;
my $r = shift;
# Prepare request handler for uncached HTML response
$r->content_type('text/html');
$r->no_cache(1);
my $self = $class->new( $r );
my $response = $self->flow;
warn "\n******************** END CLICK **************************\n\n" if ($debug);
return $response;
} # END sub handler
sub new {
my ($class, $r, $conf, $mode, $cgi) = @_;
my $q = $cgi || new CGI;
my $self = {
_data_class => $class->data_class(),
_data_class_name => $class->data_class_name(),
_cgi => $q,
_conf => $conf || undef,
_uri => $r->uri,
_r => $r, # Apache request object
_displaymode => lc($q->param('displaymode')) || $mode || '',
_errors => { },
_section => $q->param('section') || '',
};
if ($q->param('parent_pcpkey')) {
my $parentclass = "${1}::Admin::" . substr($q->param('parent_pcpkey'),0,index($q->param('parent_pcpkey'),$class->qfd));
$self->{'_parent_class'} = $parentclass;
$self->{'_selection'} = $parentclass->cpkey_params($q->param('parent_pcpkey'));
}
bless $self, $class;
return $self
} # END sub new
sub flow {
my $self = shift;
return $self->failure('Method flow called as static.') unless ref($self);
my $class = ref($self);
my $q = $self->cgi;
my $other_class;
if ($other_class = (grep { /^child##(.+)$/ } ($q->param))[0]) {
$q->delete($other_class);
$other_class = substr($other_class,7);
warn "flow - displaymode child\n" if ($debug > 1);
my $pcpkey = $q->param('cpkey');
$q->param('parent_pcpkey',$pcpkey);
my $new_class = $class;
substr($new_class,rindex($new_class,':')+1) = $other_class;
my $new_admin = $new_class->new($self->r,undef,undef,$q);
$new_admin->flow;
} elsif ($other_class = (grep { /^parent##(.+)$/ } ($q->param))[0]) {
$q->delete($other_class);
$other_class = substr($other_class,8); warn "flow - displaymode parent\n" if ($debug > 1);
my $new_class = $class;
substr($new_class,rindex($new_class,':')+1) = $other_class;
$q->delete('parent_pcpkey');
my $new_admin = $new_class->new($self->r,undef,undef,$q);
$new_admin->flow;
} elsif ($self->displaymode eq 'modify') {
$self->{'_displaymode'} = 'modify';
warn "flow - displaymode modify\n" if ($debug > 1);
if ($q->param('submit_type') eq 'Save') {
if ($self->save_data) {
warn "flow modify modify after MODIFY\n" if ($debug > 1);
$self->{'_displaymode'} = 'view';
$self->postmodify_handler('display_view');
} else {
warn "flow modify modify MODIFY FAILED\n" if ($debug > 1);
$self->display_modify;
}
} elsif ($q->param('submit_type') eq 'Cancel') {
$self->{'_displaymode'} = 'view';
$self->postmodify_handler('display_view');
} else {
$self->failure('Not a valid submit type.');
}
} elsif ($self->displaymode eq 'view') {
warn "flow - displaymode view\n" if ($debug > 1);
if ($q->param('submit_type') eq 'Modify') {
$self->{'_displaymode'} = 'modify';
$self->display_modify;
} elsif ($q->param('submit_type') eq 'Remove') {
if ($self->db_obj->rm) {
$self->postmodify_handler('display_list');
} else {
$self->{'_errors'}->{'General Database Error'} = $self->dbh->errstr;
$self->display_modify;
}
} elsif ($q->param('submit_type') eq 'Return to List') {
$self->postmodify_handler('display_list');
} else {
$self->failure('Not a valid submit type.');
}
} elsif ($self->displaymode eq 'add') {
warn "flow - displaymode add\n" if ($debug > 1);
if ($q->param('submit_type') eq 'Save') {
if ($self->save_data) {
warn "flow add add after ADD\n" if ($debug > 1);
$self->{'_displaymode'} = 'view';
$self->postadd_handler('display_view');
} else {
warn "flow add add ADD FAILED\n" if ($debug > 1);
$self->display_modify;
}
} else {
$self->postadd_handler('display_list');
}
} else {
warn "flow - displaymode none\n" if ($debug > 1);
if ($q->param('submit_type') eq 'View') {
warn "flow - displaymode none - submit_type view\n" if ($debug > 1);
if (ref $self->db_obj) {
warn "flow - displaymode none - submit_type view - we have db_obj\n" if ($debug > 1);
$self->{'_displaymode'} = 'view';
$self->display_view;
} else {
warn "no db_obj\n" if ($debug > 1);
$self->{'_displaymode'} = 'list';
$self->display_list;
}
} elsif ($q->param('submit_type') eq 'Remove') {
warn "flow - displaymode none - submit_type Remove\n" if ($debug > 1);
if ($self->db_obj->rm) {
warn "flow - displaymode none - submit_type Remove SUCCEED\n" if ($debug > 1);
$self->{'_displaymode'} = 'list';
$self->display_list;
} else {
warn "flow - displaymode none - submit_type Remove FAIL\n" if ($debug > 1);
$self->{'_errors'}->{'General Database Error'} = $self->dbh->errstr;
$self->{'_displaymode'} = 'list';
$self->display_list;
}
} elsif ($q->param('submit_type') eq 'Modify') {
warn "flow - displaymode none - submit_type modify\n" if ($debug > 1);
if (ref $self->db_obj) {
warn "flow - displaymode none - submit_type modify - we have db_obj\n" if ($debug > 1);
$self->{'_displaymode'} = 'modify';
$self->display_modify;
} else {
warn "no db_obj\n" if ($debug > 1);
$self->{'_displaymode'} = 'list';
$self->display_list;
}
} elsif ($q->param('submit_type') eq 'Add') {
warn "flow - displaymode none - submit type: add\n" if ($debug > 1);
$q->delete('cpkey'); #sometimes it sticks around if users select something in "display_list" and hit "new".
$self->{'_displaymode'} = 'add';
$self->display_modify;
} else {
$self->display_list;
}
}
} # END sub flow
sub failure {
my $self = shift;
return SERVER_ERROR unless ref($self);
my $message = shift || return SERVER_ERROR;
my $q = $self->cgi;
my $content = $q->starthtml(-title=>'Chromium Error')
. "<H2 ALIGN=center>Chromium Error</H2><BR>\n"
. "Error in Chromium-based Admin class: <FONT COLOR='blue'>" . ref($self) . "</FONT><BR>\n"
. "<FONT COLOR='red'>" . $message . "</FONT><BR>\n"
. $q->endhtml . "\n";
$self->r->custom_response(SERVER_ERROR => $content);
return SERVER_ERROR;
}
sub postmodify_handler {
my $self = shift;
my $method = shift || 'display_view';
$self->$method( @_ );
} # END sub postmodify_handler
sub postadd_handler {
my $self = shift;
my $method = shift || 'display_view';
$self->$method( @_ );
} # END sub postadd_handler
sub display_list {
my $self = shift;
my $q = $self->cgi;
$self->{'_displaymode'} = 'list';
my $r = $self->r;
my $ui = $self->ui;
unless (ref $r) {
print $q->header;
}
print $self->display_start_html({ -TITLE => 'Admin '. $self->classdesc,
-BGCOLOR => $ui->{'page_bg'}
});
my $hashref = $self->get_list_hash;
print $q->startform( -ACTION => $self->adminuri || $self->uri,
-METHOD =>'POST'
)
. $q->p . "\n"
. $q->center
. $q->start_table({ -BORDER => 0,
-CELLSPACING => 0,
-CELLPADDING => 1,
-WIDTH => 500,
-BGCOLOR => $ui->{'table_border'}
})
. $q->start_Tr
. $q->start_td
. $q->start_table({ -BORDER => 0,
-CELLSPACING => 1,
-CELLPADDING => 4,
-WIDTH => 500,
-BGCOLOR => 'white'
})
. $q->start_Tr
. $q->start_td({ -ALIGN => 'center', -BGCOLOR => $ui->{'table_header' }})
. $q->start_b
. $q->start_font({
-FACE => $ui->{'font_header'}->{'-face'},
-SIZE => 5
})
. $self->display_admin_name . "List "
. $self->classdesc . "<BR>\n";
if ($q->param('parent_pcpkey')) {
my $parent_class = $self->parent_class;
my $pclass_tfield = $parent_class->data_class->title_field;
print $q->font( { -SIZE => 4 },
"For " . $parent_class->classdesc . ": "
. $q->font( { -COLOR => 'blue' },
$parent_class->data_class->get(
$self->dbh,
$parent_class->cpkey_params(
$q->param('parent_pcpkey')
)
)->$pclass_tfield()
)
) . "<BR>\n";
}
print $q->end_font . $q->br . $q->a(
{ -HREF => $self->main_index },
[ 'Back to Main Index' ]
) . "<BR>\n"
. $q->end_b
. $q->end_td
. $q->end_Tr
. $q->start_Tr
. $q->start_td({ -ALIGN => 'center',
-BGCOLOR => $ui->{'row_value'}
}) . "\n"
. $q->p . "\n"
. $q->scrolling_list( -NAME =>'cpkey',
-VALUES => [ sort { $hashref->{$a} cmp $hashref->{$b} } keys %$hashref ],
-LABELS => $hashref,
-SIZE => 15, # should be setable
-MULTIPLE => 'true', # should be setable (why true?)
-OVERRIDE => 1
) . "\n"
. $q->br
. $q->font($ui->{'font_footer'}, "Select an item and press View. <BR>Or press Add to add a new item\n")
. $q->end_td
. $q->end_Tr
. $q->start_Tr
. $q->start_td({ -ALIGN => 'center',
-BGCOLOR => $ui->{'table_footer'}
})
. $q->start_table({ -WIDTH => '100%',
-BORDER => 0,
-CELLPADDING => 0,
-CELLSPACING => 0
})
. $q->start_Tr
. $q->start_td({ -WIDTH => '35%',
-ALIGN => 'left'
})
. $q->end_td
. $q->start_td({ -WIDTH => '30%',
-ALIGN => 'center'
})
. $self->display_list_buttons
. $q->end_td
. $q->start_td({ -WIDTH => '35%',
-ALIGN =>'right',
-VALIGN =>'bottom'
})
. $q->font({ -FACE => 'verdana,arial,helvetica',
-SIZE => 1
},
'Powered by: BingoX')
. $q->end_td
. $q->end_Tr
. $q->end_table
. $q->end_td
. $q->end_Tr
. $q->end_table
. $q->end_td
. $q->end_Tr
. $q->end_table
. $q->hidden( -NAME => 'displaymode',
-VALUE => $self->displaymode,
-OVERRIDE => 1
) . "\n"
. $q->hidden( -NAME => 'section',
-VALUE => $self->section,
-OVERRIDE => 1
) . "\n"
. $q->hidden( -NAME => 'parent_pcpkey')
. $self->hidden_fields
. $q->endform . "\n"
. $q->end_center
. $q->end_html . "\n";
return OK;
} # END sub display_list
sub display_list_buttons {
my $self = shift;
return undef unless (ref $self);
my $q = $self->cgi;
my $html = "<CENTER>";
if ($self->parents) {
foreach (@{ $self->parents }) {
$html .= $q->submit(-NAME => "parent##$_", -VALUE => "Back to ${_}");
}
$html .= '<BR>';
}
if ($self->children) {
foreach (@{ $self->children }) {
$html .= $q->submit(-NAME => "child##$_", -VALUE => "Show ${_}");
}
$html .= '<BR>';
}
return $html
. $q->submit( -NAME => 'submit_type',
-VALUE => 'Remove',
-onClick => "if (confirm('Are you sure you want to remove this record?')) { return true } else { return false }"
)
. $q->submit( -NAME => 'submit_type',
-VALUE => 'Add'
)
. $q->submit( -NAME => 'submit_type',
-VALUE => 'View'
)
. $q->submit( -NAME => 'submit_type',
-VALUE => 'Modify'
)
. "</CENTER>\n"
} # END sub display_list_buttons
sub display_modify_buttons {
my $self = shift;
# return undef unless ref($self);
my $q = $self->cgi;
return "<CENTER>"
. $q->submit( -NAME => 'submit_type',
-VALUE => 'Cancel'
)
. $q->submit( -NAME => 'submit_type',
-VALUE => 'Save'
)
. "</CENTER>\n"
} # END sub display_modify_buttons
sub display_view {
my $self = shift;
my $q = $self->cgi;
my $fields = $self->fields;
my $r = $self->r;
my $ui = $self->ui;
$self->{'_displaymode'} = 'view';
unless (ref $r) {
print $q->header;
}
print $self->display_start_html({ -TITLE => 'Admin '. $self->classdesc,
-BGCOLOR => $ui->{'page_bg'}
})
. $q->startform( -ACTION => $self->adminuri || $self->uri,
-METHOD => 'POST',
-NAME => 'displayform'
)
. $q->start_center
. $q->start_table({ -BORDER => 0,
-CELLSPACING => 0,
-CELLPADDING => 1,
-WIDTH => 500,
-BGCOLOR => $ui->{'table_border'}
})
. $q->start_Tr
. $q->start_td
. $q->start_table({ -BORDER => 0,
-CELLSPACING => 1,
-CELLPADDING => 4,
-WIDTH => 500,
-BGCOLOR => 'white'
})
. $q->start_Tr
. $q->start_td({ -COLSPAN => 2,
-BGCOLOR => $ui->{'table_header'}
})
. $q->b($q->font($ui->{'font_header'},$q->center($self->display_admin_name . "View " . $self->classdesc. "<BR>\n")))
. $q->end_td
. $q->end_Tr;
foreach (@{ $self->fieldlist }) {
$self->display_row( $_ ); # here's where the magic happens
}
print $q->start_Tr
. $q->start_td({ -COLSPAN => 2,
-ALIGN => 'center',
-BGCOLOR => $ui->{'table_footer'}
})
. $q->start_table({ -WIDTH => '100%',
-BORDER => 0,
-CELLPADDING => 0,
-CELLSPACING => 0
})
. $q->start_Tr
. $q->start_td({ -WIDTH =>'35%',
-ALIGN => 'left'
})
. $q->end_td
. $q->start_td({ -WIDTH => '30%',
-ALIGN => 'center'
})
. $self->display_view_buttons()
. $q->end_td
. $q->start_td({ -WIDTH => '35%',
-ALIGN => 'right',
-VALIGN => 'bottom'
})
. $q->font({ -FACE => 'verdana,arial,helvetica',
-SIZE => 1
},
'Powered by: BingoX')
. $q->end_td
. $q->end_Tr
. $q->end_table
. $q->end_td
. $q->end_Tr
. $q->end_table
. $q->end_td
. $q->end_Tr
. $q->end_table
. $q->hidden( -NAME => 'section',
-VALUE => $self->section,
-OVERRIDE => 1
)
. $q->hidden( -NAME => 'cpkey',
-VALUE => $self->pcpkey,
-OVERRIDE => 1
)
. $q->hidden( -NAME => 'displaymode',
-VALUE => 'view',
-OVERRIDE => 1
)
. $q->hidden( -NAME => 'parent_pcpkey')
. $self->hidden_fields
. $q->endform . "\n"
. $q->end_center
. $q->end_html . "\n";
return OK;
} # END sub display_view
sub display_view_buttons {
my $self = shift;
# return undef unless ref($self);
my $q = $self->cgi;
return "<CENTER>"
. $q->submit( -NAME => 'submit_type',
-VALUE => 'Remove',
-onClick => "if (confirm('Are you sure you want to remove this record?')) { return true } else { return false }"
)
. $q->submit( -NAME => 'submit_type',
-VALUE => 'Modify'
)
. $q->br
. $q->submit( -NAME => 'submit_type',
-VALUE => 'Return to List'
)
. "</CENTER>\n"
} # END sub display_view_buttons
sub display_modify {
my $self = shift;
my $q = $self->cgi;
my $errors = shift;
my $db_errors = $self->db_obj ? $self->db_obj->errors : '';
my $r = $self->r;
my $ui = $self->ui;
unless (ref $r) {
print $q->header;
}
print $self->display_start_html({ -TITLE => 'Admin '. $self->classdesc,
-BGCOLOR => $ui->{'page_bg'}
})
. $q->start_multipart_form( -ACTION => $self->adminuri || $self->uri,
-METHOD => 'POST')
. $q->start_center
. $q->start_table({ -BORDER => 0,
-CELLSPACING => 0,
-CELLPADDING => 1,
-WIDTH => 500,
-BGCOLOR => $ui->{'table_border'}
})
. $q->start_Tr
. $q->start_td
. $q->start_table({ -BORDER => 0,
-CELLSPACING => 1,
-CELLPADDING => 4,
-WIDTH => 500,
-BGCOLOR => 'white'
})
. $q->start_Tr
. $q->start_td({ -COLSPAN => 2,
-BGCOLOR => $ui->{'table_header'}
})
. $q->b(
$q->font(
$ui->{'font_header'},
$q->center(
$self->display_admin_name . (
($self->displaymode eq 'add')
? "Add "
: "Modify "
) . $self->classdesc. "<BR>\n"
)
)
);
if (%{ $self->{'_errors'} }) {
print $q->p . $q->font($ui->{'font_key'},"There are errors in the following fields:\n")
. '<BR><UL>';
if (ref $self->{'_errors'} eq 'HASH') {
foreach (keys %{ $self->{'_errors'} }) {
print $q->li($q->font($ui->{'font_error'}, ($self->fieldname($_) || $_) . ': ' . $self->{'_errors'}->{$_}));
}
} else {
print $q->li($q->font($ui->{'font_error'},$self->fieldname($_) . ': ' . $self->{'_errors'}));
}
# map { print "<LI>" . $_ . "\n"} keys %{$self->{'_errors'}};
print "</UL><br>\n";
} elsif (ref $db_errors) {
print $q->p . $q->font($ui->{'font_key'},"The following errors occured:\n")
. '<BR><UL>';
foreach (keys %{ $db_errors }) {
print $q->li . $q->font($ui->{'font_error'},$_ . ': ' . $db_errors->{$_} . "\n");
}
print "</UL><br>\n";
} else {
print $q->font($ui->{'font_key'},'<P ALIGN="CENTER">An asterisk ("<B>*</B>") denotes a required field.</P>');
}
print $q->end_td
. $q->end_Tr;
foreach (@{ $self->fieldlist }) {
next if (($self->displaymode eq 'add') && ($_ eq $self->data_class->primary_keys->[0]));
$self->display_row( $_ );
}
print $q->start_Tr
. $q->start_td({ -COLSPAN => 2,
-ALIGN => 'center',
-BGCOLOR => $ui->{'table_footer'}
})
. $q->start_table({ -WIDTH => '100%',
-BORDER => 0,
-CELLPADDING => 0,
-CELLSPACING => 0
})
. $q->start_Tr
. $q->start_td({ -WIDTH => '35%',
-ALIGN => 'center'
})
. $q->end_td
. $q->start_td({ -WIDTH => '30%',
-ALIGN => 'center'
})
. $self->display_modify_buttons
. $q->end_td
. $q->start_td({ -WIDTH => '35%',
-ALIGN => 'right',
-VALIGN => 'bottom'
})
. $q->font({ -FACE => 'verdana,arial,helvetica',
-SIZE => 1
},
'Powered by: BingoX')
. $q->end_td
. $q->end_Tr
. $q->end_table
. $q->end_td
. $q->end_Tr
. $q->end_table
. $q->end_td
. $q->end_Tr
. $q->end_table
. $q->hidden( -NAME => 'cpkey',
-VALUE => $self->pcpkey,
-OVERRIDE => 1
)
. $q->hidden( -NAME => 'section',
-VALUE => $self->section,
-OVERRIDE => 1
)
. $q->hidden( -NAME => 'displaymode',
-VALUE => $self->displaymode,
-OVERRIDE => 1
)
. $q->hidden( -NAME => 'parent_pcpkey')
. $self->hidden_fields
. $q->endform . "\n"
. $q->end_center
. $q->end_html . "\n";
return OK;
} # END sub display_modify
sub display_admin_name {
no strict 'refs';
my $self = shift;
my $class = ref($self) || $self;
my $q = $self->cgi;
warn "display_admin_name ==> " . $class->admin_name . "\n" if ($debug > 3);
return defined($class->admin_name) ? $class->admin_name . $q->br : undef;
} # END sub admin_name
sub admin_name { }
sub hidden_fields {
my $self = shift;
my $fields = shift;
ref($fields) || return undef;
my $string;
foreach (keys %$fields) {
$string .= $self->cgi->hidden( -NAME => $_,
-VALUE => $fields->{$_});
}
return $string;
} # END sub admin_name
sub display_start_html {
my $self = shift;
my $options = shift || { };
my $ui = $self->ui;
$options->{'-bgcolor'} ||= $ui->{'page_bg'};
$options->{'-text'} ||= $ui->{'text_color'};
$options->{'-link'} ||= $ui->{'link_color'};
$options->{'-vlink'} ||= $ui->{'vlink_color'};
$options->{'-alink'} ||= $ui->{'alink_color'};
return $self->cgi->start_html(%{ $options });
} # END sub display_start_html
sub display_search {
warn "display_search method not implimented yet!";
return undef;
} # END sub display_search
sub display_row {
my $self = shift;
return undef unless ref $self;
my $q = $self->cgi;
my $field = shift;
my $ui = $self->ui;
return undef if ($self->fieldtype($field) eq 'hidden');
## Is this field required? (i.e. not null?) ##
my $req = %{$self->fieldoptions($field) || { }}->{not_null} || 0;
if (($self->fieldtype($field) eq 'row')) {
print $self->$field();
} elsif ($self->fieldtype($field) eq 'textarea') {
print $q->Tr({ },
$q->td({ -VALIGN => 'top',
-COLSPAN => 2,
-ALIGN => 'center',
-WIDTH => 100,
-BGCOLOR => $ui->{'row_key'}
},
$q->font(
$ui->{'font_key'},
$q->b(
($req ? '* ' : '') . $self->fieldname( $field ) . ':'
)
)
)
)."\n"
. $q->Tr({ },
$q->td({ -VALIGN => 'top',
-COLSPAN => 2,
-BGCOLOR => $ui->{'row_value'}
},
$q->font(
$ui->{'font_value'},
($self->$field() ? $self->$field() : ' ')
)
)
) . "\n";
} elsif (($self->fieldtype($field) eq 'password') && ($self->displaymode() ne 'view')) {
# Once to enter
print $q->Tr({ },
$q->td({ -VALIGN => 'top',
-ALIGN => 'right',
-WIDTH => 100,
-BGCOLOR => $ui->{'row_key'}
},
$q->font(
$ui->{'font_key'},
$q->b(
($req ? '* ' : '') . $self->fieldname( $field ) . ':'
)
)
)
. $q->td({ -VALIGN => 'top',
-WIDTH => 400,
-BGCOLOR => $ui->{'row_value'}
},
$q->font(
$ui->{'font_value'},
$self->$field()
)
)
) . "\n"
# again to verify
. $q->Tr({ },
$q->td({ -VALIGN => 'top',
-ALIGN => 'right',
-WIDTH => 100,
-BGCOLOR => $ui->{'row_key'}
},
$q->font(
$ui->{'font_key'},
$q->b(
($req ? '* ' : '') . $self->fieldname( $field ) . ':'
)
. '<br/>(for verification)'
)
)
. $q->td({ -VALIGN => 'top',
-WIDTH => 400,
-BGCOLOR => $ui->{'row_value'}
},
$q->font(
$ui->{'font_value'},
$self->$field()
)
)
) . "\n"
} else {
print $q->Tr({ },
$q->td({ -VALIGN => 'top',
-ALIGN => 'right',
-WIDTH => 100,
-BGCOLOR => $ui->{'row_key'}
},
$q->font(
$ui->{'font_key'},
$q->b(
($req ? '* ' : '') . $self->fieldname( $field ) . ':'
)
)
)
. $q->td({ -VALIGN => 'top',
-WIDTH => 400,
-BGCOLOR => $ui->{'row_value'}
},
$q->font(
$ui->{'font_value'},
($self->$field() ? $self->$field() : ' ')
)
)
) . "\n";
}
} # END sub display_row
sub save_data {
my $self = shift;
return undef unless ref $self;
my $dbh = $self->dbh();
my $data = shift || $self->get_data();
warn 'save_data after get_data data: ' . Data::Dumper::Dumper($data) . "\n" if ($debug > 1);
return undef unless (ref($data) eq 'HASH');
return undef unless ($self->sanity($data));
my $newself;
warn 'save data==> ' . Data::Dumper::Dumper($data) . "\n" if ($debug);
if ($self->displaymode eq 'add') {
if ($newself = $self->data_class->new( $dbh, $data )) {
warn "save_data - new succeeded\n" if ($debug > 1);
$self->{'_db_obj'} = $newself;
warn 'save_data - after new - new self ==> ' . Data::Dumper::Dumper($self->{'_db_obj'}) if ($debug > 1);
} else {
warn "save_date - new failed\n" if ($debug > 1);
$self->{'_errors'}->{'General Database Error'} = $dbh->errstr || $self->data_class->errors;
return undef;
}
} else {
if ($newself = $self->db_obj->modify( $data )) {
warn "save_data - modify succeeded\n" if ($debug > 1);
$self->{'_db_obj'} = $newself;
warn 'save_data - after modify - new self ==> ' . Data::Dumper::Dumper($self->{'_db_obj'}) if ($debug > 1);
} else {
warn "save_date - modify failed\n" if ($debug > 1);
$self->{'_errors'}->{'General Database Error'} = $dbh->errstr || $self->db_obj->errors;
return undef;
}
}
return 1;
} # END sub save_data
sub get_data {
my $self = shift;
return undef unless ref $self;
my $data = shift || { };
my $fields = shift || $self->fields;
my $q = $self->cgi;
my $db_obj = $self->db_obj;
warn 'Admin:get_data q ==> ' . Data::Dumper::Dumper($q) . "\n" if ($debug > 2);
warn 'Admin:get_data fields ==> ' . Data::Dumper::Dumper($fields) . "\n" if ($debug > 2);
warn 'Admin:get_data db_obj ==> ' . Data::Dumper::Dumper($db_obj) . "\n" if ($debug > 2);
foreach (keys %$fields) {
my $qfieldname = $self->qfieldname( $_ );
my $foptions = $self->fieldoptions( $_ );
my $qoptions = $self->fieldhtmloptions( $_ ) || { };
# if (!$foptions->{not_null} && ($q->param( $qfieldname ) =~ /^NULL$/i)) {
# warn "Null option selected.";
# $q->param( $qfieldname, undef );
# last;
# }
if ($self->fieldrelclass( $_ )) {
warn "reclass - $_ ==> " . $self->fieldrelclass($_) . " qfieldname ==> $qfieldname - q ==> " . Data::Dumper::Dumper($q->param( $qfieldname )) ."\n" if ($debug > 1);
if ($self->fieldrelclasstype($_)) {
$data->{$self->fieldrelclass($_)} = [ $q->param( $qfieldname ) ];
} else {
warn "no classtype $_\n" if ($debug > 1);
if ($q->param( $qfieldname ) eq 'NULL') {
$data->{$_} = undef;
} else {
$data->{$_} = $q->param( $qfieldname ) unless (ref $db_obj && ($db_obj->$_() eq $q->param( $qfieldname )));
warn Data::Dumper::Dumper( $data->{$_} ) if ($debug > 1);
}
}
} elsif ($self->fieldtype($_) eq 'checkbox') {
unless (defined $q->param( $qfieldname )) {
$q->param(-NAME => $qfieldname, -VALUE => '0');
}
$data->{$_} = $q->param( $qfieldname )
unless (ref $db_obj && ($db_obj->$_() eq $q->param( $qfieldname )));
} elsif ($self->fieldtype($_) eq 'date') {
next unless ($q->param( $qfieldname.'_year' ));
my $date = BingoX::Time->new;
warn "date field => $qfieldname\n" if ($debug > 1);
## Year ##
my $year = $q->param( $qfieldname.'_year' );
if (length($year) <= 2) {
$self->{'_errors'}->{$_} = "Invalid Date Entered: be compliant and the use full year";
return undef;
}
## Month ##
my $month;
my $mon = $q->param( $qfieldname.'_mon' );
if ($mon =~ /\D/) {
$self->{'_errors'}->{$_} = "Invalid Date Entered: must be of the value [ 1 .. 12 ]";
return undef;
} else {
$month = $date->months->{ $mon };
}
## Day ##
my $day = $q->param( $qfieldname.'_day' );
my $lday = $date->last_days->{ $mon - 1 };
if ($day < 1 || $day > 31) {
$self->{'_errors'}->{$_} = "Invalid Date Entered: day is out of range";
return undef;
} elsif ($day =~ /\D/) {
$self->{'_errors'}->{$_} = "Invalid Date Entered: must be of the value [ 1 .. last day ]";
return undef;
} elsif ($day > $lday) {
$day = $lday;
}
## Hour ##
my $hour = $q->param( $qfieldname.'_hour' );
my $am_pm = $q->param( $qfieldname.'_ampm' );
unless ($qoptions->{'-SHOW_24HOURS'}) {
if ($am_pm eq 'PM') {
$hour += 12 unless ($hour == 12);
} else {
$hour = 0 if ($hour == 12);
}
}
## Minute ##
my $min = $q->param( $qfieldname.'_min' ) || '00';
## Jun 04 1998 21:09:55 ##
my $string = sprintf("%s %2d %4d %02d:%02d:00", $month, $day, $year, $hour, $min);
my $timelocal = $self->data_class->str2time( $string );
my $new_date = BingoX::Time->new( $timelocal );
$data->{$_} = $new_date->strftime( $self->data_class->date_format )
unless (ref $db_obj && ($db_obj->$_() eq $new_date));
warn 'get_data date ==> ' . Data::Dumper::Dumper($data->{$_}) . "\n" if ($debug > 1);
} else {
warn "qfieldname ==> $qfieldname\n" if ($debug > 1);
next if ($self->fieldtype( $_ ) eq 'view');
## Verify that password fields match verification
if ($self->fieldtype($_) eq 'password') {
my @pw_values = $q->param( $qfieldname );
if ($pw_values[0] ne $pw_values[1]) {
$q->param( $qfieldname, '' );
$self->{'_errors'}->{$_} = 'passwords do not match.';
}
}
if ($q->param( $qfieldname ) eq 'NULL') {
$data->{$_} = undef;
} else {
$data->{$_} = $q->param( $qfieldname )
unless (ref $db_obj && ($db_obj->$_() eq $q->param( $qfieldname )));
}
}
}
warn 'get_data ==> ' . Data::Dumper::Dumper($data) ."\n" if ($debug > 2);
return $data;
} # END sub get_data
sub sanity {
my $self = shift;
my $data_hash = shift;
ref($data_hash) || return undef;
my $q = $self->cgi;
my $qfield;
## Step through each field, calling all the necessary sanity methods ##
foreach my $field (@{ $self->fieldlist }) {
my $sanity = $self->fieldsanity( $field );
my $req = %{ $self->fieldoptions( $field ) || { } }->{'not_null'} || 0;
unless (ref($sanity) eq 'ARRAY' || $req) {
warn "BingoX::Chromium::fieldsanity('$field') is not an array ref\n" if ($debug);
next;
}
$qfield = $self->qfieldname( $field );
my @errors = ( );
my $data = (exists $data_hash->{ $field })
? $data_hash->{$field}
: ( $self->displaymode eq 'add'
? ''
: $self->db_obj->$field());
## Is this a required field? If it's empty, ##
## we can complain here and move on... ##
if ($req && !$data) {
$self->{'_errors'}{$field} ||= 'This field is required.';
next;
}
## Check each sanity method for this field ##
foreach my $sane (@$sanity) {
if (ref $sane) { # listref, call the method, passing paramters
my $method = shift @$sane;
my $err = $self->$method($data, @$sane);
warn("SANITY ERROR: $err") if ($err && $debug);
push(@errors, $err) if $err;
} else { # not a ref, call the method only
my $err = $self->$sane( $data );
warn("SANITY ERROR: $err") if ($err && $debug);
push(@errors, $err) if $err;
}
}
$self->{'_errors'}{$field} = join('<BR>', @errors) if @errors;
}
## Parlance -- true result means "sane" ##
(%{ $self->{'_errors'} }) ? 0 : 1;
} # END sub sanity
sub qfd { return "#" }
sub pkd { return $_[0]->data_class->pkd }
sub prefix { return $_[0]->data_class_name . $_[0]->qfd }
sub cpkey {
my $self = shift;
my $obj = shift || $self->db_obj;
return undef unless (ref($self) && ref($obj));
return $obj->cpkey;
} # END sub cpkey
sub cpkey_params {
my $self = shift;
my $cpkey = shift || return undef;
$cpkey = (split( $self->qfd,$cpkey ))[-1];
return $self->data_class->cpkey_params( $cpkey );
} # END sub cpkey_param
sub pcpkey {
my $self = shift;
my $obj = shift || $self->db_obj;
return undef unless (ref($self) && ref($obj));
return $self->prefix . $obj->cpkey;
} # END sub pcpkey
sub dbh {
my $self = shift;
return $self->{'_dbh'} if (ref($self) && ref($self->{'_dbh'}));
my $data_class = $self->data_class;
my $dbh = $data_class->dbh;
$self->{'_dbh'} = $dbh if (ref $self);
my $r = $self->r;
if (ref $r) {
$r->register_cleanup(sub { $data_class->purge_dbh }) unless ($r->notes('chromium_cleanup'));
$r->notes('chromium_cleanup', 1);
}
return $dbh;
} # END sub dbh
sub get_list_hash {
my $self = shift;
my $class = ref($self) || $self;
my $selection = shift || $self->selection;
my $title_size = $self->data_class->title_size || 80;
my $title_field = $self->data_class->title_field;
my $fields = $self->data_class->primary_keys;
my $sort = [ ];
unless ($self->data_class->content_fields->{ $title_field }) {
push(@$fields, $title_field);
$sort = [ $title_field ];
}
my $stream = $self->data_class->stream_obj(
$self->dbh,
$selection,
$fields,
$sort
);
my $hash = { };
return undef unless ref $stream;
while (my $obj = $stream->()) {
$hash->{ $self->pcpkey( $obj ) }
= length($obj->$title_field()) > $title_size
? substr($obj->$title_field(), 0, ($title_size - 3)) . '...'
: $obj->$title_field();
}
warn Data::Dumper::Dumper( $hash ) if ($debug > 2);
return $hash;
} # END sub get_list_hash
sub db_obj {
my $self = shift;
return undef unless ref($self);
return $self->{'_db_obj'} if ref($self->{'_db_obj'});
my $q = $self->cgi;
my $params = { };
warn "CGI ==> " . Data::Dumper::Dumper( $q ) . "\n" if ($debug > 3);
if ($q->param('cpkey')) { # should be here most of the time
warn "pkey ==> " . $q->param('cpkey') . "\n" if ($debug > 3);
$params = $self->cpkey_params( $q->param('cpkey') );
warn 'params ==> ' . Data::Dumper::Dumper( $params ) . "\n" if ($debug > 3);
} elsif ($q->param('ID')) { # BAD BAD BAD DOG! Just in case.
$params->{ $self->data_class->primary_keys->[0] } = $q->param('ID');
} else { # If the primary keys are specified individually.
foreach (@{ $self->data_class->primary_keys }) {
return undef unless $q->param($_);
my $prefix = $self->prefix;
$q->param($_) =~ /^$prefix(.*)/;
$params->{$_} = $1;
}
}
## get it from the database. Should we be using get? ##
$self->{'_db_obj'} = $self->data_class->get( $self->dbh, $params );
} # END sub db_obj
sub data_class {
my $self = shift;
return $self->{'_data_class'} if (ref $self);
my $class = ref($self) || $self;
no strict 'refs';
my $dc = ${"${class}::data_class"};
unless (defined $dc) {
($dc = $class) =~ s/::Admin::/::Data::/;
${"${class}::data_class"} = $dc;
}
return $dc;
} # END of data_class
*db_class = \&data_class; # Backward compatibility
sub data_class_name {
my $self = shift;
return $self->{'_data_class_name'} if (ref $self);
$self->data_class =~ /^.*:(.*)/;
return $1;
} # END sub data_class_name
*db_class_name = \&data_class_name; # Backward compatibility
sub ui {
my $self = shift;
return $self->{'_ui'} if (ref($self) && ref($self->{'_ui'}));
my $options = shift || { };
$options->{'text_color'} ||= '#000000';
$options->{'link_color'} ||= '#0000FF';
$options->{'vlink_color'} ||= '#660099';
$options->{'alink_color'} ||= '#FF0000';
$options->{'page_bg'} ||= '#FFFFFF';
$options->{'table_border'} ||= '#000000';
$options->{'row_key'} ||= '#EEEEDE';
$options->{'row_value'} ||= '#FFFFFF';
$options->{'table_header'} ||= '#FFFFEE';
$options->{'table_footer'} ||= '#FFFFEE';
$options->{'font_header'} ||= { -FACE => 'verdana,arial,helvetica', -SIZE => '5' };
$options->{'font_footer'} ||= { -FACE => 'verdana,arial,helvetica', -SIZE => '1' };
$options->{'font_error'} ||= { -FACE => 'verdana,arial,helvetica', -SIZE => '2', -COLOR => "#FF0000" };
$options->{'font_key'} ||= { -FACE => 'verdana,arial,helvetica', -SIZE => '2' };
$options->{'font_value'} ||= { -FACE => 'times', -SIZE => '3' };
return (ref($self) ? $self->{'_ui'} = $options : $options);
} # END sub ui
sub children {
no strict 'refs';
my $self = shift;
my $class = ref($self) || $self;
return [ @{"${class}::children"} ] || undef;
} # END sub children
sub parents {
no strict 'refs';
my $self = shift;
my $class = ref($self) || $self;
return [ @{"${class}::parents"} ] || undef;
} # END sub children
sub parent_class {
return $_[0]->{'_parent_class'};
} # END of parent_class
sub adminuri {
no strict 'refs';
my $self = shift;
my $class = ref($self) || $self;
warn 'adminuri ==> ' . ${"${class}::adminuri"} . "\n" if ($debug > 3);
return ${"${class}::adminuri"} || undef;
} # END sub adminuri
sub classdesc {
no strict 'refs';
my $self = shift;
my $class = ref($self) || $self;
warn 'classdesc ==> ' . ${"${class}::classdesc"} . "\n" if ($debug > 3);
return ${"${class}::classdesc"} || undef;
} # END sub classdesc
sub adminclass {
my $proto = shift;
my $class = shift;
my $lclass = $class;
no strict 'refs';
my @ISA = @{ "${class}::ISA" };
while ($ISA[0] ne __PACKAGE__) {
$lclass = shift(@ISA);
unshift( @ISA, @{ "${lclass}::ISA" } );
return undef unless (@ISA);
}
return $lclass;
} # END sub adminclass
sub fieldlist {
no strict 'refs';
my $self = shift;
my $class = ref($self) || $self;
return \@{"${class}::fieldlist"};
} # END sub fieldlist
sub fields {
no strict 'refs';
my $self = shift;
my $class = ref($self) || $self;
return \%{"${class}::fields"};
} # END sub fields
sub fieldname {
no strict 'refs';
my $self = shift;
my $class = ref($self) || $self;
my $field = shift;
my $fields = $class->fields();
return undef unless (defined %$fields);
return $fields->{$field}[0];
} # END sub fieldname
sub fieldtype {
no strict 'refs';
my $self = shift;
my $class = ref($self) || $self;
my $field = shift;
my $fields = $class->fields();
return undef unless (defined %$fields);
return $fields->{$field}[1];
} # END sub fieldtype
sub fieldhtmloptions {
no strict 'refs';
my $self = shift;
my $class = ref($self) || $self;
my $field = shift;
my $fields = $class->fields();
return undef unless (defined %$fields);
return $fields->{$field}[2];
} # END sub fieldhtmloptions
sub fieldrelclass {
no strict 'refs';
my $self = shift;
my $class = ref($self) || $self;
my $field = shift;
my $fields = $class->fields();
return undef unless (defined(%$fields) && exists($fields->{$field}[3]));
return $fields->{$field}[3][0];
} # END sub fieldrelclass
sub fieldrelclasstype {
no strict 'refs';
my $self = shift;
my $class = ref($self) || $self;
my $field = shift;
my $fields = $class->fields();
return undef unless (defined(%$fields) && exists($fields->{$field}[3]));
return $fields->{$field}[3][1];
} # END sub fieldrelclasstype
sub fieldoptions {
no strict 'refs';
my $self = shift;
my $class = ref($self) || $self;
my $field = shift;
my $fields = $class->fields();
return undef unless (defined %$fields);
return $fields->{$field}[4];
} # END sub fieldoptions
sub fieldsanity {
no strict 'refs';
my $self = shift;
my $class = ref($self) || $self;
my $field = shift;
my $fields = $class->fields();
return undef unless (defined %$fields);
return $fields->{$field}[5];
} # END sub fieldsanity
sub uri { $_[0]->{'_uri'} }
sub cgi { $_[0]->{'_cgi'} }
sub conf { $_[0]->{'_conf'} }
sub section { $_[0]->{'_section'} }
sub displaymode { $_[0]->{'_displaymode'} }
sub r {
return undef unless (defined $ENV{'MOD_PERL'} && ref $_[0]);
$_[0]->{'_r'} ||= Apache->request;
} # END sub r
sub selection {
my $self = shift;
my $value = shift;
if (ref $self) {
$self->{'_selection'} = $value if (defined $value);
return $self->{'_selection'} || { };
} else {
return { };
}
} # END sub selection
sub qfieldname {
my $self = shift;
return undef unless ref($self);
my $fieldname = shift;
my $qfieldname = '';
$qfieldname = $self->cpkey . $self->qfd if ($self->displaymode eq 'modify');
$qfieldname .= $self->prefix . $fieldname;
return $qfieldname;
} # END of qfieldname
sub main_index {
my $self = shift;
my $path = $self->r->dir_config('AdminMainIndex') || '/';
return $path;
} # END of main_index
sub HTML_time {
my $self = shift;
return undef unless ref($self);
my $fieldname = shift;
my $qoptions = shift || $self->fieldhtmloptions( $fieldname ) || { };
my $q = $self->cgi;
my $qfieldname = $self->qfieldname( $fieldname );
my $hr24 = $qoptions->{'-SHOW_24HOURS'};
my $date_obj;
$date_obj = $self->db_obj->$fieldname() unless ($self->displaymode eq 'add');
if (!ref($date_obj)) {
return undef if ($self->displaymode eq 'view');
$date_obj = BingoX::Time->new();
}
my ($hour, $minute, $ampm);
## get hour from the date object ##
$hour = $date_obj->hour;
## get minute from the date object ##
$minute = $date_obj->min;
unless ($hr24) {
$ampm = ($hour >= 12 ? 'PM' : 'AM');
$hour -= 12 if ($hour > 12);
$hour = 12 if ($hour == 0);
}
return ($hour . ':' . $minute . ' ' . $ampm ,
$q->hidden(-NAME => $qfieldname.'_hour', -VALUE => $hour)
. $q->hidden(-NAME => $qfieldname.'_min', -VALUE => $minute)
. $q->hidden(-NAME => $qfieldname.'_ampm', -VALUE => $ampm))
if ($self->displaymode eq 'view' || $qoptions->{'-TYPE'} =~ /view/i);
if ($qoptions->{'-TYPE'} =~/view/io) {
return $q->hidden( -NAME => $qfieldname.'_hour',
-VALUE => $hour)
. $q->hidden( -NAME => $qfieldname.'_min',
-VALUE => $minute)
. $q->hidden( -NAME => $qfieldname.'_ampm',
-VALUE => $ampm);
} elsif ($qoptions->{'-TYPE'} =~/text/io) {
return $q->textfield( -NAME => $qfieldname.'_hour',
-SIZE => $qoptions->{'-HR_SIZE'} || 2,
-MAXLENGTH => $qoptions->{'-HR_MAXLENGTH'} || 2,
-OVERRIDE => $qoptions->{'-HR_OVERRIDE'} || 1,
-DEFAULT => sprintf("%02d", $q->param( $qfieldname.'_hour' ) || $hour)
)
. ' : '
. $q->textfield( -NAME => $qfieldname.'_min',
-SIZE => $qoptions->{'-MIN_SIZE'} || 2,
-MAXLENGTH => $qoptions->{'-MIN_MAXLENGTH'} || 2,
-OVERRIDE => $qoptions->{'-MIN_OVERRIDE'} || 1,
-DEFAULT => sprintf("%02d", $q->param( $qfieldname.'_min' ) || $minute)
)
. ($hr24 ? '' :
' ' . $q->popup_menu( -NAME => $qfieldname.'_ampm',
-VALUES => [ 'AM', 'PM' ],
-DEFAULT => ($q->param( $qfieldname.'_ampm' ) || $ampm),
-OVERRIDE => $qoptions->{'-AMPM_OVERRIDE'} || 1
));
} else {
return $q->popup_menu( -NAME => $qfieldname.'_hour',
-VALUES => ($hr24 ? $date_obj->hours24 : $date_obj->hours),
-DEFAULT => sprintf("%02d", $hour),
-OVERRIDE => $qoptions->{'-HR_OVERRIDE'} || 1
)
. ' : '
. $q->popup_menu( -NAME => $qfieldname.'_min',
-VALUES => $date_obj->minutes,
-DEFAULT => sprintf("%02d", $q->param( $qfieldname.'_min' ) || $minute),
-OVERRIDE => $qoptions->{'-MIN_OVERRIDE'} || 1
)
. ($hr24 ? '' :
' ' . $q->popup_menu( -NAME => $qfieldname.'_ampm',
-VALUES => [ 'AM', 'PM' ],
-DEFAULT => ($q->param( $qfieldname.'_ampm' ) || $ampm),
-OVERRIDE => $qoptions->{'-AMPM_OVERRIDE'} || 1
));
}
} # END sub HTML_time
sub HTML_day {
my $self = shift;
return undef unless ref($self);
my $fieldname = shift;
my $qoptions = shift || $self->fieldhtmloptions( $fieldname ) || { };
my $q = $self->cgi;
my $qfieldname = $self->qfieldname( $fieldname );
my $date_obj;
$date_obj = $self->db_obj->$fieldname() unless ($self->displaymode eq 'add');
if (!ref($date_obj)) {
return undef if ($self->displaymode eq 'view');
$date_obj = BingoX::Time->new();
}
return $date_obj->mday if ($self->displaymode eq 'view');
if ($qoptions->{'-TYPE'} =~/view/io) {
return ( $date_obj->mday
,$q->hidden( -NAME => $qfieldname.'_day',
-VALUE => $date_obj->mday));
} elsif ($qoptions->{'-TYPE'} =~/text/io) {
return $q->textfield( -NAME => $qfieldname.'_day',
-SIZE => $qoptions->{'-DAY_SIZE'} || 2,
-MAXLENGTH => $qoptions->{'-DAY_MAXLENGTH'} || 2,
-OVERRIDE => $qoptions->{'-DAY_OVERRIDE'} || 1,
-DEFAULT => $q->param( $qfieldname.'_day' ) || $date_obj->mday
);
} else {
return $q->popup_menu( -NAME => $qfieldname.'_day',
-VALUES => [ 1 .. 31 ],
-OVERRIDE => $qoptions->{'-DAY_OVERRIDE'} || 1,
-DEFAULT => $q->param( $qfieldname.'_day' ) || $date_obj->mday
);
}
} # END sub HTML_day
sub HTML_month {
my $self = shift;
return undef unless ref($self);
my $fieldname = shift;
my $qoptions = shift || $self->fieldhtmloptions( $fieldname ) || { };
my $q = $self->cgi;
my $qfieldname = $self->qfieldname( $fieldname );
my $format = $qoptions->{'-FORMAT'} || "%B %e %Y";
my $date_obj;
$date_obj = $self->db_obj->$fieldname() unless ($self->displaymode eq 'add');
if (!ref($date_obj)) {
return undef if ($self->displaymode eq 'view');
$date_obj = BingoX::Time->new();
}
return $date_obj->mon if ($self->displaymode eq 'view');
if ($qoptions->{'-TYPE'} =~/view/io) {
return ($date_obj->mon,
$q->hidden( -NAME => $qfieldname.'_mon',
-VALUE => $date_obj->mon));
} elsif ($qoptions->{'-TYPE'} =~/text/io) {
return $q->textfield( -NAME => $qfieldname.'_mon',
-SIZE => $qoptions->{'-MON_SIZE'} || 2,
-MAXLENGTH => $qoptions->{'-MON_MAXLENGTH'} || 2,
-OVERRIDE => $qoptions->{'-MON_OVERRIDE'} || 1,
-DEFAULT => $q->param( $qfieldname.'_mon' ) || $date_obj->mon
);
} else {
return $q->popup_menu( -NAME => $qfieldname . '_mon',
-VALUES => [ 1 .. 12 ],
-LABELS => ($format =~ /\%B/o ? $date_obj->months_full : $date_obj->months),
-OVERRIDE => $qoptions->{'-MON_OVERRIDE'} || 1,
-DEFAULT => $q->param( $qfieldname.'_mon' ) || $date_obj->mon
);
}
} # END sub HTML_month
sub HTML_year {
my $self = shift;
return undef unless ref($self);
my $fieldname = shift;
my $qoptions = shift || $self->fieldhtmloptions( $fieldname ) || { };
my $q = $self->cgi;
my $qfieldname = $self->qfieldname( $fieldname );
my $format = $qoptions->{'-FORMAT'} || "%B %e %Y";
my $date_obj;
$date_obj = $self->db_obj->$fieldname() unless ($self->displaymode eq 'add');
if (!ref($date_obj)) {
return undef if ($self->displaymode eq 'view');
$date_obj = BingoX::Time->new();
}
my $start = $qoptions->{'-YEAR_START'} || 20;
my $end = $qoptions->{'-YEAR_END'} || 20;
my ($values, $year, $size, $max);
if ($format =~ /\%Y/o) {
$year = $date_obj->year;
$values = [ ($year - $start) .. ($year + $end) ];
$size = 4;
$max = 4;
} else {
### THERE IS NO REASON TO USE NON-COMPLIANT YEARS ###
$size = 2;
$max = 2;
$year = substr($date_obj->year, -2, 2);
my $yr = $year;
$values = [ $year ];
$start = 49 if ($start >= 50); # can only display 100 years at a time in two digit format
foreach (1 .. $start) {
$yr = 100 if ($yr == 0); # can't have negative years
unshift(@$values, sprintf("%02d", --$yr));
}
$yr = $year;
foreach (1 .. $start + 1) {
push(@$values, sprintf("%02d", ++$yr));
}
}
return $year if ($self->displaymode eq 'view');
if ($qoptions->{'-TYPE'} =~/view/io) {
return ($year ,$q->hidden( -NAME => $qfieldname.'_year',
-VALUE => $year));
} elsif ($qoptions->{'-TYPE'} =~/text/io) {
return $q->textfield( -NAME => $qfieldname.'_year',
-SIZE => $size,
-MAXLENGTH => $max,
-OVERRIDE => $qoptions->{'-YEAR_OVERRIDE'} || 1,
-DEFAULT => $q->param( $qfieldname.'_year' ) || $year
);
} else {
return $q->popup_menu( -NAME => $qfieldname.'_year',
-VALUES => $values,
-OVERRIDE => $qoptions->{'-YEAR_OVERRIDE'} || 1,
-DEFAULT => $q->param( $qfieldname.'_year' ) || $year
);
}
} # END sub HTML_year
sub HTML_date {
my $self = shift;
return undef unless ref($self);
my $fieldname = shift;
my $qoptions = shift || $self->fieldhtmloptions( $fieldname ) || { };
my $q = $self->cgi;
my $qfieldname = $self->qfieldname( $fieldname );
my $showhrs = $qoptions->{'-SHOW_HOURS'} || $qoptions->{'-SHOW_24HOURS'}; # Show the hours flag
my $format = $qoptions->{'-FORMAT'} || "%B %e %Y"; # format for date strings
my $delim = $qoptions->{'-DELIMITER'} || '/'; # delimiter for text dates
my ($day, $dhidden) = $self->HTML_day( $fieldname, $qoptions );
my ($mon, $mhidden) = $self->HTML_month($fieldname, $qoptions );
my ($year, $yhidden) = $self->HTML_year( $fieldname, $qoptions );
my ($time, $thidden) = $self->HTML_time( $fieldname, $qoptions );
my $date_obj;
$date_obj = $self->db_obj->$fieldname() unless ($self->displaymode eq 'add');
if (!ref($date_obj)) {
return undef if ($self->displaymode eq 'view');
$date_obj = BingoX::Time->new();
}
## if in display view mode get the date object from the scalar values ##
if ($self->displaymode eq 'view') {
if ($qoptions->{'-FORMAT'}) {
return $date_obj->strftime( $format ) . $dhidden . $mhidden . $yhidden . $thidden;
} elsif ($qoptions->{'-DELIMITER'}) {
return "$mon $delim $day $delim $year" . ($showhrs ? " $time" : '');
} else {
return "$mon $day $year" . ($showhrs ? " $time" : '');
}
}
my $html;
if ($qoptions->{'-TYPE'} =~/view/io) {
$html = "$mon $day $year";
} elsif ($qoptions->{'-TYPE'} =~/text/io) {
$html = "$mon $delim $day $delim $year";
} else {
$html = $mon . $day . $year;
}
$html .= "<BR>$time" if ($showhrs);
## should take care of time here. ##
return $html;
} # END sub HTML_date
sub HTML_view {
my $self = shift;
return undef unless ref($self);
my $fieldname = shift;
my $q = $self->cgi;
my $qfieldname = $self->qfieldname( $fieldname );
(defined($q->param( $qfieldname ))
? $q->param( $qfieldname )
: (($self->displaymode ne 'add') ? $self->db_obj->$fieldname() : ''))
. "\n";
} # END sub HTML_view
sub HTML_hidden {
my $self = shift;
return undef unless ref($self);
my $fieldname = shift;
my $qoptions = shift || $self->fieldhtmloptions( $fieldname );
my $q = $self->cgi;
my $qfieldname = $self->qfieldname( $fieldname );
$qfieldname = $fieldname unless (defined $q->param( $qfieldname ));
($self->displaymode eq 'view')
? $self->db_obj->$fieldname()
: $q->hidden( -NAME => $qfieldname,
-OVERRIDE => $qoptions->{'-OVERRIDE'} || 1,
-DEFAULT => (defined($q->param( $qfieldname ))
? $q->param( $qfieldname )
: (($self->displaymode eq 'modify')
? $self->db_obj->$fieldname()
: ($qoptions->{'-DEFAULT'} || '')))
) . "\n";
} # END sub HTML_hidden
sub HTML_text {
my $self = shift;
return undef unless ref($self);
my $fieldname = shift;
my $qoptions = shift || $self->fieldhtmloptions( $fieldname );
my $q = $self->cgi;
my $qfieldname = $self->qfieldname( $fieldname );
($self->displaymode eq 'view')
? $self->db_obj->$fieldname()
: $q->textfield( -NAME => $qfieldname,
-SIZE => $qoptions->{'-SIZE'} || 50,
-MAXLENGTH => $qoptions->{'-MAXLENGTH'}|| 200,
-OVERRIDE => $qoptions->{'-OVERRIDE'} || 1,
-DEFAULT => (defined($q->param( $qfieldname ))
? $q->param( $qfieldname )
: (($self->displaymode eq 'modify')
? $self->db_obj->$fieldname()
: ($qoptions->{'-DEFAULT'} || '')))
) . "\n";
} # END sub HTML_text
sub HTML_password {
my $self = shift;
return undef unless ref($self);
my $fieldname = shift;
my $qoptions = shift || $self->fieldhtmloptions( $fieldname );
my $q = $self->cgi;
my $qfieldname = $self->qfieldname( $fieldname );
($self->displaymode eq 'view')
? '<NOT DISPLAYED>'
: $q->password_field(-NAME => $qfieldname,
-SIZE => $qoptions->{'-SIZE'} || 50,
-MAXLENGTH => $qoptions->{'-MAXLENGTH'}|| 200,
-OVERRIDE => $qoptions->{'-OVERRIDE'} || 1,
-DEFAULT => (defined($q->param( $qfieldname ))
? $q->param( $qfieldname )
: (($self->displaymode eq 'modify')
? $self->db_obj->$fieldname()
: ($qoptions->{'-DEFAULT'} || '')))
) . "\n";
} # END sub HTML_password
sub HTML_textarea {
my $self = shift;
return undef unless ref($self);
my $fieldname = shift;
my $qoptions = shift || $self->fieldhtmloptions( $fieldname );
my $q = $self->cgi;
my $qfieldname = $self->qfieldname( $fieldname );
if ($self->{'_displaymode'} eq 'view') {
my $content = $self->db_obj->$fieldname();
$content =~ s/(\r\n)|[\n\r]/<BR>/go;
return $content;
}
$q->textarea( -NAME => $qfieldname,
-ROWS => $qoptions->{'-ROWS'} || 6,
-COLS => $qoptions->{'-COLS'} || 50,
-WRAP => $qoptions->{'-WRAP'} || 'VIRTUAL',
-OVERRIDE => $qoptions->{'-OVERRIDE'} || 1,
-DEFAULT => (defined($q->param( $qfieldname ))
? $q->param( $qfieldname )
: (($self->displaymode eq 'modify')
? $self->db_obj->$fieldname()
: ($qoptions->{'-DEFAULT'} || '')))
) . "\n";
} # END sub HTML_textarea
sub HTML_popup {
my $self = shift;
my $class = ref($self) || return undef;
my $fieldname = shift;
my $qoptions = shift || $self->fieldhtmloptions( $fieldname );
my $foptions = $self->fieldoptions( $fieldname );
my $q = $self->cgi;
## if modify then grab the actual values of the primary keys of the obect ##
## and prepend the fieldname with them. This will allow people to modify multiple ##
## objects on the same page. Always put the classname and the fieldname at the end ##
## of the fieldname. ##
my $qfieldname = $self->qfieldname( $fieldname );
my $relclass = $class->fieldrelclass( $fieldname );
my $relclass_title_field = $relclass->title_field;
$relclass =~ /(.+)::Data::(.+)$/;
my $reladminclass = "${1}::Admin::${2}";
## show all of the objects as text. ##
if ($self->displaymode eq 'view') {
my $obj = @{ $relclass->list_obj(
$self->dbh,
{
$relclass->primary_keys->[0] => $self->db_obj->$fieldname()
}
) || [ ] }->[0];
(ref($obj) ? return $obj->$relclass_title_field() : return 'None Selected') . "\n";
## get all of the objects with get_list_hash. ##
} else {
my $hashref = $relclass->get_list_hash( $self->dbh );
## Allows null value for popups ##
if (!$foptions->{'not_null'} && $foptions->{'null_label'}) {
$hashref->{'NULL'} = $foptions->{'null_label'};
}
# ## if the displaymode isn't add, then highlite the already related objects. ##
# my $selected = ($self->displaymode eq 'add')
# ? [ ]
# : $self->db_obj->list_related( $relclass );
# warn "Too Many Related" if ($selected->[1] && $debug);
## default - if there's already data in the query object, highlite those objects, ##
## otherwise if the displaymode if modify, show the data in the scrolling list where the ##
## keys are composit primary keys seperated by $self->pkd and the ##
## values are the title_fields of the objects, else don't highlite anything. ##
$q->popup_menu( -NAME => $qfieldname,
-VALUES => [ sort { $hashref->{$a} cmp $hashref->{$b} } keys %$hashref ], # need to fill in info later
-LABELS => $hashref, # need to fill in info later
-DEFAULT => (defined($q->param( $qfieldname ))
? $q->param( $qfieldname )
: (($self->displaymode eq 'modify')
? (defined($self->db_obj->$fieldname())
? $self->db_obj->$fieldname()
: ($foptions->{'null_label'}
? 'NULL'
: $qoptions->{'-DEFAULT'} || ''))
## The trinary below is for parent child relationships. Basically, if ##
## we're adding a new object and this pop-up represents a list of our ##
## parent fields, we should default to the parent we came through. ##
: ((($self->displaymode eq 'add') && ($reladminclass eq $self->parent_class) && ($q->param('parent_pcpkey')))
? (substr($q->param('parent_pcpkey'),rindex($q->param('parent_pcpkey'),$self->qfd)+1))
: ($qoptions->{'-DEFAULT'} || ''))))
) . "\n";
}
} # END sub HTML_popup
sub HTML_radio {
my $self = shift;
my $class = ref($self) || return undef;
my $fieldname = shift;
my $qoptions = shift || $self->fieldhtmloptions( $fieldname );
my $q = $self->cgi;
my $qfieldname = $self->qfieldname( $fieldname );
my $relclass = $class->fieldrelclass( $fieldname );
my $relclass_title_field = $relclass->title_field;
## show all of the objects as text. ##
if ($self->displaymode eq 'view') {
my $obj = @{ $relclass->list_obj( $self->dbh,
{
$relclass->primary_keys->[0] => $self->db_obj->$fieldname()
}
) || [ ] }->[0];
(ref($obj) ? return $obj->$relclass_title_field() : return 'None Selected') . "\n";
## get all of the objects with get_list_hash. ##
} else {
my $hashref = $relclass->get_list_hash( $self->dbh );
## if the displaymode isn't add, then highlite the already related objects. ##
my $selected = ($self->displaymode eq 'add')
? [ ]
: $self->db_obj->list_related( $relclass );
warn "Too Many Related" if ($selected->[1] && $debug);
$q->autoEscape(0) if ($qoptions->{'-NOESCAPE'});
my $val = $q->radio_group(
-NAME => $qfieldname,
-VALUES => [ keys %$hashref ], # need to fill in info later
-LABELS => $hashref, # need to fill in info later
-LINEBREAK => $qoptions->{'-LINEBREAK'} || 'true',
-DEFAULT => (defined($q->param( $qfieldname ))
? $q->param( $qfieldname )
: (($self->displaymode eq 'modify')
? $self->db_obj->$fieldname()
: ($qoptions->{'-DEFAULT'} || '')))
);
$q->autoEscape(1) if ($qoptions->{'-NOESCAPE'});
return $val;
}
} # END sub HTML_radio
sub HTML_scrolling {
my $self = shift;
return undef unless ref($self);
my $fieldname = shift;
my $qoptions = shift || $self->fieldhtmloptions( $fieldname );
my $q = $self->cgi;
## if modify then grab the actual values of the primary keys of the obect ##
## and prepend the fieldname with them. This will allow people to modify multiple ##
## objects on the same page. Always put the classname and the fieldname at the end ##
## of the fieldname. ##
my $qfieldname = $self->qfieldname( $fieldname );
my $relclass = $self->fieldrelclass( $fieldname );
my $relclass_title_field = $relclass->title_field;
## show all of the objects as text. ##
if ($self->displaymode eq 'view') {
my $code = $self->db_obj->stream_related( $relclass );
my $list;
if (ref $code) {
while (my $obj = $code->()) {
$list .= $obj->$relclass_title_field() . "<BR>\n";
}
}
## NEED AN ELSE AS AN ERROR CHECK! ##
($list ? return $list : return 'None Selected') . "\n";
## get all of the objects with get_list_hash. ##
} else {
my $hashref = $relclass->get_list_hash( $self->dbh );
## if the displaymode isn't add, then highlite the already related objects. ##
my $selected = ($self->displaymode eq 'add')
? [ ]
: $self->db_obj->list_related( $relclass );
## default - if there's already data in the query object, highlite those objects, ##
## otherwise if the displaymode if modify, show the data in the scrolling list where the ##
## keys are composit primary keys seperated by $self->pkd and the ##
## values are the title_fields of the objects, else don't highlite anything. ##
return $q->scrolling_list(
-NAME => $qfieldname,
-OVERRIDE => $qoptions->{'-OVERRIDE'} || 1,
-SIZE => $qoptions->{'-SIZE'} || 6,
-MULTIPLE => $qoptions->{'-MULTIPLE'} || 'true',
-VALUES => [ keys %{$hashref} ],
-LABELS => $hashref,
-DEFAULT => ($q->param( $qfieldname )
? [ $q->param( $qfieldname ) ]
: (($self->displaymode eq 'modify')
? [
map {
$_->cpkey()
} @$selected
]
: ($qoptions->{'-DEFAULT'} || [ ])))
) . "\n";
}
} # END sub HTML_scrolling
sub HTML_checkbox {
my $self = shift;
return undef unless ref($self);
my $fieldname = shift;
my $qoptions = shift || $self->fieldhtmloptions( $fieldname );
my $q = $self->cgi;
my $qfieldname = $self->qfieldname( $fieldname );
($self->displaymode eq 'view')
? $self->db_obj->$fieldname()
: $q->checkbox(
-NAME => $qfieldname,
-CHECKED => $self->displaymode eq 'modify'
? $self->db_obj->$fieldname()
: $qoptions->{'-CHECKED'},
-VALUE => $qoptions->{'-VALUE'} || '1',
-LABEL => $qoptions->{'-LABEL'} || ''
);
} # END sub HTML_checkbox
sub HTML_file {
my $self = shift;
return undef unless ref($self);
my $fieldname = shift;
my $qoptions = shift || $self->fieldhtmloptions( $fieldname );
my $q = $self->cgi;
my $qfieldname = $self->qfieldname( $fieldname );
($self->displaymode eq 'view')
? $self->db_obj->$fieldname()
: $q->filefield(
-NAME => $qfieldname,
-SIZE => $qoptions->{'-SIZE'} || 40,
-MAXLENGTH => $qoptions->{'-MAXLENGTH'} || 200,
-OVERRIDE => 1,
-DEFAULT => '' # browsers null defaults in upload fields anyway
);
} #END sub HTML_file
sub sane_regex {
my $self = shift;
my $data = shift;
my $regex = shift;
my $error = shift || 'Not correctly formatted.';
warn("sane_regex('$data', '$regex', '$error')\n") if $debug > 2;
return $error unless $data =~ /$regex/;
return "";
} #END sub sane_regex
sub sane_maxlength {
my $self = shift;
my $data = shift;
my $length = shift;
warn("sane_maxlength('$data', $length)\n") if $debug > 2;
return "Exceeds $length characters in length." unless (length($data) <= $length);
return "";
} #END sub sane_maxlength
sub sane_minlength {
my $self = shift;
my $data = shift;
my $length = shift;
warn("sane_minlength('$data', $length)\n") if $debug > 2;
return "Must be at least $length characters." unless (length($data) >= $length);
return "";
} #END sub sane_minlength
sub AUTOLOAD {
return if $AUTOLOAD =~ /::DESTROY$/;
my $self = shift;
my $name = substr($AUTOLOAD, rindex($AUTOLOAD, ':') + 1); # strip fully-qualified portion
return undef unless $self->fieldtype( $name ); # need better error
my $meth = 'HTML_' . $self->fieldtype( $name );
$self->$meth( $name ); # call one of the private fieldtype methods above
} # END sub AUTOLOAD
1;
__END__