--- loncom/lonnet/perl/lonnet.pm 2006/05/01 06:17:32 1.733 +++ loncom/lonnet/perl/lonnet.pm 2006/06/16 22:37:35 1.749 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.733 2006/05/01 06:17:32 raeburn Exp $ +# $Id: lonnet.pm,v 1.749 2006/06/16 22:37:35 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -38,7 +38,7 @@ use vars qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom %libserv %pr %prp $memcache %packagetab %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount - %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf + %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf %domaindescription %domain_auth_def %domain_auth_arg_def %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary $tmpdir $_64bit %env); @@ -52,6 +52,9 @@ use Storable qw(lock_store lock_nstore l use Time::HiRes qw( gettimeofday tv_interval ); use Cache::Memcached; use Digest::MD5; +use lib '/home/httpd/lib/perl'; +use LONCAPA; +use LONCAPA::Configuration; my $readit; my $max_connection_retries = 10; # Or some such value. @@ -1384,7 +1387,22 @@ sub userfileupload { open(my $fh,'>'.$fullpath.'/'.$fname); print $fh $env{'form.'.$formname}; close($fh); - return $fullpath.'/'.$fname; + return $fullpath.'/'.$fname; + } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { #files uploaded to create course page are handled differently + my $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}. + '_'.$env{'user.domain'}.'/pending'; + my @parts=split(/\//,$filepath); + my $fullpath = $perlvar{'lonDaemons'}; + for (my $i=0;$i<@parts;$i++) { + $fullpath .= '/'.$parts[$i]; + if ((-e $fullpath)!=1) { + mkdir($fullpath,0777); + } + } + open(my $fh,'>'.$fullpath.'/'.$fname); + print $fh $env{'form.'.$formname}; + close($fh); + return $fullpath.'/'.$fname; } # Create the directory if not present @@ -1648,11 +1666,11 @@ sub flushcourselogs { if ($courseidbuffer{$coursehombuf{$crsid}}) { $courseidbuffer{$coursehombuf{$crsid}}.='&'. &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). - ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}); + ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid}); } else { $courseidbuffer{$coursehombuf{$crsid}}= &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). - ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}); + ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid}); } } # @@ -1755,6 +1773,8 @@ sub courselog { $env{'course.'.$env{'request.course.id'}.'.internal.coursecode'}; $courseownerbuf{$env{'request.course.id'}}= $env{'course.'.$env{'request.course.id'}.'.internal.courseowner'}; + $coursetypebuf{$env{'request.course.id'}}= + $env{'course.'.$env{'request.course.id'}.'.type'}; if (defined $courselogs{$env{'request.course.id'}}) { $courselogs{$env{'request.course.id'}}.='&'.$what; } else { @@ -1925,7 +1945,7 @@ sub courseidput { } sub courseiddump { - my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref)=@_; + my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter)=@_; my %returnhash=(); unless ($domfilter) { $domfilter=''; } foreach my $tryserver (keys %libserv) { @@ -1934,7 +1954,7 @@ sub courseiddump { foreach ( split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. $sincefilter.':'.&escape($descfilter).':'. - &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter), + &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter), $tryserver))) { my ($key,$value)=split(/\=/,$_); if (($key) && ($value)) { @@ -1952,8 +1972,8 @@ sub courseiddump { sub dcmailput { my ($domain,$msgid,$message,$server)=@_; my $status = &Apache::lonnet::critical( - 'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='. - &Apache::lonnet::escape($message),$server); + 'dcmailput:'.$domain.':'.&escape($msgid).'='. + &escape($message),$server); return $status; } @@ -2637,6 +2657,9 @@ sub coursedescription { $returnhash{'home'}= $chome; $returnhash{'domain'} = $cdomain; $returnhash{'num'} = $cnum; + if (!defined($returnhash{'type'})) { + $returnhash{'type'} = 'Course'; + } while (my ($name,$value) = each %returnhash) { $envhash{'course.'.$normalid.'.'.$name}=$value; } @@ -2693,7 +2716,7 @@ sub rolesinit { my %allroles=(); my %allgroups=(); my $now=time; - my $userroles="user.login.time=$now\n"; + my %userroles = ('user.login.time' => $now); my $group_privs; if ($rolesdump ne '') { @@ -2716,7 +2739,9 @@ sub rolesinit { } else { ($trole,$tend,$tstart)=split(/_/,$role); } - $userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username); + my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain, + $username); + @userroles{keys(%new_role)} = @new_role{keys(%new_role)}; if (($tend!=0) && ($tend<$now)) { $trole=''; } if (($tstart!=0) && ($tstart>$now)) { $trole=''; } if (($area ne '') && ($trole ne '')) { @@ -2732,19 +2757,19 @@ sub rolesinit { } } } - my ($author,$adv) = &set_userprivs(\$userroles,\%allroles,\%allgroups); - $userroles.='user.adv='.$adv."\n". - 'user.author='.$author."\n"; + my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups); + $userroles{'user.adv'} = $adv; + $userroles{'user.author'} = $author; $env{'user.adv'}=$adv; } - return $userroles; + return \%userroles; } sub set_arearole { my ($trole,$area,$tstart,$tend,$domain,$username) = @_; # log the associated role with the area &userrolelog($trole,$username,$domain,$area,$tstart,$tend); - return 'user.role.'.$trole.'.'.$area.'='.$tstart.'.'.$tend."\n"; + return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend); } sub custom_roleprivs { @@ -2846,7 +2871,7 @@ sub set_userprivs { } my $thesestr=''; foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } - $$userroles.='user.priv.'.$_.'='.$thesestr."\n"; + $userroles->{'user.priv.'.$_} = $thesestr; } return ($author,$adv); } @@ -3982,7 +4007,6 @@ sub modify_group_roles { if ($result eq 'ok') { &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum); } - return $result; } @@ -4024,7 +4048,7 @@ sub get_users_groups { my $hashid="$udom:$uname:$courseid"; my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid); if (defined($cached)) { - @usersgroups = split/:/,$grouplist; + @usersgroups = split(/:/,$grouplist); } else { $grouplist = ''; my %roleshash = &dump('roles',$udom,$uname,$courseid); @@ -4035,7 +4059,7 @@ sub get_users_groups { my $access_end = $env{'course.'.$courseid. '.default_enrollment_end_date'}; my $now = time; - foreach my $key (keys %roleshash) { + foreach my $key (keys(%roleshash)) { if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) { my $group = $1; if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) { @@ -4075,8 +4099,25 @@ sub devalidate_getgroups_cache { # ------------------------------------------------------------------ Plain Text sub plaintext { - my $short=shift; - return &Apache::lonlocal::mt($prp{$short}); + my ($short,$type,$cid) = @_; + if (!defined($cid)) { + $cid = $env{'request.course.id'}; + } + if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) { + return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short. + '.plaintext'}); + } + my %rolenames = ( + Course => 'std', + Group => 'alt1', + ); + if (defined($type) && + defined($rolenames{$type}) && + defined($prp{$short}{$rolenames{$type}})) { + return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}}); + } else { + return &Apache::lonlocal::mt($prp{$short}{'std'}); + } } # ----------------------------------------------------------------- Assign Role @@ -4125,6 +4166,8 @@ sub assignrole { $command.='_0_'.$start; } } + my $origstart = $start; + my $origend = $end; # actually delete if ($deleteflag) { if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { @@ -4142,6 +4185,11 @@ sub assignrole { # log new user role if status is ok if ($answer eq 'ok') { &userrolelog($role,$uname,$udom,$url,$start,$end); +# for course roles, perform group memberships changes triggered by role change. + unless ($role =~ /^gr/) { + &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, + $origstart); + } } return $answer; } @@ -4398,7 +4446,8 @@ sub writecoursepref { # ---------------------------------------------------------- Make/modify course sub createcourse { - my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner)=@_; + my ($udom,$description,$url,$course_server,$nonstandard,$inst_code, + $course_owner,$crstype)=@_; $url=&declutter($url); my $cid=''; unless (&allowed('ccc',$udom)) { @@ -4435,7 +4484,8 @@ sub createcourse { # ----------------------------------------------------------------- Course made # log existence &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description). - ':'.&escape($inst_code).':'.&escape($course_owner),$uhome); + ':'.&escape($inst_code).':'.&escape($course_owner).':'. + &escape($crstype),$uhome); &flushcourselogs(); # set toplevel url my $topurl=$url; @@ -4505,9 +4555,15 @@ sub is_locked { $env{'user.domain'},$env{'user.name'}); my ($tmp)=keys(%locked); if ($tmp=~/^error:/) { undef(%locked); } - + if (ref($locked{$file_name}) eq 'ARRAY') { - $is_locked = 'true'; + $is_locked = 'false'; + foreach my $entry (@{$locked{$file_name}}) { + if (ref($entry) eq 'ARRAY') { + $is_locked = 'true'; + last; + } + } } else { $is_locked = 'false'; } @@ -4596,48 +4652,205 @@ sub files_not_in_path { return (@return_files); } -#--------------------------------------------------------------Get Marked as Read Only +#----------------------------------------------Get portfolio file permissions - -sub get_marked_as_readonly { - my ($domain,$user,$what) = @_; +sub get_portfile_permissions { + my ($domain,$user) = @_; my %current_permissions = &dump('file_permissions',$domain,$user); my ($tmp)=keys(%current_permissions); if ($tmp=~/^error:/) { undef(%current_permissions); } + return \%current_permissions; +} + +#---------------------------------------------Get portfolio file access controls + +sub get_access_controls { + my ($current_permissions,$group,$file) = @_; + my %access; + if (defined($file)) { + if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') { + foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) { + $access{$file}{$control} = $$current_permissions{$file."\0".$control}; + } + } + } else { + foreach my $key (keys(%{$current_permissions})) { + if ($key =~ /\0accesscontrol$/) { + if (defined($group)) { + if ($key !~ m-^\Q$group\E/-) { + next; + } + } + my ($fullpath) = split(/\0/,$key); + if (ref($$current_permissions{$key}) eq 'HASH') { + foreach my $control (keys(%{$$current_permissions{$key}})) { + $access{$fullpath}{$control}=$$current_permissions{$fullpath."\0".$control}; + } + } + } + } + } + return %access; +} + +sub parse_access_controls { + my ($access_item) = @_; + my %content; + my $token; + my $parser=HTML::TokeParser->new(\$access_item); + while ($token=$parser->get_token) { + if ($token->[0] eq 'S') { + my $entry=$token->[1]; + if ($entry eq 'scope') { + my $type = $token->[2]{'type'}; + } else { + my $value=$parser->get_text('/'.$entry); + $content{$entry}=$value; + } + } + } + return %content; +} + +sub modify_access_controls { + my ($file_name,$changes,$domain,$user)=@_; + my ($outcome,$deloutcome); + my %store_permissions; + my %new_values; + my %new_control; + my %translation; + my @deletions = (); + my $now = time; + if (exists($$changes{'activate'})) { + if (ref($$changes{'activate'}) eq 'HASH') { + my @newitems = sort(keys(%{$$changes{'activate'}})); + my $numnew = scalar(@newitems); + for (my $i=0; $i<$numnew; $i++) { + my $newkey = $newitems[$i]; + my $newid = &Apache::loncommon::get_cgi_id(); + $newkey =~ s/^(\d+)/$newid/; + $translation{$1} = $newid; + $new_values{$file_name."\0".$newkey} = + $$changes{'activate'}{$newitems[$i]}; + $new_control{$newkey} = $now; + } + } + } + my %todelete; + my %changed_items; + foreach my $action ('delete','update') { + if (exists($$changes{$action})) { + if (ref($$changes{$action}) eq 'HASH') { + foreach my $key (keys(%{$$changes{$action}})) { + my ($itemnum) = ($key =~ /^([^:]+):/); + if ($action eq 'delete') { + $todelete{$itemnum} = 1; + } else { + $changed_items{$itemnum} = $key; + } + } + } + } + } + # get lock on access controls for file. + my $lockhash = { + $file_name."\0".'locked_access_records' => $env{'user.name'}. + ':'.$env{'user.domain'}, + }; + my $tries = 0; + my $gotlock = &newput('file_permissions',$lockhash,$domain,$user); + + while (($gotlock ne 'ok') && $tries <3) { + $tries ++; + sleep 1; + $gotlock = &newput('file_permissions',$lockhash,$domain,$user); + } + if ($gotlock eq 'ok') { + my %curr_permissions = &dump('file_permissions',$domain,$user,$file_name); + my ($tmp)=keys(%curr_permissions); + if ($tmp=~/^error:/) { undef(%curr_permissions); } + if (exists($curr_permissions{$file_name."\0".'accesscontrol'})) { + my $curr_controls = $curr_permissions{$file_name."\0".'accesscontrol'}; + if (ref($curr_controls) eq 'HASH') { + foreach my $control_item (keys(%{$curr_controls})) { + my ($itemnum) = ($control_item =~ /^([^:]+):/); + if (defined($todelete{$itemnum})) { + push(@deletions,$file_name."\0".$control_item); + } else { + if (defined($changed_items{$itemnum})) { + $new_control{$changed_items{$itemnum}} = $now; + push(@deletions,$file_name."\0".$control_item); + $new_values{$file_name."\0".$changed_items{$itemnum}} = $$changes{'update'}{$changed_items{$itemnum}}; + } else { + $new_control{$control_item} = $$curr_controls{$control_item}; + } + } + } + } + } + $deloutcome = &del('file_permissions',\@deletions,$domain,$user); + $new_values{$file_name."\0".'accesscontrol'} = \%new_control; + $outcome = &put('file_permissions',\%new_values,$domain,$user); + # remove lock + my @del_lock = ($file_name."\0".'locked_access_records'); + my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user); + } else { + $outcome = "error: could not obtain lockfile\n"; + } + return ($outcome,$deloutcome,\%new_values,\%translation); +} + +#------------------------------------------------------Get Marked as Read Only + +sub get_marked_as_readonly { + my ($domain,$user,$what,$group) = @_; + my $current_permissions = &get_portfile_permissions($domain,$user); my @readonly_files; my $cmp1=$what; if (ref($what)) { $cmp1=join('',@{$what}) }; - while (my ($file_name,$value) = each(%current_permissions)) { + while (my ($file_name,$value) = each(%{$current_permissions})) { + if (defined($group)) { + if ($file_name !~ m-^\Q$group\E/-) { + next; + } + } if (ref($value) eq "ARRAY"){ foreach my $stored_what (@{$value}) { my $cmp2=$stored_what; - if (ref($stored_what)) { $cmp2=join('',@{$stored_what}) }; + if (ref($stored_what eq 'ARRAY')) { + $cmp2=join('',@{$stored_what}); + } if ($cmp1 eq $cmp2) { push(@readonly_files, $file_name); + last; } elsif (!defined($what)) { push(@readonly_files, $file_name); + last; } } - } + } } return @readonly_files; } #-----------------------------------------------------------Get Marked as Read Only Hash sub get_marked_as_readonly_hash { - my ($domain,$user,$what) = @_; - my %current_permissions = &dump('file_permissions',$domain,$user); - my ($tmp)=keys(%current_permissions); - if ($tmp=~/^error:/) { undef(%current_permissions); } - + my ($current_permissions,$group,$what) = @_; my %readonly_files; - while (my ($file_name,$value) = each(%current_permissions)) { + while (my ($file_name,$value) = each(%{$current_permissions})) { + if (defined($group)) { + if ($file_name !~ m-^\Q$group\E/-) { + next; + } + } if (ref($value) eq "ARRAY"){ foreach my $stored_what (@{$value}) { - if ($stored_what eq $what) { - $readonly_files{$file_name} = 'locked'; - } elsif (!defined($what)) { - $readonly_files{$file_name} = 'locked'; + if (ref($stored_what) eq 'ARRAY') { + if ($stored_what eq $what) { + $readonly_files{$file_name} = 'locked'; + } elsif (!defined($what)) { + $readonly_files{$file_name} = 'locked'; + } } } } @@ -4649,13 +4862,13 @@ sub get_marked_as_readonly_hash { sub unmark_as_readonly { # unmarks $file_name (if $file_name is defined), or all files locked by $what # for portfolio submissions, $what contains [$symb,$crsid] - my ($domain,$user,$what,$file_name) = @_; + my ($domain,$user,$what,$file_name,$group) = @_; my $symb_crs = $what; if (ref($what)) { $symb_crs=join('',@$what); } - my %current_permissions = &dump('file_permissions',$domain,$user); + my %current_permissions = &dump('file_permissions',$domain,$user,$group); my ($tmp)=keys(%current_permissions); if ($tmp=~/^error:/) { undef(%current_permissions); } - my @readonly_files = &get_marked_as_readonly($domain,$user,$what); + my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group); foreach my $file (@readonly_files) { if (defined($file_name) && ($file_name ne $file)) { next; } my $current_locks = $current_permissions{$file}; @@ -4664,9 +4877,11 @@ sub unmark_as_readonly { if (ref($current_locks) eq "ARRAY"){ foreach my $locker (@{$current_locks}) { my $compare=$locker; - if (ref($locker)) { $compare=join('',@{$locker}) }; - if ($compare ne $symb_crs) { - push(@new_locks, $locker); + if (ref($locker) eq 'ARRAY') { + $compare=join('',@{$locker}); + if ($compare ne $symb_crs) { + push(@new_locks, $locker); + } } } if (scalar(@new_locks) > 0) { @@ -4818,7 +5033,7 @@ sub stat_file { ($udom,$uname,$file) = ($uri =~ m-/(?:uploaded|editupload)/?([^/]*)/?([^/]*)/?(.*)-); $file = 'userfiles/'.$file; - $dir = &Apache::loncommon::propath($udom,$uname); + $dir = &propath($udom,$uname); } if ($uri =~ m-^/res/-) { ($udom,$uname) = @@ -5067,8 +5282,14 @@ sub EXT { if ( (defined($Apache::lonhomework::parsing_a_problem) || defined($Apache::lonhomework::parsing_a_task)) && - ($symbparm eq &symbread()) ) { - return $Apache::lonhomework::history{$qualifierrest}; + ($symbparm eq &symbread()) ) { + # if we are in the middle of processing the resource the + # get the value we are planning on committing + if (defined($Apache::lonhomework::results{$qualifierrest})) { + return $Apache::lonhomework::results{$qualifierrest}; + } else { + return $Apache::lonhomework::history{$qualifierrest}; + } } else { my %restored; if ($publicuser || $env{'request.state'} eq 'construct') { @@ -5171,7 +5392,7 @@ sub EXT { # ----------------------------------------------------- Cascading lookup scheme my $symbp=$symbparm; - my $mapp=(&decode_symb($symbp))[0]; + my $mapp=&deversion((&decode_symb($symbp))[0]); my $symbparm=$symbp.'.'.$spacequalifierrest; my $mapparm=$mapp.'___(all).'.$spacequalifierrest; @@ -5319,9 +5540,29 @@ sub sort_course_groups { # Sort groups b sub packages_tab_default { my ($uri,$varname)=@_; my (undef,$part,$name)=split(/\./,$varname); - my $packages=&metadata($uri,'packages'); - foreach my $package (split(/,/,$packages)) { + + my (@extension,@specifics,$do_default); + foreach my $package (split(/,/,&metadata($uri,'packages'))) { my ($pack_type,$pack_part)=split(/_/,$package,2); + if ($pack_type eq 'default') { + $do_default=1; + } elsif ($pack_type eq 'extension') { + push(@extension,[$package,$pack_type,$pack_part]); + } else { + push(@specifics,[$package,$pack_type,$pack_part]); + } + } + # first look for a package that matches the requested part id + foreach my $package (@specifics) { + my (undef,$pack_type,$pack_part)=@{$package}; + next if ($pack_part ne $part); + if (defined($packagetab{"$pack_type&$name&default"})) { + return $packagetab{"$pack_type&$name&default"}; + } + } + # look for any possible matching non extension_ package + foreach my $package (@specifics) { + my (undef,$pack_type,$pack_part)=@{$package}; if (defined($packagetab{"$pack_type&$name&default"})) { return $packagetab{"$pack_type&$name&default"}; } @@ -5330,6 +5571,20 @@ sub packages_tab_default { return $packagetab{$pack_type."_".$pack_part."&$name&default"}; } } + # look for any posible extension_ match + foreach my $package (@extension) { + my ($package,$pack_type)=@{$package}; + if (defined($packagetab{"$pack_type&$name&default"})) { + return $packagetab{"$pack_type&$name&default"}; + } + if (defined($packagetab{$package."&$name&default"})) { + return $packagetab{$package."&$name&default"}; + } + } + # look for a global default setting + if ($do_default && defined($packagetab{"default&$name&default"})) { + return $packagetab{"default&$name&default"}; + } return undef; } @@ -5415,16 +5670,16 @@ sub metadata { } else { $metaentry{':packages'}=$package.$keyroot; } - foreach (sort keys %packagetab) { + foreach my $pack_entry (keys(%packagetab)) { my $part=$keyroot; $part=~s/^\_//; - if ($_=~/^\Q$package\E\&/ || - $_=~/^\Q$package\E_0\&/) { - my ($pack,$name,$subp)=split(/\&/,$_); + if ($pack_entry=~/^\Q$package\E\&/ || + $pack_entry=~/^\Q$package\E_0\&/) { + my ($pack,$name,$subp)=split(/\&/,$pack_entry); # ignore package.tab specified default values # here &package_tab_default() will fetch those if ($subp eq 'default') { next; } - my $value=$packagetab{$_}; + my $value=$packagetab{$pack_entry}; my $unikey; if ($pack =~ /_0$/) { $unikey='parameter_0_'.$name; @@ -5472,11 +5727,12 @@ sub metadata { my $dir=$filename; $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); - foreach (sort(split(/\,/,&metadata($uri,'keys', - $location,$unikey, - $depthcount+1)))) { - $metaentry{':'.$_}=$metaentry{':'.$_}; - $metathesekeys{$_}=1; + my $metadata = + &metadata($uri,'keys', $location,$unikey, + $depthcount+1); + foreach my $meta (split(',',$metadata)) { + $metaentry{':'.$meta}=$metaentry{':'.$meta}; + $metathesekeys{$meta}=1; } } } else { @@ -5485,8 +5741,9 @@ sub metadata { $unikey.='_'.$token->[2]->{'name'}; } $metathesekeys{$unikey}=1; - foreach (@{$token->[3]}) { - $metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_}; + foreach my $param (@{$token->[3]}) { + $metaentry{':'.$unikey.'.'.$param} = + $token->[2]->{$param}; } my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); my $default=$metaentry{':'.$unikey.'.default'}; @@ -5507,14 +5764,14 @@ sub metadata { } } my ($extension) = ($uri =~ /\.(\w+)$/); - foreach my $key (sort(keys(%packagetab))) { + foreach my $key (keys(%packagetab)) { #no specific packages #how's our extension if ($key!~/^extension_\Q$extension\E&/) { next; } &metadata_create_package_def($uri,$key,'extension_'.$extension, \%metathesekeys); } if (!exists($metaentry{':packages'})) { - foreach my $key (sort(keys(%packagetab))) { + foreach my $key (keys(%packagetab)) { #no specific packages well let's get default then if ($key!~/^default&/) { next; } &metadata_create_package_def($uri,$key,'default', @@ -5532,15 +5789,22 @@ sub metadata { my $dir=$filename; $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); - foreach (sort(split(/\,/,&metadata($uri,'keys', - $location,'_rights', - $depthcount+1)))) { - #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_}; - $metathesekeys{$_}=1; + my $rights_metadata = + &metadata($uri,'keys',$location,'_rights', + $depthcount+1); + foreach my $rights (split(',',$rights_metadata)) { + #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights}; + $metathesekeys{$rights}=1; } } } - $metaentry{':keys'}=join(',',keys %metathesekeys); + # uniqifiy package listing + my %seen; + my @uniq_packages = + grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); + $metaentry{':packages'} = join(',',@uniq_packages); + + $metaentry{':keys'} = join(',',keys(%metathesekeys)); &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); &do_cache_new('meta',$uri,\%metaentry,60*60); @@ -5576,7 +5840,7 @@ sub metadata_create_package_def { sub metadata_generate_part0 { my ($metadata,$metacache,$uri) = @_; my %allnames; - foreach my $metakey (sort keys %$metadata) { + foreach my $metakey (keys(%$metadata)) { if ($metakey=~/^parameter\_(.*)/) { my $part=$$metacache{':'.$metakey.'.part'}; my $name=$$metacache{':'.$metakey.'.name'}; @@ -6411,7 +6675,7 @@ sub filelocation { my @ids=¤t_machine_ids(); foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } if ($is_me) { - $location=&Apache::loncommon::propath($udom,$uname). + $location=&propath($udom,$uname). '/userfiles/'.$filename; } else { $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. @@ -6532,21 +6796,6 @@ sub freeze_escape { return &escape($value); } -# -------------------------------------------------------- Escape Special Chars - -sub escape { - my $str=shift; - $str =~ s/(\W)/"%".unpack('H2',$1)/eg; - return $str; -} - -# ----------------------------------------------------- Un-Escape Special Chars - -sub unescape { - my $str=shift; - $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; - return $str; -} sub thaw_unescape { my ($value)=@_; @@ -6720,8 +6969,14 @@ sub get_iphost { while (my $configline=<$config>) { chomp($configline); if ($configline) { - my ($short,$plain)=split(/:/,$configline); - if ($plain ne '') { $prp{$short}=$plain; } + my ($short,@plain)=split(/:/,$configline); + %{$prp{$short}} = (); + if (@plain > 0) { + $prp{$short}{'std'} = $plain[0]; + for (my $i=1; $i<@plain; $i++) { + $prp{$short}{'alt'.$i} = $plain[$i]; + } + } } } close($config); @@ -7415,6 +7670,31 @@ cput($namespace,$storehash,$udom,$uname) =item * +newput($namespace,$storehash,$udom,$uname) : + +Attempts to store the items in the $storehash, but only if they don't +currently exist, if this succeeds you can be certain that you have +successfully created a new key value pair in the $namespace db. + + +Args: + $namespace: name of database to store values to + $storehash: hashref to store to the db + $udom: (optional) domain of user containing the db + $uname: (optional) name of user caontaining the db + +Returns: + 'ok' -> succeeded in storing all keys of $storehash + 'key_exists: ' -> failed to anything out of $storehash, as at + least already existed in the db (other + requested keys may also already exist) + 'error: ' -> unable to tie the DB or other erorr occured + 'con_lost' -> unable to contact request server + 'refused' -> action was not allowed by remote machine + + +=item * + eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array reference filled in from namesp (encrypts the return communication) ($udom and $uname are optional) @@ -7649,6 +7929,103 @@ removeuploadedurl(): convience function Args: url: a full /uploaded/... url to delete +=item * + +get_portfile_permissions(): + Args: + domain: domain of user or course contain the portfolio files + user: name of user or num of course contain the portfolio files + Returns: + hashref of a dump of the proper file_permissions.db + + +=item * + +get_access_controls(): + +Args: + current_permissions: the hash ref returned from get_portfile_permissions() + group: (optional) the group you want the files associated with + file: (optional) the file you want access info on + +Returns: + a hash (keys are file names) of hashes containing + keys are: path to file/file_name\0uniqueID:scope_end_start (see below) + values are XML containing access control settings (see below) + +Internal notes: + + access controls are stored in file_permissions.db as key=value pairs. + key -> path to file/file_name\0uniqueID:scope_end_start + where scope -> public,guest,course,group,domains or users. + end -> UNIX time for end of access (0 -> no end date) + start -> UNIX time for start of access + + value -> XML description of access control + (type =1 of: public,guest,course,group,domains,users"> + + + + for scope type = guest + + for scope type = course or group + + + + +
+ + + + for scope type = domains + + for scope type = users + + + + + + + + Access data is also aggregated for each file in an additional key=value pair: + key -> path to file/file_name\0accesscontrol + value -> reference to hash + hash contains key = value pairs + where key = uniqueID:scope_end_start + value = UNIX time record was last updated + + Used to improve speed of look-ups of access controls for each file. + + Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays. + +parse_access_controls(): + +Parses XML of an access control record +Args +1. Text string (XML) of access comtrol record + +Returns: +1. Hash of access control settings. + +modify_access_controls(): + +Modifies access controls for a portfolio file +Args +1. file name +2. reference to hash of required changes, +3. domain +4. username + where domain,username are the domain of the portfolio owner + (either a user or a course) + +Returns: +1. result of additions or updates ('ok' or 'error', with error message). +2. result of deletions ('ok' or 'error', with error message). +3. reference to hash of any new or updated access controls. +4. reference to hash used to map incoming IDs to uniqueIDs assigned to control. + key = integer (inbound ID) + value = uniqueID + =back =head2 HTTP Helper Routines