loncom/LONCAPA.pm - diff

Return to LONCAPA.pm CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/LONCAPA.pm between versions 1.2 and 1.14

version 1.2, 2006/05/30 12:45:12	version 1.14, 2006/11/22 19:58:29
Line 38 use POSIX;	Line 38 use POSIX;

my $loncapa_max_wait_time = 13;	my $loncapa_max_wait_time = 13;


	use vars qw($match_domain $match_not_domain
	$match_username $match_not_username
	$match_handle $match_not_handle);

require Exporter;	require Exporter;
our @ISA = qw (Exporter);	our @ISA = qw (Exporter);
our @EXPORT = qw(&add_get_param &escape &unescape &tie_domain_hash &untie_domain_hash &tie_user_hash &untie_user_hash &propath);	our @EXPORT = qw(&add_get_param &escape &unescape
	&tie_domain_hash &untie_domain_hash &tie_user_hash
	&untie_user_hash &propath);
	our @EXPORT_OK = qw($match_domain $match_not_domain
	$match_username $match_not_username
	$match_handle $match_not_handle);
	our %EXPORT_TAGS = ( 'match' =>[qw($match_domain $match_not_domain
	$match_username $match_not_username
	$match_handle $match_not_handle)],);
my %perlvar;	my %perlvar;



# Inputs are a url, and a hash ref of	# Inputs are a url, and a hash ref of
# form name => value pairs	# form name => value pairs
# takes care of properly adding the form name elements and values to the	# takes care of properly adding the form name elements and values to the
Line 81 sub unescape {	Line 96 sub unescape {
return $str;	return $str;
}	}

	$match_domain = $LONCAPA::domain_re = qr{[\w\-.]+};
	$match_not_domain = $LONCAPA::not_domain_re = qr{[^\w\-.]+};
	sub clean_domain {
	my ($domain) = @_;
	$domain =~ s/$match_not_domain//g;
	return $domain;
	}

	sub split_courseid {
	my ($courseid) = @_;
	my ($domain,$coursenum) =
	($courseid=~m{^/($match_domain)/($match_username)});
	return ($domain,$coursenum);
	}

	$match_username = $LONCAPA::username_re = qr{[\w\-.]+};
	$match_not_username = $LONCAPA::not_username_re = qr{[^\w\-.]+};
	sub clean_username {
	my ($username) = @_;
	$username =~ s/$match_not_username//g;
	return $username;
	}

	$match_handle = $LONCAPA::handle_re = qr{[\w\-.]+};
	$match_not_handle = $LONCAPA::not_handle_re = qr{[^\w\-.]+};
	sub clean_handle {
	my ($handle) = @_;
	$handle =~ s/$match_not_handle//g;
	return $handle;
	}

# -------------------------------------------- Return path to profile directory	# -------------------------------------------- Return path to profile directory

