DTA-CAB

 view release on metacpan or  search on metacpan

CAB/Format/XmlRpc.pm  view on Meta::CPAN

##==============================================================================
## Constructors etc.
##==============================================================================

## $fmt = CLASS_OR_OBJ->new(%args)
##  + object structure:
##    (
##     ##-- input
##     rxprs  => $rpc_parser,      ##-- RPC::XML::Parser object
##     rxdata => $rpc_data,        ##-- structured data as decoded by RPC::XML::Parser
##
##     ##-- output
##     docbuf => $doc,             ##-- DTA::CAB::Document output buffer
##     xprs   => $xml_parser,      ##-- XML::LibXML parser object
##     level  => $formatLevel,     ##-- format level
##     encoding => $encoding,      ##-- output encoding
##
##     ##-- common
##    )
sub new {

CAB/Format/XmlRpc.pm  view on Meta::CPAN

=item new

 $fmt = CLASS_OR_OBJ->new(%args);

Constructor.

%args, %$fmt:

 ##-- input
 rxprs  => $rpc_parser,      ##-- RPC::XML::Parser object
 rxdata => $rpc_data,        ##-- structured data as decoded by RPC::XML::Parser
 ##
 ##-- output
 docbuf => $doc,             ##-- DTA::CAB::Document output buffer
 xprs   => $xml_parser,      ##-- XML::LibXML parser object
 level  => $formatLevel,     ##-- format level
 encoding => $encoding,      ##-- output encoding
 ##
 ##-- common
 #(nothing here)

CAB/Server/HTTP/Handler/CGI.pm  view on Meta::CPAN

      $h->decodeStringRef(\$_,%opts) foreach (@{$$vref});
    } else {
      #$$vref = $h->decodeString($$vref,%opts); ##-- BUG here with YAML data (test-pp.t.yaml) UTF-8 flag not set after call!
      $h->decodeStringRef($vref,%opts);
    }
  }
  return $vars;
}

## \$string = $h->decodeString(\$string,%opts); ##-- decodes in-place
## $decoded = $h->decodeString( $string,%opts); ##-- decode by copy
##  + decodes string as UTF-8, optionally handling HTML-style escapes
##  + %opts:
##     allowHtmlEscapes => $bool,    ##-- whether to handle HTML escapes (default=false)
##     #encoding        => $enc,     ##-- source encoding (default=$h->{encoding}; see also $h->requestEncoding())
sub decodeString {
  my ($h,$str,%opts) = @_;
  return $h->decodeStringRef($str,%opts) if (ref($str));
  return ${$h->decodeStringRef(\$str,%opts)};
}

CAB/Server/HTTP/Handler/CGI.pm  view on Meta::CPAN

}

## $enc = $h->messageEncoding($httpMessage,$defaultEncoding)
##  + attempts to guess messagencoding from (in order of descending priority):
##    - HTTP::Message header Content-Type charset variable
##    - HTTP::Message header Content-Encoding
##    - $defaultEncoding (default=undef)
sub messageEncoding {
  my ($h,$msg,$default) = @_;
  my $ctype = $msg->header('Content-Type'); ##-- note: $msg->content_type() truncates after ';' !
  ##-- see also HTTP::Message::decoded_content() for a better way to parse header parameters!
  ##
  return $1 if (defined($ctype) && $ctype =~ /\bcharset=([\w\-]+)/);
  #$ctype    = $msg->header('Content-Encoding');
  #return $1 if (defined($ctype) && $ctype =~ /\bcharset=([\w\-]+)/);
  #return $ctype if (defined($ctype));
  return $default;
}

## $enc = $h->getEncoding(@sources)
##  + attempts to guess request encoding from the first defined

CAB/Server/HTTP/Handler/CGI.pm  view on Meta::CPAN

Decodes cgi-style variables using $h-E<gt>decodeString($str,%opts).
Known %opts:

 vars    => \@vars,      ##-- list of vars to decode (default=keys(%vars))
 someKey => $someVal,    ##-- passed to $h-E<gt>decodeString()

=item decodeString

 \$string = $h->decodeString(\$string,%opts); ##-- decodes in-place;
 $decoded = $h->decodeString( $string,%opts); ##-- decode by copy

Wrapper for L</decodeStringRef>().

=item decodeStringRef

 \$string = $h->decodeStringRef(\$string,%opts); ##-- decodes in-place;

Decodes string in-place as $h-E<gt>{encoding}, optionally handling HTML-style escapes.
Known %opts:

CAB/Socket.pm  view on Meta::CPAN

  $_[0]->logcluck("cannot handle client client request ${$_[2]}");
  return undef;
}

