File Coverage

blib/lib/IO/Util.pm

Criterion	Covered	Total	%
statement	155	182	85.1
branch	60	86	69.7
condition	23	40	57.5
subroutine	25	39	64.1
pod	7	10	70.0
total	270	357	75.6

package IO::Util ;
$VERSION = 1.5 ;
use 5.006_001 ;
use strict ;

# This file uses the "Perlish" coding style
# please read http://perl.4pro.net/perlish_coding_style.html

; use Carp
; $Carp::Internal{+__PACKAGE__}++
; use File::Spec

############# slurping files #############

; sub slurp
   { my %a = map {ref||path => $_} @_
   ; local $_ = defined $a{path}    ? $a{path}
              : defined $a{GLOB}    ? $a{GLOB}
              : (defined && length) ? $_
              : croak 'Wrong file argument, died'
   ; $a{SCALAR} ||= \ my $content
   ; if (  ref     eq 'GLOB'
        || ref \$_ eq 'GLOB'
        )
      { ${$a{SCALAR}} = do { local $/; <$_> }
      }
     else
      { open _ or croak "$^E, died"
      ; ${$a{SCALAR}} = do { local $/; <_> }
      ; close _
      }
   ; $a{SCALAR}
   }


############# unique ids #############

; my %charset = ( base34 => [ 1..9, 'A'..'N', 'P'..'Z' ]
                , base62 => [ 0..9, 'a'..'z', 'A'..'Z' ]
                )
; my $separator = '_'

; sub import
   { return unless @_
   ; require Exporter
   ; our @ISA = 'Exporter'
   ; our @EXPORT_OK = qw| capture
                          slurp
                          Tid Lid Uid
                          load_mml
                        |
   ; my ($pkg, @subs) = @_
   ; require Time::HiRes   if grep /id$/  , @subs
   ; require Sys::Hostname if grep /^Uid$/, @subs
   ; $pkg->export_to_level(1, @_)
   }

; sub _convert
   { my ( $num, $args ) = @_
   ; my $chars = defined $$args{chars}
                 ? ref($$args{chars}) eq 'ARRAY'
                   ? $$args{chars}
                   : exists $charset{$$args{chars}}
                     ? $charset{$$args{chars}}
                     : croak 'Invalid chars, died'
                 : $charset{base34}
   ; my $result = ''
   ; my $dnum = @$chars
   ; while ( $num > 0 )
      { substr($result, 0, 0) = $$chars[ $num % $dnum]
      ; $num = int($num/$dnum)
      }
   ; $result
   }

; sub Tid
   { require Time::HiRes
   ; my %args = @_
   ; my $sep = defined $args{separator} ? $args{separator} : $separator
   ; my($sec, $usec) = Time::HiRes::gettimeofday()
   ; my($new_sec, $new_usec)
   ; do{ ($new_sec, $new_usec) = Time::HiRes::gettimeofday() }
       until ( $new_usec != $usec || $new_sec != $sec )
   ; join $sep, map _convert($_, \%args), $sec , $usec
   }

; sub Lid
   { my %args = @_
   ; my $sep = defined $args{separator} ? $args{separator} : $separator
   ; join $sep, _convert($$, \%args), Tid(@_)
   }

; sub Uid
   { require Sys::Hostname
   ; my %args = @_
   ; my $sep = defined $args{separator} ? $args{separator} : $separator
   ; my $ip = sprintf '1%03d%03d%03d%03d'
            , $args{IP}
              ? @{$args{IP}}
              : unpack( "C4", (gethostbyname(Sys::Hostname::hostname()))[4] )
   ; join $sep, _convert($ip, \%args), Lid(@_)
   }

############# parsing cache #############

; our %PARSING_CACHE

; sub _path_mtime
   { my $path  = File::Spec->rel2abs($_[0])
   ; my $mtime = ( stat($path) )[9] or croak "$^E, died"
   ; $path, $mtime
   }

; sub _set_parsing_cache
   { my $type = shift
   ; my ($path, $mtime) = &_path_mtime
   ; $PARSING_CACHE{$type}{$path}{mtime} = $mtime
   ; $PARSING_CACHE{$type}{$path}{value} = $_[1]
   }

; sub _get_parsing_cache
   { my $type = shift
   ; my ($path, $mtime) = &_path_mtime
   ; exists $PARSING_CACHE{$type}{$path}               # if it is cached
     &&! $mtime > $PARSING_CACHE{$type}{$path}{mtime}  # and not old
     ? $PARSING_CACHE{$type}{$path}{value}
     : undef
   }

; sub _purge_parsing_cache
   { my $type = shift
   ; @_ || return delete $PARSING_CACHE{$type}
   ; map delete $PARSING_CACHE{$type}{$_}
   , map File::Spec->rel2abs($_)
   , @_
   }

############# loading MML #############


