File Coverage

blib/lib/Jamila.pm

Criterion	Covered	Total	%
statement	18	82	21.9
branch	0	28	0.0
condition	0	5	0.0
subroutine	6	11	54.5
pod	3	3	100.0
total	27	129	20.9

package Jamila;
use strict;
use warnings;
use utf8;
use CGI;
use JSON;
use LWP;
our $oCgi;
our $VERSION = '0.03';

#--------------------------------------------------------------------
# _disp: display about processing class
#--------------------------------------------------------------------
sub _disp($$$)
{
  my ($sClass, $sUrl, $sMod) = @_;
  binmode STDOUT, ':utf8';
  print "Content-Type: text/html\n\n";
  print<


$sClass ($sMod)


This is $sClass !
for : $sMod at $sUrl


EOD
}
#--------------------------------------------------------------------
# proc
#--------------------------------------------------------------------
sub proc($$)
{
  my($sClass, $sMod) = @_;
  $oCgi = new CGI();
  my $sPrm = $oCgi->param('_prm');
  #1. No '_prm' means default display
  return $sClass->_disp($oCgi->url(), $sMod) if(!defined($sPrm) || $sPrm eq '');

  #2. _RAW_
  utf8::decode($sPrm); #become with utf8-flag
  my $oRes = '';
  my $sMsg = '';

  if($sPrm eq '_RAW_')
  {
    my $sMethod = '_raw_' . ($oCgi->param('_method') || '');
    eval
    {
      $oRes = $sMod->$sMethod($oCgi);
    };
    return unless($@);
    $sMsg = $@;
  }
  else
  {
    if($sPrm)
    {
      my $raData = from_json($sPrm);
      my ($sMethod, @aPrm) = @$raData;
      if(substr($sMethod, 0, 1) ne '_')
      {
        eval
        {
          $oRes = $sMod->$sMethod(@aPrm);
        };
        if($@)
        {
          eval
          {
            eval "require $sMod; import $sMod;";
            $oRes = $sMod->$sMethod(@aPrm);
          };
          if($@)
          {
            $sMsg = $@;
            $oRes = '';
          }
        }
      }
      else
      {
        $sMsg = "Jamila:: can't call $sMethod";
      }
    }
    else
    {
      $sMsg = 'Jamila:: NO PARAM';
    }
  }
  binmode STDOUT, ':utf8';
  print "Content-Type: text/plain; charset=UTF-8\n\n" .
      to_json({
                error  => $sMsg,
                result => $oRes,
              });
}
#---------------------------------------------------------------------
# new : mainly for request
#---------------------------------------------------------------------
sub new($$)
{
  my($sClass, $sUrl) = @_;
  my $oUa = LWP::UserAgent->new();
  $oUa->env_proxy();
  return
    bless {
      URL => $sUrl,
      _lwpUa => $oUa,
      }, $sClass;
}
#---------------------------------------------------------------------
# _buildParam : for request
#---------------------------------------------------------------------
sub _buildParam($%)
{
    my($oSelf, %hParam) = @_;
    my $sPrm = '';
    if(%hParam)
    {
        while(my($sKey, $sVal) = each(%hParam))
        {
            $sPrm .= '&' if($sPrm ne '');
            $sVal = ($sVal)? URI::Escape::uri_escape_utf8($sVal) : '';
            $sPrm .= "$sKey=$sVal";
        }
    }
    return $sPrm;
}
#---------------------------------------------------------------------
# call :
#---------------------------------------------------------------------
sub call($@)
{
  my($oSelf, @aPrm) = @_;
  if(ref($oSelf->{URL}) ne '')
  {
    my $sFunc = shift(@aPrm);
    return $oSelf->{URL}->$sFunc(@aPrm);
  }
  else
  {
    my %hPrm;
    if(@aPrm)
    {
      $hPrm{_prm} = to_json(\@aPrm);
    }
    my $sPrm = $oSelf->_buildParam(%hPrm);
    my $oReq = new HTTP::Request('POST', $oSelf->{URL});
    $oReq->header('Content-Type',
          'application/x-www-form-urlencoded; charset=UTF-8');
    $oReq->header('Accept-Charset',  'UTF-8');
    $oReq->add_content($sPrm . "\x0d\x0a");
    my $oRes = $oSelf->{_lwpUa}->request($oReq);
    if ($oRes->is_success)
    {
        my $rhRes = from_json($oRes->content);
        die($rhRes->{error}) if($rhRes->{error});
        return $rhRes->{result};
    }
    else
    {
        die($oRes->as_string);
    }
  }
}
1;
__END__