Return to lonpdfupload.pm CVS log

Up to [LON-CAPA] / loncom / interface

fixed bug 6782, and escaped most localized messages used in Javascript blocks to make sure bugs like that do not happen again

# The LearningOnline Network with CAPA
# PDF Form Upload Handler
#
# $Id: lonpdfupload.pm,v 1.25 2015/06/09 21:22:57 damieng Exp $
#
# Copyright Michigan State University Board of Trustees
#
# This file is part of the LearningOnline Network with CAPA (LON-CAPA).
#
# LON-CAPA is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# LON-CAPA is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with LON-CAPA; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# /home/httpd/html/adm/gpl.txt
#
# http://www.lon-capa.org/
#
package Apache::lonpdfupload;

use lib '/home/httpd/lib/perl';
use Apache::Constants qw(:common :http);
use Apache::lonnet;
use Apache::lonhtmlcommon();
use Apache::loncommon();
use Apache::lonnavmaps();
use Apache::lonlocal;
use File::MMagic;
use CAM::PDF;
use LONCAPA qw(:DEFAULT :match);

use strict;

sub handler() {
    my $r = shift;
    &Apache::loncommon::content_type($r,'text/html');
    $r->send_http_header;
    return OK if $r->header_only;

    #  Needs to be in a course
    if (!$env{'request.course.fn'}) {
        # Not in a course
        $env{'user.error.msg'}="/adm/pdfupload:bre:0:0:Cannot upload PDF forms unless in a course";
        return HTTP_NOT_ACCEPTABLE;
    }

    # Breadcrumbs
    my $brcrum = [{'href' => '/adm/pdfupload',
                   'text' => 'Upload PDF Form'}];
    if ($env{'form.Uploaded'} && $env{'form.file'}) {
        push(@{$brcrum},{'href'  => '',
                         'text'  => 'PDF upload result'});
    }

    $r->print(&Apache::loncommon::start_page('Upload PDF Form',
                                             undef,
                                             {'bread_crumbs' => $brcrum,})
    );

    if ($env{'request.course.id'}) {
        my $permission = $env{'course.'.$env{'request.course.id'}.'.canuse_pdfforms'};
        if ($permission eq '') {
            my %domdefs = &Apache::lonnet::get_domain_defaults($env{'course.'.$env{'request.course.id'}.'.domain'});
            $permission = $domdefs{'canuse_pdfforms'};
        }
        unless ($permission) {
            $r->print('<p class="LC_warning">'.
                      &mt('Upload of PDF forms is not permitted for this course.').
                      '</p>'.
                      &Apache::loncommon::end_page());
            return OK;
        }
    } else {
        $r->print('<p class="LC_warning">'.
                  &mt('Could not determine identity of this course.').' '.
                  &mt('You may need to [_1]re-select[_2] the course.','<a href="/adm/roles">','</a>').
                  '</p>'.
                  &Apache::loncommon::end_page());
        return OK;
    }

    # if a file was upload
    if($env{'form.Uploaded'} && $env{'form.file'}) {
        my $mm = new File::MMagic;
        my $mime_type = $mm->checktype_contents($env{'form.file'});
        if ($mime_type eq 'application/pdf') {
            $r->print(&processPDF);
        } else {
            $r->print('<p class="LC_error">'
                     .&mt("The uploaded file does not appear to be a PDF file.")
                     .'</p>');
        }
    } else { 
        # print upload form
        $r->print(&get_javascripts);
        $r->print(&get_uploadform);
    }

    #link to course-content
    $r->print('<hr />'
             .'<p>'."\n"
             .'<a href="/adm/navmaps">'."\n"
             .&mt('Course Contents')."\n"
             .'</a>'."\n"
             .'</p>'."\n"
    );

    #&dumpenv($r); #debug -> prints the environment
    $r->print(&Apache::loncommon::end_page());
    return OK;
}

sub get_javascripts() {
    
    my $message = &mt('Please choose a PDF-File.');
    &js_escape(\$message);

    # simple test if the upload ends with ".pdf"
    # it's only for giving a message to the user
    my $result .= <<END
  <script type="text/javascript">
// <![CDATA[
    function checkFilename(form) {
        var fileExt = form.file.value;
        fileExt = fileExt.match(/[.]pdf\$/gi);
        if(fileExt) {
            return true;
        }
        alert("$message");
        return false;
    }
// ]]>
  </script>
END
;
    return $result; 
}


