view release on metacpan or  search on metacpan

lib/Colloquy/Data.pm  view on Meta::CPAN

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $DEBUG);
use constant DEFAULT_DATADIR => '/usr/local/colloquy/data';

$VERSION     = '1.15' || sprintf('%d', q$Revision: 526 $ =~ /(\d+)/g);
$DEBUG       = $ENV{DEBUG} ? 1 : 0;
@ISA         = qw(Exporter);
@EXPORT      = ();
@EXPORT_OK   = qw(&lists &users &caps &commify);
%EXPORT_TAGS = ( all => \@EXPORT_OK );

sub users {
	return _get_data(shift);
}

sub lists {
	my ($users,$lists) = _get_data(shift);
	return ($lists,$users);
}

sub caps {
	(my $c = $_[0]) =~ s/_/ /g;
	my @c = split(/\b/,$c);
	foreach (@c) { if (/^([a-z])(.*)/) { $_ = uc($1).$2; } }
	return join("",@c);
}

sub commify {
	local $_ = shift;
	s/^\s+|\s+$//g;
	1 while s/^([-+]?\d+)(\d{3})/$1,$2/;
	return $_;
}

sub _munge_user_lua {
	local $_ = shift;
	s/'/\\'/g;
	s/"/'/g; #"'
	s/(\s+[a-z0-9]+\s+=)(\s+['{\d+])/$1>$2/gi;
	s/^return //;
	return $_;
}

sub _munge_list_lua {
	local $_ = shift;
	s/\s+\['(\S+?)'\]\s+=\s+{/ $1 => {/g;
	s/'/\\'/g;
	s/"/'/g; #"'
	s/(\s+[a-z0-9]+\s+=)(\s+['{\d+])/$1>$2/gi;
	s/(\s+members\s+=>\s+)\{(.+?)\}/$1 [ ( $2 ) ]/sgi;
	s/^return //;
	return $_;
}

sub _read_file {
	my $file = shift;
	croak "No such file '$file'\n" unless -e $file;
	croak "'$file' is not a plain file type\n" unless -f _;
	croak "Insufficient permissions to read file '$file'\n" unless -r _;

	my $mode = (stat(_))[2];
	my $group_write = ($mode & S_IWGRP) >> 3;
	my $other_write = $mode & S_IWOTH;

	# Since this module started using Safe to parse the data files,
	# this code is no longer as important as before. It's now only
	# a warning.
#	if ($^W && $group_write) {
#		cluck "WARNING! $file is group writeable. This is potentially insecure!";
#	}
	#if ($other_write) {
	if ($^W && $other_write) {
		#croak "FATAL! $file is world writeable. This insecure file cannot be evaluated!";
		cluck "WARNING! $file is world writeable. This is potentially insecure!";
	}

	if (open(FH,"<$file")) {
		local $/ = undef;
		my $data = <FH>;
		close(FH);
		return $data;
	} else {
		croak "Unable to open file handle FH for file '$file': $!";
		# return undef;
	}
}

sub _get_data {
	my $datadir = shift || DEFAULT_DATADIR;
	my $users_lua = $datadir.'/users'.(-f $datadir.'/users.lua' ? '.lua' : '');
	my $lists_lua = $datadir.'/lists'.(-f $datadir.'/lists.lua' ? '.lua' : '');

	my $users = {};
	croak "Insufficient permissions to read $users_lua\n" unless -r $users_lua;

	my $c = new Safe;
	# Minimum safe opcode set for building data structures lineseq, list and
	# padany needed for perl 5.8.7
	$c->permit_only(qw(rv2sv sassign aelem aelemfast helem anonlist anonhash
				pushmark refgen const undef leaveeval lineseq list padany));

	if (-f $users_lua) {
		my $coderef = _munge_user_lua( '$' . _read_file($users_lua) );
		$users = $c->reval($coderef);
		#eval $coderef;

	} elsif (-d $users_lua) {
		if (opendir(DH,$users_lua)) {
			for my $user (grep(!/^\./,readdir(DH))) {
				next unless -f "$users_lua/$user";
				unless (-r "$users_lua/$user") {
					cluck "Insufficient permissions to read $users_lua/$user";
					next;
				}
				my $coderef = _munge_user_lua( _read_file("$users_lua/$user") );
				if (length($coderef) > 9 && $coderef =~ /^\s*(return )?{.+}\s*$/gsi) {
#				if (length($coderef) > 9 && $coderef =~ /return {.+}/gsi) {
					DUMP('$coderef',$coderef);
					$users->{$user} = $c->reval($coderef);
					DUMP('$users',$users);
					#eval { $users->{$user} = eval $coderef; }