view release on metacpan or  search on metacpan

lib/Config/XMLPerl.pm  view on Meta::CPAN

    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 ;
}