[BACK]Return to imsprocessor.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / imspackages

Diff for /loncom/imspackages/imsprocessor.pm between versions 1.19 and 1.20

version 1.19, 2005/04/07 06:56:22 version 1.20, 2005/05/03 18:38:37
Line 24 Line 24
 package Apache::imsprocessor;  package Apache::imsprocessor;
   
 use Apache::lonnet;  use Apache::lonnet;
   use LWP::UserAgent;
   use HTTP::Request::Common;
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
 use strict;  use strict;
   
Line 1724  sub parse_bb5_assessment { Line 1726  sub parse_bb5_assessment {
             $id = $attr->{id};              $id = $attr->{id};
         } elsif ( ($state[0] eq $toptag{$container}) && ($state[1] =~ m/^QUESTION_(\w+)$/) && ($state[2] eq "BODY") && ($state[3] eq "FLAGS") ) {          } elsif ( ($state[0] eq $toptag{$container}) && ($state[1] =~ m/^QUESTION_(\w+)$/) && ($state[2] eq "BODY") && ($state[3] eq "FLAGS") ) {
             if ($state[4] eq "ISHTML") {              if ($state[4] eq "ISHTML") {
                 $$settings{$id}{html} = $attr->{value};                  $$settings{$id}{ishtml} = $attr->{value};
             } elsif ($state[4] eq "ISNEWLINELITERAL") {              } elsif ($state[4] eq "ISNEWLINELITERAL") {
                 $$settings{$id}{newline} = $attr->{value};                  $$settings{$id}{newline} = $attr->{value};
             }              }
Line 2342  sub process_assessment { Line 2344  sub process_assessment {
                 if (!-e "$destdir/problems/$seqname") {                  if (!-e "$destdir/problems/$seqname") {
                     mkdir("$destdir/problems/$seqname",0755);                      mkdir("$destdir/problems/$seqname",0755);
                 }                  }
                 my $newdir = "$destdir/problems/$seqname";                  $newdir = "$destdir/problems/$seqname";
                 my $dbcontainerdir;                  my $dbcontainerdir;
                 &build_problem_container($cms,$seqname,$destdir,'database',$seqname,$total,$sequencesfiles,$pagesfiles,$randompickflag,$context,\@{$$catinfo{$category}{contents}},$udom,$uname,$dirname,\$dbcontainerdir,$cid,$cdom,$cnum,$catinfo,$qzdbsettings);                  &build_problem_container($cms,$seqname,$destdir,'database',$seqname,$total,$sequencesfiles,$pagesfiles,$randompickflag,$context,\@{$$catinfo{$category}{contents}},$udom,$uname,$dirname,\$dbcontainerdir,$cid,$cdom,$cnum,$catinfo,$qzdbsettings);
             }              }
Line 2370  sub process_assessment { Line 2372  sub process_assessment {
         if (!-e "$destdir/problems/$dirtitle") {          if (!-e "$destdir/problems/$dirtitle") {
             mkdir("$destdir/problems/$dirtitle",0755);              mkdir("$destdir/problems/$dirtitle",0755);
         }          }
         my $newdir = "$destdir/problems/$dirtitle";          $newdir = "$destdir/problems/$dirtitle";
     }      }
   
     &build_problem_container($cms,$dirtitle,$destdir,$container,$res,$total,$sequencesfiles,$pagesfiles,$randompickflag,$context,\@allids,$udom,$uname,$dirname,\$containerdir,$cid,$cdom,$cnum,$catinfo,$qzdbsettings);      if ($cms eq 'webct4') {
           &build_problem_container($cms,$dirtitle,$destdir,$container,$res,$total,$sequencesfiles,$pagesfiles,$randompickflag,$context,\@allids,$udom,$uname,$dirname,\$containerdir,$cid,$cdom,$cnum,$catinfo,$qzdbsettings);
       } else {
           &build_problem_container($cms,$dirtitle,$destdir,$container,$res,$total,$sequencesfiles,$pagesfiles,$randompickflag,$context,\@allids,$udom,$uname,$dirname,\$containerdir,$cid,$cdom,$cnum,$catinfo,$settings);
       }
     if ($cms eq 'bb5') {      if ($cms eq 'bb5') {
         &write_bb5_questions(\@allids,$containerdir,$context,$settings,$dirname,$res,\%allanswers,\%allchoices,$total,$newdir,$cid,$cdom,$cnum);          &write_bb5_questions(\@allids,$containerdir,$context,$settings,$dirname,$destdir,$res,\%allanswers,\%allchoices,$total,$newdir,$cid,$cdom,$cnum,$docroot);
     } elsif ($cms eq 'bb6') {      } elsif ($cms eq 'bb6') {
         &write_bb6_questions(\@allids,$containerdir,$context,$settings,$dirname,$res,\%allanswers,\%allchoices,$total,$newdir,$cid,$cdom,$cnum);          &write_bb6_questions(\@allids,$containerdir,$context,$settings,$dirname,$destdir,$res,\%allanswers,\%allchoices,$total,$newdir,$cid,$cdom,$cnum);
     }      }
 }  }
   
