view release on metacpan or  search on metacpan

lib/Cache/Static.pm  view on Meta::CPAN

	eval "require $ext;";
	next if($@);
	my $util = $ext;
	$util =~ s/\:\:/_/g;
	eval "require Cache::Static::${util}_Util";
	if($@) {
		_log(2, "$ext exists but Cache::Static::${util}_Util does not, disabling extension\n");
	} else {
		push @timestamp_extensions, $ext;
	}
}

sub _readconf {
	my $ns = shift;
	$ns = '' unless(defined($ns));
	_die_if_invalid_namespace($ns) if($ns);

	my $dir = "$ROOT/$ns";
	my @conf;
	open(CONF, "$dir/config") && 
	(@conf = map { my $t = $_; $t = lc($t); $t =~ s/^\s+//; $t =~ s/\s+$//;
		my $ar = []; @$ar = split(/\s+/, $t, 2); $ar } 
			grep(/^[^#]/, grep(/./, <CONF>)));
	close(CONF);
	foreach my $cr (@conf) { 
		if($cr->[0] eq 'log_level') {
			if(!$ns || $ns eq 'DEFAULT') {
				$CONF{log_level} = $cr->[1];
			} else {
				_log(3, "log_level directive in CONF($ns) ignored");
			}
		} else {
			$CONF{$ns ? $ns : 'DEFAULT'}->{$cr->[0]} = $cr->[1]; 
		}
	} 
}

#### useful when adding new modules
#warn "time: @timestamp_extensions\n";
#warn "help: @helper_extensions\n";
#die;

sub _has_timestamp {
	my $mod = shift;
	return grep(/^$mod$/, @timestamp_extensions);
}

sub _has_helper {
	my $mod = shift;
	return grep(/^$mod$/, @helper_extensions);
}

############################
### /glue for extensions ###
############################

#try to set up the logfile with lenient permissions
eval {
	open(FH, ">>$LOGFILE");
	close(FH);
	chmod 0666, $LOGFILE;
};

#number of levels of directory in cache
#TODO: move this to config file
my $CACHE_LEVELS = 3;

sub get_if_same {
### uncomment the below line to disable Cache::Static
#	return undef;
	my ($key, $depsref, %args) = @_;
	my ($ret, $dep) = _is_same($key, $depsref, %args);
	if($ret) {
		_log(1, "cache hit for key: $key");
		return _get($key, %args);
	} else {
		_log(1, "cache miss for key: $key on dep: $dep");
		return undef;
	}
}

sub _die_if_invalid_namespace {
	my $ns = shift;
	die "illegal namespace: $namespace" if($namespace =~ /\// ||
		grep (/^$namespace$/, @ILLEGAL_NAMESPACES));
}

sub set {
	my ($key, $content, $deps, %args) = @_;
	my $ns = $args{namespace} || $namespace;
	_die_if_invalid_namespace($ns);
	eval {
		#create any necessary directories
		my $dir = $key;
		$dir =~ s/\/[^\/]*$//;
		_mkdir_p("$ROOT/$ns/cache/$dir");
		die "couldn't make/walk directories: $@" if($@);

		#if we overrode the namespace, or if the dir got rm -rf'd out
		#from under us, this comes in handy...
		_mkdir_p("$ROOT/$ns/tmp");

		#write out the content
		my $tmpf = $key;
		$tmpf =~ s/\///g;
		open(FH, ">$ROOT/$ns/tmp/$tmpf") || die "couldn't open $ROOT/$ns/tmp/$tmpf: $!";
		(print FH $content) || die "couldn't print: $!";
		close(FH) || die "couldn't close: $!";
		chmod 0666, "$ROOT/$ns/tmp/$tmpf";

		#move the new cache file in place
		(rename "$ROOT/$ns/tmp/$tmpf", "$ROOT/$ns/cache/$key") ||
			die "couldn't rename content to $ROOT/$ns/cache/$key";

		if($deps) {
			#write out the deps
			my $frozen_deps = join('', map { $a=$_; $a.="\n"; $a } @$deps);
			open(FH, ">$ROOT/$ns/tmp/$tmpf.dep") || die "couldn't open: $!";
			(print FH $frozen_deps) || die "couldn't print: $!";
			close(FH) || die "couldn't close: $!";
			chmod 0666, "$ROOT/$ns/tmp/$tmpf.dep";

			#move the new .dep file in place
			(rename "$ROOT/$ns/tmp/$tmpf.dep", "$ROOT/$ns/cache/$key.dep") ||
				die "couldn't rename deps to $ROOT/$ns/cache/$key.dep: $!";
		}

	}; if($@) {
		_log(2, "Cache::Static::set couldn't save new value (in namespace: $ns) : $@");
	} else {
		_log(3, "Cache::Static::set refreshed $key in namespace: $ns");
	}
}

sub make_friendly_key {
	my ($url, $argsref) = @_;

	#key for Cache is url + args in deterministic order
	my $key = "$url?";
	foreach my $arg (sort keys %$argsref) {
		my $val = $argsref->{$arg};
		if(ref($val)) {
			if(ref($val) eq 'ARRAY') {
				$val = join("&$arg=", @$val);
			} elsif($val->isa('XML::Comma::Doc')
					&& _has_timestamp('XML::Comma')) {
				$val = "XML::Comma::Doc:".$val->doc_key;
			} else {
				_log(3, "got a ".ref($val)." and we're just freezing it...");
				$val = Storable::freeze($val);
			}
		}
		$key .= "$arg=$val&";
	}
	$key =~ s/&$//;

	#fix problem with friendly keys that have a multiple consecutive dashes,
	#as when they are printed in HTML debugging mode, they can cause SGML
	#comments to eat what is supposed to be code up to the next literal --
	#for one-to-one-ness, also map '-' (single dash) to '-1-'
	#this is really something browsers should work around, but don't. see:
	#  https://bugzilla.mozilla.org/show_bug.cgi?id=214476
	$key = join("", map { (/-+/) ? "-".length($_)."-" : $_ }
		split(/(-+)/, $key));

	return $key;
}

sub make_key {
	return md5_path(make_friendly_key(@_));
}

sub make_key_from_friendly {
	my $key = shift;
	return md5_path($key);
}

sub md5_path {
	my $key = shift;

	$key = md5_base64($key);

lib/Cache/Static.pm  view on Meta::CPAN

}

sub _write_spec_timestamp {
	my $spec = shift;
	_mkdirs_and_touch($ROOT.'/timestamps/'.md5_path($spec).'.ts', $spec);
}

sub _unlink_spec_timestamp {
	my $spec = shift;
	my $file = $ROOT.'/timestamps/'.md5_path($spec).'.ts';
	unlink($file);
	if(_get_conf($namespace, 'recursive_unlink')) {
		$file =~ s/\/[^\/]*$//;
		unless(opendir(DIR, $file)) {
			_log(3, "_unlink_spec_timestamp failed to opendir($file): (another process probably rmdir'd it):  $!");
			return;
		}
		my @files = readdir(DIR);
		closedir(DIR) if(@files);
		while($#files == 1 ) {
			unless(rmdir $file) {
				_log(3, "_unlink_spec_timestamp failed to rmdir($file): (another process probably touched a file in it): $!");
				return;
			}
			$file =~ s/\/[^\/]*$//;
			unless(opendir(DIR, $file)) {
				_log(3, "_unlink_spec_timestamp failed to opendir($file): (another process probably rmdir'd it):  $!");
				return;
			}
			my @files = readdir(DIR);
			closedir(DIR) if(@files);
		}
	}
}

#optional second argument indicates stuff to squirrel in the file
#TODO: the name is misleading given the possibility of the 2nd arg
sub _mkdirs_and_touch {
	my $file = shift;
	my $output = shift || '';

	#get rid of double slashes
	$file =~ s/\/\//\//g;

	#split the dir and the filename
	my $dir = $file;
	$dir =~ s/\/[^\/]*$//;

	my $err;
	eval {
		#mkdir -p
		_mkdir_p($dir);
		die "couldn't make/walk directories: $@" if($@);

		#touch/write to the file
		open(FH, ">$file") || die "couldn't open $file: $!";
		if($output) {
			print FH $output || die "couldn't print $output to $file: $!";
		}
		close(FH) || die "couldn't close $file: $!";
		chmod 0666, $file;
	}; if($@) {
		_log(2, "Cache::Static::_mkdirs_and_touch: couldn't update timestamps: $@");
	}
}

sub _log {
	my $severity = shift;
	return unless($severity <= $CONF{log_level});
	my $args = join(' ', @_);
	$args =~ s/\n/ /mg;
	$args =~ s/\s+$//;
	#we don't need a full stack trace at level 3
	#TODO: this regexp can be overly greedy
	$args =~ s/Stack:.*$//sg if($CONF{log_level} == 3);
	my @lt = localtime();
	$lt[4]++; #month starts at 0 for perl, 1 for humans
	@lt = map { sprintf("%02d", $_) } @lt;
	my $date = ($lt[5]+1900).'/'.$lt[4].'/'.$lt[3].' '.$lt[2].':'.$lt[1].':'.$lt[0];
	my $level = $LOG_LEVEL_NAMES[$severity];
	$level .= ' ' while(length($level) < 5);

	if($have_fcntl) {
		#TODO: we don't need to open/close every time.
		#just flock(LOG, LOCK_EX), seek, flock(LOG, LOCK_UN);
		#benchmark and safety test this...
		open(LOG, ">>$LOGFILE") || die "can't open log \"$LOGFILE\" $!";
		flock(LOG, LOCK_EX) || die "can't lock log \"$LOGFILE\" $!";
		seek(LOG, 0, 2); #seek to EOF if someone appended while we waited...
		print LOG "$level $date [$$] $args\n" || die "can't write to log \"$LOGFILE\": $!";
		#close does implicit unlock
		close(LOG) || die "can't close log \"$LOGFILE\": $!";
	} else {
		#TODO: there must be a way to escape " such that the shell doesn't puke
		$args =~ s/\"/'/g;
		`echo "$level $date [$$] $args" >>$LOGFILE`;
	}
}

sub _mkdir_p {
	my $dir = shift;
	my @dirs = grep (/./, split(/\//, $dir));
	my $dir_so_far = '/';
	foreach my $d (@dirs) {
		$dir_so_far .= "$d/";
		unless(-e $dir_so_far) {
			mkdir($dir_so_far) || die "couldn't create $dir_so_far: $!";
			chmod(0777, $dir_so_far) || die "couldn't change perms on $dir_so_far: $!";
		}
	}
}

1;
__END__


=head1 NAME

Cache::Static - Caching without freshness concerns

=head1 SYNOPSIS

=head2 HTML::Mason instructions

In handler.pl:
  use Cache::Static;

In any component you where you have a well defined set of
dependencies which change the output:

  <%init>
  my $_cs_deps = [
  #file dependencies - only regenerate if a file has changed
    'file|/path/to/some_configuration_file',

  #DBI dependencies - still under development - WONT WORK
  #DBI dependencies: note the third argument is a DSN
    '_DBI|table|mysql:scache_test_db|test_table',
    '_DBI|db|mysql:scache_test_db',

  #not yet implemented:
  #column level depends, e.g. "DBI|column|$dsn|$tablename|$columname"
  #row depends, e.g. "DBI|row|$dsn|$tablename|$uid_column_name|$uid_value"

  #XML::Comma dependencies - only regenerate if a Doc or Store has changed
    "_XML::Comma|Doc|$doc_key",
    "_XML::Comma|Store|$def|$store",

  #time dependencies (WARNING: these are discouraged, see doc/NOTE-time-deps)
    'time|15s', #every 15 seconds
    'time|M:15s', #every 15 seconds after the minute
    'time|H:2m', #every 2 minutes past the hour
    'time|W:2d3h5m0s', #every Tuesday at 3:05 AM

  #modifiers (indicate behavior when the file cannot be found)
    'file-0|/tmp/foo', #if ! -e /tmp/foo, regenerate
    'file-1|/tmp/foo', #if ! -e /tmp/foo, serve
    'file|/tmp/foo',   #use config value "dep_file_not_found_returns"

  #note modifiers also work on extensions, e.g.
    '_DBI-1|db|mysql:scache_test_db',
    '_XML::Comma-0|Store|mm_item|post',

  #etc... but modifiers CANNOT be used with times (since they have no
  #file backing on disk)
  ];

  #whatever you have in $_cs_deps above...