##==============================================================================
## Protocol
##  + all socket messages are of the form pack('NN/a*', $flags, $message_data)
##  + $flags is a bitmask of DTA::CAB::Socket flags ($sf_* constants)
##  + length element (second 'N' of pack format) is always 0 for serialized references
##  + $message_data is one of the following:
##    - if    ($flags & $sf_ref)   -> a reference written with nstore_fd(); will be decoded
##    - elsif ($flags & $sf_u8)    -> a UTF-8 encoded string; will be decoded
##    - elsif ($flags & $sf_undef) -> a literal undef value
##    - elsif ($flags & $sf_eoq)   -> undef as end-of-queue marker

##--------------------------------------------------------------
## Protocol: Constants
our $sf_eoq   = 0x1;
our $sf_undef = 0x2;
our $sf_u8    = 0x4;
our $sf_ref   = 0x8;

CAB/Socket.pm  view on Meta::CPAN

sub get_ref_data {
  $_[0]->vtrace("get_ref_data", @_[1..$#_]);
  return
    Storable::fd_retrieve($_[0]{fh})
      || $_[0]->logconfess("get_ref_data(): fd_retrieve() failed");
}

## \$str_or_undef = $s->get_str_data($flags, $len)
## \$str_or_undef = $s->get_str_data($flags, $len, \$str)
##  + reads string bytes from the socket (header should already have been read)
##  + returned value is auto-magically decoded
sub get_str_data {
  $_[0]->vtrace("get_str_data", @_[1..$#_]);
  my $s   = shift;
  my $bufr = $s->get_data(@_[1,2]);
  $$bufr = '' if (!defined($$bufr));           ##-- get_data() returns empty string as undef
  utf8::decode($$bufr) if ($_[0] & $sf_u8);
  return $bufr;
}

CAB/Utils.pm  view on Meta::CPAN

  $s =~ s/\"/\"/g;
  $s =~ s/\</\&lt;/g;
  $s =~ s/\>/\&gt;/g;
  return $s;
}

##==============================================================================
## Functions: Deep recoding
##==============================================================================

## $decoded = deep_decode($encoding,$thingy,%options)
##  + %options:
##     force    => $bool,   ##-- decode even if the utf8 flag is set
##     skipvals => \@vals,  ##-- don't decode (or recurse into)  $val (overrides $force)
##     skiprefs => \@refs,  ##-- don't decode (or recurse into) $$ref (overrides $force)
##     skippkgs => \@pkgs,  ##-- don't decode (or recurse into) anything of package $pkg (overrides $force)
sub deep_decode {
  my ($enc,$thingy,%opts) = @_;
  my %skipvals = defined($opts{skipvals}) ? (map {($_=>undef)} @{$opts{skipvals}}) : qw();
  my %skiprefs = defined($opts{skiprefs}) ? (map {($_=>undef)} @{$opts{skiprefs}}) : qw();
  my %skippkgs = defined($opts{skippkgs}) ? (map {($_=>undef)} @{$opts{skippkgs}}) : qw();

CAB/Utils.pm  view on Meta::CPAN

 use DTA::CAB::Utils;
 
 ##========================================================================
 ## Functions: XML strings
 
 $safe = xml_safe_string($str);
 
 ##========================================================================
 ## Functions: Deep recoding
 
 $decoded = deep_decode($encoding,$thingy,%options);
 $encoded = deep_encode($encoding,$thingy,%opts);
 $recoded = deep_recode($from,$to,$thingy, %opts);
 $upgraded = deep_utf8_upgrade($thingy);
 
 ##========================================================================
 ## Functions: abstract data path value
 
 $val_or_undef = path_value($obj,@path);

=cut

CAB/Utils.pm  view on Meta::CPAN

##----------------------------------------------------------------
## DESCRIPTION: DTA::CAB::Utils: Functions: Deep recoding
=pod

=head2 Functions: Deep recoding

=over 4

=item deep_decode

 $decoded = deep_decode($encoding,$thingy,%options);

Perform recursive string decoding on all scalars in $thingy.
Does B<NOT> check for cyclic references.

%options:

 force    => $bool,   ##-- decode even if the utf8 flag is set
 skipvals => \@vals,  ##-- don't decode (or recurse into)  $val (overrides $force)
 skiprefs => \@refs,  ##-- don't decode (or recurse into) $$ref (overrides $force)
 skippkgs => \@pkgs,  ##-- don't decode (or recurse into) anything of package $pkg (overrides $force)

dta-cab-http-check.perl  view on Meta::CPAN

}

my $time  = sprintf("%.3f", tv_interval($t0));

##-- parse response & add perforamance data
$mp->add_perfdata(label=>'time', value=>$time, uom=>'s');
my $status = {};
my $rc  = OK;
my $msg = '';
if ($rsp->is_success) {
  my $data = $rsp->decoded_content;
  vmsg($vl_trace, "got response = ", $data);

  if ($qmode eq 'status') {
    ##-- status check
    eval { $status = from_json($data); };
    die("$prog: failed to parse status response: $@") if (!$status);

    ##-- get status perfdata
    my $memMB = sprintf("%.2f", ($status->{memSize}//0) / 1024);
    my $rssMB = sprintf("%.2f", ($status->{memRSS}//0) / 1024);