Apache-Wyrd
view release on metacpan or search on metacpan
Checkbox and radio button opts now handle style attributes
Checkbox sets now properly handle removing all checks if there is
no "null" option
Input Set objects now properly handle literal '0' values
Using a different param from the input name now works properly on
Input wyrds
Escaped Form Inputs now also escape '<' and '>'
Setter interface now supports a _template_hash method
Limited support for internal redirects method via the
abort_redirect method. Apache::Wyrd::Request attempts to recover
the CGI environment after explicit calls to Apache's
internal_redirect method
The mother interface can now act on any attribute of a Wyrd, not
just _data
unless UNIVERSAL::isa($self, 'Apache::Wyrd');
my @caller = caller();
$caller[0] =~ s/.+://;
$caller[2] =~ s/.+://;
my $processing = undef;
$processing = $self->dbl->self_path if ($_dbl);
$processing ||= "{COULD NOT PROCESS PATH TO PERL OBJECT}";#assume self_path could be erroneously null
my $id = "($processing -- $caller[0]:$caller[2])";
$value = join(':', $id, $value , "\n". $self->{'_as_html'} . "\n");
if ($_dbl) {
my $htmlvalue = join(':', $id, $value , "<BR>\n". Apache::Util::escape_html($self->{'_as_html'}) . "<BR>\n");
$_dbl->log_event($htmlvalue);
}
die $value;
};
sub _verbose {
goto $_error_handler{$_loglevel{'verbose'}};
}
sub _debug {
to be valid. Invalid Wyrds are ignored and do not get processed, but
may cause errors in other Wyrds if malformed, so it often pays to "view
source" on your browser while debugging.
Unlike (X)HTML, however, Wyrds are named like perl modules with the double-colon
syntax (BASENAME::SUBNAME::SUBSUBNAME) and these names are B<case-sensitive>.
Furthermore, either single or double quotes MUST be used around attributes, and
these quotes must match on either side of the enclosed attribute value. Single
quotes may be used, however, to enclose double quotes and vice-versa unless the
entire attribute value is quoted. When in doubt, escape quotes by preceding
them with a backslash (\). B<HTML tags should not appear inside attributes.>
See C<Apache::Wyrd::Template> and C<Apache::Wyrd::Attribute> for common ways
around this limitation.
Also unlike (X)HTML, one Wyrd of one type cannot be embedded in another of the
same type. We believe this is a feature(TM).
=head2 LIFE CYCLE
The "normal" behavior of a Wyrd is simply to disappear, leaving its enclosed
sub _invoke_html_wyrd {
my ($self, $class, $params, $data, $original) = @_;
my $base_class = $self->base_class;
$self->_debug("$original is the original\n");
$self->_debug("$base_class is the base class\n");
$self->_debug("$class is the class\n");
$self->_debug("$params is the params\n");
$self->_debug("$data is the data\n");
my $match = 0;
my (%init, $init_ref, $unescape) = ();
$self->_error("Attempted recursion of $class") if ($data =~ /<$base_class\:\:$class[\s>]/);
#drop the nest identifier
$class =~ s/([^:]):([^:]+)$/$1/ && $self->_info("dropped the nest identifier $2");
#encode the escaped-out " and '
$params =~ s/\\'/<!apostrophe!>/g;
$params =~ s/\\"/<!quote!>/g;
#escape-out special characters when they are the only attribute
$params =~ s/\$/<!dollar!>/g;
$params =~ s/\@/<!at!>/g;
$params =~ s/\%/<!percent!>/g;
$params =~ s/\&/<!ampersand!>/g;
#nullify the blank attributes
$params =~ s/""/"<!null!>"/g;
$params =~ s/''/'<!null!>'/g;
#zerofy the numerical zero attributes
$params =~ s/"0"/"<!zero!>"/g;
$params =~ s/'0'/'<!zero!>'/g;
Wyrd/CGISetter.pm view on Meta::CPAN
=head2 HTML ATTRIBUTES
=over
=item style
three optional styles are available
=over 2
=item style="escape"
substitute HTML-interpretable characters with their entity equivalents
=item style="query"
Properly quote the values for use in SQL queries
=item style="clear"
Remove any undefined values, so that there are no remaining $:variable placemarkers.
Wyrd/CGISetter.pm view on Meta::CPAN
Does not handle multiple CGI values, but takes the first handed to it by the
Apache::Request->param call.
=cut
sub _format_output {
my ($self) = @_;
my $data = undef;
if ($self->{'style'} eq undef) {
$data = $self->_set;
} elsif ($self->{'style'} =~ /\bescape\b/i) {
$data = $self->_cgi_escape_set;
} elsif ($self->{'style'} =~ /\bquery|sql\b/i) {
$data = $self->_cgi_quote_set;
} elsif ($self->{'style'} =~ /\bclear\b/i) {
$data = $self->_clear_set;
} else {
$self->_raise_exception("Unknown style: " . $self->{'style'});
}
$self->_data($data);
}
Wyrd/DBL.pm view on Meta::CPAN
my ($self, $fh) = @_;
$self->{'logfile'} = $fh;
close ($fh) if ($fh);
eval("system('/bin/sync')");
}
=pod
=item (void) C<log_event> (scalar)
same as log_bug, but don't send the output to STDERR. Instead, make it HTML escaped and store it for later dumping.
=cut
sub log_event {
my ($self, $value) = @_;
$self->{'dbl_log'} = [@{$self->{'dbl_log'}}, $value];
my $fh = $self->{'logfile'};
if ($fh) {
print $fh (Apache::Util::escape_html($value) . "<br>\n");
}
}
=pod
=item (hashref) C<base_class> (void)
return the base class of this set of Wyrds.
=cut
Wyrd/DBL.pm view on Meta::CPAN
return a scalarref to a html-formatted dump of the log.
=cut
sub dump_log {
require Apache::Util;
my ($self) = @_;
my $out ="<code><small><b>Log Backtrace:</b><br>";
foreach my $i (reverse(@{$self->{'dbl_log'}})) {
$out .= Apache::Util::escape_html($i) . "<br>\n";
}
$out .= "</small></code>";
return \$out;
}
=head1 BUGS
UNKNOWN
=head1 AUTHOR
Wyrd/Input.pm view on Meta::CPAN
=over
=item allow_zero
By default, a value of zero is not considered a valid value, and a value of zero
will trigger an error if the required flag is set. This flag will allow values
that are mathematically equivalent to zero. It may become the default behavior
in future versions of this Wyrd.
=item escape
Escape the HTML of the value, so as to avoid HTML parsing errors.
Default behavior for Inputs who's end-result input tags have this
problem, such as E<lt>input type="text"E<gt>
=item no_fail
Always accept value, even when invalid.
=item not_null
Wyrd/Input.pm view on Meta::CPAN
B<register_error_messages> is called separately, as there may not be a
one-to-one correspondence between what the Input should warn the user
about and what it considers an error.
The no_fail flag prevents the errors from registering at all, while the
quiet flag will suppress only the error messages.
However, pass or fail, a call to the _datum object will occur with the
B<set> call, and presumably, the Datum class will know how to deal with
that. For it's own purposes, however, the value will be temporarily
stored by the Input, and HTML esacaped if the B<escape> flag is set.
=cut
sub set {
my ($self, $value) = @_;
$value = $self->_unescape($value) if ($self->_flags->escape);
#convert value to appropriate type
$value = [$value] if ((ref($value) ne 'ARRAY') and ($self->{'_multiple'}));
$value = shift(@{$value}) if ((ref($value) eq 'ARRAY') and not($self->{'_multiple'}));
my $result = $self->_check_param($value); #check params and set error values
unless ($result) {
$self->_warn("Failed to set the datum object for " . $self->{'name'} . " to the value $value");
unless ($self->_flags->no_fail) {
$self->{'_parent'}->register_errors($self);
$self->{'_parent'}->register_error_messages($self) unless ($self->_flags->quiet);
}
Wyrd/Input.pm view on Meta::CPAN
=cut
sub error_messages {
my ($self) = @_;
return $self->{'_error_messages'};
}
=pod
=item (scalar) C<_escape> (scalar)
the C<_escape> method is a utility for escaping the data in an HTML
text-type input in order to avoid formatting errors. The default is to
only escape quotes and ampersands by encoding them as the appropriate
entity.
=cut
sub _escape {
my ($self, $value) = @_;
$value =~ s/\&/\&/g;
$value =~ s/'/\'/g;
$value =~ s/"/\"/g;
$value =~ s/</\</g;
$value =~ s/>/\>/g;
$value =~ s/\?:/\?\x00:/g;
$value =~ s/\!:/\!\x00:/g;
$value =~ s/\$:/\$\x00:/g;
return $value;
}
=pod
=item (scalar) C<_escape> (scalar)
the C<_unescape> method reverse-mirrors the C<_escape> method exactly.
=cut
sub _unescape {
my ($self, $value) = @_;
$value =~ s/\&/\&/g;
$value =~ s/\'/'/g;
$value =~ s/\"/"/g;
$value =~ s/\</</g;
$value =~ s/\>/>/g;
$value =~ s/\?\x00:/\?:/g;
$value =~ s/\!\x00:/\!:/g;
$value =~ s/\$\x00:/\$:/g;
return $value;
Wyrd/Input.pm view on Meta::CPAN
$self->_raise_exception('All Inputs must have a name')
} elsif ($type eq '') {
$self->_raise_exception('All Inputs must have a type')
} elsif ($self->can('_setup_' . $type)) {
my $result = eval('$self->_setup_' . $type);
if ($@) {
$self->_raise_exception($@);
}
#send the datums the "value" for defaults.
} elsif ($type eq 'text') {
$self->_flags->escape(1);
my $max_length = $self->{'maxlength'};
if ($max_length and ($max_length < 255)) {
$params{'length'} = $max_length;
$self->{'_datum'} ||= (Apache::Wyrd::Datum::Char->new($self->{'value'}, \%params));
} else {
$self->{'_datum'} ||= (Apache::Wyrd::Datum::Text->new($self->{'value'}, \%params));
};
$self->{'_template'} ||= $self->_template_text;
} elsif ($type eq 'textarea') {
$self->_flags->escape(1);
$self->{'value'} ||= $self->_data;#value may be enclosed in a textarea input
$self->{'_datum'} ||= Apache::Wyrd::Datum::Text->new($self->{'value'}, \%params);
if ($self->{'_template'} !~ /<textarea/) {
$self->{'_template'} = $self->_template_textarea;
}
} elsif ($type eq 'hidden') {
$self->_flags->escape(1);
$self->{'_datum'} ||= Apache::Wyrd::Datum::Text->new($self->{'value'}, \%params);
$self->{'_template'} ||= $self->_template_hidden;
} elsif ($type eq 'password') {
$self->{'_datum'} ||= Apache::Wyrd::Datum::Text->new($self->{'value'}, \%params);
$self->{'_template'} ||= $self->_template_password;
} elsif ($type eq 'plaintext') {
$self->{'_datum'} ||= Apache::Wyrd::Datum::Text->new($self->{'value'}, \%params);
$self->{'_template'} ||= '$:value<input type="hidden" name="$:name" value="$:value">';
} else {
if ($self->can('_startup_' . $type)) {
Wyrd/Input.pm view on Meta::CPAN
my (%values) = ();
foreach my $value (keys %{$self}) {
next if $value =~ /^_/;
$values{$value} = $self->{$value};
}
#If by now the input has no value, try to give it one from CGI, the form, or default in that order;
unless ($values{'value'} or $self->_flags->reset or ($self->_flags->allow_zero and $values{'value'}=~ /^\s*0?E?[+\-]?\s*0(\.0+)?\s*/)) {
my ($value, $success) = $self->{'_parent'}->_get_value($self->{'name'});
$values{'value'} = ($value || $self->{'_parent'}->{'_variables'}->{$self->{'name'}} || $self->{'default'} || '');
}
$values{'value'} = $self->_escape($values{'value'}) if ($self->_flags->escape);
return ($self->_clear_set(\%values, $self->{'_template'}));
}
=pod
=head1 AUTHOR
Barry King E<lt>wyrd@nospam.wyrdwright.comE<gt>
=head1 SEE ALSO
Wyrd/Interfaces/Setter.pm view on Meta::CPAN
foreach my $i (sort {length($b) <=> length($a)} keys(%$hash)) {
next unless ($i);#this is to prevent strange tied hashes from creating iloops
$self->_verbose("temp is $temp, i is $i and hash is $$hash{$i}");
$temp =~ s/\$:$i/$$hash{$i}/gi;
}
return $temp;
}
=pod
=item (scalar) C<_escape_set> ([hashref], [scalar])
More HTML-form-ish but not CGI-ish. A blank hashref is used in place of
the CGI environment when passed no parameters. Values are HTML escaped
so they can be used within <input type="text"> tags in HTML.
=cut
sub _escape_set {
my ($self, $hash, $temp) = @_;
#if a target ($temp) is provided, use it instead of the data
$temp = $self->{'_data'} unless ($temp);
$hash = {} unless (ref($hash) eq 'HASH');
#first do conditionals
$temp = $self->_regexp_conditionals($hash, $temp);
#then do quotations, altering a copy, not the original
my %hash = %$hash;
foreach my $i (keys(%hash)) {
$hash{$i}=Apache::Util::escape_html($hash{$i});
}
#then do replacements
foreach my $i (sort {length($b) <=> length($a)} keys(%hash)) {
next unless ($i);#this is to prevent strange tied hashes from creating iloops
$self->_verbose("temp is $temp, i is $i and hash is $$hash{$i}");
$temp =~ s/\$:$i/$hash{$i}/gi;
}
return $temp;
}
=pod
=item (scalar) C<_cgi_escape_set> ([scalar])
same as C<_escape_set>, but with the CGI environment option forced and
no interpreted hash option.
=cut
sub _cgi_escape_set {
my ($self, $temp) = @_;
#if a target ($temp) is provided, use it instead of the data
$temp = $self->{'_data'} unless ($temp);
#first get a clean hash -- no point in doing conditionals if undef is changed to NULL
my $hash = $self->_cgi_hash($temp);
#then do conditionals
$temp = $self->_regexp_conditionals($hash, $temp);
#then do quotations
$hash = $self->_cgi_hash($temp, 'escaped');
#then do replacements
$temp = $self->_setter_replacements($hash, $temp);
return $temp;
}
=pod
=item (scalar) C<_regexp_conditionals> (hashref, scalar)
internal method for performing conditional interpretation.
Wyrd/Interfaces/Setter.pm view on Meta::CPAN
my $hash = {};
my @params = ();
unless ($temp) {
#give up and use CGIs params
@params = $self->dbl->param;
} else {
#guess at the params from the template
@params = ($temp =~ m/[\$\?\!]\:([a-zA-Z_][a-zA-Z0-9_]+)/g);
}
foreach my $param (@params) {
if ($modifier eq 'escaped') {
$hash->{$param} = Apache::Util::escape_html(scalar($self->dbl->param($param)));
} elsif ($modifier eq 'quoted') {
#scalar is used because of some funny business in dbh -- worth investigating?
$hash->{$param} = $self->dbl->dbh->quote(scalar($self->dbl->param($param)));
} else {
$hash->{$param} = $self->dbl->param($param);
}
$self->_verbose("$param = $$hash{$param}");
}
$self->_debug("Found params ->" . join ', ', @params);
return $hash
Wyrd/Interfaces/Setter.pm view on Meta::CPAN
}
=pod
=back
=head1 BUGS/CAVEATS/RESERVED METHODS
=head2 Interpolation Bug
"$:" is a variable in perl, so be sure to escape or single-quote your
in-code templates. If you start seeing B<-variablename> in your pages,
you'll know why.
=head2 Defined Null Conditional Bug
There's some un-perlish behavior in the setting of conditionals. Conditional
statements are set (?) or unset (!) depending on whether the item is defined,
not whether it is true. An eq operator, for example, returns '' (the null
string) when the arguments are not equivalent strings, so a template with a
conditional that should be false, and therefore unset, is actually considered
Wyrd/Services/Auth.pm view on Meta::CPAN
$login_url = $scheme . '://' . $req->hostname . $port . $login_url unless ($login_url =~ /^http/i);
my $ls_url = $req->dir_config('LSLoginURL');
$ls_url = $scheme . '://' . $req->hostname . $port . $ls_url unless ($ls_url =~ /^http/i);
if ($login_url) {
my $uri = $req->uri;
$uri = Apache::URI->parse($uri);
my $query_string = $uri->query;
$query_string =~ s/\&?check_cookie=yes\&?//;
$query_string =~ s/challenge=[0123456789abcdefABCDEF:]+\&?//g;
$query_string = '?' . $query_string if ($query_string);
my $on_success = Apache::Util::escape_uri(encode_base64($scheme . '://' . $req->hostname . $port . $req->uri . $query_string));
my $redirect = $login_url .
'?ls=' . $ls_url .
'&ticket=' . $ticket .
'&on_success=' . $on_success .
'&use_error=' . $use_error .
($challenge_failed ? '&'. $use_error . '=' . $challenge_failed : '');
$debug && warn('Need a login, with redirect going to ' . $redirect);
$req->custom_response(REDIRECT, $redirect);
return REDIRECT;
} else {
Wyrd/Services/Auth.pm view on Meta::CPAN
} else {
$debug && warn('Login was not provided.');
}
my $use_error = $req->dir_config('ReturnError');
my $login_url = $req->dir_config('LoginFormURL');
$login_url = $scheme . '://' . $req->hostname . $port . $login_url unless ($login_url =~ /^http/i);
my $ls_url = $scheme . '://' . $req->hostname . $port . $req->uri;
if ($login_url) {
my $uri = $req->uri;
$uri = Apache::URI->parse($uri);
my $on_success = Apache::Util::escape_uri(encode_base64($scheme . '://' . $req->hostname . $port . $req->uri));
my $redirect = $login_url .
'?ls=' . $ls_url .
'&on_success=' . $on_success .
'&use_error=' . $use_error.
($login_failed ? '&'. $use_error . '=' . $login_failed : '');
$debug && warn('Need a login, with redirect going to ' . $redirect);
$req->custom_response(REDIRECT, $redirect);
return REDIRECT;
} else {
die "Must define LoginFormURL in Apache Config to use Apache::Wyrd::Services::Auth";
Wyrd/Services/Auth.pm view on Meta::CPAN
my $ticketfile = $self->{'ticketfile'};
# 1) Generate a random 56-byte key. NB: values are 1-255, not 0-255 as it will be stored in A DB file, so null byte terminates string in C. Avoid it.
my $key = '';
for (my $i=0; $i<56; $i++) {
$key .= chr(int(rand(255)) + 1);
}
# 2) Make a ticket serial number by using sha256
my $ticket = sha256_hex($key);
$key = Apache::Util::escape_uri($key);
$debug && warn ("Storing key under ID $ticket");
my $pad = Apache::Wyrd::Services::TicketPad->new($ticketfile);
$pad->add_ticket($ticket, $key);
return ($key, $ticket);
}
sub decrypt_challenge {
my ($self, $challenge) = @_;
Wyrd/Services/Auth.pm view on Meta::CPAN
#separate the ticket from the data
my ($ticket, $data) = split ':', $challenge;
#find the key for decrypting the data;
$debug && warn('finding ' . $ticket);
my $pad = Apache::Wyrd::Services::TicketPad->new($ticketfile);
my $key = $pad->find($ticket);
$debug && warn "found key $key";
$key = Apache::Util::unescape_uri($key);
my $cr = Apache::Wyrd::Services::CodeRing->new({key => $key});
my ($username, $password) = split ("\t", ${$cr->decrypt(\$data)});
return ($username, $password);
}
sub authorize_user {
my ($self, $req, $user) = @_;
my $debug = $self->{'debug'};
Wyrd/Services/Index.pm view on Meta::CPAN
$attribute = "\x04";
}
my $index = $self->read_db;
my (@out, %match, %must, %mustnot, @match, @add, @remove, $restrict, @entries)=();
$string =~ s/(\+|\-)\s+/$1/g;
if ($string =~ /"/) {#first deal with exact word matches
while ($string =~ m/(([\+-]?)"([^"]+?)")/) { #whole=1, modifier=2, phrase=3
my $phrase = $self->clean_searchstring($3);
my $modifier = $2;
my $substring = $1;
#escape out phrase and substring since they will be used in regexps
#later in this subroutine.
$substring =~ s/([\\\+\?\:\\*\&\@\$\!])/\\$1/g;
$phrase =~ s/([\\\+\?\:\\*\&\@\$\!])/\\$1/g;
$string =~ s/$substring//; #remove the phrase from the string;
if ($modifier eq '+') {
push (@add, "_$phrase");
$restrict = 1;
} elsif ($modifier eq '-') {
push (@remove, "_$phrase");
} else {
Wyrd/Services/LoginServer.pm view on Meta::CPAN
$pad->add_ticket($ticket, $key);
$req->headers_out;
$req->print('Key accepted...');
return OK;
} elsif ($ticket) {
#get info on what to do if this fails to be handed back to the
#Auth handler.
my $success_url = decode_base64($apr->param('on_success')) || return AUTH_REQUIRED;
#url was escaped by the Auth module
$success_url = Apache::Util::unescape_uri($success_url);
#if the url had a query string, the challenge should be appended to it.
my $fail_url = $apr->param('on_fail') || $success_url;
#get necessaries
my $ticket = $apr->param('ticket');
#a URL for a ticket means the ticket must be picked up elsewhere at a Pre-Auth server.
if ($ticket =~ /^http/) {
my $ua = LWP::UserAgent->new;
$ua->timeout(60);
Wyrd/Services/LoginServer.pm view on Meta::CPAN
unless ($key) {
my $joiner = '?';
$joiner = '&' if ($fail_url =~ /\?/);
$debug && warn("key could not be found. Server key has probably been lost due to a re-initializtion of Apache::Wyrd::Services::CodeRing. Nothing for it but to send the browser back.");
$req->custom_response(HTTP_MOVED_TEMPORARILY, "$fail_url$joiner$use_error" . '=Login%20Server%20has%20been%20re-started%20please%20try%20again.');
return HTTP_MOVED_TEMPORARILY;
}
my $joiner = '?';
$joiner = '&' if ($success_url =~ /\?/);
$debug && warn("found the key $key");
$key = Apache::Util::unescape_uri($key);
my $ex_cr = Apache::Wyrd::Services::CodeRing->new({key => $key});
$debug && warn("Generated a new decryption ring with the found key");
my $data = "$user\t$password";
$data = $ex_cr->encrypt(\$data);
$debug && warn("Data encrypted with the key");
$req->custom_response(HTTP_MOVED_TEMPORARILY, "$success_url" . $joiner . 'challenge=' . $ticket . ':' . $$data);
$debug && warn("loginserver has set the challenge to $$data");
return HTTP_MOVED_TEMPORARILY;
} else {
return AUTH_REQUIRED
Wyrd/Services/MySQLIndex.pm view on Meta::CPAN
}
my $table = '_wyrd_index_' . $attribute;
my $index = $self->read_db;
my (@out, %match, %must, %mustnot, @match, @add, @remove, $restrict, @entries)=();
$string =~ s/(\+|\-)\s+/$1/g;
if ($string =~ /"/) {#first deal with exact word matches
while ($string =~ m/(([\+-]?)"([^"]+?)")/) { #whole=1, modifier=2, phrase=3
my $phrase = $self->clean_searchstring($3);
my $modifier = $2;
my $substring = $1;
#escape out phrase and substring since they will be used in regexps
#later in this subroutine.
$substring =~ s/([\\\+\?\:\\*\&\@\$\!])/\\$1/g;
$phrase =~ s/([\\\+\?\:\\*\&\@\$\!])/\\$1/g;
$string =~ s/$substring//; #remove the phrase from the string;
if ($modifier eq '+') {
push (@add, "_$phrase");
$restrict = 1;
} elsif ($modifier eq '-') {
push (@remove, "_$phrase");
} else {
Wyrd/Services/SAK.pm view on Meta::CPAN
normalize_href
send_mail
set_clause
slurp_file
sort_by_ikey
sort_by_key
spit_file
strip_html
token_hash
token_parse
uri_escape
uniquify_by_key
uniquify_by_ikey
utf8_force
utf8_to_entities
);
our %EXPORT_TAGS = (
all => \@EXPORT_OK,
db => [qw(cgi_query do_query set_clause _exists_in_table)],
file => [qw(file_attribute slurp_file spit_file)],
hash => [qw(array_4_get data_clean env_4_get lc_hash sort_by_ikey sort_by_key token_hash token_parse uniquify_by_ikey uniquify_by_key)],
mail => [qw(send_mail)],
string => [qw(commify strip_html utf8_force utf8_to_entities)],
tag => [qw(attopts_template)],
uri => [qw(normalize_href uri_escape)],
);
=pod
=head2 DATABASE (:db)
Functions for working with databases. Designed for use with a
combination of C<Apache::Wyrd::Interfaces::Setter> and the DBI-compatible
database stored in C<Apache::Wyrd::DBL>.
Wyrd/Services/SAK.pm view on Meta::CPAN
element exist, they are appended.
=cut
sub array_4_get {
my ($self, @array) = @_;
my @param = ();
foreach my $param (@array) {
my @values = $self->dbl->param($param);
foreach my $value (@values) {
push @param, Apache::Wyrd::Services::SAK::uri_escape("$param=" . $value);
}
}
return join('&', @param);
}
=pod
=item (scalar) C<data_clean>(scalar)
Shorthand for turning a string into "all lower case with underlines for
whitespace".
=cut
sub data_clean {
my $data = shift;
$data = lc($data);
$data =~ s/\s+/_/gm;
$data = Apache::Util::escape_uri($data);
return $data;
}
=pod
=item (scalar) C<env_4_get>([array/hashref])
attempt to re-create the current CGI environment as the query portion of a GET
request. Either a hash or an array of variables to ignore can be supplied.
Wyrd/Services/SAK.pm view on Meta::CPAN
my @params = ();
unless (ref($ignore) eq 'HASH') {
foreach my $i ($ignore, @ignore) {
$drop{$i} = 1;
}
} else {
%drop = %$ignore;
}
foreach my $i ($self->dbl->param) {
next if (exists($drop{$i}));
push @params, Apache::Wyrd::Services::SAK::uri_escape("$i=" . $self->dbl->param($i));
}
return join('&', @params);
}
=pod
=item (hashref) C<data_clean>(hashref)
Shorthand for turning a hashref into a lower-case version of itself. Will
randomly destroy one value of any key for which multiple keys of different case
Wyrd/Services/SAK.pm view on Meta::CPAN
=cut
sub uniquify_by_key {
my ($key, @array) = @_;
my %counts =();
return grep {$counts{$_->{$key}}++ == 0} @array;
}
=pod
=item (array of hashrefs) C<uri_escape>(scalar, array of hashrefs)
Quick and dirty shorthand for encoding a get request within a get request.
=cut
sub uri_escape {
my $value = shift;
$value = Apache::Util::escape_uri($value);
$value =~ s/\&/%26/g;
$value =~ s/\?/%3f/g;
$value =~ s/\#/%23/g;
return $value;
}
=pod
=item (scalar) C<normalize_href>(objectref DBL, scalar href)
Wyrd/Site/GDButton.pm view on Meta::CPAN
open FILE, "> " . $self->{'outfile'};
binmode FILE;
print FILE ($self->{'outfile'}=~/gif$/) ? $final->gif : $final->png;
close FILE;
}
#attempt to preserve any normal IMG or INPUT attributes
my @attrs = qw(name id action method alt src align onmouseover onmouseout onclick border height width ismap longdesc usemap class style);
my %attrs = map {$_ => $self->{$_}} @attrs;
$attrs{'src'} = Apache::Util::escape_uri($attrs{'src'});
if ($self->{'type'} eq 'input') {
$self->_data(q(<input type="image") . $self->_attribute_template(@attrs) . q(>));
} else {#consider anything else as an image tag.
$self->_data(q(<img) . $self->_attribute_template(@attrs) . q(>));
}
return $self->_set(\%attrs);
}
=pod
( run in 0.840 second using v1.01-cache-2.11-cpan-c21f80fb71c )