use 5.008;
no warnings qw(uninitialized);
use Encode qw(from_to _utf8_off);
our $VERSION = '0.94';
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
array_4_get
attopts_template
cgi_query
commify
data_clean
_exists_in_table
do_query
env_4_get
file_attribute
lc_hash
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 uri_escape)],
mail => [qw(send_mail)],
string => [qw(commify strip_html utf8_force utf8_to_entities)],
tag => [qw(attopts_template)]
);
sub cgi_query {
my ($self, $query) = @_;
$self->_raise_exception("Wyrd must be a Setter before you can use cgi_query. Include Apache::Wyrd::Interfaces::Setter in your use base declaration.")
unless (UNIVERSAL::isa($self, 'Apache::Wyrd::Interfaces::Setter'));
$query=Apache::Wyrd::Interfaces::Setter::_cgi_quote_set($self, $query);
$query =~ s/\$:[a-zA-Z_0-9]+/NULL/g;
my $sh = $self->dbl->dbh->prepare($query);
$self->_info("Executing $query");
$sh->execute;
my $err = $sh->errstr;
$self->_error("DB Error: $err") if ($err);
return $sh;
}
sub do_query {
my ($self, $query, $hash) = @_;
$self->_raise_exception("Wyrd must be a Setter before you can use do_query. Include Apache::Wyrd::Interfaces::Setter in your use base declaration.")
unless (UNIVERSAL::isa($self, 'Apache::Wyrd::Interfaces::Setter'));
$query = Apache::Wyrd::Interfaces::Setter::_quote_set($self, $hash, $query) if (ref($hash) eq 'HASH');
my $sh = $self->dbl->dbh->prepare($query);
$self->_info("Executing $query");
$sh->execute;
my $err = $sh->errstr;
$self->_error("DB Error: $err") if ($err);
return $sh;
}
sub _exists_in_table {
my ($self, $spec) = @_;
if (ref($spec) eq 'HASH') {
my $table = $spec->{'table'};
my $column = $spec->{'column'};
my $value = $spec->{'value'};
my $count = 0;
if ($table and $column and $value) {
$value = $self->dbl->dbh->quote($value);
($count) = $self->_dbh->selectrow_array("select count(*) from $table where $column=$value")
|| $self->_error("DBH error: " . $self->_dbh->errstr);
}
return $count;
}
$self->_error("_exists_in_table requires a hashref with keys table, column, and value");
return;
}
sub set_clause {
my @items = @_;
@items = map {$_ . '=$:' . $_} @items;
return join(", ", @items);
}
sub file_attribute {
my ($self, $attr, $tests) = @_;
$self->_error("file_attribute() accepts only the r, w,d , and f tests") if ($tests =~ /[^rwdf]/);
my @paths = ($self->{$attr});
unless (-e $paths[0]) {
$paths[0] =~ s
my ($curdir) = ($self->dbl->file_path =~ m
push @paths, "$curdir/$paths[0]";
my ($rootdir) = ($self->dbl->req->document_root);
push @paths, "$rootdir/$paths[0]";
}
foreach my $path (@paths) {
my $result = 1;
foreach my $test (split '', $tests) {
my $write_ok = (-w $path);
$result = 0 if ($test eq 'w' and not ($write_ok));
$result = 0 if ($test eq 'r' and not (-r _));
$result = 0 if ($test eq 'd' and not (-d _));
$result = 0 if ($test eq 'f' and not (-f _));
}
($path) = $path =~ /(.+)/;
return $path if ($result);
}
if (($tests =~ /w/) and ($tests !~ /d|f/)) {
foreach my $path (@paths) {
($path) = $path =~ /(.+)/;
my ($testdir, @null) = ($path =~ m
if ($tests =~ /r/) {
return $path if (-d $testdir and -w _ and -r _)
} else {
return $path if (-d $testdir and -w _)
}
}
}
return;
}
sub slurp_file {
my $file = shift;
$file = open (FILE, $file);
if ($file) {
local $/;
undef $/;
$file = <FILE>;
close (FILE);
}
return \$file;
}
sub spit_file {
my ($file, $contents) = @_;
my $success = open (FILE, "> $file");
if ($success) {
print FILE $contents;
close (FILE);
}
return $success;
}
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);
}
sub data_clean {
my $data = shift;
$data = lc($data);
$data =~ s/\s+/_/gm;
$data = Apache::Util::escape_uri($data);
return $data;
}
sub env_4_get {
my ($self, $ignore, @ignore) = @_;
my %drop = ();
my $out = undef;
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);
}
sub lc_hash {
my $hashref = shift;
return {} if (ref($hashref) ne 'HASH');
my %temp = ();
foreach my $i (keys %$hashref) {
$temp{lc($i)} = $$hashref{$i};
}
$hashref = \%temp;
return $hashref;
}
sub sort_by_ikey {
my $first = shift;
my $last = shift;
my $key = shift;
return 0 unless ($key);
if ($key =~ s/^-//) {
($first, $last) = ($last, $first);
}
no warnings q/numeric/;
return ((lc($first->{$key}) cmp lc($last->{$key})) || ($first->{$key} <=> $last->{$key}) || (sort_by_ikey($first, $last, @_)));
}
sub sort_by_key {
my $first = shift;
my $last = shift;
my $key = shift;
return 0 unless ($key);
if ($key =~ s/^-//) {
($first, $last) = ($last, $first);
}
no warnings q/numeric/;
return (($first->{$key} cmp $last->{$key}) || ($first->{$key} <=> $last->{$key}) || (sort_by_ikey($first, $last, @_)));
}
sub token_hash {
my ($text, $token_regexp) = @_;
my @parts = token_parse($text, $token_regexp);
my %hash = ();
foreach my $part (@parts) {
$hash{$part} = 1;
}
return \%hash;
}
sub token_parse {
my ($text, $token_regexp) = @_;
if ($token_regexp) {
return split(/$token_regexp/, $text);
} else {
if ($text =~ /,/) {
return split /\s*,\s*/, $text;
} else {
return split /\s+/, $text;
}
}
}
sub uniquify_by_ikey {
my ($key, @array) = @_;
my %counts =();
return grep {$counts{lc($_->{$key})}++ == 0} @array;
}
sub uniquify_by_key {
my ($key, @array) = @_;
my %counts =();
return grep {$counts{$_->{$key}}++ == 0} @array;
}
sub uri_escape {
my $value = shift;
$value = Apache::Util::escape_uri($value);
$value =~ s/\&/%26/g;
$value =~ s/\?/%3f/g;
$value =~ s/\
return $value;
}
sub send_mail {
my $mail = shift;
$mail = lc_hash($mail);
my $path = ($$mail{'path'} || '/usr/sbin');
open (OUT, "| $path/sendmail -t ") || croak("Mail Failed: sendmail could not be used to send mail");
print OUT <<__mail_end__;
From: $$mail{from}
To: $$mail{to}
Subject: $$mail{subject}
$$mail{body}
__mail_end__
close OUT;
}
sub commify {
my $number = shift;
1 while ($number =~ s/^([-+]?\d+)(\d{3})/$1,$2/);
return $number;
}
sub strip_html {
my ($data) = @_;
$data = decode_entities($data);
$data =~ s/<>//g;
$data =~ s/<--.*?-->/ /g;
$data =~ s/<[^>]*?>/ /g;
return $data;
}
sub utf8_force {
my ($text) = @_;
my $success = 0;
if (utf8::valid($text)) {
utf8::upgrade($text);
return $text;
}
for my $encoding (qw(windows-1252 MacRoman Latin-1 Latin-9)) {
my $trial_data = $text;
eval {
from_to($encoding, 'utf8', $trial_data, Encode::FB_HTMLCREF);
};
if (not($@) && utf8::valid($trial_data)) {
$text = $trial_data;
$success = 1;
last;
}
}
unless ($success) {
carp "Unable to encode as UTF8";
}
return $text;
}
sub utf8_to_entities {
my ($text) = @_;
_utf8_off($text);
while ($text =~ /(([\xC0-\xFF])([\x80-\xFF]{1,5}))/) {
my $unicode_sequence = $1;
my ($first, $second) = ($2, $3);
my @parts = split '', $second;
my $count = @parts;
$first = substr(sprintf("%b", ord($first)), $count + 2, 6 - $count);
my $full = $first;
foreach my $part (@parts) {
$part = substr(sprintf("%b", ord($part)),2,6);
$full .= $part;
}
$full = substr(0 x 32 . $full, -32);
my $hex_number = sprintf('%04X', unpack("N", pack("B32", $full)));
$text =~ s/$unicode_sequence/&
}
return $text;
}
sub attopts_template {
my @opts = @_;
my $string = '';
foreach my $opt (@opts) {
$string .= '?:' . $opt . '{ $:' . $opt . '}';
}
}
1;