sub get_uploadform() {
    
    my %lt = &Apache::lonlocal::texthash(
                 'title'  => 'Upload a PDF Form with filled Form Fields', 
                 'chFile' => 'File',
                 'submit' => 'Upload',
             );

    my $result = 
        '<br />'
       .'<form method="post" enctype="multipart/form-data" onsubmit="return checkFilename(this);" action="">'
       .&Apache::lonhtmlcommon::start_pick_box()
       .&Apache::lonhtmlcommon::row_headline()
       .'<h2>'.$lt{'title'}.'</h2>'
       .&Apache::lonhtmlcommon::row_closure()
       .&Apache::lonhtmlcommon::row_title($lt{'chFile'})
       .'<input type="file" name="file" id="filename" />'
       .&Apache::lonhtmlcommon::row_closure(1)
       .&Apache::lonhtmlcommon::end_pick_box()
       .'<p>'
       .'<input type="submit" name="Uploaded" value="'.$lt{'submit'}.'" />'
       .'</p>'
       .'</form>'
       .'<br />';

  return $result;
}

sub processPDF {
    my $result = ();  # message for Browser
    my @pdfdata = (); # answers from PDF-Forms
    
    @pdfdata = &get_pdf_data(); # get answers from PDF-Form
    
    if (scalar @pdfdata) {    
        &grade_pdf(@pdfdata);
    } else {
        $result .= '<p class="LC_error">'
                  .&mt("Can't find any valid PDF form fields.")
                  .'</p>';
    }
}

sub get_pdf_data() {
    my @data = ();
    my $pdf = CAM::PDF->new($env{'form.file'});

    if($pdf) {
        my @formFields = $pdf->getFormFieldList(); #get names of form fields

        foreach my $field (@formFields) {
            my $dict = $pdf->getFormFieldDict($pdf->getFormField($field)); # get form field dictonary

            # this is necessary because CAM::PDF has a problem with form fieldnames which include a
            # dot in fieldnames. So a fieldname like "i.am.aFormfield" will offer three fieldnames
            # "i", "i.am" and "i.am.aFormfield". The fragmentary names keep no values and will be ignored.
            if($dict->{'V'}) {
                push(@data, $field."?". $dict->{'V'}{'value'}); #binding fieldname with value
            }
        }
    }
    return @data;
}

