#############################################################################
## Name:        HPLOO.pm
## Purpose:     OO-Classes for HPL.
## Author:      Graciliano M. P.
## Modified by:
## Created:     30/09/2003
## RCS-ID:      
## Copyright:   (c) 2003 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 Class::HPLOO ;

use 5.006 ;
use Filter::Simple ;
use strict ;

use vars qw($VERSION $SYNTAX) ;

$VERSION = '0.23';

my (%HTML , %COMMENTS , %CLASSES , $SUB_OO , $DUMP , $ALL_OO , $NICE , $NO_CLEAN_ARGS , $ADD_HTML_EVAL , $DO_NOTHING , $BUILD , $BUILD_PM_FILE , $BUILD_PM_VERSION , $USE_BASE , $RET_CACHE , $FIRST_SUB_IDENT , $PREV_CLASS_NAME) ;

my (%CACHE , $LOADED) ;

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

my (%REF_TYPES , $CLASS_NEW , $CLASS_NEW_ATTR , $SUB_AUTO_OO , $SUB_ALL_OO , $SUB_HTML_EVAL , $SUB_ATTR , $USE_BASE_REF) ;

if (!$LOADED) {
  
  %REF_TYPES = (
  '$' => 'SCALAR' ,
  '@' => 'ARRAY' ,
  '%' => 'HASH' ,
  '&' => 'CODE' ,
  '*' => 'GLOB' ,
  ) ;
  
  my $CLASS_EXTRAS = q`
    sub SUPER {
      eval('package Class::HPLOO::Base ;') if !defined *{'Class::HPLOO::Base::'} ;
      
      my ($prev_pack , undef , undef , $sub0) = caller(1) ;
      $prev_pack = undef if $prev_pack eq 'Class::HPLOO::Base' ;
      
      my ($pack,$sub) = ( $sub0 =~ /^(?:(.*?)::|)(\w+)$/ );
      my $sub_is_new_hploo = $sub0 =~ /^(.*?(?:::)?$sub)\::$sub$/ ? 1 : undef ;
    
      unshift(@_ , $prev_pack) if ( $sub_is_new_hploo && $prev_pack && ((!ref($_[0]) && $_[0] ne $prev_pack && !UNIVERSAL::isa($_[0] , $prev_pack)) || (ref($_[0]) && !UNIVERSAL::isa($_[0] , $prev_pack)) ) ) ;
    
      if ( defined @{"$pack\::ISA"} ) {
        my $isa_sub = ISA_FIND_NEW($pack, ($sub_is_new_hploo?'new':$sub) ,1) ;
        my ($sub_name) = ( $isa_sub =~ /(\w+)$/gi );
        if ( $sub0 ne $isa_sub && !ref($_[0]) && $isa_sub =~ /^(.*?(?:::)?$sub_name)\::$sub_name$/ ) {
          @_ = ( bless({},$_[0]) , @_[1..$#_] ) ;
        }
        if ( $sub0 eq $isa_sub && UNIVERSAL::isa($_[0] , $pack) ) {
          my @isa = Class::HPLOO::Base::FIND_SUPER_WALK( ref($_[0]) , $pack ) ;
          my $pk = $isa[-1] ;
          if ( $sub_is_new_hploo ) {
            if ( UNIVERSAL::isa($pk , 'Class::HPLOO::Base') ) {
              ($sub) = ( $pk =~ /(\w+)$/gi );        
            }
            else { $sub = 'new' ;}
          }
          my $isa_sub = $pk->can($sub) ;
          return &$isa_sub( ARGS_WRAPPER(@_) ) if $isa_sub ;
        }
        return &$isa_sub(@_) if $isa_sub && defined &$isa_sub && $sub0 ne $isa_sub ;
      }
      $sub = $sub_is_new_hploo ? 'new' : $sub ;
      die("Can't find SUPER method for $sub0!") if "$pack\::$sub" eq $sub0 ;
      return &{"$pack\::$sub"}(@_) ;
    }
  
    sub FIND_SUPER_WALK {
      my $class_main = shift ;
      my $class_end = shift ;
      my $only_stak = shift ;
      
      my (@stack) ;
      my $stack = $only_stak || {} ;
      
      my $found ;
      foreach my $isa_i ( @{"$class_main\::ISA"} ) {
        next if $$stack{$isa_i}++ ;
        $found = 1 if $isa_i eq $class_end ;
        push(@stack , $isa_i , FIND_SUPER_WALK($isa_i , $class_end , $stack) );
      }
      
      return ($found ? @stack : ()) if $only_stak ;
      return @stack ;
    }
    
    sub ISA_FIND_NEW {
      my $pack = shift ;
      my $sub = shift ;
      my $look_deep = shift ;
      my $count = shift ;
      return if $count > 100 ;
        
      my ($sub_name) ;
      if ( UNIVERSAL::isa($pack , 'Class::HPLOO::Base') ) {
        ($sub_name) = $sub eq 'new' ? ( $pack =~ /(\w+)$/ ) : ($sub) ;
      }
      else { $sub_name = $sub ;}
      
      my $isa_sub = "$pack\::$sub_name" ;
      
      if ( $look_deep || !defined &$isa_sub ) {
        foreach my $isa_i ( @{"$pack\::ISA"} ) {
          next if $isa_i eq $pack || $isa_i eq 'Class::HPLOO::Base' ;
          last if $isa_i eq 'UNIVERSAL' ;
          $isa_sub = ISA_FIND_NEW($isa_i , $sub , 0 , $count+1) ;
          last if $isa_sub ;
        }
      }
      
      $isa_sub = undef if !defined &$isa_sub ; 
      return $isa_sub ;
    }
    
    sub new_call_BEGIN {
      my $class = shift ;
      my $this = $class ;
      foreach my $ISA_i ( @ISA ) {
        last if $ISA_i eq 'Class::HPLOO::Base' ;
        my $ret ;
        my ($sub) = ( $ISA_i =~ /(\w+)$/ );
        $sub = "$ISA_i\::$sub\_BEGIN" ;
        $ret = &$sub($this,@_) if defined &$sub ;
        $this = $ret if UNIVERSAL::isa($ret,$class) ;
      }
      return $this ;
    }
    
    sub new_call_END {
      my $class = shift ;
      foreach my $ISA_i ( @ISA ) {
        last if $ISA_i eq 'Class::HPLOO::Base' ;
        my $ret ;
        my ($sub) = ( $ISA_i =~ /(\w+)$/ );
        $sub = "$ISA_i\::$sub\_END" ;
        &$sub(@_) if defined &$sub ;
      }
      return ;
    }
  `;
  
  $CLASS_NEW = q`
    sub new {
      if ( !defined &%CLASS% && @ISA > 1 ) {
        foreach my $ISA_i ( @ISA ) {
          return &{"$ISA_i\::new"}(@_) if defined &{"$ISA_i\::new"} ;
        }
      }

      my $class = shift ; $class = ref($class) if ref($class) ;
      
      my $this = new_call_BEGIN($class , @_) ;
      $this = bless({} , $class) if !ref($this) || !UNIVERSAL::isa($this,$class) ;
      
      no warnings ;
      
      my $undef = \'' ;
      sub UNDEF {$undef} ;
      
      my $ret_this = defined &%CLASS% ? $this->%CLASS%(@_) : undef ;
      
      if ( ref($ret_this) && UNIVERSAL::isa($ret_this,$class) ) { $this = $ret_this }
      elsif ( $ret_this == $undef ) { $this = undef }
      
      new_call_END($class,$this,@_) ;

      return $this ;
    }
    
    sub CLASS_HPLOO_TIE_KEYS ;

  ` . $CLASS_EXTRAS ;
  
  $CLASS_NEW_ATTR = q`
    sub new {
      if ( !defined &%CLASS% && @ISA > 1 ) {
        foreach my $ISA_i ( @ISA ) {
          return &{"$ISA_i\::new"}(@_) if defined &{"$ISA_i\::new"} ;
        }
      }

      my $class = shift ; $class = ref($class) if ref($class) ;
      
      my $this = new_call_BEGIN($class , @_) ;
      $this = bless({} , $class) if !ref($this) || !UNIVERSAL::isa($this,$class) ;
      
      no warnings ;
      
      my $undef = \'' ;
      sub UNDEF {$undef} ;
      
      if ( $CLASS_HPLOO{ATTR} ) { CLASS_HPLOO_TIE_KEYS($this) }
      
      my $ret_this = defined &%CLASS% ? $this->%CLASS%(@_) : undef ;
      
      if ( ref($ret_this) && UNIVERSAL::isa($ret_this,$class) ) {
        $this = $ret_this ;
        if ( $CLASS_HPLOO{ATTR} && UNIVERSAL::isa($this,'HASH') ) { CLASS_HPLOO_TIE_KEYS($this) }
      }
      elsif ( $ret_this == $undef ) { $this = undef }
      
      new_call_END($this,@_) ;

      return $this ;
    }
    
    sub CLASS_HPLOO_TIE_KEYS {
      my $this = shift ;
      if ( $CLASS_HPLOO{ATTR} ) {
        foreach my $Key ( keys %{$CLASS_HPLOO{ATTR}} ) {
          tie( $this->{$Key} => '%PACKAGE%::HPLOO_TIESCALAR' , $this , $Key , $CLASS_HPLOO{ATTR}{$Key}{tp} , $CLASS_HPLOO{ATTR}{$Key}{pr} , \$this->{CLASS_HPLOO_ATTR}{$Key} , \$this->{CLASS_HPLOO_CHANGED} , '%PACKAGE%' ) if !exists $this->{$Key} ;
        }
      }
    }
    
  ` . $CLASS_EXTRAS ;
  
  $SUB_AUTO_OO = q`
    my $CLASS_HPLOO ;
  
    $CLASS_HPLOO = $this if defined $this ;
    my $this = ref($_[0]) && UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : $CLASS_HPLOO ;
    my $CLASS = ref($this) || __PACKAGE__ ;
  
    $CLASS_HPLOO = undef ;
  ` ;  
  
  $SUB_ALL_OO = q`
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
  ` ;
  
  ## my $this = ref($_[0]) && UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : undef ;
  
  $SUB_HTML_EVAL = q~
  sub CLASS_HPLOO_HTML {
    return '' if !$CLASS_HPLOO{HTML}{$_[0]} ;
    no strict ;
    return eval( ${$CLASS_HPLOO{HTML}{$_[0]}}[0] . " <<CLASS_HPLOO_HTML;\n". ${$CLASS_HPLOO{HTML}{$_[0]}}[1] ."CLASS_HPLOO_HTML\n" . (shift)[1]) if ( ref($CLASS_HPLOO{HTML}{$_[0]}) eq 'ARRAY' ) ;
    return eval("<<CLASS_HPLOO_HTML;\n". $CLASS_HPLOO{HTML}{$_[0]} ."CLASS_HPLOO_HTML\n" . (shift)[1] ) ;
  }
  ~ ;
  
  $SUB_ATTR = q`
  
  sub GET_CLASS_HPLOO_HASH { return \%CLASS_HPLOO } ;
  
  sub ATTRS { return @{[@{ $CLASS_HPLOO{ATTR_ORDER} }]} } ;
  
  sub CLASS_HPLOO_ATTR {
    my @attrs = split(/\s*,\s*/ , $_[0]) ;

    foreach my $attrs_i ( @attrs ) {
      $attrs_i =~ s/^\s+//s ;
      $attrs_i =~ s/\s+$//s ;
      my ($name) = ( $attrs_i =~ /(\w+)$/gi ) ;
      my ($type) = ( $attrs_i =~ /^((?:\w+\s+)*?&?\w+|(?:\w+\s+)*?\w+(?:(?:::|\.)\w+)*)\s+\w+$/gi ) ;
      
      my $type0 = $type ;
      $type0 =~ s/\s+/ /gs ;
      
      $type = lc($type) ;
      $type =~ s/(?:^|\s*)bool$/boolean/gs ;
      $type =~ s/(?:^|\s*)int$/integer/gs ;
      $type =~ s/(?:^|\s*)float$/floating/gs ;
      $type =~ s/(?:^|\s*)str$/string/gs ;
      $type =~ s/(?:^|\s*)sub$/sub_$name/gs ;
      $type =~ s/\s//gs ;
      
      $type = 'any' if $type !~ /^(?:(?:ref)|(?:ref)?(?:array|hash)(?:boolean|integer|floating|string|sub_\w+|any|&\w+)|(?:ref)?(?:array|hash)|(?:array|hash)?(?:boolean|integer|floating|string|sub_\w+|any|&\w+))$/ ;

      if ( $type eq 'any' && $type0 =~ /^((?:ref\s*)?(?:array|hash) )?(\w+(?:(?:::|\.)\w+)*)$/ ) {
        my ($tp1 , $tp2) = ($1 , $2) ;
        $tp1 =~ s/\s+//gs ;
        $tp2 = 'UNIVERSAL' if $tp2 =~ /^(?:obj|object)$/i ;
        $tp2 =~ s/\.+/::/gs ;
        $type = "$tp1$tp2" ;      
      }
      
      my $parse_ref = $type =~ /^(?:array|hash)/ ? 1 : 0 ;
      
      push(@{ $CLASS_HPLOO{ATTR_ORDER} } , $name) if !$CLASS_HPLOO{ATTR}{$name} ;
      
      $CLASS_HPLOO{ATTR}{$name}{tp} = $type ;
      $CLASS_HPLOO{ATTR}{$name}{pr} = $parse_ref ;

      my $return ;

      if ( $type =~ /^sub_(\w+)$/ ) {
        my $sub = $1 ;
        $return = qq~
          return (&$sub(\$this,\@_))[0] if defined &$sub ;
          return undef ;
        ~ ;
      }
      else {
         $return = $parse_ref ? qq~
                     ref(\$this->{CLASS_HPLOO_ATTR}{$name}) eq 'ARRAY' ? \@{\$this->{CLASS_HPLOO_ATTR}{$name}} :
                     ref(\$this->{CLASS_HPLOO_ATTR}{$name}) eq 'HASH' ? \%{\$this->{CLASS_HPLOO_ATTR}{$name}} :
                     \$this->{CLASS_HPLOO_ATTR}{$name}
                   ~ :
                   "\$this->{CLASS_HPLOO_ATTR}{$name}" ;
      }

      eval(qq~
      sub set_$name {
        my \$this = shift ;
        if ( !defined \$this->{$name} ) {
          tie( \$this->{$name} => '%PACKAGE%::HPLOO_TIESCALAR' , \$this , '$name' , '$type' , $parse_ref , \\\\\\$this->{CLASS_HPLOO_ATTR}{$name} , \\\\\\$this->{CLASS_HPLOO_CHANGED} , '%PACKAGE%' ) ;
        }
        
        \$this->{CLASS_HPLOO_CHANGED}{$name} = 1 ;
        \$this->{CLASS_HPLOO_ATTR}{$name} = CLASS_HPLOO_ATTR_TYPE( ref(\$this) , '$type',\@_) ;
      }
      ~) if !defined &{"set_$name"} ;
      
      eval(qq~
      sub get_$name {
        my \$this = shift ;
        $return ;
      }
      ~) if !defined &{"get_$name"} ;
    }
  }
  
  { package %PACKAGE%::HPLOO_TIESCALAR ;
    sub TIESCALAR {
      shift ;
      my $obj = shift ;
      my $this = bless( { nm => $_[0] , tp => $_[1] , pr => $_[2] , rf => $_[3] , rfcg => $_[4] , pk => ($_[5] || scalar caller) } , __PACKAGE__ ) ;
            
      if ( $this->{tp} =~ /^sub_(\w+)$/ ) {
        my $CLASS_HPLOO = %PACKAGE%::GET_CLASS_HPLOO_HASH() ;
      
        if ( !ref($$CLASS_HPLOO{OBJ_TBL}) ) {
          eval { require Hash::NoRef } ;
          if ( !$@ ) {
            $$CLASS_HPLOO{OBJ_TBL} = {} ;
            tie( %{$$CLASS_HPLOO{OBJ_TBL}} , 'Hash::NoRef') ;
          }
          else { $@ = undef }
        }

        $$CLASS_HPLOO{OBJ_TBL}{ ++$$CLASS_HPLOO{OBJ_TBL}{x} } = $obj ;
        $this->{oid} = $$CLASS_HPLOO{OBJ_TBL}{x} ;
      }

      return $this ;
    }
    
    sub STORE {
      my $this = shift ;
      my $ref = $this->{rf} ;
      my $ref_changed = $this->{rfcg} ;

      if ( $ref_changed ) {
        if ( ref $$ref_changed ne 'HASH' ) { $$ref_changed = {} }
        $$ref_changed->{$this->{nm}} = 1 ;
      }
      
      if ( $this->{pr} ) {
        my $tp = $this->{tp} =~ /^ref/ ? $this->{tp} : 'ref' . $this->{tp} ;
        $$ref = &{"$this->{pk}::CLASS_HPLOO_ATTR_TYPE"}($this->{pk} , $tp , @_) ;
      }
      else {
        $$ref = &{"$this->{pk}::CLASS_HPLOO_ATTR_TYPE"}($this->{pk} , $this->{tp} , @_) ;  
      }
    }
    
    sub FETCH {
      my $this = shift ;
      my $ref = $this->{rf} ;
      
      if ( $this->{tp} =~ /^sub_(\w+)$/ ) {
        my $CLASS_HPLOO = %PACKAGE%::GET_CLASS_HPLOO_HASH() ;
        my $sub = $this->{pk} . '::' . $1 ;
        my $obj = $$CLASS_HPLOO{OBJ_TBL}{ $this->{oid} } ;
        return (&$sub($obj,@_))[0] if defined &$sub ;
      }
      else {
        if ( $this->{tp} =~ /^(?:ref)?(?:array|hash)/ ) {
          my $ref_changed = $this->{rfcg} ;
          if ( $ref_changed ) {
            if ( ref $$ref_changed ne 'HASH' ) { $$ref_changed = {} }
            $$ref_changed->{$this->{nm}} = 1 ;
          }
        }
        return $$ref ;
      }
      return undef ;
    }    
    sub UNTIE {}
    sub DESTROY {}
  }
  
  sub CLASS_HPLOO_ATTR_TYPE {
    my $class = shift ;
    my $type = shift ;
    
    if ($type eq 'any') { return $_[0] }
    elsif ($type eq 'string') {
      return "$_[0]" ;
    }
    elsif ($type eq 'boolean') {
      return if $_[0] =~ /^(?:false|null|undef)$/i ;
      return 1 if $_[0] ;
      return ;
    }
    elsif ($type eq 'integer') {
      my $val = $_[0] ;
      my ($sig) = ( $val =~ /^(-)/ );
      $val =~ s/[^0-9]//gs ;
      $val = "$sig$val" ;
      return $val ;
    }
    elsif ($type eq 'floating') {
      my $val = $_[0] ;
      $val =~ s/[\s_]+//gs ;
      if ( $val !~ /^\d+\.\d+$/ ) {
        ($val) = ( $val =~ /(\d+)/ ) ;
        $val .= '.0' ;
      }
      return $val ;
    }
    elsif ($type =~ /^sub_(\w+)$/) {
      my $sub = $1 ;
      return (&$sub(@_))[0] if defined &$sub ;
    }
    elsif ($type =~ /^&(\w+)$/) {
      my $sub = $1 ;
      return (&$sub(@_))[0] if defined &$sub ;
    }
    elsif ($type eq 'ref') {
      my $val = $_[0] ;
      return $val if ref($val) ;
    }
    elsif ($type eq 'array') {
      my @val = @_ ;
      return \@val ;
    }
    elsif ($type eq 'hash') {
      my %val = @_ ;
      return \%val ;
    }
    elsif ($type eq 'refarray') {
      my $val = $_[0] ;
      return $val if ref($val) eq 'ARRAY' ;
    }
    elsif ($type eq 'refhash') {
      my $val = $_[0] ;
      return $val if ref($val) eq 'HASH' ;
    }
    elsif ($type =~ /^array(&?[\w:]+)/ ) {
      my $tp = $1 ;
      my @val = @_ ;
      my $accept_undef = $tp =~ /^(?:any|string|boolean|integer|floating|sub_\w+|&\w+)$/ ? 1 : undef ;
      if ( $accept_undef ) {
        return [map { CLASS_HPLOO_ATTR_TYPE($class , $tp , $_) } @val] ;
      }
      else {
        return [map { CLASS_HPLOO_ATTR_TYPE($class , $tp , $_) || () } @val] ;
      }
    }
    elsif ($type =~ /^hash(&?[\w:]+)/ ) {
      my $tp = $1 ;
      my %val = @_ ;
      foreach my $Key ( keys %val ) {
        $val{$Key} = CLASS_HPLOO_ATTR_TYPE($class , $tp , $val{$Key}) ;
      }
      return \%val ;
    }
    elsif ($type =~ /^refarray(&?[\w:]+)/ ) {
      my $tp = $1 ;
      return undef if ref($_[0]) ne 'ARRAY' ;
      my $ref = CLASS_HPLOO_ATTR_TYPE($class , "array$tp" , @{$_[0]}) ;
      @{$_[0]} = @{$ref} ;
      return $_[0] ;
    }
    elsif ($type =~ /^refhash(&?[\w:]+)/ ) {
      my $tp = $1 ;
      return undef if ref($_[0]) ne 'HASH' ;
      my $ref = CLASS_HPLOO_ATTR_TYPE($class , "hash$tp" , %{$_[0]}) ;
      %{$_[0]} = %{$ref} ;
      return $_[0] ;
    }
    elsif ($type =~ /^\w+(?:::\w+)*$/ ) {
      return( UNIVERSAL::isa($_[0] , $type) ? $_[0] : undef ) ;
    }
    return undef ;
  }
  ` ;
  
  $USE_BASE_REF = "use Class::HPLOO::Base ;" ;
  
  $CLASS_NEW   =~ s/[ \t]*\n[ \t]*/ /gs ;
  $CLASS_NEW_ATTR =~ s/[ \t]*\n[ \t]*/ /gs ;
  $SUB_AUTO_OO =~ s/[ \t]*\n[ \t]*/ /gs ;
  $SUB_ALL_OO  =~ s/[ \t]*\n[ \t]*/ /gs ;
  $SUB_HTML_EVAL  =~ s/[ \t]*\n[ \t]*/ /gs ;
  $SUB_ATTR  =~ s/[ \t]*\n[ \t]*/ /gs ;
  
  $LOADED = 1 ;

}

