File Coverage

blib/lib/personal.pm

Criterion	Covered	Total	%
statement	23	74	31.0
branch	1	28	3.5
condition	0	11	0.0
subroutine	7	15	46.6
pod	1	1	100.0
total	32	129	24.8

package personal;

use 5.006_001;
use strict;
use File::Spec ();

use constant IS_MODPERL => exists $ENV{MOD_PERL};

our $VERSION = '0.22';

our $Cache = {};
our $Count = 1;

# Public method
sub import : method {
  shift->_export( qw(personal) );

  if( @_ ) {
    my $cache = _personal_cache();
    my $class = shift;

    unless( $cache->{$class} ) {
      my $project = {
        class => $class,
        relative => _class2relative($class)
      };
      unless( _search_package($project) ) {
        _croak("Can't locate $project->{relative} in \@INC (\@INC contains: @INC)");
      } else {
        $project->{realname} = _class_newname();
        _compile_package($project);

        $cache->{$class} = {
          realname => $project->{realname}, mtime => $project->{filestat}[9],
          absolute => $project->{absolute},
        };
      }
    }

    if( @_
    and $cache->{$class}{realname}->can('import') ) {
      my @caller = caller;
      my $cinfo = $cache->{$class};

      eval qq(#line $caller[2] $caller[1]
        eval qq\(#line \$caller[2] \$caller[1]
          package \$caller[0]; \$cinfo->{realname}->import(\\\@_);
        \);
        die \$@ if \$@;
      );
      die $@ if $@;
    }
  }
}

# Public function
sub personal {
  my $cache = _personal_cache();
  my $class = shift;

  unless( exists $cache->{$class} ) {
    _croak("Package $class was not loaded with 'use personal'");
  } else {
    return $cache->{$class}{realname};
  }
}

# Private function: _search_package(PROJECT)
# Searching package in @INC. Returns true on success
sub _search_package {
  my $project = shift;

  foreach( @INC ) {
    my $t_path = File::Spec->catfile($_, $project->{relative});

    if( -f $t_path ) {
      $project->{filestat} = [ stat _ ];
      $project->{absolute} = File::Spec->rel2abs($t_path);
      return 1;
    }
  }
  return undef;
}

# Private function: _compile_package(PROJECT)
# Package compilation. Dieing on eny errors
sub _compile_package {
  my $project = shift;
  my $size = $project->{filestat}[7];
  my $fh;
  my $data;

  if( !open($fh, $project->{absolute})
  or  !binmode($fh) ) {
    _croak("Error opening $project->{relative}");
  }
  elsif( read($fh, $data, $size) != $size ) {
    _croak("Error reading $project->{relative}");
  }
  elsif( $data !~ s/^ *?package +?$project->{class}\b// ) {
    _croak("Package $project->{class} ",
           "is uncompatible with 'use personal'");
  }
  else {
    my @caller = caller 1;
    my $result = eval qq(#line $caller[2] $caller[1]
      my \$result = eval qq\(#line 1 \$project->{relative}
        package \$project->{realname} \$data
      \);
      warn \$@ if \$@;
      \$result;
    );
    warn $@ if $@;

    unless( $result ) {
      _carp("$project->{relative} did not return true value");
    }
    if( $@ or !$result ) {
      _croak("Compilation failed on 'use personal'");
    }
  }
}

# Private function: _class_newname()
# Generation of new unique personal class name
sub _class_newname {
  return sprintf( '%s::_%012d', __PACKAGE__, $Count++ );
}

# Private function: _class2relative(CLASS)
# Conversion class name to relative path of current FS
sub _class2relative {
  return File::Spec->catfile( split('::', shift) ).'.pm';
}

# Private function: _personal_cache()
# Returns reference to personal cache hash
sub _personal_cache {
  my $area;

  if( IS_MODPERL ) {
    my $r = Apache->request;
    $area = $r->dir_config('PersonalArea');
    $area = $r->filename unless defined($area);
  }
  $area = $0 unless defined($area);
  return $Cache->{$area} ||= {};
}

# Private method: SELF->_export( GLOB1, GLOB2, ... )
# Very simple exporter. Only for using from import() method in this package
sub _export : method {
  my $source = shift;
  my $destination = caller(1);

  no strict qw(refs);
  foreach( @_ ) {
    *{ "${destination}::$_" } = \&{ "${source}::$_" };
  }
}

# Private function: _carp(MESSAGE)
# Handling warnings
sub _carp {
  require Carp; &Carp::carp;
}

# Private function: _croak(REASON)
# Handling fatals
sub _croak {
  require Carp; &Carp::croak;
}

1;

__END__