|
version 1.2, 2012/04/26 19:51:40
|
version 1.8.2.3.2.5, 2024/08/18 01:37:26
|
|
Line 27
|
Line 27
|
| ### |
### |
| |
|
| #NOTE perldoc at the end of file |
#NOTE perldoc at the end of file |
| |
#TODO move remaining lond functions into this |
| |
|
| package LONCAPA::Lond; |
package LONCAPA::Lond; |
| |
|
|
Line 36 use lib '/home/httpd/lib/perl/';
|
Line 37 use lib '/home/httpd/lib/perl/';
|
| use LONCAPA; |
use LONCAPA; |
| use Apache::lonnet; |
use Apache::lonnet; |
| use GDBM_File; |
use GDBM_File; |
| |
use Net::OAuth; |
| |
use Crypt::CBC; |
| |
use Digest::SHA; |
| |
use Digest::MD5 qw(md5_hex); |
| |
|
| sub dump_with_regexp { |
sub dump_with_regexp { |
| my ( $tail, $clientname, $clientversion ) = @_; |
my ( $tail, $clientversion ) = @_; |
| my ( $udom, $uname, $namespace, $regexp, $range ) = |
my ( $udom, $uname, $namespace, $regexp, $range ) = |
| split /:/, $tail; |
split /:/, $tail; |
| |
|
| $regexp = defined $regexp ? unescape($regexp) : '.'; |
$regexp = $regexp ? unescape($regexp) : '.'; |
| |
|
| my ($start,$end); |
my ($start,$end); |
| |
|
|
Line 57 sub dump_with_regexp {
|
Line 61 sub dump_with_regexp {
|
| } |
} |
| } |
} |
| |
|
| |
# |
| |
# If dump is for file_permissions.db from a pre-2.12 server and |
| |
# $uname:$udom is not a course, determine if value of portaccess |
| |
# in effect for $uname:$udom allows portfolio files to be shared. |
| |
# If sharing is not allowed, records returned for accesscontrol |
| |
# are restricted to those based on ip (i.e., for externalresponse). |
| |
# |
| |
# Note: for 2.12 or later session-hosting server, determination |
| |
# of portaccess value in effect occurs client-side. |
| |
# |
| |
my ($check_portaccess,$access,$now,$major,$minor,%by_ip); |
| |
if ($namespace eq 'file_permissions') { |
| |
if ($clientversion =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) { |
| |
$major = $1; |
| |
$minor = $2; |
| |
} |
| |
unless ((($major > 2) || (($major == 2) && ($minor > 11))) || |
| |
&is_course($udom,$uname)) { |
| |
$check_portaccess = 1; |
| |
$access = &portfolio_is_shareable($udom,$uname); |
| |
} |
| |
$now = time; |
| |
} |
| |
|
| my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()) or |
my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()) or |
| return "error: ".($!+0)." tie(GDBM) Failed while attempting dump"; |
return "error: ".($!+0)." tie(GDBM) Failed while attempting dump"; |
| |
|
|
Line 70 sub dump_with_regexp {
|
Line 98 sub dump_with_regexp {
|
| # |
# |
| my $skipcheck; |
my $skipcheck; |
| my @ids = &Apache::lonnet::current_machine_ids(); |
my @ids = &Apache::lonnet::current_machine_ids(); |
| my (%homecourses, $major, $minor, $now); |
my %homecourses; |
| # |
# |
| # If dump is for roles.db from a pre-2.10 server, determine the LON-CAPA |
# If dump is for roles.db from a pre-2.10 server, determine the LON-CAPA |
| # version on the server which requested the data. |
# version on the server which requested the data. |
|
Line 79 sub dump_with_regexp {
|
Line 107 sub dump_with_regexp {
|
| if ($clientversion =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) { |
if ($clientversion =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) { |
| $major = $1; |
$major = $1; |
| $minor = $2; |
$minor = $2; |
| |
|
| } |
} |
| if (($major > 2) || (($major == 2) && ($minor > 9))) { |
if (($major > 2) || (($major == 2) && ($minor > 9))) { |
| $skipcheck = 1; |
$skipcheck = 1; |
|
Line 107 sub dump_with_regexp {
|
Line 136 sub dump_with_regexp {
|
| } |
} |
| } |
} |
| } |
} |
| |
if ($namespace eq 'file_permissions') { |
| |
if ($check_portaccess) { |
| |
unless ($access) { |
| |
my $unesckey = &unescape($key); |
| |
if ($unesckey =~ m{\0((\d+)_\d+_\d+:([a-z]+)_(\d+)_(\d+))$}) { |
| |
my ($acl,$timestamp,$scope,$end,$start) = ($1,$2,$3,$4); |
| |
if ($scope eq 'ip') { |
| |
unless (($start > $now) && |
| |
($end && $end<$now)) { |
| |
my ($path) = split(/\0/,$unesckey); |
| |
push(@{$by_ip{$path}},{$acl => $timestamp}); |
| |
} |
| |
} |
| |
next; |
| |
} elsif ($unesckey =~ m{\0accesscontrol$}) { |
| |
next; |
| |
} |
| |
} |
| |
} |
| |
} |
| if ($regexp eq '.') { |
if ($regexp eq '.') { |
| $count++; |
$count++; |
| if (defined($range) && $count >= $end) { last; } |
if (defined($range) && $count >= $end) { last; } |
|
Line 122 sub dump_with_regexp {
|
Line 171 sub dump_with_regexp {
|
| } |
} |
| } |
} |
| } |
} |
| |
if (($namespace eq 'file_permissions') && ($check_portaccess) && (!$access)) { |
| |
if (keys(%by_ip)) { |
| |
my %accesscontrol; |
| |
foreach my $path (keys(%by_ip)) { |
| |
if (ref($by_ip{$path}) eq 'ARRAY') { |
| |
foreach my $item (@{$by_ip{$path}}) { |
| |
if (ref($item) eq 'HASH') { |
| |
my ($acl,$timestamp) = each(%$item); |
| |
my $key = &escape("$path\0$acl"); |
| |
my $value = $hashref->{$key}; |
| |
$qresult.= "$key=$value&"; |
| |
$accesscontrol{"$path\0accesscontrol"}{$acl} = $timestamp; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if (keys(%accesscontrol)) { |
| |
while (my ($key,$value) = each(%accesscontrol)) { |
| |
$qresult.= &escape($key).'='.&Apache::lonnet::freeze_escape($value).'&'; |
| |
} |
| |
} |
| |
} |
| |
} |
| &untie_user_hash($hashref) or |
&untie_user_hash($hashref) or |
| return "error: ".($!+0)." untie(GDBM) Failed while attempting dump"; |
return "error: ".($!+0)." untie(GDBM) Failed while attempting dump"; |
| # |
# |
|
Line 237 sub check_homecourses {
|
Line 308 sub check_homecourses {
|
| } |
} |
| } |
} |
| unless (&untie_domain_hash($hashref)) { |
unless (&untie_domain_hash($hashref)) { |
| &logthis("Failed to untie tied hash for nohist_courseids.db for $domain"); |
&Apache::lonnet::logthis("Failed to untie tied hash for nohist_courseids.db for $domain"); |
| } |
} |
| } else { |
} else { |
| &logthis("Failed to tie hash for nohist_courseids.db for $domain"); |
&Apache::lonnet::logthis("Failed to tie hash for nohist_courseids.db for $domain"); |
| } |
} |
| } |
} |
| foreach my $hashid (keys(%recent)) { |
foreach my $hashid (keys(%recent)) { |
|
Line 300 sub useable_role {
|
Line 371 sub useable_role {
|
| } |
} |
| |
|
| |
|
| |
sub get_courseinfo_hash { |
| |
my ($cnum,$cdom,$home) = @_; |
| |
my %info; |
| |
eval { |
| |
local($SIG{ALRM}) = sub { die "timeout\n"; }; |
| |
local($SIG{__DIE__})='DEFAULT'; |
| |
alarm(3); |
| |
%info = &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,1,[$home],'.'); |
| |
alarm(0); |
| |
}; |
| |
if ($@) { |
| |
if ($@ eq "timeout\n") { |
| |
&Apache::lonnet::logthis("<font color='blue'>WARNING courseiddump for $cnum:$cdom from $home timedout</font>"); |
| |
} else { |
| |
&Apache::lonnet::logthis("<font color='yellow'>WARNING unexpected error during eval of call for courseiddump from $home</font>"); |
| |
} |
| |
} else { |
| |
if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') { |
| |
my $hashid = $cdom.':'.$cnum; |
| |
return &Apache::lonnet::do_cache_new('courseinfo',$hashid,$info{$cdom.'_'.$cnum},600); |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub portfolio_is_shareable { |
| |
my ($udom,$uname) = @_; |
| |
my $check_portaccess = 1; |
| |
my ($userportaccess,$inststatus,$access); |
| |
my $hashref = &tie_user_hash($udom, $uname, 'environment', &GDBM_READER()); |
| |
if (ref($hashref) eq 'HASH') { |
| |
my $accesskey = &escape('tools.portaccess'); |
| |
$userportaccess = $hashref->{$accesskey}; |
| |
$inststatus = $hashref->{'inststatus'}; |
| |
&untie_user_hash($hashref); |
| |
} |
| |
if ($userportaccess ne '') { |
| |
$access = $userportaccess; |
| |
} else { |
| |
my %domdefs = &Apache::lonnet::get_domain_defaults($udom); |
| |
if (ref($domdefs{'portaccess'}) eq 'HASH') { |
| |
if (($domdefs{'portaccess'}{'_LC_adv'} ne '') && |
| |
(&Apache::lonnet::is_advanced_user($udom,$uname))) { |
| |
if ($domdefs{'portaccess'}{'_LC_adv'}) { |
| |
$access = 1; |
| |
} else { |
| |
$access = 0; |
| |
} |
| |
} elsif ($inststatus ne '') { |
| |
my ($hasaccess,$hasnoaccess); |
| |
foreach my $affiliation (split(/:/,$inststatus)) { |
| |
if ($domdefs{'portaccess'}{$affiliation} ne '') { |
| |
if ($domdefs{'portaccess'}{$affiliation}) { |
| |
$hasaccess = 1; |
| |
} else { |
| |
$hasnoaccess = 1; |
| |
} |
| |
} |
| |
} |
| |
if ($hasaccess || $hasnoaccess) { |
| |
if ($hasaccess) { |
| |
$access = 1; |
| |
} elsif ($hasnoaccess) { |
| |
$access = 0; |
| |
} |
| |
} |
| |
} else { |
| |
if ($domdefs{'portaccess'}{'default'} ne '') { |
| |
if ($domdefs{'portaccess'}{'default'}) { |
| |
$access = 1; |
| |
} elsif ($domdefs{'portaccess'}{'default'} == 0) { |
| |
$access = 0; |
| |
} |
| |
} |
| |
} |
| |
} else { |
| |
$access = 1; |
| |
} |
| |
} |
| |
return $access; |
| |
} |
| |
|
| |
sub dump_course_id_handler { |
| |
my ($tail) = @_; |
| |
|
| |
my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter, |
| |
$typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden, |
| |
$caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter, |
| |
$creationcontext,$domcloner,$hasuniquecode,$reqcrsdom,$reqinstcode) = split(/:/,$tail); |
| |
my $now = time; |
| |
my ($cloneruname,$clonerudom,%cc_clone); |
| |
if (defined($description)) { |
| |
$description=&unescape($description); |
| |
} else { |
| |
$description='.'; |
| |
} |
| |
if (defined($instcodefilter)) { |
| |
$instcodefilter=&unescape($instcodefilter); |
| |
} else { |
| |
$instcodefilter='.'; |
| |
} |
| |
my ($ownerunamefilter,$ownerdomfilter); |
| |
if (defined($ownerfilter)) { |
| |
$ownerfilter=&unescape($ownerfilter); |
| |
if ($ownerfilter ne '.' && defined($ownerfilter)) { |
| |
if ($ownerfilter =~ /^([^:]*):([^:]*)$/) { |
| |
$ownerunamefilter = $1; |
| |
$ownerdomfilter = $2; |
| |
} else { |
| |
$ownerunamefilter = $ownerfilter; |
| |
$ownerdomfilter = ''; |
| |
} |
| |
} |
| |
} else { |
| |
$ownerfilter='.'; |
| |
} |
| |
|
| |
if (defined($coursefilter)) { |
| |
$coursefilter=&unescape($coursefilter); |
| |
} else { |
| |
$coursefilter='.'; |
| |
} |
| |
if (defined($typefilter)) { |
| |
$typefilter=&unescape($typefilter); |
| |
} else { |
| |
$typefilter='.'; |
| |
} |
| |
if (defined($regexp_ok)) { |
| |
$regexp_ok=&unescape($regexp_ok); |
| |
} |
| |
if (defined($catfilter)) { |
| |
$catfilter=&unescape($catfilter); |
| |
} |
| |
if (defined($cloner)) { |
| |
$cloner = &unescape($cloner); |
| |
($cloneruname,$clonerudom) = ($cloner =~ /^($LONCAPA::match_username):($LONCAPA::match_domain)$/); |
| |
} |
| |
if (defined($cc_clone_list)) { |
| |
$cc_clone_list = &unescape($cc_clone_list); |
| |
my @cc_cloners = split('&',$cc_clone_list); |
| |
foreach my $cid (@cc_cloners) { |
| |
my ($clonedom,$clonenum) = split(':',$cid); |
| |
next if ($clonedom ne $udom); |
| |
$cc_clone{$clonedom.'_'.$clonenum} = 1; |
| |
} |
| |
} |
| |
if ($createdbefore ne '') { |
| |
$createdbefore = &unescape($createdbefore); |
| |
} else { |
| |
$createdbefore = 0; |
| |
} |
| |
if ($createdafter ne '') { |
| |
$createdafter = &unescape($createdafter); |
| |
} else { |
| |
$createdafter = 0; |
| |
} |
| |
if ($creationcontext ne '') { |
| |
$creationcontext = &unescape($creationcontext); |
| |
} else { |
| |
$creationcontext = '.'; |
| |
} |
| |
unless ($hasuniquecode) { |
| |
$hasuniquecode = '.'; |
| |
} |
| |
if ($reqinstcode ne '') { |
| |
$reqinstcode = &unescape($reqinstcode); |
| |
} |
| |
my $unpack = 1; |
| |
if ($description eq '.' && $instcodefilter eq '.' && $ownerfilter eq '.' && |
| |
$typefilter eq '.') { |
| |
$unpack = 0; |
| |
} |
| |
if (!defined($since)) { $since=0; } |
| |
my (%gotcodedefaults,%otcodedefaults); |
| |
my $qresult=''; |
| |
|
| |
my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT()) |
| |
or return "error: ".($!+0)." tie(GDBM) Failed while attempting courseiddump"; |
| |
|
| |
while (my ($key,$value) = each(%$hashref)) { |
| |
my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val, |
| |
%unesc_val,$selfenroll_end,$selfenroll_types,$created, |
| |
$context); |
| |
$unesc_key = &unescape($key); |
| |
if ($unesc_key =~ /^lasttime:/) { |
| |
next; |
| |
} else { |
| |
$lasttime_key = &escape('lasttime:'.$unesc_key); |
| |
} |
| |
if ($hashref->{$lasttime_key} ne '') { |
| |
$lasttime = $hashref->{$lasttime_key}; |
| |
next if ($lasttime<$since); |
| |
} |
| |
my ($canclone,$valchange,$clonefromcode); |
| |
my $items = &Apache::lonnet::thaw_unescape($value); |
| |
if (ref($items) eq 'HASH') { |
| |
if ($hashref->{$lasttime_key} eq '') { |
| |
next if ($since > 1); |
| |
} |
| |
if ($items->{'inst_code'}) { |
| |
$clonefromcode = $items->{'inst_code'}; |
| |
} |
| |
$is_hash = 1; |
| |
if ($domcloner) { |
| |
$canclone = 1; |
| |
} elsif (defined($clonerudom)) { |
| |
if ($items->{'cloners'}) { |
| |
my @cloneable = split(',',$items->{'cloners'}); |
| |
if (@cloneable) { |
| |
if (grep(/^\*$/,@cloneable)) { |
| |
$canclone = 1; |
| |
} elsif (grep(/^\*:\Q$clonerudom\E$/,@cloneable)) { |
| |
$canclone = 1; |
| |
} elsif (grep(/^\Q$cloneruname\E:\Q$clonerudom\E$/,@cloneable)) { |
| |
$canclone = 1; |
| |
} |
| |
} |
| |
unless ($canclone) { |
| |
if ($cloneruname ne '' && $clonerudom ne '') { |
| |
if ($cc_clone{$unesc_key}) { |
| |
$canclone = 1; |
| |
$items->{'cloners'} .= ','.$cloneruname.':'. |
| |
$clonerudom; |
| |
$valchange = 1; |
| |
} |
| |
} |
| |
} |
| |
unless ($canclone) { |
| |
if (($reqcrsdom eq $udom) && ($reqinstcode) && ($clonefromcode)) { |
| |
if (grep(/\=/,@cloneable)) { |
| |
foreach my $cloner (@cloneable) { |
| |
if (($cloner ne '*') && ($cloner !~ /^\*\:$LONCAPA::match_domain$/) && |
| |
($cloner !~ /^$LONCAPA::match_username\:$LONCAPA::match_domain$/) && ($cloner ne '')) { |
| |
if ($cloner =~ /=/) { |
| |
my (%codedefaults,@code_order); |
| |
if (ref($gotcodedefaults{$udom}) eq 'HASH') { |
| |
if (ref($gotcodedefaults{$udom}{'defaults'}) eq 'HASH') { |
| |
%codedefaults = %{$gotcodedefaults{$udom}{'defaults'}}; |
| |
} |
| |
if (ref($gotcodedefaults{$udom}{'order'}) eq 'ARRAY') { |
| |
@code_order = @{$gotcodedefaults{$udom}{'order'}}; |
| |
} |
| |
} else { |
| |
&Apache::lonnet::auto_instcode_defaults($udom, |
| |
\%codedefaults, |
| |
\@code_order); |
| |
$gotcodedefaults{$udom}{'defaults'} = \%codedefaults; |
| |
$gotcodedefaults{$udom}{'order'} = \@code_order; |
| |
} |
| |
if (@code_order > 0) { |
| |
if (&Apache::lonnet::check_instcode_cloning(\%codedefaults,\@code_order, |
| |
$cloner,$clonefromcode,$reqinstcode)) { |
| |
$canclone = 1; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} elsif (defined($cloneruname)) { |
| |
if ($cc_clone{$unesc_key}) { |
| |
$canclone = 1; |
| |
$items->{'cloners'} = $cloneruname.':'.$clonerudom; |
| |
$valchange = 1; |
| |
} |
| |
unless ($canclone) { |
| |
if ($items->{'owner'} =~ /:/) { |
| |
if ($items->{'owner'} eq $cloner) { |
| |
$canclone = 1; |
| |
} |
| |
} elsif ($cloner eq $items->{'owner'}.':'.$udom) { |
| |
$canclone = 1; |
| |
} |
| |
if ($canclone) { |
| |
$items->{'cloners'} = $cloneruname.':'.$clonerudom; |
| |
$valchange = 1; |
| |
} |
| |
} |
| |
} |
| |
unless (($canclone) || ($items->{'cloners'})) { |
| |
my %domdefs = &Apache::lonnet::get_domain_defaults($udom); |
| |
if ($domdefs{'canclone'}) { |
| |
unless ($domdefs{'canclone'} eq 'none') { |
| |
if ($domdefs{'canclone'} eq 'domain') { |
| |
if ($clonerudom eq $udom) { |
| |
$canclone = 1; |
| |
} |
| |
} elsif (($clonefromcode) && ($reqinstcode) && |
| |
($udom eq $reqcrsdom)) { |
| |
if (&Apache::lonnet::default_instcode_cloning($udom,$domdefs{'canclone'}, |
| |
$clonefromcode,$reqinstcode)) { |
| |
$canclone = 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($unpack || !$rtn_as_hash) { |
| |
$unesc_val{'descr'} = $items->{'description'}; |
| |
$unesc_val{'inst_code'} = $items->{'inst_code'}; |
| |
$unesc_val{'owner'} = $items->{'owner'}; |
| |
$unesc_val{'type'} = $items->{'type'}; |
| |
$unesc_val{'cloners'} = $items->{'cloners'}; |
| |
$unesc_val{'created'} = $items->{'created'}; |
| |
$unesc_val{'context'} = $items->{'context'}; |
| |
} |
| |
$selfenroll_types = $items->{'selfenroll_types'}; |
| |
$selfenroll_end = $items->{'selfenroll_end_date'}; |
| |
$created = $items->{'created'}; |
| |
$context = $items->{'context'}; |
| |
if ($selfenrollonly) { |
| |
next if (!$selfenroll_types); |
| |
if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) { |
| |
next; |
| |
} |
| |
} |
| |
if ($creationcontext ne '.') { |
| |
next if (($context ne '') && ($context ne $creationcontext)); |
| |
} |
| |
if ($createdbefore > 0) { |
| |
next if (($created eq '') || ($created > $createdbefore)); |
| |
} |
| |
if ($createdafter > 0) { |
| |
next if (($created eq '') || ($created <= $createdafter)); |
| |
} |
| |
if ($catfilter ne '') { |
| |
next if ($items->{'categories'} eq ''); |
| |
my @categories = split('&',$items->{'categories'}); |
| |
next if (@categories == 0); |
| |
my @subcats = split('&',$catfilter); |
| |
my $matchcat = 0; |
| |
foreach my $cat (@categories) { |
| |
if (grep(/^\Q$cat\E$/,@subcats)) { |
| |
$matchcat = 1; |
| |
last; |
| |
} |
| |
} |
| |
next if (!$matchcat); |
| |
} |
| |
if ($caller eq 'coursecatalog') { |
| |
if ($items->{'hidefromcat'} eq 'yes') { |
| |
next if !$showhidden; |
| |
} |
| |
} |
| |
if ($hasuniquecode ne '.') { |
| |
next unless ($items->{'uniquecode'}); |
| |
} |
| |
} else { |
| |
next if ($catfilter ne ''); |
| |
next if ($selfenrollonly); |
| |
next if ($createdbefore || $createdafter); |
| |
next if ($creationcontext ne '.'); |
| |
if ((defined($clonerudom)) && (defined($cloneruname))) { |
| |
if ($cc_clone{$unesc_key}) { |
| |
$canclone = 1; |
| |
$val{'cloners'} = &escape($cloneruname.':'.$clonerudom); |
| |
} |
| |
} |
| |
$is_hash = 0; |
| |
my @courseitems = split(/:/,$value); |
| |
$lasttime = pop(@courseitems); |
| |
if ($hashref->{$lasttime_key} eq '') { |
| |
next if ($lasttime<$since); |
| |
} |
| |
($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems; |
| |
} |
| |
if ($cloneonly) { |
| |
next unless ($canclone); |
| |
} |
| |
my $match = 1; |
| |
if ($description ne '.') { |
| |
if (!$is_hash) { |
| |
$unesc_val{'descr'} = &unescape($val{'descr'}); |
| |
} |
| |
if (eval{$unesc_val{'descr'} !~ /\Q$description\E/i}) { |
| |
$match = 0; |
| |
} |
| |
} |
| |
if ($instcodefilter ne '.') { |
| |
if (!$is_hash) { |
| |
$unesc_val{'inst_code'} = &unescape($val{'inst_code'}); |
| |
} |
| |
if ($regexp_ok == 1) { |
| |
if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) { |
| |
$match = 0; |
| |
} |
| |
} elsif ($regexp_ok == -1) { |
| |
if (eval{$unesc_val{'inst_code'} =~ /$instcodefilter/}) { |
| |
$match = 0; |
| |
} |
| |
} else { |
| |
if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) { |
| |
$match = 0; |
| |
} |
| |
} |
| |
} |
| |
if ($ownerfilter ne '.') { |
| |
if (!$is_hash) { |
| |
$unesc_val{'owner'} = &unescape($val{'owner'}); |
| |
} |
| |
if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) { |
| |
if ($unesc_val{'owner'} =~ /:/) { |
| |
if (eval{$unesc_val{'owner'} !~ |
| |
/\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i}) { |
| |
$match = 0; |
| |
} |
| |
} else { |
| |
if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) { |
| |
$match = 0; |
| |
} |
| |
} |
| |
} elsif ($ownerunamefilter ne '') { |
| |
if ($unesc_val{'owner'} =~ /:/) { |
| |
if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E:[^:]+$/i}) { |
| |
$match = 0; |
| |
} |
| |
} else { |
| |
if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) { |
| |
$match = 0; |
| |
} |
| |
} |
| |
} elsif ($ownerdomfilter ne '') { |
| |
if ($unesc_val{'owner'} =~ /:/) { |
| |
if (eval{$unesc_val{'owner'} !~ /^[^:]+:\Q$ownerdomfilter\E/}) { |
| |
$match = 0; |
| |
} |
| |
} else { |
| |
if ($ownerdomfilter ne $udom) { |
| |
$match = 0; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($coursefilter ne '.') { |
| |
if (eval{$unesc_key !~ /^$udom(_)\Q$coursefilter\E$/}) { |
| |
$match = 0; |
| |
} |
| |
} |
| |
if ($typefilter ne '.') { |
| |
if (!$is_hash) { |
| |
$unesc_val{'type'} = &unescape($val{'type'}); |
| |
} |
| |
if ($unesc_val{'type'} eq '') { |
| |
if ($typefilter ne 'Course') { |
| |
$match = 0; |
| |
} |
| |
} else { |
| |
if (eval{$unesc_val{'type'} !~ /^\Q$typefilter\E$/}) { |
| |
$match = 0; |
| |
} |
| |
} |
| |
} |
| |
if ($match == 1) { |
| |
if ($rtn_as_hash) { |
| |
if ($is_hash) { |
| |
if ($valchange) { |
| |
my $newvalue = &Apache::lonnet::freeze_escape($items); |
| |
$qresult.=$key.'='.$newvalue.'&'; |
| |
} else { |
| |
$qresult.=$key.'='.$value.'&'; |
| |
} |
| |
} else { |
| |
my %rtnhash = ( 'description' => &unescape($val{'descr'}), |
| |
'inst_code' => &unescape($val{'inst_code'}), |
| |
'owner' => &unescape($val{'owner'}), |
| |
'type' => &unescape($val{'type'}), |
| |
'cloners' => &unescape($val{'cloners'}), |
| |
); |
| |
my $items = &Apache::lonnet::freeze_escape(\%rtnhash); |
| |
$qresult.=$key.'='.$items.'&'; |
| |
} |
| |
} else { |
| |
if ($is_hash) { |
| |
$qresult .= $key.'='.&escape($unesc_val{'descr'}).':'. |
| |
&escape($unesc_val{'inst_code'}).':'. |
| |
&escape($unesc_val{'owner'}).'&'; |
| |
} else { |
| |
$qresult .= $key.'='.$val{'descr'}.':'.$val{'inst_code'}. |
| |
':'.$val{'owner'}.'&'; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
&untie_domain_hash($hashref) or |
| |
return "error: ".($!+0)." untie(GDBM) Failed while attempting courseiddump"; |
| |
|
| |
chop($qresult); |
| |
return $qresult; |
| |
} |
| |
|
| |
sub dump_profile_database { |
| |
my ($tail) = @_; |
| |
|
| |
my ($udom,$uname,$namespace) = split(/:/,$tail); |
| |
|
| |
my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()) or |
| |
return "error: ".($!+0)." tie(GDBM) Failed while attempting currentdump"; |
| |
|
| |
# Structure of %data: |
| |
# $data{$symb}->{$parameter}=$value; |
| |
# $data{$symb}->{'v.'.$parameter}=$version; |
| |
# since $parameter will be unescaped, we do not |
| |
# have to worry about silly parameter names... |
| |
|
| |
my $qresult=''; |
| |
my %data = (); # A hash of anonymous hashes.. |
| |
while (my ($key,$value) = each(%$hashref)) { |
| |
my ($v,$symb,$param) = split(/:/,$key); |
| |
next if ($v eq 'version' || $symb eq 'keys'); |
| |
next if (exists($data{$symb}) && |
| |
exists($data{$symb}->{$param}) && |
| |
$data{$symb}->{'v.'.$param} > $v); |
| |
$data{$symb}->{$param}=$value; |
| |
$data{$symb}->{'v.'.$param}=$v; |
| |
} |
| |
|
| |
&untie_user_hash($hashref) or |
| |
return "error: ".($!+0)." untie(GDBM) Failed while attempting currentdump"; |
| |
|
| |
while (my ($symb,$param_hash) = each(%data)) { |
| |
while(my ($param,$value) = each (%$param_hash)){ |
| |
next if ($param =~ /^v\./); # Ignore versions... |
| |
# |
| |
# Just dump the symb=value pairs separated by & |
| |
# |
| |
$qresult.=$symb.':'.$param.'='.$value.'&'; |
| |
} |
| |
} |
| |
|
| |
chop($qresult); |
| |
return $qresult; |
| |
} |
| |
|
| |
sub is_course { |
| |
my ($cdom,$cnum) = @_; |
| |
|
| |
return unless (($cdom =~ /^$LONCAPA::match_domain$/) && |
| |
($cnum =~ /^$LONCAPA::match_courseid$/)); |
| |
my $hashid = $cdom.':'.$cnum; |
| |
my ($iscourse,$cached) = |
| |
&Apache::lonnet::is_cached_new('iscourse',$hashid); |
| |
unless (defined($cached)) { |
| |
my $hashref = |
| |
&tie_domain_hash($cdom, "nohist_courseids", &GDBM_WRCREAT()); |
| |
if (ref($hashref) eq 'HASH') { |
| |
my $esc_key = &escape($cdom.'_'.$cnum); |
| |
if (exists($hashref->{$esc_key})) { |
| |
$iscourse = 1; |
| |
} else { |
| |
$iscourse = 0; |
| |
} |
| |
&Apache::lonnet::do_cache_new('iscourse',$hashid,$iscourse,3600); |
| |
unless (&untie_domain_hash($hashref)) { |
| |
&Apache::lonnet::logthis("Failed to untie tied hash for nohist_courseids.db for $cdom"); |
| |
} |
| |
} else { |
| |
&Apache::lonnet::logthis("Failed to tie hash for nohist_courseids.db for $cdom"); |
| |
} |
| |
} |
| |
return $iscourse; |
| |
} |
| |
|
| |
sub get_dom { |
| |
my ($userinput) = @_; |
| |
my ($cmd,$udom,$namespace,$what) =split(/:/,$userinput,4); |
| |
my $hashref = &tie_domain_hash($udom,$namespace,&GDBM_READER()) or |
| |
return "error: ".($!+0)." tie(GDBM) Failed while attempting $cmd"; |
| |
my $qresult=''; |
| |
if (ref($hashref)) { |
| |
chomp($what); |
| |
my @queries=split(/\&/,$what); |
| |
for (my $i=0;$i<=$#queries;$i++) { |
| |
$qresult.="$hashref->{$queries[$i]}&"; |
| |
} |
| |
$qresult=~s/\&$//; |
| |
} |
| |
&untie_user_hash($hashref) or |
| |
return "error: ".($!+0)." untie(GDBM) Failed while attempting $cmd"; |
| |
return $qresult; |
| |
} |
| |
|
| |
sub store_dom { |
| |
my ($userinput) = @_; |
| |
my ($cmd,$dom,$namespace,$rid,$what) =split(/:/,$userinput); |
| |
my $hashref = &tie_domain_hash($dom,$namespace,&GDBM_WRCREAT(),"S","$rid:$what") or |
| |
return "error: ".($!+0)." tie(GDBM) Failed while attempting $cmd"; |
| |
$hashref->{"version:$rid"}++; |
| |
my $version=$hashref->{"version:$rid"}; |
| |
my $allkeys=''; |
| |
my @pairs=split(/\&/,$what); |
| |
foreach my $pair (@pairs) { |
| |
my ($key,$value)=split(/=/,$pair); |
| |
$allkeys.=$key.':'; |
| |
$hashref->{"$version:$rid:$key"}=$value; |
| |
} |
| |
my $now = time; |
| |
$hashref->{"$version:$rid:timestamp"}=$now; |
| |
$allkeys.='timestamp'; |
| |
$hashref->{"$version:keys:$rid"}=$allkeys; |
| |
&untie_user_hash($hashref) or |
| |
return "error: ".($!+0)." untie(GDBM) Failed while attempting $cmd"; |
| |
return 'ok'; |
| |
} |
| |
|
| |
sub restore_dom { |
| |
my ($userinput) = @_; |
| |
my ($cmd,$dom,$namespace,$rid) = split(/:/,$userinput); |
| |
my $hashref = &tie_domain_hash($dom,$namespace,&GDBM_READER()) or |
| |
return "error: ".($!+0)." tie(GDBM) Failed while attempting $cmd"; |
| |
my $qresult=''; |
| |
if (ref($hashref)) { |
| |
chomp($rid); |
| |
my $version=$hashref->{"version:$rid"}; |
| |
$qresult.="version=$version&"; |
| |
my $scope; |
| |
for ($scope=1;$scope<=$version;$scope++) { |
| |
my $vkeys=$hashref->{"$scope:keys:$rid"}; |
| |
my @keys=split(/:/,$vkeys); |
| |
my $key; |
| |
$qresult.="$scope:keys=$vkeys&"; |
| |
foreach $key (@keys) { |
| |
$qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&"; |
| |
} |
| |
} |
| |
$qresult=~s/\&$//; |
| |
} |
| |
&untie_user_hash($hashref) or |
| |
return "error: ".($!+0)." untie(GDBM) Failed while attempting $cmd"; |
| |
return $qresult; |
| |
} |
| |
|
| |
sub crslti_itemid { |
| |
my ($cdom,$cnum,$url,$method,$params,$loncaparev) = @_; |
| |
unless (ref($params) eq 'HASH') { |
| |
return; |
| |
} |
| |
if (($cdom eq '') || ($cnum eq '')) { |
| |
return; |
| |
} |
| |
my ($itemid,$consumer_key,$secret); |
| |
|
| |
if (exists($params->{'oauth_callback'})) { |
| |
$Net::OAuth::PROTOCOL_VERSION = Net::OAuth::PROTOCOL_VERSION_1_0A; |
| |
} else { |
| |
$Net::OAuth::PROTOCOL_VERSION = Net::OAuth::PROTOCOL_VERSION_1_0; |
| |
} |
| |
|
| |
my $consumer_key = $params->{'oauth_consumer_key'}; |
| |
return if ($consumer_key eq ''); |
| |
|
| |
my (%crslti,%crslti_by_key); |
| |
my $hashid=$cdom.'_'.$cnum; |
| |
my ($result,$cached)=&Apache::lonnet::is_cached_new('courseltienc',$hashid); |
| |
if (defined($cached)) { |
| |
if (ref($result) eq 'HASH') { |
| |
%crslti = %{$result}; |
| |
} |
| |
} else { |
| |
my $reply = &dump_with_regexp(join(":",($cdom,$cnum,'nohist_ltienc','','')),$loncaparev); |
| |
%crslti = %{&Apache::lonnet::unserialize($reply)}; |
| |
my $cachetime = 24*60*60; |
| |
&Apache::lonnet::do_cache_new('courseltienc',$hashid,\%crslti,$cachetime); |
| |
} |
| |
|
| |
return if (!keys(%crslti)); |
| |
|
| |
foreach my $id (keys(%crslti)) { |
| |
if (ref($crslti{$id}) eq 'HASH') { |
| |
my $key = $crslti{$id}{'key'}; |
| |
if (($key ne '') && ($crslti{$id}{'secret'} ne '')) { |
| |
push(@{$crslti_by_key{$key}},$id); |
| |
} |
| |
} |
| |
} |
| |
|
| |
return if (!keys(%crslti_by_key)); |
| |
|
| |
my %courselti = &Apache::lonnet::get_course_lti($cnum,$cdom,'provider'); |
| |
|
| |
if (ref($crslti_by_key{$consumer_key}) eq 'ARRAY') { |
| |
foreach my $id (@{$crslti_by_key{$consumer_key}}) { |
| |
my $secret = $crslti{$id}{'secret'}; |
| |
if (ref($courselti{$id}) eq 'HASH') { |
| |
if ((exists($courselti{$id}{'cipher'})) && |
| |
($courselti{$id}{'cipher'} =~ /^\d+$/)) { |
| |
my $keynum = $courselti{$id}{'cipher'}; |
| |
my $privkey = &get_dom("getdom:$cdom:private:$keynum:lti:key"); |
| |
if ($privkey ne '') { |
| |
my $cipher = new Crypt::CBC($privkey); |
| |
$secret = $cipher->decrypt_hex($secret); |
| |
} |
| |
} |
| |
} |
| |
my $request = Net::OAuth->request('request token')->from_hash($params, |
| |
request_url => $url, |
| |
request_method => $method, |
| |
consumer_secret => $secret,); |
| |
if ($request->verify()) { |
| |
$itemid = $id; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
return $itemid; |
| |
} |
| |
|
| |
sub domlti_itemid { |
| |
my ($dom,$context,$url,$method,$params,$loncaparev) = @_; |
| |
unless (ref($params) eq 'HASH') { |
| |
return; |
| |
} |
| |
if ($dom eq '') { |
| |
return; |
| |
} |
| |
my ($itemid,$consumer_key,$secret); |
| |
|
| |
if (exists($params->{'oauth_callback'})) { |
| |
$Net::OAuth::PROTOCOL_VERSION = Net::OAuth::PROTOCOL_VERSION_1_0A; |
| |
} else { |
| |
$Net::OAuth::PROTOCOL_VERSION = Net::OAuth::PROTOCOL_VERSION_1_0; |
| |
} |
| |
|
| |
my $consumer_key = $params->{'oauth_consumer_key'}; |
| |
return if ($consumer_key eq ''); |
| |
|
| |
my ($name,$cachename); |
| |
if ($context eq 'linkprot') { |
| |
$name = $context; |
| |
} else { |
| |
$name = 'lti'; |
| |
if ($context eq '') { |
| |
$context = 'provider'; |
| |
} |
| |
} |
| |
$cachename = $name.'enc'; |
| |
my %ltienc; |
| |
my ($encresult,$enccached)=&Apache::lonnet::is_cached_new($cachename,$dom); |
| |
if (defined($enccached)) { |
| |
if (ref($encresult) eq 'HASH') { |
| |
%ltienc = %{$encresult}; |
| |
} |
| |
} else { |
| |
my $reply = &get_dom("getdom:$dom:encconfig:$name"); |
| |
my $ltiencref = &Apache::lonnet::thaw_unescape($reply); |
| |
if (ref($ltiencref) eq 'HASH') { |
| |
%ltienc = %{$ltiencref}; |
| |
} |
| |
my $cachetime = 24*60*60; |
| |
&Apache::lonnet::do_cache_new($cachename,$dom,\%ltienc,$cachetime); |
| |
} |
| |
|
| |
return if (!keys(%ltienc)); |
| |
|
| |
my %lti_by_key; |
| |
foreach my $id (keys(%ltienc)) { |
| |
if (ref($ltienc{$id}) eq 'HASH') { |
| |
my $key = $ltienc{$id}{'key'}; |
| |
if (($key ne '') && ($ltienc{$id}{'secret'} ne '')) { |
| |
push(@{$lti_by_key{$key}},$id); |
| |
} |
| |
} |
| |
} |
| |
return if (!keys(%lti_by_key)); |
| |
|
| |
my %lti = &Apache::lonnet::get_domain_lti($dom,$context); |
| |
|
| |
if (ref($lti_by_key{$consumer_key}) eq 'ARRAY') { |
| |
foreach my $id (@{$lti_by_key{$consumer_key}}) { |
| |
my $secret = $ltienc{$id}{'secret'}; |
| |
if (ref($lti{$id}) eq 'HASH') { |
| |
if ((exists($lti{$id}{'cipher'})) && |
| |
($lti{$id}{'cipher'} =~ /^\d+$/)) { |
| |
my $keynum = $lti{$id}{'cipher'}; |
| |
my $privkey = &get_dom("getdom:$dom:private:$keynum:lti:key"); |
| |
if ($privkey ne '') { |
| |
my $cipher = new Crypt::CBC($privkey); |
| |
$secret = $cipher->decrypt_hex($secret); |
| |
} |
| |
} |
| |
} |
| |
my $request = Net::OAuth->request('request token')->from_hash($params, |
| |
request_url => $url, |
| |
request_method => $method, |
| |
consumer_secret => $secret,); |
| |
if ($request->verify()) { |
| |
$itemid = $id; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
return $itemid; |
| |
} |
| |
|
| |
sub sign_lti_payload { |
| |
my ($cdom,$cnum,$crsdef,$type,$context,$url,$idx,$keynum,$loncaparev,$paramsref,$inforef) = @_; |
| |
return unless (ref($paramsref) eq 'HASH'); |
| |
my ($sigmethod,$callback,$reqtype,$reqmethod,$respfmt,$bodyhash); |
| |
if (ref($inforef) eq 'HASH') { |
| |
if (exists($inforef->{'method'})) { |
| |
$sigmethod = $inforef->{'method'}; |
| |
} |
| |
if (exists($inforef->{'cb'})) { |
| |
$callback = $inforef->{'cb'}; |
| |
} |
| |
if (exists($inforef->{'reqtype'})) { |
| |
$reqtype = $inforef->{'reqtype'}; |
| |
} |
| |
if (exists($inforef->{'reqmethod'})) { |
| |
$reqmethod = $inforef->{'reqmethod'}; |
| |
} |
| |
if (exists($inforef->{'body_hash'})) { |
| |
$bodyhash = $inforef->{'body_hash'}; |
| |
} |
| |
if (exists($inforef->{'respfmt'})) { |
| |
$respfmt = $inforef->{'respfmt'}; |
| |
} |
| |
} |
| |
my ($key,$secret) = &get_lti_credentials($cdom,$cnum,$crsdef,$type,$idx,$keynum,$loncaparev); |
| |
return if (($key eq '') || ($secret eq '')); |
| |
if ($sigmethod eq '') { |
| |
$sigmethod = 'HMAC-SHA1'; |
| |
} |
| |
if ($callback eq '') { |
| |
$callback = 'about:blank', |
| |
} |
| |
if ($reqtype eq '') { |
| |
$reqtype = 'request token'; |
| |
} |
| |
if ($reqmethod eq '') { |
| |
$reqmethod = 'POST'; |
| |
} |
| |
srand( time() ^ ($$ + ($$ << 15)) ); # Seed rand. |
| |
my $nonce = Digest::SHA::sha1_hex(sprintf("%06x%06x",rand(0xfffff0),rand(0xfffff0))); |
| |
my $request; |
| |
if (($context eq 'grade') && ($reqtype eq 'consumer') && ($bodyhash ne '')) { |
| |
$request = Net::OAuth->request($reqtype)->new( |
| |
consumer_key => $key, |
| |
consumer_secret => $secret, |
| |
request_url => $url, |
| |
request_method => $reqmethod, |
| |
signature_method => $sigmethod, |
| |
timestamp => time(), |
| |
nonce => $nonce, |
| |
body_hash => $bodyhash, |
| |
); |
| |
$request->add_required_message_params('body_hash'); |
| |
} else { |
| |
$request = Net::OAuth->request($reqtype)->new( |
| |
consumer_key => $key, |
| |
consumer_secret => $secret, |
| |
request_url => $url, |
| |
request_method => 'POST', |
| |
signature_method => $sigmethod, |
| |
timestamp => time, |
| |
nonce => $nonce, |
| |
callback => $callback, |
| |
extra_params => $paramsref, |
| |
version => '1.0', |
| |
); |
| |
} |
| |
$request->sign(); |
| |
if ($respfmt eq 'to_post_body') { |
| |
return $request->to_post_body(); |
| |
} elsif ($respfmt eq 'to_authorization_header') { |
| |
return $request->to_authorization_header(); |
| |
} else { |
| |
return $request->to_hash(); |
| |
} |
| |
} |
| |
|
| |
sub get_lti_credentials { |
| |
my ($cdom,$cnum,$crsdef,$type,$idx,$keynum,$loncaparev) = @_; |
| |
my ($dbname,$name,$cachename,$hashid,$key,$secret,%ltienc); |
| |
if ($crsdef) { |
| |
$hashid = $cdom.'_'.$cnum; |
| |
} else { |
| |
$hashid = $cdom; |
| |
} |
| |
if ($type eq 'tools') { |
| |
if ($crsdef) { |
| |
$dbname = 'nohist_toolsenc'; |
| |
$cachename = 'crsltitoolsenc'; |
| |
} else { |
| |
$name = 'ltitools'; |
| |
$dbname = 'encconfig'; |
| |
$cachename = 'ltitoolsenc'; |
| |
} |
| |
} elsif ($type eq 'linkprot') { |
| |
if ($crsdef) { |
| |
$dbname = 'nohist_ltienc'; |
| |
$cachename = 'courseltienc'; |
| |
} else { |
| |
$name = 'linkprot'; |
| |
$dbname = 'encconfig'; |
| |
$cachename = 'linkprotenc'; |
| |
} |
| |
} elsif ($type eq 'lti') { |
| |
$name = 'lti'; |
| |
$dbname = 'encconfig'; |
| |
$cachename = 'ltienc'; |
| |
} |
| |
my ($encresult,$enccached)=&Apache::lonnet::is_cached_new($cachename,$hashid); |
| |
if (defined($enccached)) { |
| |
if (ref($encresult) eq 'HASH') { |
| |
%ltienc = %{$encresult}; |
| |
} |
| |
} else { |
| |
if ($crsdef) { |
| |
my $reply = &dump_with_regexp(join(":",($cdom,$cnum,$dbname,'','')),$loncaparev); |
| |
%ltienc = %{&Apache::lonnet::unserialize($reply)}; |
| |
} else { |
| |
my $reply = &get_dom("getdom:$cdom:$dbname:$name"); |
| |
my $encref = &Apache::lonnet::thaw_unescape($reply); |
| |
if (ref($encref) eq 'HASH') { |
| |
%ltienc = %{$encref}; |
| |
} |
| |
} |
| |
my $cachetime = 24*60*60; |
| |
&Apache::lonnet::do_cache_new($cachename,$hashid,\%ltienc,$cachetime); |
| |
} |
| |
if (!keys(%ltienc)) { |
| |
return (); |
| |
} elsif (exists($ltienc{$idx})) { |
| |
if (ref($ltienc{$idx}) eq 'HASH') { |
| |
if (exists($ltienc{$idx}{'key'})) { |
| |
$key = $ltienc{$idx}{'key'}; |
| |
} |
| |
if (exists($ltienc{$idx}{'secret'})) { |
| |
$secret = $ltienc{$idx}{'secret'}; |
| |
if ($keynum =~ /^\d+$/) { |
| |
my $privhost; |
| |
my $privname = 'ltitools'; |
| |
if (($type eq 'lti') || ($type eq 'linkprot')) { |
| |
$privname = 'lti'; |
| |
} |
| |
if ($crsdef) { |
| |
my $primary = &Apache::lonnet::domain($cdom,'primary'); |
| |
my @ids = &Apache::lonnet::current_machine_ids(); |
| |
unless (grep(/^\Q$primary\E$/,@ids)) { |
| |
$privhost = $primary; |
| |
my ($result,$plainsecret) = &decrypt_secret($privhost,$secret,$keynum,$privname); |
| |
if ($result eq 'ok') { |
| |
$secret = $plainsecret; |
| |
} else { |
| |
undef($secret); |
| |
} |
| |
} |
| |
} |
| |
unless ($privhost) { |
| |
my $privkey = &get_dom("getdom:$cdom:private:$keynum:$privname:key"); |
| |
if (($privkey ne '') && ($secret ne '')) { |
| |
my $cipher = new Crypt::CBC($privkey); |
| |
$secret = $cipher->decrypt_hex($secret); |
| |
} else { |
| |
undef($secret); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return ($key,$secret); |
| |
} |
| |
|
| |
sub decrypt_secret { |
| |
my ($privhost,$secret,$keynum,$type) = @_; |
| |
return; |
| |
} |
| |
|
| 1; |
1; |
| |
|
|
Line 363 Returns: 1 (Continue processing).
|
Line 1403 Returns: 1 (Continue processing).
|
| |
|
| Side effects: response is written to $client. |
Side effects: response is written to $client. |
| |
|
| |
=item dump_course_id_handler |
| |
|
| |
#TODO copy from lond |
| |
|
| |
=item dump_profile_database |
| |
|
| |
#TODO copy from lond |
| |
|
| =item releasereqd_check( $cnum, $cdom, $key, $value, $major, $minor, |
=item releasereqd_check( $cnum, $cdom, $key, $value, $major, $minor, |
| $homecourses, $ids ) |
$homecourses, $ids ) |
|
Line 408 the version available on the client serv
|
Line 1455 the version available on the client serv
|
| is compatible, 1 will be returned. |
is compatible, 1 will be returned. |
| |
|
| |
|
| |
=item get_courseinfo_hash( $cnum, $cdom, $home ) |
| |
|
| |
get_courseinfo_hash() is used to retrieve course information from the db |
| |
file: nohist_courseids.db for a course for which the current server is *not* |
| |
the home server. |
| |
|
| |
A hash of a hash will be retrieved. The outer hash contains a single key -- |
| |
courseID -- for the course for which the data are being requested. |
| |
The contents of the inner hash, for that single item in the outer hash |
| |
are returned (and cached in memcache for 10 minutes). |
| |
|
| |
=item get_dom ( $userinput ) |
| |
|
| |
get_dom() will retrieve domain configuration information from a GDBM file |
| |
in /home/httpd/lonUsers/$dom on the primary library server in a domain. |
| |
The single argument passed is the string: $cmd:$udom:$namespace:$what |
| |
where $cmd is the command historically passed to lond - i.e., getdom |
| |
or egetdom, $udom is the domain, $namespace is the name of the GDBM file |
| |
(encconfig or configuration), and $what is a string containing names of |
| |
items to retrieve from the db file (each item name is escaped and separated |
| |
from the next item name with an ampersand). The return value is either: |
| |
error: followed by an error message, or a string containing the value (escaped) |
| |
for each item, again separated from the next item with an ampersand. |
| |
|
| =back |
=back |
| |
|
| =head1 BUGS |
=head1 BUGS |
![[BACK]](/icons/back.gif){kind=icon}
Return to Lond.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom