File Coverage

lib/Cache/Static/HTML_Mason_Util/hmc.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

##
#
#    Copyright 2005-2006, Brian Szymanski
#
#    This file is part of Cache::Static
#
#    Cache::Static is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation; either version 2 of the License, or
#    any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    For more information about Cache::Static, point a web browser at
#    http://chronicle.allafrica.com/scache/ or read the
#    documentation included with the Cache::Static distribution in the
#    doc/ directory
#
##

package Cache::Static::HTML_Mason_Util::hmc;

use strict;
use warnings;

use vars qw ( @ISA );

use HTML::Mason;
use HTML::Mason::Compiler;
use HTML::Mason::Compiler::ToObject;
use Cache::Static;

@ISA = qw(HTML::Mason::Compiler::ToObject);

my %last_component_deps;
my ($r, $m, $wr);
my $parent_dir = undef;

sub find_extra_deps {
	my ($self, $subcomponent, %args) = @_;

	my $top_call = defined($args{top_call}) ? $args{top_call} : 1;
	$m = $args{m};
	$r = $args{r};
	$wr = $r->document_root;

	Cache::Static::_log(3, "called find_extra_deps: $subcomponent (top: $top_call)\n");

	my @ret = ();
	#cache Mason compiles we know if none of our depends changed we don't
	#need to do any compilation (however, if any of them changed, we may
	#still need to do compilation - currently we just recompile ALL -
	#this will be improved later)
	my $str_ret = undef;
	my $sc_key = ($top_call ? Cache::Static::make_key($subcomponent) : undef);
	if($top_call) {
		my $hmc_deps = Cache::Static::get_if_same($sc_key, [],
			namespace => "_Cache_Static_hmc");
		if(defined($hmc_deps)) {
			my @hmc_deps = @{Storable::thaw $hmc_deps};
			($str_ret, undef) = Cache::Static::_is_same($sc_key,
				\@hmc_deps, namespace => "_Cache_Static_hmc");
			@ret = @hmc_deps;
		}
	}
	if(defined($str_ret)) {
		Cache::Static::_log(3, "got cached depend list for $subcomponent");
	} else {
		open(F, $subcomponent) || die "can't open $subcomponent";
		my $code = join("\n", ) || die "can't read $subcomponent";
		close(F) || die "can't close $subcomponent";
		my $cr = $self->compile(
			top_call => $top_call,
			comp_source => $code,
			name => "something or other (fill me in!)",
			cache_static_friendly_key => "$subcomponent" );
		die "couldn't compile $subcomponent: $cr" unless(defined($cr));

		if($top_call) {
			my %processed_deps = ();
			while((scalar keys %processed_deps) !=
					(scalar keys %last_component_deps)) {
				my @deps = keys %last_component_deps;
				Cache::Static::_log(4, "deps: @deps");
				Cache::Static::_log(4, "proc'd deps: ".
					join(" ", keys %processed_deps));
				foreach my $dep (@deps) {
					next if $processed_deps{$dep};
					unless($dep =~ /^file\|/) {
						$processed_deps{$dep} = 1;
						next;
					}
					Cache::Static::_log(4, "got new mason file dep: $dep");
					$processed_deps{$dep} = 1;
					$dep = _pathify($dep, 0);
					Cache::Static::_log(3, "recursing on dep: $dep\n");
					#note this has a side effect of modifying %last_component_deps
					$self->find_extra_deps($dep, %args, top_call => 0);
				}
			}
		}
		@ret = map { _pathify($_, 1) } keys %last_component_deps;
		Cache::Static::_log(4, "ret: @ret");
		#we are caching the dependencies of this mason file
		#e.g. @ret has a list of file dependencies
		if($top_call) {
			Cache::Static::set($sc_key, Storable::freeze(\@ret),
				[], namespace => "_Cache_Static_hmc");
		}
	}

	return \@ret;
}

sub _pathify {
	my $file = shift;
	my $leave_spec = shift || 0;
	if($leave_spec) {
		$file =~ s/^file\|/file\|$wr\//;
	} else {
		$file =~ s/^file\|/$wr\//;
	}
	#strip out ../, ./
	$file =~ s/\/[^\/]+\/\.\.\//\//g;
	$file =~ s/\.\///g;
	#strip redundant slashes
	$file =~ s/\/\/+/\//g;
	return $file;
}

sub _Cache_Static_component_call {
	my $self = shift;
	my $has_content = shift;

	#args should be 'call' => $component
	my $k = shift;
	die "Cache::Static - incompatible version of HTML::Mason" unless($k eq 'call');
	my $component = shift;

	my $curr_dir = $parent_dir || $m->current_comp->dir_path;
	Cache::Static::_log(4, "component: $component, curr_dir: $curr_dir",
		", parent_dir: $parent_dir, dir_path: ", $m->current_comp->dir_path);

	#don't worry about components with embedded content for now (<|& foo &>...)
	unless($has_content) {
		$component =~ s/^\s+//;
		# (from HTML::Mason::Devel) - To eliminate the need for quotes in
		# most cases, Mason employs some magic parsing: If the first character is
		# one of "[\w/_.]", comp_path is assumed to be a literal string running
		# up to the first comma or &>. Otherwise, comp_path is evaluated as an
		# expression.
		if($component =~ /^['"]?[\w\/_.]/) {
			#support for "component" & 'component'
			if($component =~ /^[']/) {
				$component =~ s/^[']//;
				$component =~ s/['].*//;
			} elsif($component =~ /^["]/) {
				$component =~ s/^["]//;
				$component =~ s/["].*//;
			}
			#strip off everything after a comma
			$component =~ s/,.*$//s;
			#strip off any trailing whitespace
			$component =~ s/\s+$//s;
			#now we've got the component, add a file dep
			if($component) {
				my $component_path =
					($component =~ /^\//) ?
						$component :
						$curr_dir.'/'.$component;
				$component_path =~ s/\/\/+/\//g;
				Cache::Static::_log(4, "HTML_Mason_Util::hmc added component dep: file|$component_path");
				$last_component_deps{"file|$component_path"} = 1;
			}
		} else {
			Cache::Static::_log(3, "HTML_Mason_Util::hmc added MISS dep for dynamic component: $component");
			$last_component_deps{MISS} = 1;
		}
	} else {
		Cache::Static::_log(3, "HTML_Mason_Util::hmc added MISS dep for component $component with content");
		$last_component_deps{MISS} = 1;
	}

	if($has_content) {
		return $self->SUPER::component_content_call(@_);
	} else {
		return $self->SUPER::component_call(@_);
	}
}

sub compile {
	my ($self, %args) = @_;
	my $fkey = $args{cache_static_friendly_key};
	delete $args{cache_static_friendly_key};
	$parent_dir = $fkey;
	$parent_dir =~ s/\/[^\/]*$//; #just the dir
	$parent_dir =~ s/^$wr//;      #strip off webroot
	Cache::Static::_log(4, "compiling: $fkey in $parent_dir");
	my $ret = 0;
	unless($ret) {
		%last_component_deps = () if($args{top_call});
		delete $args{top_call};
		$ret = $self->SUPER::compile(%args);
	}
	return $ret;
}

sub component_content_call {
	my $self = shift;
	return _Cache_Static_component_call($self, 1, @_);
}

sub component_call {
	my $self = shift;
	return _Cache_Static_component_call($self, 0, @_);
}
1;