sub propath {	sub propath {
my ($udom,$uname)=@_;	my ($udom,$uname)=@_;
$udom=~s/\W//g;	$udom = &clean_domain($udom);
$uname=~s/\W//g;	$uname= &clean_username($uname);
my $subdir=$uname.'__';	my $subdir=$uname.'__';
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;	$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";	my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
Line 120 sub tie_domain_hash {	Line 166 sub tie_domain_hash {

# Filter out any whitespace in the domain name:	# Filter out any whitespace in the domain name:

$domain =~ s/\W//g;	$domain = &clean_domain($domain);

# We have enough to go on to tie the hash:	# We have enough to go on to tie the hash:

Line 167 sub untie_user_hash {	Line 213 sub untie_user_hash {
return &_locking_hash_untie(@_);	return &_locking_hash_untie(@_);
}	}

	# routines if you just have a filename
	# return tied hashref or undef

	sub locking_hash_tie {
	my ($filename,$how)=@_;
	my ($file_prefix,$namespace)=&db_filename_parts($filename);
	if ($namespace eq '') { return undef; }
	return &_locking_hash_tie($file_prefix,$namespace,$how);
	}

	sub locking_hash_untie {
	return &_locking_hash_untie(@_);
	}

	sub db_filename_parts {
	my ($filename)=@_;
	my ($file_path,$namespace)=($filename=~/^(.*)\/([^\/]+)\.db$/);
	if ($namespace eq '') { return undef; }
	return ($file_path.'/'.$namespace,$namespace);
	}

# internal routines that handle the actual tieing and untieing process	# internal routines that handle the actual tieing and untieing process

sub _do_hash_tie {	sub _do_hash_tie {
Line 176 sub _do_hash_tie {	Line 243 sub _do_hash_tie {
# If this is a namespace for which a history is kept,	# If this is a namespace for which a history is kept,
# make the history log entry:	# make the history log entry:
if (($namespace !~/^nohist\_/) && (defined($loghead))) {	if (($namespace !~/^nohist\_/) && (defined($loghead))) {
my $args = scalar @_;
Debug(" Opening history: $file_prefix $args");
my $hfh = IO::File->new(">>$file_prefix.hist");	my $hfh = IO::File->new(">>$file_prefix.hist");
if($hfh) {	if($hfh) {
my $now = time;	my $now = time();
print $hfh "$loghead:$now:$what\n";	print $hfh ("$loghead:$now:$what\n");
}	}
$hfh->close;	$hfh->close;
}	}
Line 199 sub _do_hash_untie {	Line 264 sub _do_hash_untie {

{	{
my $sym;	my $sym;
	my @pushed_syms;

	sub clean_sym {
	undef($sym);
	}
	sub push_locking_hash_tie {
	if (!defined($sym)) {
	die("Invalid used of push_locking_hash_tie, should only be called after a lock has occurred and before and unlock.");
	}
	push(@pushed_syms,$sym);
	undef($sym);
	}

	sub pop_locking_hash_tie {
	if (defined($sym)) {
	die("Invalid nested used of pop_locking_hash_tie, should only be called after a unlock has occurred.");
	}
	$sym = pop(@pushed_syms);
	}

sub _locking_hash_tie {	sub _locking_hash_tie {
my ($file_prefix,$namespace,$how,$loghead,$what) = @_;	my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
	if (defined($sym)) {
	die('Nested locking attempted without proper use of push_locking_hash_tie, this is unsupported');
	}

my $lock_type=LOCK_SH;	my $lock_type=LOCK_SH;
# Are we reading or writing?	# Are we reading or writing?
if ($how eq &GDBM_READER()) {	if ($how eq &GDBM_READER()) {
Line 213 sub _do_hash_untie {	Line 301 sub _do_hash_untie {
if ((! -e "$file_prefix.db") && (! -e "$file_prefix.db.gz")) {	if ((! -e "$file_prefix.db") && (! -e "$file_prefix.db.gz")) {
# No such file. Forget it.	# No such file. Forget it.
$! = 2;	$! = 2;
	&clean_sym();
return undef;	return undef;
}	}
# Apparently just no lock file yet. Make one	# Apparently just no lock file yet. Make one
open($sym,">>$file_prefix.db.lock");	open($sym,">>$file_prefix.db.lock");
}	}
# Do a shared lock	# Do a shared lock
if (!&flock_sym(LOCK_SH)) { return undef; }	if (!&flock_sym(LOCK_SH)) {
	&clean_sym();
	return undef;
	}
# If this is compressed, we will actually need an exclusive lock	# If this is compressed, we will actually need an exclusive lock
if (-e "$file_prefix.db.gz") {	if (-e "$file_prefix.db.gz") {
if (!&flock_sym(LOCK_EX)) { return undef; }	if (!&flock_sym(LOCK_EX)) {
	&clean_sym();
	return undef;
	}
}	}
} elsif ($how eq &GDBM_WRCREAT()) {	} elsif ($how eq &GDBM_WRCREAT()) {
# We are writing	# We are writing
open($sym,">>$file_prefix.db.lock");	open($sym,">>$file_prefix.db.lock");
# Writing needs exclusive lock	# Writing needs exclusive lock
if (!&flock_sym(LOCK_EX)) { return undef; }	if (!&flock_sym(LOCK_EX)) {
	&clean_sym();
	return undef;
	}
} else {	} else {
&logthis("Unknown method $how for $file_prefix");	die("Unknown method $how for $file_prefix");
die();
}	}
# The file is ours!	# The file is ours!
# If it is archived, un-archive it now	# If it is archived, un-archive it now
Line 244 sub _do_hash_untie {	Line 341 sub _do_hash_untie {
# Change access mode to non-blocking	# Change access mode to non-blocking
$how=$how\|&GDBM_NOLOCK();	$how=$how\|&GDBM_NOLOCK();
# Go ahead and tie the hash	# Go ahead and tie the hash
return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);	my $result =
	&_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
	if (!$result) {
	&clean_sym();
	}
	return $result;
}	}

sub flock_sym {	sub flock_sym {
Line 273 sub _do_hash_untie {	Line 375 sub _do_hash_untie {
my $result = untie(%$hashref);	my $result = untie(%$hashref);
flock($sym,LOCK_UN);	flock($sym,LOCK_UN);
close($sym);	close($sym);
undef($sym);	&clean_sym();
return $result;	return $result;
}	}
}	}

BEGIN {	BEGIN {
my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');	%perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')};
%perlvar=%{$perlvarref};
undef $perlvarref;
}	}

1;	1;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

Removed from v.1.2
changed lines
	Added in v.1.14