##########
# IMPORT #
##########

my %BUILDING ;

sub import {
  my $class = shift ;
  
  ($SUB_OO , $DUMP , $ALL_OO , $NICE , $NO_CLEAN_ARGS , $ADD_HTML_EVAL , $DO_NOTHING , $BUILD , $BUILD_PM_FILE , $BUILD_PM_VERSION , $USE_BASE , $RET_CACHE , $FIRST_SUB_IDENT , $PREV_CLASS_NAME) = () ;

  my $args = join(" ", @_) ;
  
  if ( $args =~ /(?:use)?[_\s]*base/i) { $USE_BASE = 1 ;}
  
  if ( $args =~ /build/i) { $args =~ s/(?:build|dump|nice)//gsi ; $BUILD = 1 ; $NICE = 1 ;}
  elsif    ( $args =~ /nice/i) { $args = "dump alloo nocleanarg" ; $NICE = 1 ;}
  
  if ( $args =~ /all[_\s]*oo/i) { $SUB_OO = $SUB_ALL_OO ; $ALL_OO = 1 ;}
  else { $SUB_OO = $SUB_AUTO_OO ;}
  
  if ( $args =~ /dump/i) { $DUMP = 1 ;}
  
  if ( $args =~ /no[_\s]*clean[_\s]*arg/i) { $NO_CLEAN_ARGS = 1 ;}
  
  if ( $args =~ /do\s*nothing/i ) { $DO_NOTHING = 1 ;}
  
  if ( $BUILD ) {
    unshift (@INC, sub {
      my @call = caller ;
      
      if ( $BUILDING{ $call[1] } ) {
        my $fh ;
        open ($fh, $BUILD_PM_FILE ) ;
        return $fh ;
      }
 
      undef ;
    }) if !%BUILDING ;
   
    my @call = caller ;
    $BUILDING{ $call[1] } = 1 ;
  }

}

##########
# FILTER #
##########

FILTER_ONLY( all => \&filter_html_blocks , code => \&CLASS_HPLOO , all => \&dump_code ) ;

#############
# DUMP_CODE #
#############

sub dump_code {
  return if $DO_NOTHING ;
  
  $_ = $CACHE{$_} if $RET_CACHE ;
  
  $_ =~ s/_CLASS_HPLOO_FIXER_//gs ;
  $_ =~ s/_CLASS_HPLOO_\/DIV_FIX_//gs ;  
  $_ =~ s/_CLASS_HPLOO_DIV_FIX/\//gs ;

  #if ( $DUMP || $BUILD ) {
    $_ =~ s/#_CLASS_HPLOO_CMT_(\d+)#/$COMMENTS{$1}/gs if %COMMENTS ;
  #}

  %COMMENTS = () ;

  if ( $DUMP ) {
    my $syntax = $_ ;
    $syntax =~ s/\r\n?/\n/gs ;
    print "$syntax\n" ;
    exit ;
  }
  
  if ( $BUILD ) {
    $BUILD = $_ ;
  }
  
  $CACHE{$CACHE{_}} = $_ ;
  ++$CACHE{X} ;
    
  $RET_CACHE = $CACHE{_} = undef ;
  
  %CLASSES = %HTML = () ;
  
}

######################
# FILTER_HTML_BLOCKS #
######################

sub filter_html_blocks {
  return if $DO_NOTHING || $_ !~ /\S/s ;
  
  if ( $CACHE{X} == 50 ) { %CACHE = () ;}
  
  if ( $CACHE{$_} ) { $RET_CACHE = 1 ; return ;}
  
  my $line_init ;
  {
    my ($c,@call) ;
    while( ($call[0] =~ /^Filter::/ || $call[0] eq '') && $c <= 10 ) { @call = caller(++$c) ;}
    $line_init = $call[2] ;
  }
  
  $_ =~ s/(?:\r\n?|\n)/\n/gs ;
  
  if ( $_ =~ /(.*)\n__END__\n.*?$/s ) {
    $_ = $1 ;
  }

  %CLASSES = %HTML = %COMMENTS = () ;
  
  my $set_init_line = !$BUILD ? "\n#line $line_init\n" : undef ;
  my $data = $CACHE{_} = $set_init_line . clean_comments("\n".$_) ;
  
  for(1..2) {
    $data =~ s/(\{\s*)((?:q|qq|qr|qw|qx|tr|x|y|s|m)\s*\})/$1\_CLASS_HPLOO_FIXER_$2/gs ;  ## {s}
    $data =~ s/(\W)((?:q|qq|qr|qw|qx|tr|x|y|s|m)\s*=>)/$1\_CLASS_HPLOO_FIXER_$2/gs ;   ## s =>
    $data =~ s/(->)((?:q|qq|qr|qw|qx|tr|x|y|s|m)\W)/$1\_CLASS_HPLOO_FIXER_$2/gs ;   ## ->s
  
    $data =~ s/([\$\@\%\*])((?:q|qq|qr|qw|qx|tr|x|y|s|m)(?:\W|\s+\S))/$1\_CLASS_HPLOO_FIXER_$2/gs ; ## $q
    $data =~ s/(-[sx])(\s+\S|[^\w\s])/$1\_CLASS_HPLOO_FIXER_$2/gs ; ## -s foo
    $data =~ s/(\Wsub\s+)((?:q|qq|qr|qw|qx|tr|x|y|s|m)[\s\(\{])/$1\_CLASS_HPLOO_FIXER_$2/gs ;  ## sub m {}
  
    $data =~ s/(\W)((?:q|qq|qr|qw|qx|tr|x|y|s|m)\s*[=,\)\}\]\>\*\;\+\-])/$1\_CLASS_HPLOO_FIXER_$2/gs ;   ## txt y = | (x-y) | , y ; | (y+1)
    
    $data =~ s/(<)(<)/$1\_CLASS_HPLOO_FIXER_$2/gs ;   ## $x <<= 1 ;
  }
  
  $data = _fix_div($data) ;
  
  $data =~ s/<%[ \t]*html?(\w+)[ \t]*>(?:(\(.*?\))|)/CLASS_HPLOO_HTML('$1',$2)/sgi ;
  
  if ( !$BUILD && !$NICE ) {
    $data =~ s/([\r\n][ \t]*<%\s*html\w+[ \t]*(?:\(.*?\))?[ \t]*[^\r\n]*(?:\r\n|[\r\n]).*?(?:\r\n|[\r\n])?%>)((?:\r\n|[\r\n])?)/
      my $blk = $1 ;
      my $dt = substr($data , 0 , pos($data)) . $blk . $2 ;
      my $ln = ($dt =~ tr~\n~~s) + $line_init ;
      "$blk#line $ln\n";
    /egsix ;
  }
                                   
  $data =~ s/([\r\n])[ \t]*<%\s*html(\w+)[ \t]*(\(.*?\))?[ \t]*[^\r\n]*(?:\r\n|[\r\n])(.*?)(?:\r\n|[\r\n])?%>(?:\r\n|[\r\n])?/
    my $tag = "<?CLASS_HPLOO_HTML_$2?>" ;
    $HTML{$tag}{a} = $3 if $3 ne '' ;
    $HTML{$tag}{1} = "$1\$CLASS_HPLOO{HTML}{'$2'} = " ;
    $HTML{$tag}{2} = "<<'CLASS_HPLOO_HTML';" ;
    $HTML{$tag}{3} = "\n$4" ;
    $HTML{$tag}{4} = "\nCLASS_HPLOO_HTML\n" ;
    $tag ;
  /egsix ;
  
  $data =~ s/([\r\n])<%.*?%>/$1/gs ;
  
  $ADD_HTML_EVAL = 1 if %HTML ;
  
  foreach my $Key ( keys %HTML ) {
    if ( $HTML{$Key}{a} ne '' ) {
      my $args = &generate_args_code( delete $HTML{$Key}{a} ) ;
      $HTML{$Key}{2} =~ s/;$// ;
      $HTML{$Key}{2} = "[ q`$args` , $HTML{$Key}{2} ];" ;
    }
  }

  $_ = $SYNTAX = $data ;
}

