view release on metacpan or  search on metacpan

CAB/Utils.pm  view on Meta::CPAN

  die ($@) if ($@);
  return wantarray ? @rc : $rc[0];
}


##==============================================================================
## Functions: version dump
##==============================================================================

## $str = cab_version(%opts)
##  + %opts:
##     program          => $program_name,    ##-- default: basename($0) (undef for no report)
##     program_version  => $program_version, ##-- default: undef (don't report)
##     author           => $author,          ##-- default: $DTA::CAB::Utils::CAB_AUTHOR
our $CAB_AUTHOR = "Bryan Jurish <jurish\@bbaw.de>";
sub cab_version {
  my %opts = @_;
  $opts{program} = basename($0) if (!exists($opts{program}));
  $opts{author}  = $CAB_AUTHOR  if (!exists($opts{author}));
  return
    (
     ($opts{program}
      ? ($opts{program}
	 .($opts{program_version} ? " version $opts{program_version}" : '')
	 .($opts{author} ? " by $opts{author}" : '')
	 ."\n")
      : '')
     ." : DTA::CAB version $DTA::CAB::VERSION\n"
     ." : $DTA::CAB::SVNVERSION\n"
    );
}

##==============================================================================
## Functions: XML strings
##==============================================================================

## $safe = xml_safe_string($str)
##  + returns an XML-safe string
sub xml_safe_string {
  my $s = shift;
  $s =~ s/\:\:/\./g;
  $s =~ s/[\s\/\\]/_/g;
  return $s;
}

## $xmlstr = xml_escape($str)
sub xml_escape {
  my $s = shift;
  $s =~ s/\&(?![\w\#]+\;)/\&amp;/g;
  $s =~ s/\'/\&apos;/g;
  $s =~ s/\"/\&quot;/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();
  my $force    = $opts{force};
  my @queue = (\$thingy);
  my ($ar);
  while (defined($ar=shift(@queue))) {
    if (exists($skiprefs{$ar}) || exists($skipvals{$$ar}) || (ref($$ar) && exists($skippkgs{ref($$ar)}))) {
      next;
    } elsif (UNIVERSAL::isa($$ar,'ARRAY')) {
      push(@queue, map { \$_ } @{$$ar});
    } elsif (UNIVERSAL::isa($$ar,'HASH')) {
      push(@queue, map { \$_ } values %{$$ar});
    } elsif (UNIVERSAL::isa($$ar, 'SCALAR') || UNIVERSAL::isa($$ar,'REF')) {
      push(@queue, $$ar);
    } elsif (!ref($$ar)) {
      $$ar = decode($enc,$$ar) if (defined($$ar) && ($force || !utf8::is_utf8($$ar)));
    }
  }
  return $thingy;
}

## $encoded = deep_encode($encoding,$thingy,%opts)
##  + %opts:
##     force => $bool,            ##-- encode even if the utf8 flag is NOT set
##     skipvals => \@vals,        ##-- don't encode (or recurse into)  $val (overrides $force)
##     skiprefs => \@refs,        ##-- don't encode (or recurse into) $$ref (overrides $force)
##     skippkgs => \@pkgs,        ##-- don't encode (or recurse into) anything of package $pkg (overrides $force)
sub deep_encode {
  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();
  my $force    = $opts{force};
  my @queue = (\$thingy);
  my ($ar);
  while (defined($ar=shift(@queue))) {
    if (exists($skiprefs{$ar}) || !defined($$ar) || exists($skipvals{$$ar}) || (ref($$ar) && exists($skippkgs{ref($$ar)}))) {
      next;
    } elsif (UNIVERSAL::isa($$ar,'ARRAY')) {
      push(@queue, map { \$_ } @{$$ar});
    } elsif (UNIVERSAL::isa($$ar,'HASH')) {
      push(@queue, map { \$_ } values %{$$ar});
    } elsif (UNIVERSAL::isa($$ar, 'SCALAR') || UNIVERSAL::isa($$ar,'REF')) {
      push(@queue, $$ar);
    } elsif (!ref($$ar)) {
      $$ar = encode($enc,$$ar) if (defined($$ar) && ($force || utf8::is_utf8($$ar)));
    }
  }
  return $thingy;
}

## $recoded = deep_recode($from,$to,$thingy, %opts);

CAB/Utils.pm  view on Meta::CPAN

##  + append a new sample value with timestamp $newTime
sub append {
  require Time::HiRes;
  my ($ema,$newVal,$newTime) = @_;
  $newVal  //= 0;
  $newTime   = [Time::HiRes::gettimeofday()] if (!$newTime);
  my $tdiff  = Time::HiRes::tv_interval($ema->{t},$newTime);
  my ($alpha);
  foreach (0..$#{$ema->{decay}}) {
    $alpha = exp(-$tdiff/$ema->{decay}[$_]);
    $ema->{vals}[$_] = (1-$alpha)*$newVal + $alpha*$ema->{vals}[$_];
  }
  $ema->{t} = $newTime;
  return $ema;
}

##  @vals = $ema->vals($newVal,$newTime)
## \@vals = $ema->vals($newVal,$newTime)
##  + wrapper for $ema->append($newVal,$newTime)->{vals}
##  + optionally append a sample and return current (decayed) value(s)
##  + default $newVal=0, default $newTime=[Time::HiRes::gettimeofday] --> current decayed sample values
sub vals {
  $_[0]->append(@_[1..$#_]);
  return wantarray ? @{$_[0]{vals}} : $_[0]{vals};
}


1; ##-- be happy

__END__

##========================================================================
## POD DOCUMENTATION, auto-generated by podextract.perl

##========================================================================
## NAME
=pod

=head1 NAME

DTA::CAB::Utils - generic DTA::CAB utilities

=cut

##========================================================================
## SYNOPSIS
=pod

=head1 SYNOPSIS

 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

##========================================================================
## DESCRIPTION
=pod

=head1 DESCRIPTION

=cut

##----------------------------------------------------------------
## DESCRIPTION: DTA::CAB::Utils: Globals
=pod

=head2 Globals

=over 4

=item Variable: @EXPORT

No symbols are exported by default.

=item Variable: %EXPORT_TAGS

Supports the following export tags:

 :xml     ##-- xml_safe_string
 :data    ##-- path_value
 :encode  ##-- deep_encode, deep_decode, deep_recode, deep_utf8_upgrade

=back

=cut

##----------------------------------------------------------------
## DESCRIPTION: DTA::CAB::Utils: Functions: XML strings
=pod

=head2 Functions: XML strings

=over 4

=item xml_safe_string

 $safe = xml_safe_string($str);

Returns a string $safe similar to the argument $str which
can function as an element or attribute name in XML.

=back

=cut

##----------------------------------------------------------------
## 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)


=item deep_encode

 $encoded = deep_encode($encoding,$thingy,%opts);

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

%opts:

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

=item deep_recode

 $recoded = deep_recode($from,$to,$thingy, %opts);

Wrapper for:

 deep_encode($to,deep_decode($from,$thingy,%opts),%opts);

=item deep_utf8_upgrade

 $upgraded = deep_utf8_upgrade($thingy);

Perform recursive utf_uprade() on all scalars in $thingy.
Does B<NOT> check for cyclic references.

=back

=cut

##----------------------------------------------------------------
## DESCRIPTION: DTA::CAB::Utils: Functions: abstract data path value
=pod

=head2 Functions: abstract data path value

=over 4

=item path_value

 $val_or_undef = path_value($obj,@path);

Gets the value of the data path @path in $obj.

=back