| 1 |
dpavlin |
1 |
package Gedafe::Pearl; |
| 2 |
|
|
|
| 3 |
|
|
use strict; |
| 4 |
|
|
use Carp; |
| 5 |
|
|
use Exporter; |
| 6 |
|
|
use Text::Wrap; |
| 7 |
|
|
use Gedafe::GUI qw(GUI_WidgetRead); |
| 8 |
|
|
use POSIX qw(mktime strftime); |
| 9 |
|
|
use vars qw(@ISA @EXPORT_OK); |
| 10 |
|
|
@ISA = qw(Exporter); |
| 11 |
|
|
@EXPORT_OK = qw(format_desc date_print ); |
| 12 |
|
|
|
| 13 |
|
|
# at the moment the class we create is empty |
| 14 |
|
|
|
| 15 |
|
|
sub new($;@){ |
| 16 |
|
|
my $proto = shift; |
| 17 |
|
|
my %params = @_; |
| 18 |
|
|
my $class = ref($proto) || $proto; |
| 19 |
|
|
my $self = {}; |
| 20 |
|
|
bless $self, $class; |
| 21 |
|
|
} |
| 22 |
|
|
|
| 23 |
|
|
# get them to overwrite the base methods |
| 24 |
|
|
sub info($){ |
| 25 |
|
|
croak "ERROR: info method must be overwritten\n"; |
| 26 |
|
|
} |
| 27 |
|
|
sub template ($){ |
| 28 |
|
|
croak "ERROR: template method must be overwritten\n"; |
| 29 |
|
|
} |
| 30 |
|
|
|
| 31 |
|
|
sub run ($$){ |
| 32 |
|
|
my $self = shift; |
| 33 |
|
|
# $s is the gedafe state |
| 34 |
|
|
my $s = shift; |
| 35 |
|
|
|
| 36 |
|
|
# import first get the ones from the form, and then add the ones |
| 37 |
|
|
# defined in the url if there are any. |
| 38 |
|
|
$self->{param}={}; |
| 39 |
|
|
for (@{$self->template()}) { |
| 40 |
|
|
my ($field,$lable,$widget,$value,$test) = @$_; |
| 41 |
|
|
$self->{param}{$field} = GUI_WidgetRead($s, "field_$field",$widget); |
| 42 |
|
|
die "Pearl paramter $field='$self->{param}{$field}' does not match /^$test\$/". |
| 43 |
|
|
"<BR>You can use the back button to get back at your form\n" |
| 44 |
|
|
unless $self->{param}{$field} =~ /^$test$/; |
| 45 |
|
|
} |
| 46 |
|
|
# the rest is up to you :-) |
| 47 |
|
|
# you can access accessing parameters $self->{param}{$name} |
| 48 |
|
|
} |
| 49 |
|
|
|
| 50 |
|
|
|
| 51 |
|
|
# utility helpers |
| 52 |
|
|
sub date_print ($) { |
| 53 |
|
|
my $time = time; |
| 54 |
|
|
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = |
| 55 |
|
|
localtime($time); |
| 56 |
|
|
# mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) |
| 57 |
|
|
|
| 58 |
|
|
for (shift){ |
| 59 |
|
|
/month_first/ && do { $time = mktime 0,0,0,1,$mon,$year; |
| 60 |
|
|
next; }; |
| 61 |
|
|
/month_last/ && do { $time = mktime 0,0,0,0,$mon+1,$year; |
| 62 |
|
|
next; }; |
| 63 |
|
|
}; |
| 64 |
|
|
|
| 65 |
|
|
return strftime('%Y-%m-%d',localtime($time)); |
| 66 |
|
|
} |
| 67 |
|
|
|
| 68 |
|
|
sub format_desc { |
| 69 |
|
|
my $desc = shift; |
| 70 |
|
|
my $indent = shift; |
| 71 |
|
|
my $cols = shift; |
| 72 |
|
|
return "" unless $desc; |
| 73 |
|
|
$Text::Wrap::columns = $cols; |
| 74 |
|
|
$desc =~ s/^\s+//g; $desc =~ s/\s+$//g; |
| 75 |
|
|
$desc =~ s/\s+/ /g; |
| 76 |
|
|
|
| 77 |
|
|
$desc = wrap('','',$desc); |
| 78 |
|
|
my $indent_str = ' 'x$indent; |
| 79 |
|
|
$desc =~ s/\n/\n$indent_str/g; |
| 80 |
|
|
return $desc; |
| 81 |
|
|
} |
| 82 |
|
|
|
| 83 |
|
|
1; |
| 84 |
|
|
# Emacs Configuration |
| 85 |
|
|
# |
| 86 |
|
|
# Local Variables: |
| 87 |
|
|
# mode: cperl |
| 88 |
|
|
# eval: (cperl-set-style "PerlStyle") |
| 89 |
|
|
# mode: flyspell |
| 90 |
|
|
# mode: flyspell-prog |
| 91 |
|
|
# End: |
| 92 |
|
|
# |
Parent Directory
| 
Revision Log