File Coverage

blib/lib/Config/XMLPerl.pm

Criterion	Covered	Total	%
statement	44	72	61.1
branch	10	30	33.3
condition	1	6	16.6
subroutine	12	13	92.3
pod	1	6	16.6
total	68	127	53.5

#############################################################################
## Name:        XMLPerl.pm
## Purpose:     Config::XMLPerl
## Author:      Graciliano M. P.
## Modified by:
## Created:     2004-01-15
## RCS-ID:
## Copyright:   (c) 2004 Graciliano M. P.
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

package Config::XMLPerl ;
use 5.006 ;

use strict qw(vars);

use vars qw($VERSION @ISA) ;

$VERSION = '0.01' ;

require Exporter;
@ISA = qw(Exporter);

our @EXPORT = qw(config_load) ;
our @EXPORT_OK = @EXPORT ;

###########
# REQUIRE #
###########

  use XML::Smart ;
  use Safe ;

########
# VARS #
########

  use vars qw($CACHE_DELAY) ;

  $CACHE_DELAY = 0 ;

  my ( %CACHE , $CACHE_SLEEP , $EVAL_VALUES_COMPARTMENT ) ;

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

  my @PERMIT_OPS = qw(
  :base_mem

    null stub pushmark const defined undef

    preinc i_preinc predec i_predec postinc i_postinc postdec i_postdec
    int hex oct abs pow multiply i_multiply divide i_divide
    modulo i_modulo add i_add subtract i_subtract

    left_shift right_shift bit_and bit_xor bit_or negate i_negate
    not complement

    lt i_lt gt i_gt le i_le ge i_ge eq i_eq ne i_ne ncmp i_ncmp
    slt sgt sle sge seq sne scmp

    substr stringify length ord chr

    ucfirst lcfirst uc lc quotemeta trans chop schop chomp schomp

    match split

    list lslice reverse

    cond_expr flip flop andassign orassign and or xor

    lineseq scope enter leave setstate

    rv2cv

    leaveeval


  gvsv gv gelem

  padsv padav padhv padany

  refgen srefgen ref

  time
  sort
  pack unpack
  ) ;

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


#######
# NEW #
#######

sub new {
  shift ; return config_load(@_) ;
}

###############
# CONFIG_LOAD #
###############

sub config_load {

  if ( my $doc = $CACHE{$_[0]} ) {

    if ( (time-$CACHE_SLEEP) > $CACHE_DELAY ) {
      my @stats = stat($_[0]) ;
      if ( $doc->{s} != $stats[7] || $doc->{t} != $stats[9] ) {
        $doc = undef ;
        delete $CACHE{$_[0]} ;
      }
    }
    return $doc->{x} if $doc ;
  }

  my ($data , $file) = read_data($_[0]) ;

  $data =~ s/(?:^|\n)[ \t]*#[^\n]+//gs ;

  my $xml = XML::Smart->new($data , 'html' ,
  lowtag => 1 ,
  lowarg => 1 ,
  on_char => \&on_char ,
  ) ;

  $xml = $xml->cut_root ;

  if ( $file ) {
    my @stats = stat($file) ;
    $CACHE{$file}{x} = $xml ;
    $CACHE{$file}{s} = $stats[7] ;
    $CACHE{$file}{t} = $stats[9] ;
  }

  return $xml ;
}

###########
# ON_CHAR #
###########

sub on_char {
  my ( $tag , $pointer , $pointer_back , $cont) = @_ ;

  my $data = $$cont ;

  my (@args) = ( $data =~ /[^\n\w]*(\w+[\w:\.]*[ \t]*(?:=>?|->|:)[ \t]*[^\n]+)/gs ) ;

  foreach my $args_i ( @args ) {
    $data =~ s/\Q$args_i\E//s ;
    my ($name,$val) = ( $args_i =~ /(\w+[\w:\.]*)[ \t]*(?:=>?|->|:)[ \t]*([^\n]+)/ );
    $val =~ s/\s*,\s*$// ;

    if    ( $val =~ /^'([^'\\]*)'$/ ) { $val = $1 ;}
    elsif ( $val =~ /^"([^"\\]*)"$/ ) { $val = $1 ;}
    elsif ( $val =~ /^(?:\{.*?\}|\[.*?\]|'.*?'|".*?")$/ ) { $val = reval($val) ;}

    $pointer->{$name} = $val ;
  }

  $data =~ s/\s+//gs ;

  if ( !$data ) { $$cont = undef ;}
}

#############
# READ_DATA #
#############

sub read_data {
  my $in = shift ;
  my ($data , $file , $fh) ;

  if ( ref($in) eq 'GLOB' ) { $fh = $in ;}
  elsif ( $in !~ /[\r\n]/s && -e $in ) {
    $file = $in ;
    open ($fh,$in) ; binmode($fh) ;
  }

  if ( $fh ) {
    1 while( read($fh , $data , 1024*8 , length($data) ) ) ;
  }
  elsif ($in =~ /[<>\r\n]/s) { $data = $in ;}

  $data =~ s/\r\n?/\n/gs ;

  return( $data , $file ) if wantarray ;
  return $data ;
}

#########
# REVAL #
#########

sub reval {
  if ( !$EVAL_VALUES_COMPARTMENT ) {
    $EVAL_VALUES_COMPARTMENT = Safe->new('Config::XMLPerl::EVAL') ;
    $EVAL_VALUES_COMPARTMENT->permit_only(@PERMIT_OPS) ;
  }
  return $EVAL_VALUES_COMPARTMENT->reval(@_) ;
}

###############
# CLEAN_CACHE #
###############

sub CLEAN_CACHE {
  %CACHE = () ;
  $CACHE_SLEEP = undef ;
}

#######
# END #
#######

sub END { &CLEAN_CACHE ;}

#######
# END #
#######

1;


__END__