view release on metacpan or  search on metacpan

Wyrd/Services/SAK.pm  view on Meta::CPAN

use 5.008;
use strict;
use warnings;
no warnings qw(uninitialized);

package Apache::Wyrd::Services::SAK;
use Carp;
use Exporter;
use Apache::Util;
use HTML::Entities;
use Encode qw(from_to _utf8_off);

=pod

=head1 NAME

Apache::Wyrd::Services::SAK - Swiss Army Knife of common subs

=head1 SYNOPSIS

	use Apache::Wyrd::Services::SAK qw(:hashes spit_file);

=head1 DESCRIPTION

"Swiss Army Knife" of functions used in Apache::Wyrd.  These are mostly
internal to the base classes of Wyrds, and are probably better implemented
elsewhere in CPAN, but reducing the number of external modules was a goal of
the Apache::Wyrd project.

I<(format: (returns) C<name> (arguments))> for regular functions.

I<(format: (returns) C<$wyrd-E<gt>name> (arguments))> for methods


=cut

our $VERSION = '0.98';
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
	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>.

=over

=item (scalarref) C<$wyrd-E<gt>cgi_query>(scalar)

For turning strings with conditional variables into
queries parseable by the SQL interpreter.  First sets all conditional variables
in the query that are known, then set all unknown variables to NULL.  The query
is then executes and the DBI handle to the query is returned.

     $sh = $wyrd->cgi_query(
       'select names from people where name=$:name'
     );

	$wyrd->cgi_query('delete from people where id=$:id');

=cut

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);
	#replace unknown variables with null
	$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;
}

=pod

=item (scalarref) C<$wyrd-E<gt>do_query>(scalar, [hashref])

Shorthand for creating and executing a DBI statement handle, returning the
handle.  If the optional hashref is supplied, it will perform a substitution in
the manner of C<Apache::Wyrd::Interfaces::Setter>. Unknown variables will be
made NULL for the query.  The query is then executes and the DBI handle to the
query is returned.

    $sh = $wyrd->do_query(
      'select names from people where name=$:name', {name => $name}
    );

    $wyrd->do_query('delete from people');

Wyrd/Services/SAK.pm  view on Meta::CPAN

=cut

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;
}

=pod

=back

=head2 Strings (:string)

String manipulations.

=over

=item (scalar) C<commify> (array)

Add commas to numbers, thanks to the perlfaq.

=cut

sub commify {
	my $number = shift;
	1 while ($number =~ s/^([-+]?\d+)(\d{3})/$1,$2/);
	return $number;
}

=pod

=item (scalar) C<strip_html>(scalar)

Escape out entities and strip tags from a given string.

=cut

sub strip_html {
	my ($data) = @_;
	$data = decode_entities($data);
	$data =~ s/<>//g; # Strip out all empty tags
	$data =~ s/<--.*?-->/ /g; # Strip out all comments
	$data =~ s/<[^>]*?>/ /g; # Strip out all HTML tags
	return $data;
}

=pod

=item (scalar) C<utf8_force>(scalar)

Attempt to decode the text into UTF-8 by trying different common encodings
until one returns valid UTF-8.

=cut

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;
}

=pod

=item (scalar) C<utf8_to_entities>(scalar)

Seek through the given text for Unicode byte sequences and replace them with
numbered entities for that unicode character.  Assumes the text is properly-
formatted UTF8.

=cut


sub utf8_to_entities {
	my ($text) = @_;
	use Encode qw(_utf8_off);
	_utf8_off($text);
	while ($text =~ /(([\xC0-\xFF])([\x80-\xFF]{1,5}))/) {

		#store the sequence for later;
		my $unicode_sequence = $1;

		#separate the first byte from the others
		my ($first, $second) = ($2, $3);

		#split remaining bytes and count them
		my @parts = split '', $second;
		my $count = @parts;

		#remove the appropriate number of bits from the high end of the first
		#byte (3 for 2 bytes, 4 for 3, etc) and use that for the first part of
		#the 32-bit binary number
		$first = substr(sprintf("%b", ord($first)), $count + 2, 6 - $count);
		my $full = $first;

		#Remove the two highest bits from the remaining bytes and concatenate
		#the result with the first part
		foreach my $part (@parts) {
			$part = substr(sprintf("%b", ord($part)),2,6);
			$full .= $part;
		}

		#Left-fill with zeroes to make a full 32 bit binary number
		$full =  substr(0 x 32 . $full, -32);

		#Turn the binary number into a 32-bit unsigned integer value
		my $hex_number = sprintf('%04X', unpack("N", pack("B32", $full)));

		#Replace all instances of that byte sequence found in the text with a
		#numbered entity sequence
		$text =~ s/$unicode_sequence/&#x$hex_number;/g;
	}
	return $text;
}

=pod

=back

=head2 TAGS (:tag)

Tag-generation tools.

=over

=item (scalar) C<attopts_template> (array)

Creates a template of attribute options, given an array of the attributes.

=cut

sub attopts_template {
	my @opts = @_;
	my $string = '';
	foreach my $opt (@opts) {
		$string .= '?:' . $opt . '{ $:' . $opt . '}';
	}