File Coverage

blib/lib/XAO/Utils.pm

Criterion	Covered	Total	%
statement	102	107	95.3
branch	28	36	77.7
condition	3	7	42.8
subroutine	20	21	95.2
pod	14	15	93.3
total	167	186	89.7

=head1 NAME

XAO::Utils - Utility functions widely used by XAO suite

=head1 SYNOPSIS

  use XAO::Utils (:all);    # export everything

  or

  use XAO::Utils (:none);   # do not export anything

=head1 DESCRIPTION

This is not an object, but a collection of useful utility
functions.

=cut

###############################################################################
package XAO::Utils;
use strict;
use Encode;
use XAO::Errors qw(XAO::Utils);

##
# Prototypes
#
sub generate_key (;$);
sub repair_key ($);
sub set_debug ($);
sub get_debug ();
sub dprint (@);
sub eprint (@);
sub t2ht ($);
sub t2hf ($);
sub t2hq ($;$);
sub t2hj ($);
sub get_args (@);
sub merge_refs (@);
sub fround ($$);

use vars qw($VERSION);
$VERSION='2.7';

###############################################################################
# Export control
#
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
require Exporter;
@ISA=qw(Exporter);
%EXPORT_TAGS=(
    all => \@EXPORT_OK,
    args => [qw(get_args merge_refs)],
    debug => [qw(dprint eprint)],
    html => [qw(t2ht t2hq t2hf t2hj)],
    keys => [qw(generate_key repair_key)],
    math => [qw(fround)],
    none => [],
);
@EXPORT=(
    @{$EXPORT_TAGS{args}},
    @{$EXPORT_TAGS{debug}},
);
@EXPORT_OK=(
    @{$EXPORT_TAGS{args}},
    @{$EXPORT_TAGS{debug}},
    @{$EXPORT_TAGS{html}},
    @{$EXPORT_TAGS{keys}},
    @{$EXPORT_TAGS{math}},
);

###############################################################################

=head2 KEYS HANDLING

Utility functions in this group can be imported by using 'keys' tag:

 use XAO::Utils qw(:keys);

Here is the list of functions available:

=over

=cut

###############################################################################

=item generate_key (;$)

Generating new 8-characters random ID. Not guaranteed to be unique,
must be checked against existing database.

Generated ID is relativelly suitable for humans - it does not contain
some letters and digits that could be easily misunderstood in writing:

=over

=item 0 (zero)

Looks the same as letter O.

=item 1 (one)

Is almost undistinguishable from capital I

=item 7

Written by american is often taken as 1 by europeans and vice versa.

=item V

Is similar to U.

=back

Examples of generated IDs are E5TUVX82, ZK845LP6 and so on.

The generated ID will never start with a digit!

The default generated key length is 8. This can be changed by supplying
an optional argument -- generate_key(20) for example.

=cut

my $generate_key_alpha;
my $generate_key_alnum;
my $generate_key_alpha_len;
my $generate_key_alnum_len;

sub generate_key (;$) {
    my $length=$_[0] || 8;

    if(!$generate_key_alpha) {
        #                              1    1    2    2    3
        #                    0----5----0----5----0----5----0-
        $generate_key_alpha=        'ABCDEFGHIJKLMNOPQRSTUWXYZ';
        $generate_key_alnum='2345689'.$generate_key_alpha;
        $generate_key_alpha_len=length($generate_key_alpha);
        $generate_key_alnum_len=length($generate_key_alnum);
    }

    my $key=substr($generate_key_alpha,rand($generate_key_alpha_len),1);

    for(my $i=1; $i!=$length; $i++) {
        $key.=substr($generate_key_alnum,rand($generate_key_alnum_len),1);
    }

    return $key;
}

###############################################################################

=item repair_key ($)

Repairing human-entered ID. Similar letters and digits are substituted
to allowed ones.

Example:

 my $ans=;
 my $id=repair_key($ans);
 die "Wrong ID" unless $id;
 print "id=$id\n";

If you enter "10qwexcv" to that script it will print "IOQWEXCU".

=cut

sub repair_key ($)
{ my $key=uc($_[0]);
  $key=~s/[\r\n\s]//sg;
  return undef unless length($key) == 8;
  $key=~s/0/O/g;
  $key=~s/1/I/g;
  $key=~s/7/I/g;
  $key=~s/V/U/g;
  $key;
}

###############################################################################

=back

=head2 DEBUGGING

