Apache-SdnFw
view release on metacpan or search on metacpan
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
if ($croak && !$s->{env}{DEV}) {
# check and see if this is a common database error we just want to capture and report
# in a different way
if ($croak =~ m/^ERROR:\s+invalid input syntax for type date:\s+"(.+)"/) {
$message = "'$1' is not a valid date";
$croak = 0;
} elsif ($croak =~ m/^ERROR:\s+null value in column "(.+)" violates not-null constraint/) {
$message = "The database field '$1' can not be null/empty. Is there a for field that you left blank that needed to be filled in?";
$croak = 0;
} elsif ($croak =~ m/^ERROR:\s+invalid input syntax for integer: "(.+)"/) {
$message = "'$1' is not a valid integer";
$croak = 0;
}
}
if ($s->{raw_message}) {
$s->{raw_message} .= "\n";
}
$s->{raw_message} .= $message;
my $class = ($croak) ? 'alert' : 'warning';
if ($s->{o}{perl_dump}) {
$s->{perl_dump}{error} = $message;
} elsif (!defined($s->{tt})) {
print "alert: $message\n";
$s->{message} .= $message;
} else {
if ($s->{quiet_errors} && $croak) {
$message = "Sorry an error has occured";
}
$s->tt('alert.tt', { s => $s, message => $message, class => $class }, \$alert);
$s->{message} .= $alert;
}
# add some debugging information so we know where the error is getting called from
#$s->{message} .= "<pre>".Carp::longmess('Stack-Trace')."</pre>";
if ($croak && $s->{object} ne 'e') {
$s->send_error($croak);
}
}
sub send_error {
=head2 send_error
$s->send_error($msg);
=cut
my $s = shift;
my $msg = shift;
# make sure we do not report errors to ourself, otherwise we go into a circular loop!
# if this was a croak, it means that we should record this error into the main error
# recording system
my $error = $s->escape($msg);
my $employee = '<employee>'.$s->escape("$s->{employee_id} $s->{employee}{name}").
'</employee>' if ($s->{employee_id});
my $in = $s->escape(Data::Dumper->Dump([\%{$s->{in}}]));
my $env = $s->escape(Data::Dumper->Dump([\%{$s->{env}}]));
my $session = $s->escape(Data::Dumper->Dump([\%{$s->{session_data}}]));
my $uri = $s->escape($s->{uri});
my $xml = <<END;
<?xml version="1.0" encoding="UTF-8"?>
<error>
<message>$error</message>
$employee
<var_in>$in</var_in>
<uri>$uri</uri>
<var_env>$env</var_env>
<remote_addr>$s->{remote_addr}</remote_addr>
<server_name>$s->{server_name}</server_name>
<session_data>$session</session_data>
</error>
END
my $ua = new LWP::UserAgent;
$ua->timeout(5);
my $req = new HTTP::Request('POST' => "http://erp.smalldognet.com/sdnerp/e");
$req->content_type('application/x-www-form-urlencoded');
$req->content($xml);
$ua->request($req);
}
sub lwp_xml {
my $s = shift;
my $url = shift;
my $ua = new LWP::UserAgent;
my $req = new HTTP::Request('GET' => $url);
my $resp = $ua->request($req);
if ($resp->is_success) {
my $content = $resp->content;
my $xml = eval { XMLin($content); };
if ($@) {
croak "Failed to eval returned xml: $@";
} else {
return $xml;
}
} else {
croak "Request to $url failed";
}
}
sub confirm {
=head2 confirm
$s->confirm($msg);
=cut
my $s = shift;
my $message = shift;
$s->tt('confirm.tt', { s => $s, message => $message });
}
sub notify {
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
=head2 html_font
my $html = $s->html_font($text,$size);
=cut
my $s = shift;
my $text = shift;
my $size = shift;
return qq(<font size="$size">$text</font>);
}
sub html_a {
=head2 html_a
my $html = $s->html_a($url,$name,[$class]);
=cut
my $s = shift;
my $url = shift;
my $name = shift;
my $class = shift;
my $str = qq(<a href="$url");
$str .= qq( class="$class") if ($class);
$str .= qq(>$name</a>);
return $str;
}
sub html_submit {
=head2 html_submit
my $html = $s->html_submit($name,[$class]);
=cut
my $s = shift;
my $name = shift;
my $class = shift;
my $c = qq( class="$class") if ($class);
return qq(<input type="submit" value="$name"$c>);
}
sub html_radio {
=head2 html_radio
my $html = $s->html_radio($key,$value,[$checked],[$desc],[$id]);
=cut
my $s = shift;
my $key = $s->escape(shift);
my $value = $s->escape(shift);
my $checked = shift;
my $desc = shift;
my $id = shift;
$key = "$s->{acfb}::$key" if ($s->{acfb});
my $str = qq(<input type="radio" name="$key" value="$value");
$str .= ' checked' if ($checked eq $value);
$str .= qq( id="$id") if ($id);
$str .= '>';
$str .= " $desc" if ($desc);
return $str;
}
sub html_checkbox {
=head2 html_checkbox
my $html = $s->html_checkbox($key,$value,[$checked],[$desc],[$id]);
=cut
my $s = shift;
my $key = $s->escape(shift);
my $value = $s->escape(shift);
my $checked = shift;
my $desc = shift;
my $id = shift;
$key = "$s->{acfb}::$key" if ($s->{acfb});
my $str = qq(<input type="checkbox" name="$key" value="$value");
$str .= ' checked' unless ($checked eq undef);
$str .= qq( id="$id") if ($id);
$str .= '>';
$str .= " $desc" if ($desc);
return $str;
}
sub html_password {
=head2 html_password
my $html = $s->html_password($key,$value,[$size]);
=cut
my $s = shift;
my $key = $s->escape(shift);
my $value = $s->escape(shift);
my $size = shift;
$key = "$s->{acfb}::$key" if ($s->{acfb});
my $str = qq(<input type="password" name="$key" value="$value" autocomplete="off");
$str .= qq( size="$size") if ($size);
$str .= '>';
return $str;
}
sub html_upload {
=head2 html_upload
my $html = $s->html_upload($key,[$size],[$class],[$id]);
=cut
my $s = shift;
my $key = $s->escape(shift);
my $size = shift;
my $class = shift;
my $id = shift;
$key = "$s->{acfb}::$key" if ($s->{acfb});
my $str = qq(<input type="file" name="$key");
$str .= qq( size="$size") if ($size);
$str .= qq( id="$id") if ($id);
$str .= qq( class="$class") if ($class);
$str .= '>';
return $str;
}
sub html_input_email {
=head2 html_input_email
my $html = $s->html_input_email($key,$value,[$size]);
=cut
my $s = shift;
my $key = $s->escape(shift);
my $value = $s->escape(shift);
my $size = shift;
my $class = shift;
my $id = shift;
$key = "$s->{acfb}::$key" if ($s->{acfb});
my $str = qq(<input type="email" name="$key" value="$value" autocomplete="off");
$str .= qq( size="$size") if ($size);
$str .= qq( id="$id") if ($id);
$str .= qq( class="$class") if ($class);
$str .= '>';
return $str;
}
sub html_input_number {
=head2 html_input_number
my $html = $s->html_input_number($key,$value,[$size]);
=cut
my $s = shift;
my $key = $s->escape(shift);
my $value = $s->escape(shift);
my $size = shift;
my $class = shift;
my $id = shift;
$key = "$s->{acfb}::$key" if ($s->{acfb});
my $str = qq(<input type="number" name="$key" value="$value" autocomplete="off");
$str .= qq( size="$size") if ($size);
$str .= qq( id="$id") if ($id);
$str .= qq( class="$class") if ($class);
$str .= '>';
return $str;
}
sub html_input {
=head2 html_input
my $html = $s->html_input($key,$value,[$size]);
=cut
my $s = shift;
my $key = $s->escape(shift);
my $value = $s->escape(shift);
my $size = shift;
my $class = shift;
my $id = shift;
$key = "$s->{acfb}::$key" if ($s->{acfb});
my $str = qq(<input name="$key" value="$value" autocomplete="off");
$str .= qq( size="$size") if ($size);
$str .= qq( id="$id") if ($id);
$str .= qq( class="$class") if ($class);
$str .= '>';
return $str;
}
sub html_textarea {
=head2 html_textarea
my $html = $s->html_input($key,$value,[$cols || 40],[$row || 3],[$class]);
=cut
my $s = shift;
my $key = $s->escape(shift);
my $value = $s->escape(shift);
my $cols = shift || 40;
my $rows = shift || 3;
my $class = shift;
$key = "$s->{acfb}::$key" if ($s->{acfb});
$class = qq( class="$class") if ($class);
my $str = qq(<textarea name="$key"$class cols="$cols" rows="$rows">$value</textarea>);
return $str;
}
sub html_hidden {
=head2 html_hidden
my $html $s->html_hidden($key,$value,[$desc],[$id]);
=cut
my $s = shift;
my $key = $s->escape(shift);
my $value = $s->escape(shift);
my $desc = shift;
my $id = shift;
$key = "$s->{acfb}::$key" if ($s->{acfb});
my $idfield = qq( id="$id") if ($id);
my $str = qq(<input$idfield type="hidden" name="$key" value="$value">);
$str .= $desc if ($desc);
return $str;
}
sub html_thtd {
=head2 html_thtd
my $html = $s->html_thtd($th,$td);
=cut
my $s = shift;
my $th = shift;
my $td = shift;
return qq(\n<tr>\n\t<th>$th</th>\n\t<td>$td</td>\n</tr>);
}
sub html_thead {
=head2 html_thead
my $html = $s->html_thead(@list);
=cut
my $s = shift;
my @list = @_;
my $str = qq(\n\t<thead>\n\t\t<tr>\n);
foreach my $k (@list) {
$str .= qq(\t\t\t<th>$k</th>\n);
}
$str .= qq(\t\t</tr>\n\t</thead>);
return $str;
}
sub html_select_basic {
=head2 html_select_basic
my $html = $s->html_select_basic(\@list,$key,[$existing],[$showblank]);
=cut
my $s = shift;
my $data = shift;
my $key = shift;
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
my $html = $s->html_select(\@arrayhash,$key,$idkey,$idname,[$existing],[$showblank]);
=cut
my $s = shift;
my $data = shift;
my $key = shift;
my $idkey = shift;
my $idname = shift;
my $existing = shift;
my $showblank = shift;
my $class = shift;
my $id = shift;
$key = "$s->{acfb}::$key" if ($s->{acfb});
my $str = qq(\n<select name="$key");
$str .= qq( id="$id") if ($id);
$str .= qq( class="$class") if ($class);
$str .= '>';
if ($showblank) {
$str .= qq(\n\t<option value=""></option>);
}
foreach my $ref (@{$data}) {
$str .= qq(\n\t<option value="$ref->{$idkey}");
$str .= qq( selected) if ($ref->{$idkey} eq $existing);
$str .= qq(>$ref->{$idname}</option>);
}
$str .= qq(\n</select>);
}
sub html_tbody {
=head2 html_tbody
my $html = $s->html_tbody(\@arrayhash,@cols);
=cut
my $s = shift;
my $data = shift;
my @cols = @_;
my $str = qq(\n\t<tbody>\n\t\t<tr>\n);
foreach my $ref (@{$data}) {
$str .= qq(\t\t<tr>\n);
foreach my $k (@cols) {
$str .= qq(\t\t\t<td>$ref->{$k}</td>\n);
}
$str .= qq(\t\t</tr>\n);
}
$str .= qq(\t\t</tr>\n\t</tbody>);
return $str;
}
sub escape {
my $s = shift;
my $string = shift;
$string =~ s/&([^#])/&$1/g;
$string =~ s/"/"/g;
$string =~ s/>/>/g;
$string =~ s/</</g;
# ' is a valid XML entity, but not a valid HTML entity.
# @todo: the ' character is valid HTML and shouldn't need to be escaped.
# However, a lot of the code uses value='' instead of "" so we need
# to leave this in for now.
$string =~ s/'/'/g;
return $string;
}
sub address_display {
=head2 address_display
my $html = $s->address_display(\%hash,$wrap);
=cut
my $s = shift;
my $ref = shift;
my $wrap = shift;
my $commercial = shift; # puts the first last name after the company
return '' unless(ref $ref eq 'HASH');
my $return;
unless($commercial) {
$return .= $s->display_wrap("$ref->{first_name} $ref->{last_name}",$wrap)
if ($ref->{first_name} || $ref->{last_name});
}
$return .= $s->display_wrap($ref->{company},$wrap) if ($ref->{company});
foreach my $k (qw(address address2)) {
$return .= $s->display_wrap($ref->{$k},$wrap) if ($ref->{$k});
}
if ($ref->{zipcode} && $ref->{state}) {
$return .= $s->display_wrap("$ref->{city}, $ref->{state} $ref->{zipcode}",$wrap);
} elsif ($ref->{zipcode} && $ref->{state_name}) {
$return .= $s->display_wrap("$ref->{city}, $ref->{state_name} $ref->{zipcode}",$wrap);
} elsif ($ref->{zipcode} && $ref->{city}) {
$return .= $s->display_wrap("$ref->{city} $ref->{zipcode}",$wrap);
}
if ($ref->{country_name}) {
$return .= $s->display_wrap($ref->{country_name},$wrap);
}
if ($commercial) {
$return .= $s->display_wrap("$ref->{first_name} $ref->{last_name}",$wrap)
if (($ref->{first_name} || $ref->{last_name}) && $commercial ne 'nocontact');
}
if ($ref->{phone}) {
$return .= $s->display_wrap($s->format_phone($ref->{phone}),$wrap);
}
return $return;
}
sub display_wrap {
my $s = shift;
my $string = shift;
my $wrap = shift;
if ($string) {
return "$string$wrap";
} else {
return '';
}
}
sub format_csv {
my $s = shift;
my $string = shift;
$string =~ s/"/""/g;
return qq("$string");
}
sub format_text {
=head2 format_text
my $string = $s->format_text($string);
Converts newlines to <br>, tabs and 8 spaces to 4 nbsp;. Also does an escape.
=cut
my $s = shift;
my $string = shift;
$string = $s->escape($string);
$string =~ s/\n/<br>\n/g;
$string =~ s/\t/ /g;
$string =~ s/\s{8}/ /g;
return $string;
}
sub format_accounting {
=head2 format_accounting
my $string = $s->format_accounting($string);
takes things like 1234 and returns 1,234, and -1234 and returns (1,234)
=cut
my $s = shift;
my $string = shift;
my ($h,$d) = split '\.', $string;
my @c = split '', $h;
my @out;
my $n = 0;
foreach my $char (reverse @c) {
if ($char =~ m/\d/) {
if ($n == 3) {
unshift @out, ',';
$n = 0;
}
unshift @out, $char;
$n++;
} else {
# for things like negative signs
1; #unshift @out, $char;
}
}
$string = join '', @out;
$string .= ".$d" if (($d || $d eq '00') && $string ne '');
if ($h =~ m/^-/) {
return "($string)";
}
return $string;
}
sub format_number {
=head2 format_number
my $string = $s->format_number($string);
Adds commas to numbers. 1234 becomes 1,234.
=cut
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
return $number;
}
sub format_boolean {
=head2 format_boolean
my $string = $s->format_boolean($value);
Returns Yes for true value, No for false value, and '' for empty value.
=cut
my $s = shift;
my $value = shift;
return $value if ($value eq '');
return 'Yes' if ($value);
return 'No' if (!$value);
}
sub format_percent {
=head2 format_percent
my $string = $s->format_percent($number);
Given 0.123, returns 12.3%.
=cut
my $s = shift;
my $number = shift;
my $d = shift;
$d = 1 unless(defined($d));
return $number unless($number);
$number = (sprintf "%.${d}f", $number*100).'%';
return $number;
}
sub csv_to_array {
=head2 csv_to_array
my @array = $s->csv_to_array($text,[$onerow]);
=cut
my $s = shift;
my $text = shift;
my $onerow = shift;
my @rows = ();
$text =~ s/\s+$//s;
my $row = [];
while ($text=~ m/( (?!")[^,\r\n]* # Handle normal fields
| "(?:["\\]"|[^"])*?" # Handle quoted fields, escaped quotes as "" or \"
)(\r?\n|,|$)
/sgx) {
my $val = defined $1 ? $1 : '';
my $eol = $2;
if ($val =~ m/^"(.*)"$/s) {
$val = defined $1 ? $1 : '';
$val =~ s/["\\]"/"/sg;
}
push @{$row}, $val;
if ((!$eol || $eol ne ',') && scalar(@{$row}) > 0) {
push @rows, $row;
$row = [];
last if ($onerow);
}
last unless($eol);
}
if ($onerow) {
return @{$rows[0]};
}
return @rows;
}
sub mime_type {
my $s = shift;
return unless($s->{r}{file_path});
return 'text/html' if ($s->{r}{file_path} =~ m/\.html?$/i);
return 'image/jpeg' if ($s->{r}{file_path} =~ m/\.jpg$/i);
return 'image/png' if ($s->{r}{file_path} =~ m/\.png$/i);
return 'image/gif' if ($s->{r}{file_path} =~ m/\.gif$/i);
return 'text/xml' if ($s->{r}{file_path} =~ m/\.x(m|s)l$/i);
return 'text/css' if ($s->{r}{file_path} =~ m/\.css$/i);
return 'application/pdf' if ($s->{r}{file_path} =~ m/\.pdf$/i);
return 'text/plain' if ($s->{r}{file_path} =~ m/\.txt$/i);
}
sub session_delete {
my $s = shift;
my $key = shift;
if ($key) {
# just delete one key
if (defined($s->{session_data}{$key})) {
delete $s->{session_data}{$key};
_session_update($s);
}
} else {
# delete entire session
$s->{session_data} = undef;
$s->db_q("
DELETE FROM employee_sessions
WHERE employee_id=?
",undef,
v => [ $s->{employee_id} ]);
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
push @tmp, unpack('c',$c);
}
return join '|', @tmp;
}
sub decrypt {
my $s = shift;
my $data = shift;
my $tmp;
foreach my $c (split /\|/, $data) {
$tmp .= pack('c',$c);
}
my $k = $s->{env}{CRYPT_KEY} || 'ilikegreeneggsandhamsamiam';
my $cipher = new Crypt::CBC($k,'Blowfish');
my $out = $cipher->decrypt($tmp) if ($tmp);
return $out;
}
sub help {
my $s = shift;
# we use our function to look for help
$s->{function} = 'home' if ($s->{function} eq 'list');
my $path = "$s->{function}.tt";
if ($s->{function} eq 'system') {
unless($s->{employee}{admin}) {
$s->alert("Sorry, you are not an admin, you can't look at that");
return;
}
# show our system help file, disaster recovery type information
$s->{nomenu} = 1;
my $debug = "<pre>".Data::Dumper->Dump([$s])."</pre>";
$s->tt('system.tt', { s => $s });
#$s->{content} .= $debug;
return;
}
if ($s->{in}{f} eq 'save' && $s->{employee}{admin}) {
open F, ">/data/$s->{obase}/template/help/$s->{function}.tt";
$s->{in}{help_text} =~ s/\r//g;
print F $s->{in}{help_text};
close F;
}
if (-e "/data/$s->{obase}/template/help/$path") {
if ($s->{employee}{admin}) {
$s->add_action(function => $s->{function},
title => 'edit',
params => "f=edit");
if ($s->{in}{f} eq 'edit') {
open F, "/data/$s->{obase}/template/help/$s->{function}.tt";
while (my $line = <F>) {
$s->{help_text} .= $s->escape($line);
}
close F;
$s->tt('help_edit.tt', { s => $s, });
return;
}
} else {
$s->add_action(
title => 'edit',
class => 'greyout',
nourl => 1);
}
my $help;
$s->tt("template/help/$s->{function}.tt", { s => $s }, \$help);
$help =~ s/\n\n/<br><br>/g;
$s->{help_text} = $help;
$s->tt('help.tt', { s => $s });
} else {
if ($s->{employee}{admin}) {
$s->add_action(function => $s->{function},
title => 'add',
params => "f=add");
if ($s->{in}{f} eq 'add') {
$s->tt('help_add.tt', { s => $s, });
return;
}
} else {
$s->add_action(
title => 'add',
class => 'greyout',
nourl => 1);
}
$s->{content} = "Sorry no help file found for $s->{function}";
}
if ($s->{employee}{admin}) {
$s->add_action(function => 'system',
title => 'emergency information');
}
#$s->{content} = "<pre>".Data::Dumper->Dump([$s])."</pre>";
}
sub permission {
my $s = shift;
# manage permissions on an object. This should only be accessable
# with thos who are part of an admin group
unless($s->{employee}{admin}) {
$s->alert("You are not an admin. You can not do this!");
return 0;
}
$s->add_action(function => 'list') if (defined($s->{o}{functions}{list}));
# before we get down to looking at the current permissions, lets make sure
# we have defined them all in the database first
my %check = $s->db_q("
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
ORDER BY d.stat_date
",'arrayhash',
v => [ $start_day, $start_day ]);
my @weeks;
my %week;
foreach my $ref (@list) {
if (keys %week) {
if ($ref->{dow} == 0) {
push @weeks, { %week };
%week = ();
} elsif ($ref->{month_name} ne $week{month_name}) {
push @weeks, { %week };
%week = ();
}
}
$week{month_name} = $ref->{month_name};
$week{month} = $ref->{month};
$week{days}{$ref->{dow}}{day} = $ref->{day};
$week{days}{$ref->{dow}}{date} = $ref->{stat_date};
}
push @weeks, { %week };
my %calendar = (
weeks => \@weeks,
dow => {
0 => { s => 'S', m => 'Sun', l => 'Sunday' },
1 => { s => 'M', m => 'Mon', l => 'Monday' },
2 => { s => 'T', m => 'Tue', l => 'Tuesday' },
3 => { s => 'W', m => 'Wed', l => 'Wednesday' },
4 => { s => 'T', m => 'Thu', l => 'Thursday' },
5 => { s => 'F', m => 'Fri', l => 'Friday' },
6 => { s => 'S', m => 'Sat', l => 'Saturday' },
},
);
return %calendar;
}
####################################
# PRIVATE STUFF
####################################
sub _content_add_menu {
my $s = shift;
if ($s->{nomenu}) {
if ($s->{o}{interface} && $s->{$s->{o}{id}}) {
my $menu;
$s->tt('interface_menu.tt', { s => $s }, \$menu)
unless($s->{nomenu_interface});
return $menu;
} else {
return '';
}
} else {
if ($s->{employee}{admin} && !($s->{object} =~ m/^(me|help)$/)) {
$s->{employee}{object}{$s->{object}}{permission} = 1;
(my $args = $s->{args}) =~ s/=/%3D/g;
$s->add_action(function => 'permission',
params => "return=$s->{function}&return_args=".$s->escape($args))
unless($s->{env}{HIDE_PERMISSION} || $s->{agent});
}
# if we are in autocommit still at this point
# then it probably means there was an error, so we need
# to rollback before we can do this query below
if ($s->{dbh}->{AutoCommit} == 0) {
$s->{dbh}->rollback;
}
# load tabs
@{$s->{tabs}} = $s->db_q("
SELECT code, COALESCE(tab_name, name) as name
FROM objects
WHERE tab_order IS NOT NULL
ORDER BY tab_order
",'arrayhash');
my $menu;
$s->tt($s->{o}{menutemplate} || 'menu.tt', { s => $s }, \$menu);
return $menu;
}
}
sub _head_add_css {
my $s = shift;
return if ($s->{no_css});
my $stylefile = 'style';
if ($s->{agent}) {
$stylefile = "$s->{agent}/$stylefile";
}
# in order to help with load times, just include the css directly
# instead of having them call the request the file separatly
my $sfile = "/data/$s->{obase}/content/css/$stylefile.css";
# if our object has a specific style file, then use that instead
$sfile = "/code/$s->{obase}/css/$s->{o}{css}.css" if ($s->{o}{css});
my $return;
if (-e $sfile) {
$return = "<style>";
open F, $sfile;
while (<F>) {
chomp;
$return .= $_;
}
close F;
$return .= "</style>\n";
}
return $return;
# my $v = (stat("$s->{plib}/css/$stylefile.css"))[9];
# my $return = qq(\t<link rel="stylesheet" href="/css/$stylefile-r$v.css" />\n);
#
# # check for a custom stylesheet
# my $cv = (stat("/data/$s->{obase}/content/custom.css"))[9];
lib/Apache/SdnFw/lib/Core.pm view on Meta::CPAN
sub add_js {
my $s = shift;
my $type = shift;
$s->{add_js}{$type} = 1;
return '';
}
sub _head_add_js {
my $s = shift;
if (defined($s->{add_js})) {
# always add prototype
$s->{add_js}{prototype} = 1;
}
my $return = qq(\n<script type="text/javascript" src="/js/prototype.js"></script>\n)
if ($s->{add_js}{prototype});
foreach my $k (keys %{$s->{add_js}}) {
next if ($k eq 'prototype');
if ($k eq 'scriptaculous') {
$return .= qq(<script type="text/javascript" src="/js/scriptaculous.js?effects,controls"></script>\n);
} elsif ($k eq 'calendar') {
$return .= qq(<script type="text/javascript" src="/js/calendar_date_select/calendar_date_select.js"></script>\n).
qq(<script type="text/javascript" src="/js/calendar_date_select/format_iso_date.js"></script>\n);
} else {
$return .= qq(<script type="text/javascript" src="/js/$k.js"></script>\n);
}
}
$return .= join "\n", @{$s->{head_js}} if (defined($s->{head_js}));
return $return;
}
sub html_caption_scroll {
my $s = shift;
my $caption = shift;
my $scroll = shift;
my $title = shift || 'scroll';
my $bmargin = shift || 5;
return qq|<div class="floatleft">$caption</div><div id="clink" class="captionlink"><a href="#" onClick="javascript:dscroll(\$('$scroll'),$bmargin); \$('clink').style.display = 'none'; return true;" class="action">$title</a></div>|;
}
sub html_display_link {
my $s = shift;
my $object = shift;
my $id = shift;
my $name = shift;
my $keyfield = shift || 'id';
return $s->html_a("$s->{ubase}/$object/display?$keyfield=$id",$name);
}
sub html_input_calendar {
my $s = shift;
my $key = $s->escape(shift);
my $value = $s->escape(shift);
$key = "$s->{acfb}::$key" if ($s->{acfb});
my $cal = $s->add_calendar($key);
my $str = qq(<input $cal name="$key" value="$value" autocomplete="off" size="12">);
return $str;
}
sub add_calendar {
my $s = shift;
my $id = shift;
$s->add_js('calendar');
return qq|id="$id" onclick="javascript: new CalendarDateSelect( \$('$id'), {close_on_click: true, embedded:true, year_range:1} );"|;
}
sub _head_add_title {
my $s = shift;
if (ref $s->{title} eq 'ARRAY') {
my $t = join ' :: ', @{$s->{title}};
$s->{title} = $t;
}
if ($s->{env}{TITLE}) {
if ($s->{title}) {
$s->{title} = "$s->{env}{TITLE} :: $s->{title}";
} else {
$s->{title} = $s->{env}{TITLE};
}
}
$s->{title} = $s->{uri} unless($s->{title});
return "<title>$s->{title}</title>\n";
}
sub _interface_auth {
my $s = shift;
# make sure we have some things
croak "id not defined in object $s->{object}" unless($s->{o}{id});
croak "table not defined in object $s->{object}" unless($s->{o}{table});
croak "view not defined in object $s->{object}" unless($s->{o}{view});
croak "interface not defined in object $s->{object}" unless($s->{o}{interface});
if ($s->{object} eq 'logout' && $s->{cookies}{IL}) {
$s->db_q("
UPDATE $s->{o}{table} SET interface_cookie=NULL
WHERE interface_cookie=?
",undef,
v => [ $s->{cookies}{IL} ],
);
#$s->{raw_path} = '/';
#$s->{uri} =~ s/logout//;
}
( run in 0.979 second using v1.01-cache-2.11-cpan-8f98c5d2c55 )