Line 2411  sub build_problem_container { Line 2417  sub build_problem_container {
     my $probsrc = "/res/lib/templates/simpleproblem.problem";      my $probsrc = "/res/lib/templates/simpleproblem.problem";
     if ($context eq 'CSTR') {      if ($context eq 'CSTR') {
         foreach my $id (@{$allids}) {          foreach my $id (@{$allids}) {
             $probtitle{$id} = $$settings{$id}{title};              if ($cms eq 'webct4') {
                   $probtitle{$id} = $$settings{$id}{title};
               } else {
                   $probtitle{$id} = $$settings{title};
               }
             $probtitle{$id} =~ s/\s/_/g;              $probtitle{$id} =~ s/\s/_/g;
             $probtitle{$id} =~ s/\W//g;              $probtitle{$id} =~ s/\W//g;
             $probtitle{$id} .= '_'.$id;              $probtitle{$id} .= '_'.$id;
Line 2423  sub build_problem_container { Line 2433  sub build_problem_container {
             $probdir =~ s/\W//g;              $probdir =~ s/\W//g;
             $probsrc = "$dirname/problems/$probdir/$probtitle{$$allids[0]}.problem";              $probsrc = "$dirname/problems/$probdir/$probtitle{$$allids[0]}.problem";
         } else {          } else {
             $probsrc="$dirname/problems/$dirtitle/$$allids[0].problem";              $probsrc="$dirname/problems/$dirtitle/$probtitle{$$allids[0]}.problem";
         }          }
     }      }
     print $fh qq|<resource id="1" src="$probsrc" type="start" title="question_0001"></resource>|;      print $fh qq|<resource id="1" src="$probsrc" type="start" title="question_0001"></resource>|;
Line 2447  sub build_problem_container { Line 2457  sub build_problem_container {
                     $probdir =~ s/\W//g;                      $probdir =~ s/\W//g;
                     $probsrc = "$dirname/problems/$probdir/$probtitle{$$allids[$j]}.problem";                      $probsrc = "$dirname/problems/$probdir/$probtitle{$$allids[$j]}.problem";
                 } else {                  } else {
                     $probsrc = "$dirname/problems/$dirtitle/$$allids[$j].problem";                      $probsrc = "$dirname/problems/$dirtitle/$probtitle{$$allids[$j]}.problem";
                 }                  }
             }              }
             print $fh qq|              print $fh qq|
Line 2465  sub build_problem_container { Line 2475  sub build_problem_container {
 }  }
   
 sub write_bb5_questions {  sub write_bb5_questions {
     my ($allids,$containerdir,$context,$settings,$dirname,$res,$allanswers,$allchoices,$total,$newdir,$cid,$cdom,$cnum) = @_;      my ($allids,$containerdir,$context,$settings,$dirname,$destdir,$res,$allanswers,$allchoices,$total,$newdir,$cid,$cdom,$cnum,$docroot) = @_;
     my $qnum = 0;      my $qnum = 0;
     foreach my $id (@{$allids}) {      foreach my $id (@{$allids}) {
           if ($$settings{$id}{ishtml} eq 'true') {
               $$settings{$id}{text} = &HTML::Entities::decode($$settings{$id}{text});
           }
           if ($$settings{$id}{text} =~ m#<img src=['"]?(https?://[^\s]+/)([^/\s\'"]+)['"]?[^>]*>#) {
               if (&retrieve_image($context,$res,$dirname,$cdom,$cnum,$docroot,$destdir,$1,$2) eq 'ok') {
                   $$settings{$id}{text} =~ s#(<img src=['"]?)(https?://[^\s]+/)([^/\s'"]+)(['"]?[^>]*>)#$1../../resfiles/$res/webimages/$3$4#g;
               }
           }
           $$settings{$id}{text} =~ s#(<img src=[^>]+)/*>#$1 />#gi;
           $$settings{$id}{text} =~ s#<br>#<br />#g;
         $qnum ++;          $qnum ++;
         my $output;          my $output;
         my $permcontainer = $containerdir;          my $permcontainer = $containerdir;
Line 2811  sub write_bb5_questions { Line 2831  sub write_bb5_questions {
         if ($context eq 'CSTR') {          if ($context eq 'CSTR') {
             $output .= qq|</problem>              $output .= qq|</problem>
 |;  |;
             open(PROB,">$newdir/problems/$id.problem");              my $title = $$settings{title};
               $title =~ s/\s/_/g;
               $title =~ s/\W//g;
               $title .= '_'.$id;
               open(PROB,">:utf8", "$newdir/$title.problem");
             print PROB $output;              print PROB $output;
             close PROB;              close PROB;
         } else {          } else {
Line 2841  sub write_webct4_questions { Line 2865  sub write_webct4_questions {
         if ($$settings{$id}{texttype} eq 'text/html') {          if ($$settings{$id}{texttype} eq 'text/html') {
             $$settings{$id}{text} = &HTML::Entities::decode($$settings{$id}{text});              $$settings{$id}{text} = &HTML::Entities::decode($$settings{$id}{text});
             $$settings{$id}{text} = &Apache::lonxml::htmlclean($$settings{$id}{text});              $$settings{$id}{text} = &Apache::lonxml::htmlclean($$settings{$id}{text});
             $$settings{$id}{text} =~ s#(<img src=")([^>]+)>#$1../../resfiles/$2 />#gi;              $$settings{$id}{text} =~ s#(<img src=["']?)([^>]+)(/?>)#$1../../resfiles/$2 />#gi;
             $$settings{$id}{text} =~ s#<hr>#<hr />#g;              $$settings{$id}{text} =~ s#<([bh])r>#<$1r />#g;
 #            $$settings{$id}{text} =~ s#<p>#</p><p>#g;  #            $$settings{$id}{text} =~ s#<p>#</p><p>#g;
 #            $$settings{$id}{text} =~ s#</p></p>#</p>#;  #            $$settings{$id}{text} =~ s#</p></p>#</p>#;
 #            $$settings{$id}{text} =~ s#<p></p>##g;  #            $$settings{$id}{text} =~ s#<p></p>##g;
             $$settings{$id}{text} =~ s#<p>#<br /><br />#g;              $$settings{$id}{text} =~ s#<p>#<br /><br />#g;
             $$settings{$id}{text} =~ s#<\\p>##g;              $$settings{$id}{text} =~ s#</p>##g;
         }          }
         if ($$settings{$id}{class} eq 'numerical') {          if ($$settings{$id}{class} eq 'numerical') {
             foreach my $numid (@{$$settings{$id}{numids}}) {              foreach my $numid (@{$$settings{$id}{numids}}) {
Line 3332  sub test_for_html { Line 3356  sub test_for_html {
 }   } 
   
 sub write_bb6_questions {  sub write_bb6_questions {
     my ($allids,$containerdir,$context,$settings,$dirname,$res,$allanswers,$allchoices) = @_;      my ($allids,$containerdir,$context,$settings,$dirname,$destdir,$res,$allanswers,$allchoices) = @_;
   }
   
   sub retrieve_image {
       my ($context,$res,$dirname,$cdom,$cname,$docroot,$destdir,$urlpath,$filename) = @_;
       my $contents;
       my $url = $urlpath.$filename;
       my $ua=new LWP::UserAgent;
       my $request=new HTTP::Request('GET',$url);
       my $response=$ua->request($request);
       if ($response->is_success) { 
           $contents = $response->content;
           if (!-e "$docroot/$res") {
               mkdir("$docroot/$res",0755);
           }
           if (!-e "$docroot/$res/webimages") {
               mkdir("$docroot/$res/webimages",0755);
           }
           open(my $fh,">$docroot/$res/webimages/$filename");
           print $fh $contents;
           close($fh);
           if ($context eq 'DOCS') {
               my $chome = &Apache::lonnet::homeserver($cname,$cdom);
               my $copyfile = $dirname.'/'.$filename;
               my $source = "$docroot/$res/webimages/$filename";
               my $fileresult;
               if (-e $source) {
                   $fileresult = &Apache::lonnet::process_coursefile('copy',$cname,$cdom,$chome,$copyfile,$source);
               }
               return $fileresult;
           } elsif ($context eq 'CSTR') {
               if (!-e "$destdir/resfiles/$res") {
                   mkdir("$destdir/resfiles/$res",0755);
               }
               if (!-e "$destdir/resfiles/$res/webimages") {
                   mkdir("$destdir/resfiles/$res/webimages",0755);
               }
               rename("$docroot/$res/webimages/$filename","$destdir/resfiles/$res/webimages/$filename");
               return 'ok';
           }
       } else {
           return -1;
       }
 }  }
   
 # ---------------------------------------------------------------- Process Blackboard Announcements  # ---------------------------------------------------------------- Process Blackboard Announcements
Removed from v.1.19  
changed lines
  Added in v.1.20

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