sub grade_pdf {
    my @pdfdata = @_;
    my ($result,$meta,%grades,%problems,%foreigncourse,$debug);

    my $navmap = Apache::lonnavmaps::navmap->new();
    if (!defined($navmap)) {
        $result = '<h3>'.&mt('Verification of PDF form items failed').'</h3>'.
                  '<div class="LC_error">'.
                  &mt('Unable to retrieve information about course contents').' '.
                  &mt('You may need to [_1]re-select[_2] the course.','<a href="/adm/roles">','</a>').
                  '</div>';
        return $result;
    }
    my %restitles;
    foreach my $res ($navmap->retrieveResources()) {
        my $symb = $res->symb; 
        $restitles{$symb} = $res->compTitle();
    }
   
    $debug  .= "Found: ". scalar @pdfdata." Entries \n";

    foreach my $entry (sort(@pdfdata)) {
        if ($entry =~ /^meta.*/) {
            $debug .= 'found: metadata -> '.$entry . "<br />";
            my ($label, $value) = ($entry =~ /^([^?]*)\?(.*)/);
            my ($domain, $user) = split('&', $value);
            $user =~ s/(.*)\n/$1/; #TODO is that equals to chomp?
            if($user ne $env{'user.name'} or  $domain ne $env{'user.domain'}) {
                return '<p class="LC_error">'
                      .&mt('Wrong username ([_1]) found in PDF file. Expected username: [_2]'
                          ,$user.':'.$domain
                          ,$env{'user.domain'}.':'.$env{'user.name'})
                      .'</p>';
            }

        } elsif ($entry =~ /^upload.*/)  {
            $debug .= 'found: a problem -> '.$entry;
            my ($label, $value) = ($entry =~ /^([^?]*)\?(.*)/);
            my ($symb, $part, $type, $HWVAL) = split('&', $label);
            my ($map,$id,$resource)=&Apache::lonnet::decode_symb($symb);
            if ($map =~ m{^uploaded/($match_domain)/($match_courseid)/default(_?\d*)\.(page|sequence)}) {
                my $mapcid = $1.'_'.$2;
                if ($mapcid ne $env{'request.course.id'}) {
                    push(@{$foreigncourse{$mapcid}},$symb);
                }
            }
            next unless (exists($restitles{$symb}));
            $value =~ s/(.*)\n/$1/; 

            #filter incorrect radiobuttons (Bug in CABAReT Stage)
            if ($type eq 'radiobuttonresponse' && $value eq 'Off' ) {
                next;
            }
 
            my $submit = $part;
            $submit =~ s/part_(.*)/submit_$1/;
            if ($problems{$symb.$part}) {
                 $problems{$symb.$part}{$HWVAL} = $value;
            } else {
                 $problems{$symb.$part} =  { 'resource' => $resource,
                                        'symb' => $symb,
                                        'submitted' => $part,
                                        $submit => 'Answer',
                                        $HWVAL => $value};
            }
        } else {
            $debug .= 'found: -> '.$entry;
            next;
        }
    }
    #$result .= $debug;

    $result .= '<h3>'.&mt('Result of PDF Form upload').'</h3>';

    if (keys(%problems) > 0) {
        $result .= &Apache::loncommon::start_data_table()
                  .&Apache::loncommon::start_data_table_header_row()
                  .'<th>'.&mt('Problem Name').'</th>'
                  .'<th>'.&mt('Grading').'</th>'
                  .&Apache::loncommon::start_data_table_header_row()
                  .&Apache::loncommon::end_data_table_header_row();

        foreach my $key (sort(keys(%problems))) {
            my %problem = %{$problems{$key}};
            my ($problemname, $grade) = &grade_problem(%problem);

            $result .= &Apache::loncommon::start_data_table_row();
            $result .= '<td><a href="/res/'.$problem{'resource'}.
                       '?symb='.
                       &HTML::Entities::encode($problem{'symb'},'"&<>').
                       '">'.$problemname.'</a></td><td><span class="';
            if ($grade eq "EXACT_ANS" || $grade eq "APPROX_ANS") {
                $result .= 'LC_answer_correct';
            } elsif ($grade eq "DRAFT") {
                $result .= 'LC_answer_not_charged_try';
            } else {
                $result .= 'LC_answer_charged_try';
            }
            $result .= '">';
            $grade = &parse_grade_answer($grade);
            $result .= $grade.'</span></td>';
            $result .= &Apache::loncommon::end_data_table_row();
        }
        $result .= &Apache::loncommon::end_data_table();
    } else {
        $result .= '<p class="LC_warning">'.
                   &mt('As no gradable form items were found, no submissions have been recorded.').
                   '</p>';
    }
    if (keys(%foreigncourse)) {
        my ($numother,$othercrsmsg);
        foreach my $cid (sort(keys(%foreigncourse))) {
            my %coursehash = &Apache::lonnet::coursedescription($cid,
                                                          {'one_time' => 1});
            if (ref($foreigncourse{$cid}) eq 'ARRAY') {
                if ($numother) {
                    $othercrsmsg .= '</li><li>';
                }
                $othercrsmsg .= '<b>'.$coursehash{'description'}.'</b><ul>'."\n";
                foreach my $symb (@{$foreigncourse{$cid}}) {
                    my ($map,$id,$resource)=&Apache::lonnet::decode_symb($symb);
                    $othercrsmsg .= '<li>'.$resource.'</li>';
                }
                $othercrsmsg .= '</ul>';
                $numother ++;
            }
        }
        if ($numother) {
            $result .= '<div class="LC_warning">';
            if ($numother > 1) {
                $result .= &mt('Your uploaded PDF form contained the following resource(s) from [_1] different courses:','<b>'.$numother.'</b>')."\n".'<ul><li>'.
                           $othercrsmsg.'</li></ul>';
            } else {
                $result .= &mt('Your uploaded PDF form contained the following resource(s) from a different course:').' '.$othercrsmsg.
                           &mt('Did you download the PDF form from another course and upload it to the wrong course?'); 
            }
            $result .= '</div>';
        }
    }

    return $result;
}

sub grade_problem {
    my %problem = @_;
    my ($title, $part) = ();

    &Apache::loncommon::ssi_with_retries('/res/'.$problem{'resource'}, 5, %problem);

    $title = &Apache::lonnet::gettitle($problem{'symb'});    
    $part = $problem{submitted};
    $part =~ s/part_(.*)/$1/;
    unless($part eq '0') {
        #add information about part number
        $title .= " - Part $part";
    }
 
    my %problemhash = &Apache::lonnet::restore($problem{'symb'});
    my $grade = $problemhash{"resource.$part.award"};

    return ($title, $grade);    
}

sub parse_grade_answer {
    my ($shortcut) = @_;
     my %answerhash = ('EXACT_ANS' => &mt('You are correct.'),
                       'APPROX_ANS' => &mt('You are correct.'),
                       'INCORRECT' => &mt('You are incorrect'),
                       'DRAFT' => &mt('Copy saved but not submitted.'),
     );

    foreach my $key (keys(%answerhash)) {
        if($shortcut eq $key) {
            return $answerhash{$shortcut};
        }  
    }
    return &mt('See course contents for further information.');

}


sub dumpenv  {
    my $r = shift;

    $r->print ("<br />-------------------<br />");
    foreach my $key (sort(keys(%env))) {
        $r->print ("<br />$key -> $env{$key}");
    }
    $r->print ("<br />-------------------<br />");
    $r->print ("<br />-------------------<br />");
    foreach my $key (sort(keys(%ENV))) {
        $r->print ("<br />$key -> $ENV{$key}");
    }
    $r->print ("<br />-------------------<br />");
    
}	

1;
__END__