############
# _FIX_DIV #
############

sub _fix_div {
  my ( $data ) = @_ ;
  
  my ($data_ok , $init , $p) ;
  
  my $re = qr/
  (?:
    [^\/\\]?\/
  |
    (?:\\\\|\\\/)\/
  |
    (?:
      (?:\\\/)
    |
      [^\/]
    )+
    (?!\\)
    [^\/]?\/
  )
  /sx ;

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

  while( $data =~ /(.*?)\/(.*)/gs ) {
    $init = $1 ;
    $data = $2 ;
    
    $p = pos($data) ;
    
    if ( $init =~ /(?:^|\W)(?:tr|s|y)\s*$/s ) {
      my ($patern,$rest) = ( $data =~ /^($re$re)(.*)/s ) ;
      $data_ok .= "$init/$patern" ;
      $data = $rest ;
    }
    elsif ( $init =~ /(?:^|\W)(?:q|qq|qr|qw|qx|m)\s*$/s || $init =~ /(?:[=!]~|\()\s*$/s ) {
      my ($patern,$rest) = ( $data =~ /^($re)(.*)/s ) ;
      $data_ok .= "$init/$patern" ;
      $data = $rest ;
    }
    elsif ( $data =~ /^=/s ) {
      $data_ok .= "$init\_CLASS_HPLOO_DIV_FIX" ;
    }
    else {
      $data_ok .= "$init\_CLASS_HPLOO_\/DIV_FIX_/" ;
    }
  }
  
  $data_ok .= substr($data , $p) ;

  return $data_ok ;
}

###############
# CLASS_HPLOO #
###############

sub CLASS_HPLOO {
  return if $DO_NOTHING || $RET_CACHE || $_ !~ /\S/s ;
  
  my $data = $_ ;
  
  my (@ph) = ( $data =~ /(\Q$;\E....\Q$;\E)/gs );
  my $phx = -1 ;
  $data =~ s/\Q$;\E....\Q$;\E/"$;HPL_PH". ++$phx ."$;"/egs ;
  
  my $syntax = parse_class($data) ;
  
  if ( %CLASSES ) {
    1 while( $syntax =~ s/#_CLASS_HPLOO_CLASS_(\d+)#/$CLASSES{$1}/gs ) ;
  }
  
  $syntax .= "\n1;\n" if $syntax !~ /\s*1\s*;\s*$/ ;

  $syntax =~ s/(<\?CLASS_HPLOO_HTML_\w+\?>)/$HTML{$1}{1}$HTML{$1}{2}$HTML{$1}{3}$HTML{$1}{4}/gs ;
  $syntax =~ s/\Q$;\EHPL_PH(\d+)\Q$;\E/$ph[$1]/gs ;
  
  %HTML = () ;
  
  $_ = $SYNTAX = $syntax ;
}

###############
# PARSE_CLASS #
###############

sub parse_class {
  my $data = shift ;
  my $is_subclass = shift ;
  
  my $first_sub_ident = $FIRST_SUB_IDENT ;
  $FIRST_SUB_IDENT = undef ;
  
  my $syntax ;
  my ( $init , $class ) ;

  while( $data =~ /^
    (.*?\W|)
    (
      [cC]lass\s+
      [\w\.:]+
      (?:
        \s*\[[ \t\w\.-]+\]
      )?
      (?:
        \s+[eE]xtends\s*[^\{\}]*
      )?
    )
    \s*(\{.*)
  $/gsx ) {
    $init = $1 ;
    $class = $2 ;
    $data = $3 ;

    my @ret = extract_block($data) ;
    
    if ($ret[0] ne '') {
      $class .= $ret[0] ;
      $data = $ret[1] ;
      $init =~ s/[ \t]+$//s ;
      
      $class = build_class($class) ;
      
      if ( $is_subclass ) {
        $CLASSES{ ++$CLASSES{x} } = $class ;
        $class = "#_CLASS_HPLOO_CLASS_$CLASSES{x}#" ;
      }
    }
    
    $syntax .= $init . $class ;
  }
  
  $syntax .= $data ;
  
  $FIRST_SUB_IDENT = $first_sub_ident ;
  
  return( $syntax ) ;
}

#################
# EXTRACT_BLOCK #
#################

sub extract_block {
  my ( $data ) = @_ ;
  
  my $block ;
  
  my $level ;
  while( $data =~ /(.*?)([\{\}])/gs ) {
    $block .= $1 . $2 ;
    if    ($2 eq '{') { ++$level ;}
    elsif ($2 eq '}') { --$level ;}
    if ($level <= 0) { last ;}
  }

  if ( $level != 0 ) {
    die("Missing right curly or square bracket at data:\n$_[0]") if !$DUMP ;
  }
  
  my ($end) = ( $data =~ /\G(.*)$/s ) ;
  
  return ($block,$end) ;
}

##################
# CLEAN_COMMENTS #
##################

sub clean_comments {
  my $data = shift ;
  
  if ( 1 || $DUMP || $BUILD ) {
    $data =~ s/(?:([\r\n][ \t]*)(#+[^\r\n]*)|([^\r\n\#\$])(#+[^\r\n]*))/++$COMMENTS{i} ; $COMMENTS{ $COMMENTS{i} } = (defined $2 ? $2 : $4) ; (defined $1 ? $1 : $3) . "#_CLASS_HPLOO_CMT_$COMMENTS{i}#"/gse ;
  }
  else {
    $data =~ s/(?:([\r\n][ \t]*)(#+[^\r\n]*)|([^\r\n\#\$])(#+[^\r\n]*))/ my $s = ' ' x length(defined $2 ? $2 : $4) ; (defined $1 ? $1 : $3) . "$s" /gse ;
  }

  return $data ;
}

###############
# BUILD_CLASS #
###############

sub build_class {
  my $code = shift ;
  
  my ($name,$version,$extends,$body) = ( $code =~ /
    class\s+
    ([\w\.:]+)
    (?:
      \s*\[[ \t]*([ \t\w\.-]+?)[ \t]*\]
    |)
    (?:
      \s+extends\s+
      (
        [\w\.:]+
        (?:
          \s*,\s*[\w\.:]+
        )*
      )
      \s*
    |
      \s+extends
    |)
    \s*{(.*)
  $/six ) ;
  
  $version =~ s/["'\s]//gs ;
  
  $body =~ s/}\s*$//s ;
  
  $name =~ s/^\./$PREV_CLASS_NAME\::/gs ;
  
  $name = package_name($name);
  
  my @extends = split(/\s*,\s*/s , $extends) ;
  foreach my $extends_i ( @extends ) {
    $extends_i = package_name($extends_i);
  }
  
  my $isa_base = 'Class::HPLOO::Base UNIVERSAL' ;
  
  if ( @extends ) {
    $extends = "push(\@ISA , qw(". join(' ',@extends) ." $isa_base)) ;" ;
  }
  else {
    $extends = "\@ISA = qw($isa_base) ;" ;
  }

  my $version_number ;
  if ( $version ) {
    $version_number = $version ;
    $version = "\$VERSION = '$version' ;" ;
  }
  
  my ($name_end) = ( $name =~ /(\w+)$/ );
  
  ## vars () ;
  $body =~ s~
    ((?:^|[^\w\s])\s*)(?:use\s+)?vars\s*\(
      (
        (?:
          \s*[\$\@\%]\w[\w:]*\s*
          (?:,\s*[\$\@\%]\w[\w:]*\s*)*
        )
      )
      \s*,?\s*
    \)
  ~
    my @vars = split(/\s*,\s*/s , $2) ;
    "$1use vars qw(". join(" ", @vars) .")" ;
  ~gsex ;
  
  ## attr ( foo , int bar , Foo::Bar bar ) ;
  my $add_attr ;
  
  {
    my $vars = qr/(?:(?:\w+\s+)*?&?\w+\s+|(?:\w+\s+)*?\w+(?:(?:::|\.)\w+)*\s+)?\w+/s ;
    
    $body =~ s~
      ((?:^|[^\w\s])\s*)(?:attrs?|attributes?)\s*\(
        (
          (?:
            \s*$vars\s*
            (?:,\s*$vars\s*)*
          )
        )
        \s*,?\s*
      \)
    ~
      $add_attr = 1 ;
      "${1}CLASS_HPLOO_ATTR('$2')" 
    ~gsex ;
  }
  
  my $new = $add_attr ? $CLASS_NEW_ATTR : $CLASS_NEW ;
  $new =~ s/%CLASS%/$name_end/gs ;
  $new =~ s/%PACKAGE%/$name/gs ;
  
  ##################
  
  {
    my $prev_class_name = $PREV_CLASS_NAME ;
    $PREV_CLASS_NAME = $name ;

    $body = parse_class($body , 1) ;

    $PREV_CLASS_NAME = $prev_class_name ;
  }
  
  my ($body , $extra_vars) = parse_subs($body,$name,$version_number) ;
  
  $body =~ s/^[ \t]*\n//gs ;
  
  my $sub_attr = $add_attr ? $SUB_ATTR : undef ;
  $sub_attr =~ s/%PACKAGE%/$name/gs ;
  
  my $sub_html_eval = $ADD_HTML_EVAL ? $SUB_HTML_EVAL : undef ;
  
  ###################
  
  my @local_vars ;

  push(@local_vars , '$this') if !$ALL_OO ;
  
  push(@local_vars , @$extra_vars) if ref $extra_vars && @$extra_vars ;

  my $local_vars ;
  if ( @local_vars ) { $local_vars = "my (". join(' , ', @local_vars) .") ;" ;}
  
  ###################
  
  my @global_vars = qw(%CLASS_HPLOO @ISA) ;
  
  push(@global_vars , '$VERSION') if $version ;

  my $global_vars ;
  if ( @global_vars ) { $global_vars = "use vars qw(". join(' ', @global_vars) .") ;" ;}
  
  ###################
  
  my $const_class = "my \$CLASS = '$name' ; sub __CLASS__ { '$name' } ;" ;
  
  my $use_base_ref = $USE_BASE ? $USE_BASE_REF : '' ;
    
  my $class ;
  
  if ( $NICE || $BUILD ) {
    $new = format_nice_sub($new) ;
    $sub_html_eval = format_nice_sub($sub_html_eval) if $sub_html_eval ;
    $sub_attr = format_nice_sub($sub_attr) if $sub_attr ;
  
    $class .= "{ package $name ;\n" ;
    $class .= "\n${FIRST_SUB_IDENT}use strict qw(vars) ; no warnings ;\n" ;
    
    $class .= "\n$FIRST_SUB_IDENT$global_vars\n" if $global_vars ;
    
    if ( $version ) {
      $version =~ s/;\s+/;\n$FIRST_SUB_IDENT/ ;
      $class .= "\n${FIRST_SUB_IDENT}$version\n" ;
    }
    
    $class .= "\n$FIRST_SUB_IDENT$extends\n" if $extends ;

    $class .= "\n$FIRST_SUB_IDENT$local_vars\n" if $local_vars ;
    
    $class .= "\n$FIRST_SUB_IDENT$const_class\n" ;
    
    $class .= "$new\n" if !$USE_BASE ;
    
    $class .= "\n$sub_html_eval\n" if $sub_html_eval ;
    
    $class .= "\n$sub_attr\n" if !$USE_BASE && $sub_attr ;
    
    $class .= "\n$FIRST_SUB_IDENT$use_base_ref\n" if $use_base_ref ;
  }
  else {
    $new = '' if $USE_BASE ;
    $sub_attr = '' if $USE_BASE ;
    
    $class .= "{ package $name ; use strict qw(vars) ; no warnings ;$global_vars$version$extends$local_vars$const_class$new$sub_html_eval$sub_attr$use_base_ref\n" ;
    $body =~ s/^(?:\r\n?|\n)//s ;
  }
  
  $class .= $body ;
  
  $class .= "\n}\n" ;
  
  return( $class ) ;
}

###################
# FORMAT_NICE_SUB #
###################

sub format_nice_sub {
  my $sub = shift ;
  if ( !$sub ) { return $sub ;}
  $sub =~ s/({\s+)/$1\n$FIRST_SUB_IDENT  /s ;
  $sub =~ s/(\s*;)\s*/$1\n$FIRST_SUB_IDENT  /gs ;
  $sub =~ s/^(\s*)/$1\n$FIRST_SUB_IDENT/gs ;
  $sub =~ s/\s+$//gs ;
  $sub =~ s/\n[ \t]*(})$/\n$FIRST_SUB_IDENT$1/s ;
  $sub =~ s/(\S)( {) (\S)/$1$2\n$FIRST_SUB_IDENT  $3/gs ;
  return $sub ;
}

###############
# FORMAT_NICE #
###############

sub format_nice {
  my $code = shift ;
  if ( !$code ) { return $code ;}
  $code =~ s/(\s*;)\s*/$1\n$FIRST_SUB_IDENT/gs ;
  $code =~ s/^(\s*)/$1\n$FIRST_SUB_IDENT/gs ;
  return $code ;
}

##############
# PARSE_SUBS #
##############

sub parse_subs {
  my $data = shift ;
  my $class_name = shift ;
  my $class_version = shift ;
  
  $class_version ||= '0.01' ;
  
  my $syntax ;
  
  my ( $init , $sub , %inline ) ;
  
  $data =~ s/\n__\[(\w+)\]__[ \t]*\n(.*?)\n__\[\1\]__[ \t]*\n/\nsub[$1] __INLINE_CODE__ {\n$2\n}\n/gs ;
  
  while( $data =~ /^
    (.*?\W|)
    (
      (?:
        (?:static)
        \s+
      )?
      sub\s+[\w\.:]+\s*
      (?:\(.*?\)|)?
    |
      sub\[\w+\].*?
    )
    \s*
    (\{.*)
  
  $/gsx ) {
    $init = $1 ;
    $sub = $2 ;
    $data = $3 ;
    
    if ( !$FIRST_SUB_IDENT ) {
      $FIRST_SUB_IDENT = $init ;
      $FIRST_SUB_IDENT =~ s/.*?([ \t]*)$/$1/s ;
    }
    
    my @ret = extract_block($data) ;
    
    if ($ret[0] ne '') {
      $sub .= $ret[0] ;
      $data = $ret[1] ;
      $sub = build_sub($sub,\%inline) ;
    }
    $syntax .= $init . $sub ;
  }
  
  $syntax .= $data ;
  
  my @extra_vars ;
  
  foreach my $Key ( sort keys %inline ) {
    #my $src = "use Inline $Key => <<'__INLINE_$Key\_SRC__' , NAME => '$class_name' , VERSION => '$class_version' ;\n\n" ;
    
    push(@extra_vars , "\%__${Key}__") ;
    
    my $src_header ;
    eval("require Class::HPLOO::Inline$Key") ;
    if (!$@) {
      $src_header = eval("Class::HPLOO::Inline$Key\::code_header()") ;
    }
    
    my $src = q`
my $INLINE_INSTALL ;
BEGIN {
  use Config ;
  my @installs = ($Config{installarchlib} , $Config{installprivlib} , $Config{installsitelib}) ;
  foreach my $i ( @installs ) { $i =~ s/[\\\\\/]/\//gs ;}
  $INLINE_INSTALL = 1 if ( __FILE__ =~ /\.pm$/ && ( join(" ",@INC) =~ /\Wblib\W/s || __FILE__ =~ /^(?:\Q$installs[0]\E|\Q$installs[1]\E|\Q$installs[2]\E)/ ) ) ;

` . qq`

  my \$config = 'use Inline $Key => Config' ;
  foreach my \$k (sort keys \%__${Key}__ ) {
    \$config .= " => '\$k' => \\\$__${Key}__{'\$k'}" ;
  }
  eval(\$config) ;
}
`;

    $src =~ s/^\s+//s ;
    $src =~ s/\s+$//s ;
    $src =~ s/\s+/ /gs ;
    $src .= "\n\n" ;
    
    my $pm_ver = $BUILD_PM_VERSION || $class_version ;

    $src .= qq`use Inline $Key => <<'__INLINE_$Key\_SRC__' , ( \$INLINE_INSTALL ? (NAME => '$class_name' , VERSION => '$pm_ver' ) : () ) ;\n\n` ;

    $src .= $src_header ;
    $src .= $inline{$Key} ;
    $src =~ s/\s+$/\n/s ;
    $src .= "\n__INLINE_$Key\_SRC__\n\n" ;
    $syntax .= $src ;
  }

  return($syntax , \@extra_vars) ;
}

#############
# BUILD_SUB #
#############

sub build_sub {
  my $code = shift ;
  my $inline = shift ;
  my $sub ;
  
  $code =~ s/\r\n?/\n/gs ;
  
  if ( $code =~ /^\s*sub\[\w+\]/ ) {
    my ($language,$header,$body) = ( $code =~ /^\s*sub\[(\w+)\]\s*(.*?)\s*{(.*)/s );
    $language = uc($language) ;
    
    if ( $header eq '__INLINE_CODE__' ) {
      $body =~ s/[ \t]*}\s*$/\n/s ;
      $$inline{$language} .= $body ;
    }
    else {
      if ( $language eq 'C' ) {
        require Class::HPLOO::InlineC ;
        $body = Class::HPLOO::InlineC::apply_CPL($body) ;
      }
      my $src = "$header {$body" ;
      $src =~ s/[ \t]*}\s*$/}\n\n/s ;
      $$inline{$language} .= $src ;
    }
  }
  else {
    my ($sub_type,$name,$prototype,$body) = ( $code =~ /^\s*(?:(static)\s+)?sub\s+([\w\.:]+)\s*((?:\(.*?\))?)\s*{(.*)/s );
    $body =~ s/}\s*$//s ;
    
    $name = package_name($name);
    
    my $no_sub_oo = $sub_type eq 'static' ? 1 : undef ;
    
    my $my_args ;
    if ( $prototype ) {
      if ( $prototype =~ /^\(\s*\*\s*\)$/ ) {
        $no_sub_oo = 1 ;
        $prototype = '' ;
      }
      else {
        $my_args = &generate_args_code($prototype) ;
        if ( $my_args ) { $prototype = '' ;}
        elsif (!$no_sub_oo) { $prototype =~ s/^(\()(.*)$/$1\$$2/gs ;}
      }
    }
    
    my $my_code = (!$no_sub_oo ? $SUB_OO : '') . $my_args ;
    
    if ( $NICE || $BUILD ) {
      my ($n,$ident) = ( $body =~ /(\r\n?|\n)([ \t]+)/s );
      $my_code =~ s/(\s*;)\s*/$1$n$ident/gs ;
      $my_code =~ s/^(\s*)/$1$n$ident/gs ;
    }
    
    $sub = "sub $name$prototype {$my_code$body}" ;
  }
  
  return $sub ;
}

################
# PACKAGE_NAME #
################

sub package_name {
  my ( $pack ) = @_ ;
  
  $pack =~ s/[:\.]+/::/gs ;
  $pack =~ s/:+$//s ;
  
  return( $pack ) ;
}

######################
# GENERATE_ARGS_CODE #
######################

sub generate_args_code {
  my $args = shift ;
  
  my $my_args ;

  if ($args =~ /\(
    \s*
    (
      (?:[\$\@\%]|\\[\@\%])\w[\w:]*\s*
      (?:,\s*(?:[\$\@\%]|\\[\@\%])\w[\w:]*\s*)*
    )
    \s*,?\s*
  \)/sx) {
    my ($vars , $clean_args) = $1 ;
    $vars =~ s/^\s+//gs ;
    $vars =~ s/\s+$//gs ;    
    my @vars = split(/\s*,\s*/s , $vars) ;
    
    foreach my $vars_i ( @vars ) {
      my ($ref,$type,$var) = ( $vars_i =~ /(\\?)([\$\@\%])(.*?)\s*$/gs );
      
      if ( $clean_args ) { $my_args .= "my $vars_i ;" ; next ;}
      
      if ($ref) {
        my $ref_type = $REF_TYPES{$type} ;
        
        if ($ref_type eq 'ARRAY') {
          $my_args .= "my $type$var = ref(\$_[0]) eq 'ARRAY' ? \@\{ shift(\@_) } : ( ref(\$_[0]) eq 'HASH' ? \%\{ shift(\@_) } : shift(\@_) ) ;" ;
        }
        elsif ($ref_type eq 'HASH') {
          $my_args .= "my $type$var = ref(\$_[0]) eq 'HASH' ? \%\{ shift(\@_) } : ( ref(\$_[0]) eq 'ARRAY' ? \@\{ shift(\@_) } : shift(\@_) ) ;" ;
        }
        else {
          $my_args .= "my $type$var = ref(\$_[0]) eq '$ref_type' ? $type\{ shift(\@_) } : shift(\@_) ;" ;
        }
      }
      elsif ($type ne '$') { $my_args .= "my $vars_i = \@_ ;" ; $clean_args = 1 ;}
      else { $my_args .= "my $vars_i = shift(\@_) ;" ;}
    }
    if ($clean_args) { $my_args .= "\@_ = () ;" ;}
  }
  
  return $my_args ;
}

###############
# BUILD_HPLOO #
###############

sub build_hploo {
  my ( $hploo_file , $pm_file , $pm_version ) = @_ ;
  
  my $file_data ;
  {
    open (my $fh,$hploo_file) ;
    $file_data = join '' , <$fh> ;
    close ($fh) ;
  }
  
  my ($file_init,$file_splitter,$file_end) ;
  
  if ( $file_data =~ /(.*)(\n__END__\n)(.*?)$/s ) {
    ($file_init,$file_splitter,$file_end) = ($1 , $2 , $3) ;
  }
  else {
    $file_init = $file_data ;
  }
  
  my ($import_args) = ( $file_init =~ /(?:^|\n)[ \t]*use[ \t]+Class::HPLOO(?:(\W.*?);|;)/s );
  
  $file_init =~ s/(?:^|\n)[ \t]*use[ \t]+Class::HPLOO(?:\W.*?;|;)//s ;

  $import_args = join ("", (eval($import_args))) ;
  $import_args =~ s/\W/ /gs ;
  $import_args =~ s/\s+/ /gs ;
  
  $file_init = "use Class::HPLOO qw(build $import_args);\n" . $file_init ;
  
  $BUILD_PM_FILE = $pm_file ;
  $BUILD_PM_VERSION = $pm_version ;  
  
  open (my $fh,">$pm_file") ;
  print $fh $file_init ;
  close ($fh) ;
  
  my ($path,$file) = ( $pm_file =~ /(?:(.*)[\\\/]|^)([^\\\/]+)$/s );
  
  {
    unshift (@INC, $path) ;
    
    my $pack = $file ;
    $pack =~ s/\.pm$//s ;

    eval(" use $pack ") ;
    
    delete $INC{$pack} ;
    shift (@INC) ;
  }
  
  my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
  $year += 1900 ;
  ++$mon ;
  
  $sec = "0$sec" if $sec < 10 ;
  $min = "0$min" if $min < 10 ;
  $hour = "0$hour" if $hour < 10 ;
  $mday = "0$mday" if $mday < 10 ;
  $mon = "0$mon" if $mon < 10 ;
  
  my $code = qq`#############################################################################
## This file was generated automatically by Class::HPLOO/$Class::HPLOO::VERSION
##
## Original file:    $hploo_file
## Generation date:  $year-$mon-$mday $hour:$min:$sec
##
## ** Do not change this file, use the original HPLOO source! **
#############################################################################
` . $BUILD ;

  $BUILD = undef ;
  
  my $epod ;
  eval(q` require ePod `);
  if ( !$@ ) { $epod = new ePod( over_size => 4 ) ;}
  
  if ( $file_end ne '' && $epod && $epod->VERSION >= 0.03 && $epod->is_epod($file_end) ) {
    $file_end = $epod->epod2pod($file_end) ;
    $file_end =~ s/^\n//s ;
  }
  
  $code .= $file_splitter . $file_end ;
  
  $code =~ s/\r\n?/\n/gs ;
  
  open ($fh,">$pm_file") ;
  print $fh $code ;
  close ($fh) ;
  
  return $code ;
}

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

1;


__END__

=head1 NAME

Class::HPLOO - Easier way to declare classes on Perl, based in the popular class {...} style and ePod.

=head1 DESCRIPTION

This is the implemantation of OO-Classes for HPL. This brings an easy way to create PM classes, but with HPL resources/style.

=head1 USAGE

  use Class::HPLOO ;

  class Foo extends Bar , Baz {
  
    use LWP::Simple qw(get) ; ## import the method get() to this package.
  
    attr ( array foo_list , int age , string name , foo ) ## define attributes.

    vars ($GLOBAL_VAR) ; ## same as: use vars qw($GLOBAL_VAR);

    my ($local_var) ;
  
    ## constructor/initializer:
    sub Foo {
      $this->{attr} = $_[0] ;
    }
  
    ## methods with input variables declared:
    sub get_pages ($base , \@pages , \%options) {
      my @htmls ;
      
      if ( $options{proxy} ) { ... }
  
      foreach my $pages_i ( @pages ) {
        my $url = "$base/$pages_i" ;
        my $html = get($url) ;
        push(@htmls , $html) ;
        $this->cache($url , $html) ;
      }
      
      return @htmls ;
    }
    
    ## methos like a normal Perl sub:
    sub cache {
      my ( $url , $html ) = @_ ;
      $this->{CACHE}{$url} = $html ;
    }
    
    sub attributes_example {
      $this->set_foo_list(qw(a b c d e f)) ;
      my @l = $this->get_foo_list ;
      
      $this->set_age(30) ;
      $this->set_name("Joe") ;
      $this->set_foo( time() ) ;
      print "NAME: ". $this->get_name ."\n" ;
      print "AGE: ". $this->get_age ."\n" ;
      print "FOO: ". $this->get_foo ."\n" ;
    }
    
  }
  
  ## Example of use of the class:
  
  package main ;
  
  my $foo = new Foo(123) ;
  $foo->get_pages('http://www.perlmonks.com/', ['/index.pl','/foo'] , {proxy => 'localhost:8080'}) ;

=head1 CONTRUCTOR

The "method" new() is automatically declared by Class::HPLOO, then it calls the initializer that is a method with the name of the class, like Java.

  class Foo extends {
    ## initializer:
    sub Foo {
      $this->{attr} = $_[0] ;
    }
  }

B<** Note that what the initializer returns is ignored! Unless you return a new constructed object or UNDEF.
Return UNDEF (a constant of the class) makes the creation of the object return I<undef>.>

=head1 DESTRUCTOR

Use DESTROY() like a normal Perl package.

=head1 Class VERSION

From Class::HPLOO 0.12, you can define the class version in it's declaration:

  class Foo [0.01] extends bar , baz {
   ...
  }

This is just a replacement of the original Perl syntax:

  use vars qw($VERSION) ;
  $VERSION = '0.01' ;

=head1 SUBs

The syntax for I<sub>s was extend to allow argument definitions:

  Class Foo {
    sub add( $x , $y ) {
      return $x + $y ;
    }
  }

Also you can define HASH and ARRAY arguments:

  Class Foo {
    sub add( \@list , $n , \%hash ) {
      foreach my $list_i ( @list ) {
        $list_i += $n ;
      }
    }
  }

This new syntax for arguments make much more easy to create functions and paste
references for HASHes and ARRAYs.

=head1 INLINE SUBs

From version B<0.18> is possible to define inline functions directly in the class code:

  class Foo {
  
    sub normal_perl_sub {
      print "PERL SUB> @_\n" ;
    }
  
    sub[C] int add( int x , int y ) {
      int res = x + y ;
      return res ;
    }
  
  }

The parser for the I<INLINE SUB>s is defined by:

  sub[\w+].*?{...}
       |   |   |
       |   |   ---> body.
       |   ---> sub/function/method header.
       ---> language

So, basically is possible to use any language that L<Inline> supports. Here's
a I<Java> example:

  class Foo {
  
    sub[Java] public void msg( String txt ) {
      System.out.println(txt) ;
    }
  
  }

B<Enjoy! ;-P>

=head1 ATTRIBUTES , GLOBAL VARS & LOCAL VARS

You can use 3 types of definitions for class variables:

=head2 ATTRIBUTES

The main difference of an attribute of normal Perl variables, is the existence of the
methods I<set> and I<get> for each attribute/key. Also an attribute can have a I<type>
definition and a handler, soo each value can be automatically formatted before be really set.

B<For better OO and persistence of objects ATTRIBUTES should be the main choice.>

To set an attribute you use:

To define:

  attr( type name , ref type name , array name , hash name , sub id )

To set:

  $this->set_name($val) ;
  ## or:
  $this->{name} = $val ;

To get:

  my $foo = $this->get_name ;
  ## or:
  my $foo = $this->{name} ;

The I<attr()> definition has this syntax:

  REF? ARRAY?|HASH? TYPE? NAME

=over 4

=item NAME

The name of the attribute.

An attribute only can be set by I<set_name()> and get by I<get_name()>.
It also has a tied key with it's I<NAME> in the HASH reference of the object.

=item TYPE I<(optional)>

Tells the type of  the attribute. If not defined I<any> will be used as default.

B<Standart types:>

=over 4

=item any

Accept any type of value.

=item string | str

A normal string.

=item boolean | bool

A boolean value. Also accept 'true' and 'false' strings.

=item integer | int

An integer that accepts only I<[0-9]> digits.

=item floating | float

A floating point, with the format I</\d+\.\d+/>. If  I</\.\d+$/> doesn't exists B<I<'.0'>> will be added in the end.

=item sub

Define an attribute as a sub call:

  class foo {
    attr( sub id ) ;
  
    sub id() { return 123 ; }
  }
  
  ## call:
  
  $foo->id() ;
  ## or
  print " $foo->{id} \n" ;

=item Object

This type will accept only object types or a defined object class:

  class Foo {
    attr ( XML::Smart xml , object any_obj , obj any_obj2 , UNIVERSAL any_obj3 ) ;
  }

In the example above the attribute I<xml> will accept only objects from I<XML::Smart>,
or objects that inherites from I<XML::Smart>. The attribute any_obj will aceept any type of
object. You can see that the types I<object>, I<obj> and I<UNIVERSAL> are all the same.

=back

B<Personalized types:>

To create your own type you can use this syntax:

  attr( &mytypex foo ) ;

Then you need to create the I<sub> that will handle the type format:

  sub mytypex ($value) {
    $value =~ s/x/y/gi ; ## do some formatting.
    return $value ; ## return the value
  }

Note that a type will handle one value/SCALAR per time. Soo, the same type can be used for array attributes or not:

  attr( &mytypex foo , array &mytypex list ) ;

Soo, in the definition above, when list is set with some ARRAY, eache element of the array will be past one by one to the I<&mytypex> sub.

=item REF I<(optional)>

Tells that the value is a reference. Soo, you need to always set it with a reference:

  attr( ref foo ) ;

  ...
  
  $this->set_foo( \$var ) ;
  ## or
  $this->set_foo( [1 , 2 , 3] ) ;

=item ARRAY or HASH I<(optional)>

Tells that the value is an array or a hash of some type.

Soo, for this type:

  attr( array int ages ) ;

You can set and get without references:

  $this->set_ages(20 , 25 , 30 , 'invalid' , 40) ;
  
  ...
  
  my @ages = $this->get_ages ;

Note that in this example, all the values of the array will be formated to I<integer>.
Soo, the value I<'invalid'> will be set to I<undef>.

=back

The attribute definition was created to handle object databases and the persistence of objects
created with I<Class::HPLOO>. Soo, for object persistence you should use only I<ATTRIBUTES> and I<GLOBAL VARS>.

Note that for object persistence, keys sets in the HASH reference of the object, that aren't defined as attributes, own't be saved.
Soo, for the I<attr()> definition below, the key I<foo> won't be persistent:

  attr( str bar , int baz ) ;
  $this->{bar} = 'persistent' ;
  $this->{foo} = 'not persistent' ;

=head2 GLOBAL VARS

To set a global variable (static variable of a class), you use this syntax:

  vars ($foo , @bar , %baz) ;

Actually this is the same to write:

  use vars qw($foo @bar %baz) ;

B<** Note that a global variable is just a normal Perl variable, with a public access in it's package/class.>

=head2 LOCAL VARS

This are just variables with private access (only accessed by the scope defined with it).

  my ($foo , @bar , %baz) ;

B<** Note that a local variable is just a normal Perl variable accessed only through it's scope.>

=head1 Persistence with HDB::Object

From Class::HPLOO/0.16 we can use L<HDB::Object> as a base class for persitence.

Example of class built with it:

  use Class::HPLOO ;
  
  class User extends HDB::Object {
  
    use HDB::Object ;
  
    attr( user , pass , name , int age ) ;
    
    sub User( $user , $pass , $name , $age ) {
      $this->{user} = $user ;
      $this->{pass} = $pass ;
      $this->{name} = $name ;
      $this->{age} = time ;
    }
  
  }

When you create the object it will be automatically stored in the HDB database:

  my $user = new User('joe' , '123' , 'Joe Smith' , 30) ;
  ...
  $user = undef ; ## Destroy and automatically save (insert into table User).
  

To load an already stored object you should use the method I<load()>:

  my $user = load User("user eq 'joe'") ;
  $user->{age} = 40 ;
  $user = undef ; ## Destroy and automatically save (update col age).

B<** Note that you don't need to care about the DB, including the creation
of the table! Is everything automatic.>

=head1 METHODS

All the methods of the classes are declared like a normal sub.

You can declare the input variables to receive the arguments of the method:

  sub methodx ($arg1 , $arg2 , \@listref , \%hasref , @rest) {
    ...
  }
  
  ## Calling:
  
  $foo->methodx(123 , 456 , [0,1,2] , {k1 => 'x'} , 7 , 8 , 9 ) ;

=head2 PREDEFINED METHODS

=over 10

=item ATTRS

Return the list of attributes in the declaration order.

=item __CLASS__

A constant that returns the name of the class.

=back

=head1 HTML BLOCKS

You can use HTML blocks in the class like in HPL documents:

  class Foo {
  
    sub test {
      print <% html_test>(123) ;
    }
    
    <% html_test($n)
      <hr>
      NUMBER: $n
      <hr>    
    %>
  
  }

=head1 SUB CLASSES

From version 0.04+ you can declare sub-classes:

  class foo {
    class subfoo { ... }
  }

You also can handle the base name of a class adding "." in the begin of the class name:

  class foo {
    class .in { ... }
  }

B<In the example above, the class name I<.in> will be translated as I<foo::in>.>

=head1 USE_BASE

By default the code generated by I<Class::HPLOO> is stand alone, so you don't need
to install I<Class::HPLOO> to run it, but as disadvantage the code to be loaded
by a group of classes built with I<Class::HPLOO> will be bigger.

As an option you can use the I<USE_BASE> parameter, that will define the use
of the class I<Class::HPLOO::Base> in the I<@ISA> path, so all the common codes
for class that are built by I<Class::HPLOO> will be shared, saving memory and load time:

  use Class::HPLOO qw(use_base) ;
  
  class Foo {
  }

That will generate this code:

  { package Foo ;
  
  use strict qw(vars) ; no warnings ;
  
  use vars qw(%CLASS_HPLOO @ISA) ;
  
  @ISA = qw(Class::HPLOO::Base UNIVERSAL) ;
  
  my $CLASS = 'Foo' ; sub __CLASS__ { 'Foo' } ;
  
  use Class::HPLOO::Base ;
    
  }

Without I<USE_BASE> this is the default code to be generated:

  { package Foo ;
  
  use strict qw(vars) ; no warnings ;
  
  use vars qw(%CLASS_HPLOO @ISA) ;
  
  @ISA = qw(UNIVERSAL) ;
  
  my $CLASS = 'Foo' ; sub __CLASS__ { 'Foo' } ;
   
  sub new { 
    if ( !defined &Foo && @ISA > 1 ) {
      foreach my $ISA_i ( @ISA ) {
        return &{"$ISA_i\::new"}(@_) if defined &{"$ISA_i\::new"} ;
      }
    }
    my $class = shift ;
    my $this = bless({} , $class) ;
    no warnings ;
    my $undef = \'' ;
    sub UNDEF {$undef} ;
    my $ret_this = defined &Foo ? $this->Foo(@_) : undef ;
    if ( ref($ret_this) && UNIVERSAL::isa($ret_this,$class) ) { $this = $ret_this }
    elsif ( $ret_this == $undef ) { $this = undef }
    return $this ;
  }
    
  sub SUPER {
    my ($pack , undef , undef , $sub0) = caller(1) ;
    unshift(@_ , $pack) if ( (!ref($_[0]) && $_[0] ne $pack) || (ref($_[0]) && !UNIVERSAL::isa($_[0] , $pack)) ) ;
    my $sub = $sub0 ;
    $sub =~ s/.*?(\w+)$/$1/ ;
    $sub = 'new' if $sub0 =~ /(?:^|::)$sub\::$sub$/ ;
    $sub = "SUPER::$sub" ;
    $_[0]->$sub(@_[1..$#_]) ;
  }
    
  }

=head1 DUMP

You can dump the generated code:

  use Class::HPLOO qw(dump nice) ;

** The I<nice> option just try to make a cleaner code.

=head1 BUILD

The script "build-hploo.pl" can be used to convert I<.hploo> files to I<.pm> files.

So you can write a Perl Module with Class::HPLOO and release it as a normal I<.pm>
file without need I<Class::HPLOO> installed.

If you have L<ePod> (0.03+) installed you can use ePod to write your documentation.
For I<.hploo> files the ePod need to be always after __END__.

Note that ePod accepts POD syntax too, so you still can use normal POD for documentation.

=head1 SEE ALSO

L<Perl6::Classes>, L<HPL>, L<HDB::Object>, L<HDB>.

=head1 AUTHOR

Graciliano M. P. <gmpassos@cpan.org>

I will appreciate any type of feedback (include your opinions and/or suggestions). ;-P

=head1 COPYRIGHT

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut