File Coverage

blib/lib/DiaColloDB/WWW/CGI.pm

Criterion	Covered	Total	%
statement	49	288	17.0
branch	0	150	0.0
condition	0	59	0.0
subroutine	17	74	22.9
pod	52	52	100.0
total	118	623	18.9

##-*- Mode: CPerl; coding: utf-8; -*-
##
## File: DiaColloDB/WWW/CGI.pm
## Author: Bryan Jurish
## Description: collocation db, www wrappers: (f)cgi handler
##  + adapted from DbCgi.pm ( svn+ssh://odo.dwds.de/home/svn/dev/dbcgi/trunk/DbCgi.pm )

package DiaColloDB::WWW::CGI;
use DiaColloDB;
use DiaColloDB::Logger;
use CGI qw(:standard :cgi-lib);
use URI;
use URI::Escape qw(uri_escape_utf8);
use HTTP::Status;
use Encode qw(); #qw(encode decode encode_utf8 decode_utf8);
use File::Basename qw(basename dirname);
use File::ShareDir qw(); ##-- for shared template data
use Cwd qw(getcwd abs_path);
#use LWP::UserAgent;
use Template;
use JSON qw();
use Time::HiRes qw();
use utf8;
use Carp;
use strict;

BEGIN {
  #binmode(STDIN, ':utf8');
  #binmode(STDOUT,':utf8');
  binmode(STDERR,':utf8');
}

*isa = \&UNIVERSAL::isa;
*can = \&UNIVERSAL::can;

##======================================================================
## globals

our $VERSION = "0.02.003";
our @ISA  = qw(DiaColloDB::Logger);

##======================================================================
## constructors etc.

## $dbcgi = $that->new(%args)
##  + %args, object structure:
##    (
##     ##-- basic stuff
##     prog => basename($0),
##     ##
##     ##-- underlying CGI module
##     cgipkg => 'CGI',
##     ##
##     ##-- CGI params
##     defaults => {},
##     vars     => undef,
##     charset  => 'utf-8',
##     nodecode => {}, ##-- vars not to decode
##     ##
##     ##-- CGI environment stuff : see getenv() method
##     remote_addr => undef,
##     remote_user => undef,
##     request_method => undef,
##     request_uri => undef,
##     request_query => undef,
##     http_referer => undef,
##     http_host    => undef,
##     server_addr  => undef,
##     server_port  => undef,
##     ##
##     ##-- template toolkit stuff
##     ttk_package => (ref($that)||$that),
##     ttk_vars    => {},			##-- template vars
##     ttk_config  => {ENCODING=>'utf8'},	##-- options for Template->new()
##     ttk_process => {binmode=>':utf8'},	##-- options for Template->process()
##     ttk_dir     => abs_path(dirname($0)),
##     ttk_key     => undef,		##-- current template basename
##     ttk_rawkeys => {			##-- pseudo-set of raw keys
##     profile=>1,
##     },
##     ##
##     ##-- File::ShareDir stuff (fallbacks for ttk_dir)
##     ttk_sharedir => File::ShareDir::dist_dir("DiaColloDB-WWW")."/htdocs",
##    )
sub new {
  my $that = shift;
  my $dbcgi = bless({
		     ##-- basic stuff
		     prog => basename($0),
		     ##
		     ##-- underlying CGI module
		     cgipkg => 'CGI',
		     ##
		     ##-- CGI params
		     defaults => {},
		     vars     => undef,
		     charset  => 'utf-8',
		     nodecode => {}, ##-- vars not to decode
		     ##
		     ##-- CGI environment stuff : see getenv() method
		     remote_addr => undef,
		     remote_user => undef,
		     request_method => undef,
		     request_uri => undef,
		     request_query => undef,
		     http_referer => undef,
		     http_host    => undef,
		     server_addr  => undef,
		     server_port  => undef,
		     ##
		     ##-- template toolkit stuff
		     ttk_package => (ref($that)||$that),
		     ttk_vars    => {},			##-- template vars
		     ttk_config  => {ENCODING=>'utf8'},	##-- options for Template->new()
		     ttk_process => {binmode=>':utf8'},	##-- options for Template->process()
		     ttk_dir     => abs_path(dirname($0)),
		     ttk_key     => undef,		##-- current template basename
		     ttk_rawkeys => {			##-- pseudo-set of raw keys
				     profile=>1,
				    },
		     ##
		     ##-- File::ShareDir stuff (fallbacks for ttk_dir)
		     ttk_sharedir => File::ShareDir::dist_dir("DiaColloDB-WWW")."/htdocs",
		     ##
		     ##-- user args
		     @_,
		    }, ref($that)||$that);

  ##-- CGI package
  if ($dbcgi->{cgipkg}) {
    eval "use $dbcgi->{cgipkg} qw(:standard :cgi-lib);";
    $dbcgi->logconfess("new(): could not use {cgipkg} $dbcgi->{cgipkg}: $@") if ($@);
  }

  ##-- environment defaults
  $dbcgi->_getenv();

  return $dbcgi;
}