; my %parser_re = ( '<>' =>
                  qr/ \G(.*?)   # elements and text outside blocks
                      (?
                        (\w+)([^>]*?)  # id + attributes
                      (?  # not escaped '>'
                      (.*?)     # content
                      <\/\2>    # end
                    /xs
                  , '[]' =>
                  qr/ \G(.*?)   # elements and text outside blocks
                      (?
                        (\w+)([^\]]*?)  # id + attributes
                      (?
                      (.*?)     # content
                      \[\/\2\]    # end
                    /xs
                  , '{}' =>
                  qr/ \G(.*?)   # elements and text outside blocks
                      (?
                        (\w+)([^\}]*?)  # id + attributes
                      (?'
                      (.*?)     # content
                      \{\/\2\}    # end
                    /xs
                  )

; my %not_escaped_re = ( '<>' => qr/( (? )/xs
                       , '[]' => qr/( (?
                       , '{}' => qr/( (?
                       )

; my %comment_re = ( '<>' => qr//xs
                   , '[]' => qr/\[!--.*?--\]/xs
                   , '{}' => qr/\{!--.*?--\}/xs
                   )

; sub load_mml
   { my $mml = shift
   ; my $opt = ref $_[0] eq 'HASH' ? $_[0] : { @_ }
   ; if ( $$opt{optional} && not ref $mml )
      { return unless -f $mml
      }
   ; my $struct
   ; defined $$opt{cache} or $$opt{cache} = 1
   ; if ( $$opt{cache} && not ref $mml )
      { $struct = _get_parsing_cache 'mml_struct', $mml
      ; return $struct if $struct
      }
   ; defined $$opt{strict} or $$opt{strict} = 1
   ; my $content = ref $mml eq 'SCALAR' ? $mml : slurp $mml
   ; $$opt{markers} ||= '<>'
   ; $$content =~ s/$comment_re{$$opt{markers}}//g
   ; $struct = parse_mml( '', $content, $opt )
   ; unless ( $$opt{keep_root} )
      { ref $struct eq 'HASH'
        or croak 'Parsed structure is not a HASH reference: '
               . 'check your MML or set keep_root, died'
      ; $struct = $$struct{(keys %$struct)[0]}
      }
   ; $$opt{cache} &&! ref($mml)
     && _set_parsing_cache 'mml_struct', $mml, $struct
   ; $struct
   }

; sub parse_mml
   { my ($id, $mml, $opt) = @_
   ; my ($node, $control, $no_data)
   ; while ( $$mml =~ /$parser_re{$$opt{markers}}/g )
      { $no_data = 1
      ; my ( $garb, $child_id, $attr, $child_mml ) = ($1, $2, $3, $4)
      ; if ( $$opt{strict} )
         { $garb =~ /\S/ && croak
           "Garbage '$garb' found parsing element '$child_id', died"
         ; length $attr && croak
           "Attributes '$attr' found parsing element '$child_id', died"
         }
      ; my ($k) = grep $child_id =~ /$_/
                , keys %{$$opt{handler}}
      ; my $parser_sub = defined $k
                         ? $$opt{handler}{$k}
                         : \&parse_mml
      ; my $child = do{ no strict 'refs'
                      ; &$parser_sub($child_id, \$child_mml, $opt)
                      }
      ; if ( defined $child )
         { if ( defined $$control{$child_id} )
            { if ( $$control{$child_id} > 1 )
               { push @{$$node{$child_id}}, $child
               }
              else
               { $$node{$child_id} = [ $$node{$child_id}, $child ]
               }
            }
           else
            { $$node{$child_id} = $child
            }
         ; $$control{$child_id} ++
         }
      }
   ; return $node if $no_data
   ; $$opt{strict} && ( $$mml =~ $not_escaped_re{$$opt{markers}} )
	  and croak "Not escaped '$1' found in '$id' data, died"
	; $$mml =~ s/\\(.)/$1/g   # unescape
	; my ($k) = grep $id =~ /$_/
	          , keys %{$$opt{filter}}
   ; my $filter_sub = $$opt{filter}{$k} if defined $k
   ; $filter_sub
     ? do{ local $_ = $$mml
         ; no strict 'refs'
         ; &{$filter_sub}($id, $mml, $opt)
         }
     : $$mml
   }

; sub TRIM_BLANKS  # filter
   { s/^\s+//gm
   ; s/\s+$//gm
   ; $_
   }

; sub ONE_LINE    # filter
   { s/\n+/ /g
   ; $_
   }

; sub SPLIT_LINES  # handler
   { [ split /\n+/, parse_mml @_ ]
   }

############## capturing output #############

; sub capture (&;@)
   { my %a = map {ref, $_} @_
   ; $a{GLOB} ||= select
   ; local $IO::Util::WriteHandle::out_ref
     = $a{SCALAR} || \ my $scalar
   ; no strict 'refs'
   ; if ( my $tied = tied *{$a{GLOB}} )
      { my $tied_class = ref $tied
      ; bless $tied, 'IO::Util::WriteHandle'
      ; $a{CODE}->()
      ; bless $tied, $tied_class
      }
     else
      { tie *{$a{GLOB}}, 'IO::Util::WriteHandle'
      ; $a{CODE}->()
      ; untie *{$a{GLOB}}
      }
   ; $IO::Util::WriteHandle::out_ref
   }


###############################
; package IO::Util::WriteHandle
; use strict
; our $out_ref

; sub TIEHANDLE
   { bless \ my $dummy, $_[0]
   }

; sub WRITE
   { shift
   ; my( $scalar, $len, $offset ) = @_
   ; my $data = substr $scalar
                     , $offset || 0
                     , $len    || length $scalar
   ; $$out_ref .= $data
   ; length $data
   }

; sub PRINT
   { shift
   ; $$out_ref .= join defined $, ? $, : '', @_
   ; $$out_ref .= $\ if defined $\
   ; 1
   }

; sub PRINTF
   { shift
   ; $$out_ref .= sprintf shift, @_
   ; 1
   }

; sub OPEN    { 1 }
; sub CLOSE   { 1 }
; sub FILENO  { 1 }
; sub BINMODE { 1 }
; sub UNTIE   { 1 }

###### not supported #######
; sub READ     { 0 }
; sub READLINE { undef }
; sub GETC     { undef }
; sub TELL     {-1 }
; sub SEEK     { 0 }
; sub EOF      { 1 }


; 1
__END__