Return to LONCAPA.pm CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/LONCAPA.pm between versions 1.4 and 1.19

version 1.4, 2006/05/30 19:26:34	version 1.19, 2006/12/09 23:33:56
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_courseid $match_not_courseid
	$match_name
	$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_courseid $match_not_courseid
	$match_name
	$match_handle $match_not_handle);
	our %EXPORT_TAGS = ( 'match' =>[qw($match_domain $match_not_domain
	$match_username $match_not_username
	$match_courseid $match_not_courseid
	$match_name
	$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 102 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;
	}

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


	$match_courseid = $LONCAPA::courseid_re = qr{\d[\w\-.]+};
	$match_not_courseid = $LONCAPA::not_courseid_re = qr{[^\w\-.]+};

	$match_name = $LONCAPA::name = qr{$match_username\|$match_courseid};
	sub clean_name {
	my ($name) = @_;
	$name =~ s/$match_not_username//g;
	return $name;
	}

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

	$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_name($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 184 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 155 sub untie_domain_hash {	Line 219 sub untie_domain_hash {
sub tie_user_hash {	sub tie_user_hash {
my ($domain,$user,$namespace,$how,$loghead,$what) = @_;	my ($domain,$user,$namespace,$how,$loghead,$what) = @_;

$namespace=~s/\//\_/g; # / -> _	$namespace=~s{/}{_}g; # / -> _
$namespace=~s/\W//g; # whitespace eliminated.	$namespace = &clean_username($namespace);
my $proname = &propath($domain, $user);	my $proname = &propath($domain, $user);

my $file_prefix="$proname/$namespace";	my $file_prefix="$proname/$namespace";
return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what);	return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
}	}
Line 167 sub untie_user_hash {	Line 230 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 260 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 @_;
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 198 sub _do_hash_untie {	Line 281 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 212 sub _do_hash_untie {	Line 318 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 243 sub _do_hash_untie {	Line 358 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 272 sub _do_hash_untie {	Line 392 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;
}	}
}	}

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

500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.

Removed from v.1.4
changed lines
	Added in v.1.19