## @keys = $dbcgi->_param()
## $val  = $dbcgi->_param($name)
sub _param {
  my $dbcgi = shift;
  return $dbcgi->cgi('param',@_);
}

## $dbcgi = $dbcgi->_reset()
##  + resets CGI environment
sub _reset {
  my $dbcgi = shift;
  delete @$dbcgi{(qw(vars),
		qw(remote_addr remote_user),
		qw(request_method request_uri request_query),
		qw(http_referer http_host server_addr server_port),
	       )};
  return $dbcgi;
}

## $dbcgi = $dbcgi->_getenv()
sub _getenv {
  my $dbcgi = shift;
  $dbcgi->{remote_addr} = ($ENV{REMOTE_ADDR}||'0.0.0.0');
  $dbcgi->{remote_user} = ($ENV{REMOTE_USER} || getpwuid($>));
  $dbcgi->{request_method} = ($ENV{REQUEST_METHOD}||'GET');
  $dbcgi->{request_uri} = ($ENV{REQUEST_URI} || $0);
  $dbcgi->{request_query} = $ENV{QUERY_STRING};
  $dbcgi->{http_referer} = $ENV{HTTP_REFERER};
  $dbcgi->{http_host} = $ENV{HTTP_HOST};
  $dbcgi->{server_addr} = $ENV{SERVER_ADDR};
  $dbcgi->{server_port} = $ENV{SERVER_PORT};
  return $dbcgi;
}

## $dbcgi = $dbcgi->fromRequest($httpRequest,$csock)
##  + sets up $dbcgi from an HTTP::Request object
sub fromRequest {
  my ($dbcgi,$hreq,$csock) = @_;

  ##-- setup pseudo-environment
  my $uri = $hreq->uri;
  my @path = grep {$_ ne ''} $uri->path_segments;
  $dbcgi->{prog}        = $path[$#path] || 'index';
  $dbcgi->{remote_addr} = $ENV{REMOTE_ADDR} = $csock ? $csock->peerhost : '0.0.0.0';
  $dbcgi->{remote_port} = $ENV{REMOTE_PORT} = $csock ? $csock->peerport : '0';
  $dbcgi->{remote_user} = $ENV{REMOTE_USER} = '';
  $dbcgi->{request_method} = $ENV{REQUEST_METHOD} = $hreq->method;
  $dbcgi->{request_uri}   = $ENV{REQUEST_URI} = $uri->as_string;
  $dbcgi->{request_query} = $ENV{REQUEST_QUERY} = $uri->query;
  $dbcgi->{http_referer}  = $ENV{HTTP_REFERER} = $hreq->referer;
  $dbcgi->{http_host}   = $ENV{HTTP_HOST} = $uri->host || $csock->sockhost;
  $dbcgi->{server_addr} = $ENV{SERVER_ADDR} = $csock ? $csock->sockaddr : '0.0.0.0';
  $dbcgi->{server_port} = $ENV{SERVER_PORT} = $csock ? $csock->sockport : '0';

  ##-- setup variables
  my %vars = $uri->query_form;
  my $addVars = sub {
    my $add = shift;
    foreach (grep {defined $add->{$_}} keys %$add) {
      if (!exists($vars{$_})) {
	$vars{$_} = $add->{$_};
      } else {
	$vars{$_} = [ $vars{$_} ] if (!ref($vars{$_}));
	push(@{$vars{$_}}, ref($add->{$_}) ? @{$add->{$_}} : $add->{$_});
      }
    }
  };
  if ($hreq->method eq 'POST') {
    if ($hreq->content_type eq 'application/x-www-form-urlencoded') {
      ##-- POST: x-www-form-urlencoded
      $addVars->( {URI->new('?'.$hreq->content)->query_form} );
    }
    elsif ($hreq->content_type eq 'multipart/form-data') {
      ##-- POST: multipart/form-data: parse by hand
      foreach my $part ($hreq->parts) {
	my $pdis = $part->header('Content-Disposition');
	if ($pdis =~ /^form-data\b/) {
	  ##-- POST: multipart/form-data: part: form-data; name="PARAMNAME"
	  if ($pdis =~ /\bname=[\"\']?([\w\-\.\,\+]*)[\'\"]?/) {
	    $addVars->({ $1 => $part->content });
	    next;
	  }
	}
	##-- POST: multipart/form-data: part: anything other than 'form-data; name="PARAMNAME"'
	$addVars->({ POSTDATA => $part->content });
      }
    }
    elsif ($hreq->content_length > 0) {
      ##-- POST: anything else: use POSTDATA
      $addVars->({ POSTDATA => $hreq->content });
    }
  }
  $dbcgi->vars(\%vars);

  return $dbcgi;
}


## \%vars = $dbcgi->vars()
## \%vars = $dbcgi->vars(\%vars)
##   + get/set CGI variables, instantiating $dbcgi->{defaults} if present
sub vars {
  my ($dbcgi,$vars) = @_;
  return $dbcgi->{vars} if (defined($dbcgi->{vars}) && !defined($vars));
  $vars ||= $dbcgi->cgi('param') ? { %{$dbcgi->cgi('Vars')} } : {};

  if (($dbcgi->{cgipkg}//'CGI') ne 'CGI' || defined($vars->{POSTDATA})) {
    ##-- parse params from query string; required e.g. for CGI::Fast or non-form POST requests (which set POSTDATA)
    my $uri  = URI->new($dbcgi->{request_uri});
    my %urif = $uri->query_form();
    @$vars{keys %urif} = values %urif;
  }

  foreach (grep {!exists($vars->{$_}) && defined($dbcgi->{defaults}{$_})} keys %{$dbcgi->{defaults}||{}}) {
    ##-- defaults
    $vars->{$_} = $dbcgi->{defaults}{$_}
  }
  my ($tmp);
  foreach (keys %$vars) {
    ##-- decode (annoying temporary variable hack hopefully ensures that utf8 flag is set!)
    $tmp = $vars->{$_};
    $tmp =~ s/\x{0}/ /g;
    if ($dbcgi->{charset} && !utf8::is_utf8($tmp) && !exists($dbcgi->{nodecode}{$_})) {
      $tmp = Encode::decode($dbcgi->{charset},$tmp);
      #$dbcgi->trace("decode var '$_':\n+ OLD=$vars->{$_}\n+ NEW=$tmp\n");
      $vars->{$_} = $tmp;
    }
  }
  return $dbcgi->{vars} = $vars;
}

##======================================================================
## config loading (optional)

## $dbcgi = $dbcgi->load_config($filename)
##  + clobers %$dbcgi keys from JSON filename
sub load_config {
  my ($dbcgi,$file) = @_;
  open(RC,"<:raw",$file)
    or $dbcgi->logconfess("load_config(): failed for '$file': $!");
  local $/ = undef;
  my $buf = ;
  close RC
    or $dbcgi->logconfess("load_config(): close failed for '$file': $!");
  my $data = JSON::from_json($buf,{utf8=>1,relaxed=>1})
    or $dbcgi->logconfess("load_config(): from_json() failed for config data from '$file': $!");
  @$dbcgi{keys %$data} = values %$data;
  return $dbcgi;
}

##======================================================================
## Template Toolkit stuff

## $key = $dbcgi->ttk_key($key)
## $key = $dbcgi->ttk_key()
##  + returns current template key
##  + default is basename($dbcgi->{prog}) without final extension
sub ttk_key {
  my ($dbcgi,$key) = @_;
  ($key=basename($dbcgi->{prog})) =~ s/\.[^\.]*\z// if (!$key);
  return $key;
}

## @paths = $dbcgi->ttk_include()
## $paths = $dbcgi->ttk_include()
##  + returns ttk search path @$dbcgi->{qw(ttk_dir ttk_sharedir)}
##  + in scalar context returns ":"-separated list
sub ttk_include {
  my $dbcgi = shift;
  my @dirs = map {s/\/+\z//; abs_path($_)} grep {defined($_) && $_ ne ''} @$dbcgi{qw(ttk_dir ttk_sharedir)};
  return wantarray ? @dirs : join(":",@dirs);
}

## $file = $dbcgi->ttk_file()
## $file = $dbcgi->ttk_file($key)
##  + returns template filename for template key (basename) $key
##  + $key defaults to $dbcgi->{prog} without final extension
##  + searches in $dbcgi->{ttk_dir} or $dbcgi->{ttk_sharedir}
sub ttk_file {
  my ($dbcgi,$key) = @_;
  (my $dir  = $dbcgi->{ttk_dir} || '.') =~ s/\/+\z//;
  $key      = $dbcgi->ttk_key($key);
  my $file  = "$key.ttk";
  my @dirs  = $dbcgi->ttk_include();
  foreach (@dirs) {
    return "$_/$file" if (-f "$_/$file");
  }
  $dbcgi->logconfess("ttk_file(): could not find template file '$file' in ttk search path ".$dbcgi->ttk_include);
}

## $t = $dbcgi->ttk_template(\%templateConfigArgs)
##  + returns a new Template object with default args set
sub ttk_template {
  my ($dbcgi,$targs) = @_;
  my $t = Template->new(
			INTERPOLATE=>1,
			PRE_CHOMP=>0,
			POST_CHOMP=>1,
			EVAL_PERL=>1,
			ABSOLUTE=>1,
			RELATIVE=>1,
			INCLUDE_PATH =>scalar($dbcgi->ttk_include),
			%{$dbcgi->{ttk_config}||{}},
			%{$targs||{}},
		       );
  return $t;
}

## $data  = $dbcgi->ttk_process($srcFile, \%templateVars, \%templateConfigArgs, \%templateProcessArgs)
## $dbcgi = $dbcgi->ttk_process($srcFile, \%templateVars, \%templateConfigArgs, \%templateProcessArgs, $outfh)
## $dbcgi = $dbcgi->ttk_process($srcFile, \%templateVars, \%templateConfigArgs, \%templateProcessArgs, \$outbuf)
##  + process a template $srcFile, returns generated $data
sub ttk_process {
  my ($dbcgi,$src,$tvars,$targs,$pargs,$output) = @_;
  my $outbuf = '';
  my $t = $dbcgi->ttk_template($targs);
  $t->process($src,
	      {package=>$dbcgi->{ttk_package}, version=>$VERSION, ENV=>{%ENV}, %{$dbcgi->{ttk_vars}||{}}, cdb=>$dbcgi, %{$tvars||{}}},
	      (defined($output) ? $output : \$outbuf),
	      %{$dbcgi->{ttk_process}||{}},
	      %{$pargs||{}},
	     )
    or $dbcgi->logconfess("ttk_process(): template error: ".$t->error);
  return defined($output) ? $dbcgi : $outbuf;
}

##======================================================================
## CGI stuff: generic

## @error = $dbcgi->htmlerror($status,@message)
##  + returns a print()-able HTML error
sub htmlerror {
  my ($dbcgi,$status,@msg) = @_;
  $status = 500 if (!defined($status)); ##-- RC_INTERNAL_SERVER_ERROR
  my $title = 'Error: '.$status.' '.status_message($status);
  charset($dbcgi->{charset});
  my $msg = join(($,//''), @msg);
  $msg =~ s/\beval\s*\'(?:\\.|[^\'])*\'/eval '...'/sg; ##-- suppress long eval '...' messsages
  return
    (header(-status=>$status),
     start_html($title),
     h1($title),
     pre("\n",escapeHTML($msg),"\n"),
     end_html,
    );
}

## @whatever = $dbcgi->cgi($method, @args)
##  + call a method from the CGI package $dbcgi->{cgipkg}->can($method)
sub cgi {
  my ($dbcgi,$method)=splice(@_,0,2);
  CGI::charset($dbcgi->{charset}) if ($dbcgi->{charset});
  my ($sub);
  if (ref($method)) {
    return $method->(@_);
  }
  elsif ($sub=$dbcgi->{cgipkg}->can($method)) {
    return $sub->(@_);
  }
  elsif ($sub=CGI->can($method)) {
    return $sub->(@_);
  }
  $dbcgi->logconfess("cgi(): unknown method '$method' for cgipkg='$dbcgi->{cgipkg}'");
}

## undef = $dbcgi->cgi_main()
## undef = $dbcgi->cgi_main($ttk_key)
##  + wraps a template-instantiation for $ttk_key, by default basename($0)
sub cgi_main {
  my ($dbcgi,$key) = @_;
  my @content;
  my $israw = $dbcgi->{ttk_rawkeys}{$dbcgi->ttk_key($key)};
  eval {
    @content = $dbcgi->ttk_process($dbcgi->ttk_file($key), $dbcgi->vars, ($israw ? {ENCODING=>undef} : undef), ($israw ? {binmode=>':raw'} : undef));
  };
  if ($@) {
    $israw   = 0;
    @content = $dbcgi->htmlerror(undef, $@);
  }
  elsif (!@content || !defined($content[0])) {
    $israw   = 0;
    @content = $dbcgi->htmlerror(undef, "template '$key' returned no content");
  }

  if ($dbcgi->{charset}) {
    charset($dbcgi->{charset});
    binmode(\*STDOUT, ($israw ? ":raw" : ":encoding($dbcgi->{charset})"));
  }
  print @content;
}

## undef = $dbcgi->fcgi_main()
## undef = $dbcgi->fcgi_main($ttk_key)
##  + wraps a template-instantiation for $ttk_key, by default basename($0)
sub fcgi_main {
  my ($dbcgi,$key) = @_;
  require CGI::Fast;
  CGI::Fast->import(':standard');
  $dbcgi->{cgipkg} = 'CGI::Fast';
  while (CGI::Fast->new()) {
    $dbcgi->_getenv();
    $dbcgi->cgi_main($key);
    $dbcgi->_reset();
  }
}

##======================================================================
## Template stuff: useful aliases

sub remoteAddr { return $_[0]{remote_addr}; }
sub remoteUser { return $_[0]{remote_user}; }
sub requestMethod { return $_[0]{request_method}; }
sub requestUri { return $_[0]{request_uri}; }
sub requestQuery { return $_[0]{request_query}; }
sub httpReferer { return $_[0]{http_referer}; }
sub httpHost { return $_[0]{http_host}; }
sub serverAddr { return $_[0]{server_addr}; }
sub serverPort {
  return $_[0]{server_port} if ($_[0]{server_port});
  my $host = $_[0]->httpHost;
  return $1 if ($host && $host =~ /:([0-9]+)$/);
  return $ENV{HTTPS} ? 443 : 80; ##-- guess port from scheme
}


## $uri    = $dbcgi->uri()
## $uri    = $dbcgi->uri($uri)
sub uri {
  return URI->new($_[1]) if (defined $_[1]);
  my $dbcgi = shift;
  my $host = $dbcgi->httpHost // '';
  my $port = $dbcgi->serverPort;
  my $scheme = ($ENV{HTTPS} ? 'https' : 'http');
  return URI->new(
		  #($host ? "http://$host" : "file://")
		  ($host ? "${scheme}://$host" : "file://") ##-- guess scheme from HTTPS environment variable
		  .( ($host && $host =~ /:[0-9]+$/) || $port==($scheme eq 'https' ? 443 : 80) ? '' : ":$port" )
		  .$dbcgi->requestUri
		 );
}

## $scheme = $dbcgi->uriScheme($uri?)
## $opaque = $dbcgi->uriOpaque($uri?)
## $path   = $dbcgi->uriPath($uri?)
## $frag   = $dbcgi->uriFragment($uri?)
## $canon  = $dbcgi->uriCanonical($uri?)
## $abs    = $dbcgi->uriAbs($uri?);
sub uriScheme { $_[0]->uri($_[1])->scheme; }
sub uriPath { $_[0]->uri($_[1])->path; }
sub uriFragment { $_[0]->uri($_[1])->fragment; }
sub uriCanonical { $_[0]->uri($_[1])->canonical->as_string; }
sub uriAbs { $_[0]->uri($_[1])->abs->as_string; }

## $dir = $dbcgi->uriDir($uri?)
##  + returns URI up to but not including query or fragment, truncating any trailing slashes
sub uriDir {
  my $uri = $_[0]->uri($_[1])->as_string;
  $uri =~ s{[?#].*$}{};
  $uri =~ s{/+[^/]*$}{};
  return $uri;
}

## $auth   = $dbcgi->uriAuthority($uri?)
## $pquery = $dbcgi->uriPathQuery($uri?)
## \@segs   = $dbcgi->uriPathSegments($uri?)
## $query  = $dbcgi->uriQuery($uri?)
## \%form  = $dbcgi->uriQueryForm($uri?)
## \@kws    = $dbcgi->uriQueryKeywords($uri?)
sub uriAuthority { $_[0]->uri($_[1])->authority; }
sub uriPathQuery { $_[0]->uri($_[1])->path_query; }
sub uriPathSegments { [$_[0]->uri($_[1])->path_segments]; }
sub uriQuery { $_[0]->uri($_[1])->query; }
sub uriQueryForm { {$_[0]->uri($_[1])->query_form}; }
sub uriQueryKeywords { [$_[0]->uri($_[1])->query_keywords]; }

## $userinfo = $dbcgi->uriUserInfo($uri?)
## $host     = $dbcgi->uriHost($uri?)
## $port     = $dbcgi->uriPort($uri?)
sub userinfo { $_[0]->uri($_[1])->userinfo; }
sub uriHost { $_[0]->uri($_[1])->host; }
sub uriPort { $_[0]->uri($_[1])->port; }

## $uristr = quri($base, \%form)
sub quri {
  shift if (isa($_[0],__PACKAGE__));
  my ($base,$form)=@_;
  my $uri=URI->new($base);
  $uri->query_form($uri->query_form, map {utf8::is_utf8($_) ? Encode::encode_utf8($_) : $_} %{$form||{}});
  return $uri->as_string;
}

## $urisub = uuri($base, \%form)
## $uristr = $urisub->(\%form)
sub uuri {
  shift if (isa($_[0],__PACKAGE__));
  my $qbase = quri(@_);
  return sub { quri($qbase,@_); };
}

## $sqstring = sqstring($str)
sub sqstring {
  shift if (isa($_[0],__PACKAGE__));
  (my $s=shift) =~ s/([\\\'])/\\$1/g; "'$s'"
}

## $str = sprintf_(...)
sub sprintf_ {
  shift if (isa($_[0],__PACKAGE__));
  return CORE::sprintf($_[0],@_[1..$#_]);
}

## $mtime = $dbcgi->mtime($filename)
sub mtime {
  my $dbcgi = shift;
  my $file = shift;
  $file =~ s/^.*?=(\w+).*$/$1/ if ($file =~ /^dbi:/); ##-- trim dsns
  my @stat = stat($file);
  return $stat[9];
}

## $str = $dbcgi->timestamp()
##  + gets localtime timestamp
sub timestamp {
  #my $dbcgi = shift;
  return POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime());
}

## $json_str = PACKAGE->to_json($data)
## $json_str = PACKAGE::to_json($data)
## $json_str = PACKAGE->to_json($data,\%opts)
## $json_str = PACKAGE::to_json($data,\%opts)
sub to_json {
  shift if (isa($_[0],__PACKAGE__));
  return JSON::to_json($_[0]) if (@_==1);
  return JSON::to_json($_[0],$_[1]);
}

## $json_str = PACKAGE->from_json($data)
## $json_str = PACKAGE::from_json($data)
sub from_json {
  shift if (isa($_[0],__PACKAGE__));
  return JSON::from_json(@_);
}

## \@timeofday = PACKAGE->gettimeofday()
## \@timeofday = PACKAGE::gettimeofday()
sub gettimeofday {
  shift if (isa($_[0],__PACKAGE__));
  return [Time::HiRes::gettimeofday()];
}

## $secs = PACKAGE->tv_interval($t0,$t1)
## $secs = PACKAGE::tv_interval($t0,$t1)
sub tv_interval {
  shift if (isa($_[0],__PACKAGE__));
  return Time::HiRes::tv_interval(@_);
}

## \@timeofday = PACKAGE->t_start()
## \@timeofday = PACKAGE->t_start()
##  + sets package variable $t_started
our $t_started = [Time::HiRes::gettimeofday];
sub t_start {
  shift if (isa($_[0],__PACKAGE__));
  $t_started = [Time::HiRes::gettimeofday];
}

## $secs = PACKAGE->t_elapsed()
## $secs = PACKAGE->t_elapsed($t1)
## $secs = PACKAGE->t_elapsed($t0,$t1)
## $secs = PACKAGE::t_elapsed()
## $secs = PACKAGE::t_elapsed($t1)
## $secs = PACKAGE::t_elapsed($t0,$t1)
sub t_elapsed {
  shift if (isa($_[0],__PACKAGE__));
  my ($t0,$t1) = @_;
  return tv_interval($t_started,[Time::HiRes::gettimeofday]) if (!@_);
  return tv_interval($t_started,$_[0]) if (@_==1);
  return tv_interval($_[0],$_[1]);
}

## $enc = PACKAGE->encode_utf8($str, $force=0)
## $enc = PACKAGE::encode_utf8($str, $force=0)
##  + encodes only if $force is true or if not already flagged as a byte-string
sub encode_utf8 {
  shift if (isa($_[0],__PACKAGE__));
  return $_[0] if (!$_[1] && !utf8::is_utf8($_[0]));
  return Encode::encode_utf8($_[0]);
}

## $enc = PACKAGE->decode_utf8($str, $force=0)
## $enc = PACKAGE::decode_utf8($str, $force=0)
##  + decodes only if $force is true or if not flagged as a byte-string
sub decode_utf8 {
  shift if (isa($_[0],__PACKAGE__));
  return $_[0] if (!$_[1] && utf8::is_utf8($_[0]));
  return Encode::decode_utf8($_[0]);
}

1; ##-- be happy

__END__