version 1.10, 2006/06/27 15:21:28
|
version 1.35.2.2, 2019/08/25 22:29:29
|
Line 27
|
Line 27
|
# |
# |
### |
### |
|
|
|
|
|
|
package LONCAPA; |
package LONCAPA; |
|
|
use strict; |
use strict; |
Line 35 use LONCAPA::Configuration;
|
Line 37 use LONCAPA::Configuration;
|
use Fcntl qw(:flock); |
use Fcntl qw(:flock); |
use GDBM_File; |
use GDBM_File; |
use POSIX; |
use POSIX; |
|
#use Apache::lonnet; |
|
|
my $loncapa_max_wait_time = 13; |
my $loncapa_max_wait_time = 13; |
|
|
|
|
|
#-------------------------------------------------------------------------- |
|
# |
|
# The constant definnitions below probably should really be in |
|
# a configuration file somewhere (loncapa.conf?) and loaded so that they can be |
|
# modified without requring source code changes: |
|
# |
|
# COURSE_CACHE_TIME - Number of minutes after which an unaccessed |
|
# course.db or course_param.db file is considered |
|
# to be a stale cache of this info. |
|
# |
|
# LONCAPA_TEMPDIR - Place loncapa puts temporary files |
|
# |
|
|
|
my $COURSE_CACHE_TIME = 60; # minutes course cache file is considered valid. |
|
my $LONCAPA_TEMPDIR = '/tmp/'; # relative to configuration{'lonTabDir'}. |
|
|
|
use vars qw($match_domain $match_not_domain |
|
$match_username $match_not_username |
|
$match_courseid $match_not_courseid |
|
$match_community |
|
$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 &tie_course); |
|
our @EXPORT_OK = qw($match_domain $match_not_domain |
|
$match_username $match_not_username |
|
$match_courseid $match_not_courseid |
|
$match_community |
|
$match_name |
|
$match_lonid |
|
$match_handle $match_not_handle &tie_course); |
|
our %EXPORT_TAGS = ( 'match' =>[qw($match_domain $match_not_domain |
|
$match_username $match_not_username |
|
$match_courseid $match_not_courseid |
|
$match_community |
|
$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 { |
# If necessary fetch and tie a user's image of the course hash |
my ($string) = @_; |
# to the specified hash |
$string =~ s/[\#\$\%\&\\^_{}]/\\$&/g; |
# Parameters: |
return $string; |
# domain - User's domain |
|
# user - Name of user. |
|
# course - Course number. |
|
# cdom - Domain that is home to the course |
|
# hash - reference to the has to tie. |
|
# |
|
# Side effects: |
|
# a gdbm file and it's associated lock file will be created in the |
|
# tmp directory tree. |
|
# |
|
# Returns: |
|
# 0 - failure. |
|
# 1 - success. |
|
# |
|
# Note: |
|
# It's possible the required user's db file is already present in the tempdir. |
|
# in that case a decision must be made about whether or not to just tie to it |
|
# or to fetch it again. Remember this sub could be called in the context of a user |
|
# other than the one whose data are being fetched. We don't know if that user already |
|
# has a live session on this server. What we'll do is only re-fetch if the hash atime. |
|
# is older than COURSE_CACHE_TIME...that is if it's been accessed relatively recently |
|
# where COURSE_CACHE_TIME defines the caching time. |
|
# |
|
# The database files this function creates are of the form: |
|
# $user@$domain_$course@$cdom.{db,lock} |
|
# This differs from the prior filenames. Therefore if a module does its own |
|
# caching (That's a coding no-no) and does not use this centralized sub, |
|
# multiple cache files for the same course/user will be created. |
|
# |
|
sub tie_course { |
|
my ($domain, $user, $course, $cdom, $hash) = @_; |
|
|
|
# |
|
# See if we need to re-fetch the course data |
|
# |
|
|
|
|
} |
} |
|
|
|
# Return a string that is the path in which loncapa puts temp files: |
|
|
# Inputs are a url, and a hash ref of |
sub tempdir { |
# form name => value pairs |
my $result = $perlvar{'lonDaemons'}.$LONCAPA_TEMPDIR; # to allow debugging. |
# takes care of properly adding the form name elements and values to the |
return $result; |
# the url doing proper escaping of the values and joining with ? or & as |
} |
# needed |
|
|
# Return the default engine to use to render content of <m></m> tags unless |
|
# a domain, course, or user specific value exists. |
|
|
|
sub texengine { |
|
return 'tth'; |
|
} |
|
|
|
# Return the Linux distro where this LON-CAPA instance is running |
|
|
|
sub distro { |
|
my $distro; |
|
if (open(PIPE,"/home/httpd/perl/distprobe |")) { |
|
$distro = <PIPE>; |
|
close(PIPE); |
|
} |
|
return $distro; |
|
} |
|
|
|
# Return the default password length. Can be overridden in a domain |
|
# by specifying a larger value (integer) in the domain configuration. |
|
|
|
sub passwd_min { |
|
return 7; |
|
} |
|
|
|
#---------------------------------------------------------------------- |
|
# |
|
# some of these subs need a bit of documentation |
|
|
sub add_get_param { |
sub add_get_param { |
my ($url,$form_data) = @_; |
my ($url,$form_data) = @_; |
Line 91 sub unescape {
|
Line 199 sub unescape {
|
return $str; |
return $str; |
} |
} |
|
|
|
$LONCAPA::assess_re = qr{\.(problem|exam|quiz|assess|survey|form|library|task)$}; |
|
$LONCAPA::assess_page_re = qr{\.(problem|exam|quiz|assess|survey|form|library|task|page)$}; |
|
$LONCAPA::assess_page_seq_re = qr{\.(problem|exam|quiz|assess|survey|form|library|task|sequence|page)$}; |
|
$LONCAPA::parse_re = qr{\.(problem|exam|quiz|assess|survey|form|library|page|xml|html|htm|xhtml|xhtm)$}; |
|
$LONCAPA::parse_page_re = qr{\.(problem|exam|quiz|assess|survey|form|library|page|xml|html|htm|xhtml|xhtm|page)$}; |
|
$LONCAPA::parse_page_sty_re = qr{\.(problem|exam|quiz|assess|survey|form|library|page|xml|html|htm|xhtml|xhtm|page|sty)$}; |
|
|
|
|
|
$match_domain = $LONCAPA::domain_re = qr{[[:alnum:]\-.]+}; |
|
$match_not_domain = $LONCAPA::not_domain_re = qr{[^[:alnum:]\-.]+}; |
|
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_community =$LONCAPA::community_re = qr{0[\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; |
|
} |
|
|
|
# |
|
# -- Ensure another process for same filesystem action is not running. |
|
# lond uses for: apachereload; loncron uses for: lciptables |
|
# |
|
|
|
sub try_to_lock { |
|
my ($lockfile)=@_; |
|
my $currentpid; |
|
my $lastpid; |
|
# Do not manipulate lock file as root |
|
if ($>==0) { |
|
return 0; |
|
} |
|
# Try to generate lock file. |
|
# Wait 3 seconds. If same process id is in |
|
# lock file, then assume lock file is stale, and |
|
# go ahead. If process id's fluctuate, try |
|
# for a maximum of 10 times. |
|
for (0..10) { |
|
if (-e $lockfile) { |
|
open(LOCK,"<$lockfile"); |
|
$currentpid=<LOCK>; |
|
close LOCK; |
|
if ($currentpid==$lastpid) { |
|
last; |
|
} |
|
sleep 3; |
|
$lastpid=$currentpid; |
|
} else { |
|
last; |
|
} |
|
if ($_==10) { |
|
return 0; |
|
} |
|
} |
|
open(LOCK,">$lockfile"); |
|
print LOCK $$; |
|
close LOCK; |
|
return 1; |
|
} |
|
|
# -------------------------------------------- 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"; |
return $proname; |
return $proname; |
} |
} |
|
|
|
|
#--------------------------------------------------------------- |
|
# |
|
# Manipulation of hash based databases (factoring out common code |
|
# for later use as we refactor. |
|
# |
|
# Ties a domain level resource file to a hash. |
|
# If requested a history entry is created in the associated hist file. |
|
# |
|
# Parameters: |
|
# domain - Name of the domain in which the resource file lives. |
|
# namespace - Name of the hash within that domain. |
|
# how - How to tie the hash (e.g. GDBM_WRCREAT()). |
|
# loghead - Optional parameter, if present a log entry is created |
|
# in the associated history file and this is the first part |
|
# of that entry. |
|
# logtail - Goes along with loghead, The actual logentry is of the |
|
# form $loghead:<timestamp>:logtail. |
|
# Returns: |
|
# Reference to a hash bound to the db file or alternatively undef |
|
# if the tie failed. |
|
# |
|
sub tie_domain_hash { |
sub tie_domain_hash { |
my ($domain,$namespace,$how,$loghead,$logtail) = @_; |
my ($domain,$namespace,$how,$loghead,$logtail) = @_; |
|
|
# 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 143 sub tie_domain_hash {
|
Line 330 sub tie_domain_hash {
|
sub untie_domain_hash { |
sub untie_domain_hash { |
return &_locking_hash_untie(@_); |
return &_locking_hash_untie(@_); |
} |
} |
# |
|
# Ties a user's resource file to a hash. |
|
# If necessary, an appropriate history |
|
# log file entry is made as well. |
|
# This sub factors out common code from the subs that manipulate |
|
# the various gdbm files that keep keyword value pairs. |
|
# Parameters: |
|
# domain - Name of the domain the user is in. |
|
# user - Name of the 'current user'. |
|
# namespace - Namespace representing the file to tie. |
|
# how - What the tie is done to (e.g. GDBM_WRCREAT(). |
|
# loghead - Optional first part of log entry if there may be a |
|
# history file. |
|
# what - Optional tail of log entry if there may be a history |
|
# file. |
|
# Returns: |
|
# hash to which the database is tied. It's up to the caller to untie. |
|
# undef if the has could not be tied. |
|
# |
|
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 177 sub untie_user_hash {
|
Line 346 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 { |
sub locking_hash_tie { |
my ($filename,$how)=@_; |
my ($filename,$how)=@_; |
Line 229 sub _do_hash_untie {
|
Line 396 sub _do_hash_untie {
|
{ |
{ |
my $sym; |
my $sym; |
my @pushed_syms; |
my @pushed_syms; |
|
|
|
sub clean_sym { |
|
undef($sym); |
|
} |
sub push_locking_hash_tie { |
sub push_locking_hash_tie { |
if (!defined($sym)) { |
if (!defined($sym)) { |
die("Invalid used of push_locking_hash_tie, should only be called after a lock has occurred and before and unlock."); |
die("Invalid used of push_locking_hash_tie, should only be called after a lock has occurred and before and unlock."); |
Line 247 sub _do_hash_untie {
|
Line 418 sub _do_hash_untie {
|
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 withut proper use of push_locking_hahs_tie, 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 261 sub _do_hash_untie {
|
Line 432 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 268 sub _do_hash_untie {
|
Line 440 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 281 sub _do_hash_untie {
|
Line 455 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 297 sub _do_hash_untie {
|
Line 472 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 326 sub _do_hash_untie {
|
Line 506 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 { |
%perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')}; |
%perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')}; |
} |
} |
Line 343 __END__
|
Line 524 __END__
|
|
|
=head1 NAME |
=head1 NAME |
|
|
|
Apache::LONCAPA |
|
|
LONCAPA - Basic routines |
LONCAPA - Basic routines |
|
|
=head1 SYNOPSIS |
=head1 SYNOPSIS |
Line 351 Generally useful routines
|
Line 534 Generally useful routines
|
|
|
=head1 EXPORTED SUBROUTINES |
=head1 EXPORTED SUBROUTINES |
|
|
=over 4 |
=over |
|
|
=item * |
=item escape() |
|
|
escape() : unpack non-word characters into CGI-compatible hex codes |
unpack non-word characters into CGI-compatible hex codes |
|
|
=item * |
=item unescape() |
|
|
unescape() : pack CGI-compatible hex codes into actual non-word ASCII character |
pack CGI-compatible hex codes into actual non-word ASCII character |
|
|
=item * |
=item add_get_param() |
|
|
add_get_param() : |
Append escaped form elements (name=value etc.) to a url. |
|
|
Inputs: url (with or without exit GET from parameters), hash ref of |
Inputs: url (with or without exit GET from parameters), hash ref of |
form name => value pairs |
form name => value pairs |
|
|
Return: url with properly added the form name elements and values to the |
Return: url with form name elements and values appended to the |
the url doing proper escaping of the values and joining with ? or & |
the url, doing proper escaping of the values and joining with ? or & |
as needed |
as needed |
|
|
|
=item clean_handle() |
|
|
|
=item propath() |
|
|
|
=item untie_domain_hash() |
|
|
|
=item tie_domain_hash() |
|
|
|
Manipulation of hash based databases (factoring out common code |
|
for later use as we refactor. |
|
|
|
Ties a domain level resource file to a hash. |
|
If requested a history entry is created in the associated hist file. |
|
|
|
Parameters: |
|
domain - Name of the domain in which the resource file lives. |
|
namespace - Name of the hash within that domain. |
|
how - How to tie the hash (e.g. GDBM_WRCREAT()). |
|
loghead - Optional parameter, if present a log entry is created |
|
in the associated history file and this is the first part |
|
of that entry. |
|
logtail - Goes along with loghead, The actual logentry is of the |
|
form $loghead:<timestamp>:logtail. |
|
Returns: |
|
Reference to a hash bound to the db file or alternatively undef |
|
if the tie failed. |
|
|
|
=item tie_user_hash() |
|
|
|
Ties a user's resource file to a hash. |
|
If necessary, an appropriate history |
|
log file entry is made as well. |
|
This sub factors out common code from the subs that manipulate |
|
the various gdbm files that keep keyword value pairs. |
|
Parameters: |
|
domain - Name of the domain the user is in. |
|
user - Name of the 'current user'. |
|
namespace - Namespace representing the file to tie. |
|
how - What the tie is done to (e.g. GDBM_WRCREAT(). |
|
loghead - Optional first part of log entry if there may be a |
|
history file. |
|
what - Optional tail of log entry if there may be a history |
|
file. |
|
Returns: |
|
hash to which the database is tied. It's up to the caller to untie. |
|
undef if the has could not be tied. |
|
|
|
=item tie_course |
|
|
|
Caches the course database into the temp directory in the context of a specific |
|
user and ties it to a hash. |
|
Parameters: |
|
domain - Domain the user is in. |
|
user - Username of the user. |
|
course - Course specification |
|
cdom - The course domain. |
|
hash - Reference to the hash to tie. |
|
|
|
Returns: |
|
1 - Success |
|
0 - Failure. |
|
|
|
=item tie_course_params |
|
|
|
Caches the course parameter database into the temp directory in the context |
|
of a specific user and ties it to a hash. |
|
Parameters: |
|
domain - Domain the user is in. |
|
user - Username of the user. |
|
course - course specification. |
|
cdom - The course domain. |
|
hash - reference to the hash to tie. |
|
|
|
Returns: |
|
1 - Success. |
|
0 - Failure./ |
|
|
|
|
|
=item locking_hash_tie() |
|
|
|
routines if you just have a filename return tied hashref or undef |
|
|
|
=item locking_hash_untie() |
|
|
|
=item db_filename_parts() |
|
|
=back |
=back |
|
|
|
=item tempdir() |
|
|
|
Returns the file system path to the place loncapa temporary files should be placed/found. |
|
|
|
|
|
=head1 INTERNAL SUBROUTINES |
|
|
|
=over |
|
|
|
=item _do_hash_tie() |
|
|
|
=item _do_hash_untie() |
|
|
|
=back |
|
|
|
=cut |
|
|