Return to LONCAPA.pm CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/LONCAPA.pm between versions 1.9 and 1.23

version 1.9, 2006/06/27 14:49:29	version 1.23, 2007/01/10 20:22:30
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_lonid
	$match_handle $match_not_handle);

require Exporter;	require Exporter;
our @ISA = qw (Exporter);	our @ISA = qw (Exporter);
our @EXPORT = qw(&escape_LaTeX &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_lonid
	$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_lonid
	$match_handle $match_not_handle)],);
my %perlvar;	my %perlvar;

# Escape a LaTeX string of special characters that according to LaTeX line by line
# pg 9 are: # $ % & \ ^ _ { } ~ These are escaped by prepending a \
#
sub escape_LaTeX {
my ($string) = @_;
$string =~ s/[\#\$\%\&\\^_{}]/\\$&/g;
return $string;
}


# Inputs are a url, and a hash ref of	# Inputs are a url, and a hash ref of
Line 91 sub unescape {	Line 105 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{\w[\w\-.]+};
	$match_not_username = $LONCAPA::not_username_re = qr{[^\w\-.]+};
	sub clean_username {
	my ($username) = @_;
	$username =~ s/^\W+//;
	$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\-.]+};
	sub clean_courseid {
	my ($courseid) = @_;
	$courseid =~ s/^\D+//;
	$courseid =~ s/$match_not_courseid//g;
	return $courseid;
	}

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

	$match_lonid = $LONCAPA::lonid_re = qr{[\w\-.]+};

	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 130 sub tie_domain_hash {	Line 195 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 165 sub untie_domain_hash {	Line 230 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 228 sub _do_hash_untie {	Line 292 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)) {	if (defined($sym)) {
die('Nested locking attempted, this is unsupportted');	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;
Line 246 sub _do_hash_untie {	Line 329 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
Line 253 sub _do_hash_untie {	Line 337 sub _do_hash_untie {
}	}
# Do a shared lock	# Do a shared lock
if (!&flock_sym(LOCK_SH)) {	if (!&flock_sym(LOCK_SH)) {
	&clean_sym();
return undef;	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)) {	if (!&flock_sym(LOCK_EX)) {
	&clean_sym();
return undef;	return undef;
}	}
}	}
Line 266 sub _do_hash_untie {	Line 352 sub _do_hash_untie {
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)) {	if (!&flock_sym(LOCK_EX)) {
	&clean_sym();
return undef;	return undef;
}	}
} else {	} else {
Line 282 sub _do_hash_untie {	Line 369 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 311 sub _do_hash_untie {	Line 403 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.9
changed lines
	Added in v.1.23