File Coverage

blib/lib/Inline/Files.pm

Criterion	Covered	Total	%
statement	101	110	91.8
branch	14	20	70.0
condition	5	15	33.3
subroutine	21	26	80.7
pod	0	1	0.0
total	141	172	81.9

package Inline::Files;
$VERSION = '0.70';
use strict;

use Inline::Files::Virtual;
use Filter::Util::Call;
use Cwd qw(abs_path);
use Carp;

my $SOVFM_pat = qr/^__[A-Z](?:_*[A-Z0-9]+)*__\n/m;
my %files;

sub import {
    DEBUG && TRACE(@_);
    $DB::single = 1;
    my ($class, @args) = @_;
    my ($package, $file, $line) = caller;

    my $path = './';
    $file =~ s|\\|/|g;
    ($path, $file) = ($1, $2) if $file =~ m|^(.*)/(.*)$|;
    $file = abs_path($path) . "/$file";
    $files{$package} = $file;

    while (@args) {
	my $next = shift @args;
	if ($next eq '-backup') {
		my $backup = shift(@args)||"$file.bak";
		local (*IN, *OUT);
		open IN, $file and open OUT, ">$backup" and
		print OUT  and
		close IN and close OUT
			or croak "Cannot make backup of '$file'\n($!)";
	}
	else { croak "usage: use $class [-backup [=> 'filename']]" }
    }

    my (%symbols, $source);
    foreach my $vfile (vf_load($file, $SOVFM_pat)) {
        my $symbol = vf_marker($vfile);
        $symbol =~ s/^__|__\n//g;
        push @{$symbols{$symbol}}, $vfile;
    }

    foreach my $symbol (keys %symbols) {
        no strict 'refs';
        my $fq_symbol = "${package}::${symbol}";
        @$fq_symbol = @{$symbols{$symbol}};
        $$fq_symbol = $symbols{$symbol}[0];
        my $impl = tie *$fq_symbol, $class, $fq_symbol, -w $file;
	tie %$fq_symbol, $class."::Data", $impl;
    }

    foreach (qw( open close seek tell truncate write )) {
        no strict 'refs';
        *{"CORE::GLOBAL::$_"} = \&{"vf_$_"};
    }

    ($source = vf_prefix($file)) =~ s/(.*\n){$line}//;
    filter_add( sub {
        return 0 unless $source;
        $_ = $source;
        $source = "";
        return 1;
    } );
}

sub TIEHANDLE {
    DEBUG && TRACE(@_);
    my ($class, $symbol, $writable) = @_;
    bless { symbol => $symbol, writable => $writable }, $class;
}

sub STORE {
    DEBUG && TRACE(@_);
}

sub DESTROY {
    DEBUG && TRACE(@_);
}

sub AUTOLOAD {
    DEBUG && TRACE(@_) &&
      print "AUTOLOAD => $Inline::Files::AUTOLOAD\n";
    no strict;
    local $^W;
    my $impl = shift;
    my $symbol = $impl->{symbol};
    untie *$symbol;
    $$symbol = shift @$symbol;
    return unless $$symbol;
    my $open_mode = $impl->{writable} ? "+<" : "<";
    vf_open $symbol, "$open_mode$$symbol", $symbol  or return;
    croak "Internal error" unless tied *$symbol;
    $AUTOLOAD =~ s/.*:://;
    local $Carp::CarpLevel = 1;
    return tied(*$symbol)->$AUTOLOAD(@_);
}

sub get_filename {
    DEBUG && TRACE(@_);
    $files{$_[0]} || "";
}

package Inline::Files::Data;
use Carp;
BEGIN {
    *DEBUG = \&Inline::Files::DEBUG;
    *TRACE = \&Inline::Files::TRACE;
}

sub access {
    DEBUG && TRACE(@_);
    no strict 'refs';
    tied(*{$_[0]->{impl}{symbol}});
}
my %fetch = (
	     file     => sub { access($_[0])->{afile} },
	     line     => sub { access($_[0])->{vfile}{line}},
	     offset   => sub { access($_[0])->{vfile}{offset}},
	     writable => sub { $_[0]->{impl}{writable} },
	    );

my @validkeys = keys %fetch;
my $validkey = qr/${\join '|', @validkeys}/;

sub TIEHASH {
    DEBUG && TRACE(@_);
    my ($class, $impl) = @_;
    bless { impl=>$impl, iter=>0 }, $class;
}

sub FETCH {
    DEBUG && TRACE(@_);
    my ($self, $key) = @_;
    return undef unless $key =~ $validkey;
    return $fetch{$key}->($self);
}

sub FIRSTKEY {
    DEBUG && TRACE(@_);
    return $validkeys[$_[0]->{iter} = 0];
}

sub NEXTKEY  {
    DEBUG && TRACE(@_);
    return $validkeys[++$_[0]->{iter}];
}

sub EXISTS   {
    DEBUG && TRACE(@_);
    return $_[1] =~ $validkey;
}

sub DESTROY  {
    DEBUG && TRACE(@_);
}

sub AUTOLOAD {
    DEBUG && TRACE(@_);
    croak "Cannot modify read-only hash";
}


1;

__END__