Utility functions in this group are imported by default, their tag name is
`debug'. In the rare event when you need everything but debug functions
you can say:

 use XAO::Utils qw(:all !:debug);

Here is the list of functions available:

=over

=cut

###############################################################################

use vars qw($debug_flag $logprint_handler);

###############################################################################

sub logprint ($) {
    if($logprint_handler) {
        &{$logprint_handler}($_[0]);
    }
    else {
        print STDERR $_[0]."\n";
    }
}

###############################################################################

=item dprint (@)

Prints all arguments just like normal "print" does but 1) it prints
them to STDERR or uses the handler provided by set_logprint_handler()
and 2) only if you called set_debug(1) somewhere above. Useful for
printing various debug messages and then looking at them in S<"tail -f
apache/logs/error_log">.

Once you debugged your program you just turn off set_debug() somewhere at
the top and all output goes away.

Example:

 @arr=parse_my_stuff();
 dprint "Got Array: ",join(",",@arr);

B Debugging status is global. In case of mod_perl environment
with multiple sites under the same Apache server you enable or disable
debugging for all sites at once.

=cut

sub dprint (@) {
    return unless $debug_flag;
    my $str=join('',map { defined($_) ? $_ : '' } @_);
    chomp $str;
    logprint($str);
}

###############################################################################

=item eprint (@)

Prints all arguments to STDERR or using the handler provided by
set_logprint_handler() like dprint() does but unconditionally. Great for
reporting minor problems to the server log.

=cut

sub eprint (@) {
    my $str=join('',map { defined($_) ? $_ : '' } @_);
    chomp $str;
    logprint('*ERROR: '.$str);
}

###############################################################################

=item set_logprint_handler ($)

Installs a handler to be used by eprint() and dprint(). Useful when
STDERR is not available or should not be used.

Example:

 my $s=Apache->request->server;
 XAO::Utils::set_logprint_handler(sub { $s->log_error($_[0] });
 dprint "Using Apache error logging";

=cut

sub set_logprint_handler ($) {
    my $newh=shift;
    my $oldh=$logprint_handler;
    if($newh) {
        if(ref($newh) eq 'CODE') {
            $logprint_handler=$newh;
        }
        else {
            eprint "set_logprint_handler - bad handler '$newh', expected code reference";
        }
    }
    else {
        $logprint_handler=undef;
    }
    return $oldh;
}

###############################################################################

=item get_debug ($)

Returns boolean value of the current state of the debug flag.

=cut

sub get_debug () {
    return $debug_flag;
}

###############################################################################

=item set_debug ($)

Turns debug flag on or off. The flag is global for all packages that
use XAO::Utils!

Example:

 use XAO::Utils;

 XAO::Utils::set_debug(1);
 dprint "dprint will now work!";

=cut

sub set_debug ($) {
    my $old_flag=$debug_flag;
    $debug_flag=$_[0];
    return $old_flag;
}

###############################################################################

=back

=head2 HTML ENCODING

Utility functions in this group can be imported by using 'html' tag:

 use XAO::Utils qw(:html);

Here is the list of functions available:

=over

=cut

###############################################################################

=item t2hf ($)

Escapes text to be be included in HTML tags arguments. Can be used for
XAO::Web object arguments as well.

 " ->> "

All symbols from 0x0 to 0x1f are substituted with their codes in &#NNN;
format.

=cut

sub t2hf ($) {
    my $text=t2ht($_[0]);
    $text=~s/"/"/sg;
    $text=~s/([\x00-\x1f<>])/'&#'.ord($1).';'/sge;
    $text;
}

###############################################################################

=item t2hq ($;$)

Escapes text to be be included into URL parameters.

All symbols from 0x0 to 0x1f and from 0x80 to 0xff as well as the
symbols from [&?<>"=%#+] are substituted to %XX hexadecimal codes
interpreted by all standard CGI tools. The same conversion may be used
for URLs themselves.

Unicode is encoded into UTF-8 (unless a different encoding is specified
in the second argument).

=cut

sub t2hq ($;$) {
    my ($text,$encoding)=@_;

    my $bytes=Encode::is_utf8($text)
                ? Encode::encode($encoding || 'utf8',$text)
                : $text;

    $bytes=~s/([^[:ascii:]]|[\x00-\x20\&\?<>;"=%#\+])/"%".unpack("H2",$1)/sge;

    return $bytes;
}

###############################################################################

=item t2ht ($)

Escapes text to look the same in HTML.

 & ->> &
 > ->> >
 < ->> <

=cut

sub t2ht ($) {
    my $text=shift;
    $text=~s/&/&/sg;
    $text=~s/
    $text=~s/>/>/sg;
    return $text;
}

###############################################################################

=item t2hj ($)

Escapes text to look the same in JavaScript.

 ' ->> \u0027
 " ->> \"
 \ ->> \\
 < ->> \u003c
 > ->> \u003e

Single quote is escaped into a hex code because that is acceptable in
both Javascript and JSON strings, whereas \' is not valid in JSON.

Angle brackets are escaped because otherwise a value of  inside
a field would close the outer script tag even though it's encountered in
the middle of a literal.

=cut

sub t2hj ($) {
    my $text=shift;
    $text=~s/\\/\\\\/sg;
    $text=~s/'/\\u0027/sg;
    $text=~s/"/\\"/sg;
    $text=~s/([\x00-\x1f<>])/'\\u'.sprintf('%04x',ord($1))/esg;
    return $text;
}

###############################################################################

=back

=head2 ARGUMENTS HANDLING

Utility functions in this group are imported by default, their tag name is
`args'. For example if you need everything but them you can say:

 use XAO::Utils qw(:all !:args);

Here is the list of functions available:

=over

=cut

###############################################################################

=item get_args ($)

Probably one of the most used functions throughout XAO
tools. Understands arguments in the variety of formats and always
returns a hash reference as the result.

Undrestands arrays, array references and hash references.

Should be used as follows:

 use XAO::Utils;

 sub my_method ($%) {
     my $self=shift;
     my $args=get_args(\@_);

     if($args->{mode} eq 'fubar') {
         ...
 }

Now my_method could be called in either way:

 $self->my_method(mode => 'fubar');

 $self->my_method( { mode => 'fubar' } );

Or even:

 $self->my_method( { mode => 'fubar' }, { submode => 'barfoo' });

 sub other_method ($%) {
     my $self=shift;
     my $args=get_args(\@_);

     if(some condition) {

        return $self->my_method($args);
     }
     ...

 sub debug_my_method ($%) {
     my $self=shift;
     dprint "will call my_method with our arguments";
     $self->my_method(@_);
 }

Note, that in the above examples you could also use "get_args(@_)"
instead of "get_args(\@_)". That's fine and that will work, but
slower.

=cut

sub get_args (@) {
    my $arr=ref($_[0]) eq 'ARRAY' ? $_[0] : \@_;

    if(!@$arr) {
        return { };
    }
    elsif(@$arr == 1) {
        my $args=$arr->[0];
        ref($args) eq 'HASH' ||
            throw XAO::E::Utils "get_args - single argument not a hash ref";
        return $args;
    }
    elsif(ref($arr->[0]) eq 'HASH') {
        return merge_refs(@$arr);
    }
    elsif(!ref($arr->[0]) && (scalar(@$arr)%2)==0) {
        my %a=@$arr;
        return \%a;
    }
    else {
        throw XAO::E::Utils "get_args - unparsable arguments";
    }
}

###############################################################################

=item merge_refs (@)

Combines together multiple hash references into one without altering
original hashes. Can be used in situations when you want to pass along
slightly modified hash reference like that:

 sub some_wrapper (%) {
     my $args=get_args(\@_);
     real_method(merge_args($args,{ objname => 'Fubar' }));
 }

Any number of hash references can be passed, first has lowest priority.

=cut

sub merge_refs (@) {
    my %hash;
    foreach my $ref (@_) {
        next unless defined $ref;
        @hash{keys %$ref}=values %$ref;
    }
    \%hash;
}

###############################################################################

=back

=head2 MATH

Utility functions in this group can be imported by using 'math' tag:

 use XAO::Utils qw(:math);

Here is the list of functions available:

=over

=cut

###############################################################################

=item fround ($$)

Rounds a floating point number according to the given
precision.

Precision is given as X in 1/X, for instance to round to two digits
after decimal point use precision 100.

Examples:

 fround(0.25,10)        => 0.3
 fround(0.01234,1000)   => 0.012

=cut

sub fround ($$) {
    my ($num,$prec)=@_;

    $prec>0 || throw XAO::E::Utils "fround - no precision given";
    $prec*=1.0;

    # Adding a very small amount is a dirty hack, but without it
    # it is hard to deal with fround(7.42/0.8, 100) being 9.27 instead
    # of 9.28.
    #
    my $d=1/($prec * 100_000);
    if($num<0) {
        $num-=$d;
        return -(int((-$num+1/$prec/2)*$prec))/$prec;
    }
    else {
        $num+=$d;
        return (int(($num+1/$prec/2)*$prec))/$prec;
    }
}

###############################################################################
1;
__END__