diff --git a/.gitignore b/.gitignore index b3a84c7776..0ee1d29ce5 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,4 @@ -lib/chromatic/color -conf/pg_defaults.yml +conf/pg_config.yml *.bak cover_db/ @@ -7,3 +6,4 @@ htdocs/node_modules htdocs/static-assets.json htdocs/**/*.min.js htdocs/**/*.min.css +htdocs/tmp diff --git a/.perltidyrc b/.perltidyrc index 8314b7c173..4620751c6f 100644 --- a/.perltidyrc +++ b/.perltidyrc @@ -20,3 +20,4 @@ -nlop # No logical padding (this causes mixed tabs and spaces) -wn # Weld nested containers -xci # Extended continuation indentation +-vxl='q' # No vertical alignment of qw quotes diff --git a/conf/pg_config.dist.yml b/conf/pg_config.dist.yml new file mode 100644 index 0000000000..f8d4735028 --- /dev/null +++ b/conf/pg_config.dist.yml @@ -0,0 +1,263 @@ +# Configuration options needed by PG. + +# You should not edit pg_config.dist.yml directly. Copy pg_config.dist.yml file to pg_config.yml and make changes to +# that file. + +# $pg_root may be used in values and will be replaced with the pg root directory set from the PG_ROOT environment +# variable. + +# $render_root may be used in values and will be replaced with the renderer root directory set from the RENDER_ROOT +# environment variable. + +# $OPL_dir may be used in values and will be replaced with the value of the directories OPL setting below. +# $Contrib_dir may be used in values and will be replaced with the value of the directories Contrib setting below. +# $pg_root_url may be used in values and will be replaced with the value of the URLs html setting below. + +directories: + # The OPL and Contrib directories. + OPL: /opt/webwork/libraries/webwork-open-problem-library/OpenProblemLibrary + Contrib: /opt/webwork/libraries/webwork-open-problem-library/Contrib + + # The root PG location. This will be set from the PG_ROOT environment variable, but can be overriden here. + root: $pg_root + + # Global temporary directory. This location must be writable. + tmp: /tmp + + # Public html location containing the PG javascript, css, and help files. + html: $pg_root/htdocs + + # Temporary directory from which generated files will be served. This location must be writable. + html_temp: $pg_root/htdocs/tmp + + # Directory from which WeBWorK::PG::IO allows files to be read. + permitted_read_dir: /opt/webwork + + # Location of cached equation images. + equationCache: $pg_root/htdocs/tmp/equations + + # The macro file search path. Each directory in this list is searched + # (in this order) by loadMacros when it looks for a .pl macro file. + macrosPath: + - . + - $pg_root/macros + - $OPL_dir/macros/Alfred + - $OPL_dir/macros/BrockPhysics + - $OPL_dir/macros/CollegeOfIdaho + - $OPL_dir/macros/Dartmouth + - $OPL_dir/macros/FortLewis + - $OPL_dir/macros/Hope + - $OPL_dir/macros/LaTech + - $OPL_dir/macros/MC + - $OPL_dir/macros/Michigan + - $OPL_dir/macros/Mizzou + - $OPL_dir/macros/NAU + - $OPL_dir/macros/PCC + - $OPL_dir/macros/TCNJ + - $OPL_dir/macros/UBC + - $OPL_dir/macros/UMass-Amherst + - $OPL_dir/macros/UW-Stout + - $OPL_dir/macros/UniSiegen + - $OPL_dir/macros/Union + - $OPL_dir/macros/WHFreeman + - $OPL_dir/macros/Wiley + - $Contrib_dir/CAPA/macros/CAPA_Tools + - $Contrib_dir/CAPA/macros/CAPA_MCTools + +URLs: + # The public URL of the html directory above. + html: /pg_files + + # The public URL of the html_temp directory above. + tempURL: $pg_root_url/tmp + + # The public URL of the PG help files. + localHelpURL: $pg_root_url/helpFiles + + # URL of cached equation images. + equationCache: $pg_root_url/tmp/equations + + # Paths to search for auxiliary html files (requires full url). + htmlPath: + - . + - $pg_root_url + + # Paths to search for image files (requires full url). + imagesPath: + - . + - $pg_root_url/images + +# Flat-file database used to protect against MD5 hash collisions. TeX equations +# are hashed to determine the name of the image file. There is a tiny chance of +# a collision between two TeX strings. This file allows for that. However, this +# is slow, so most people chose not to worry about it. Set this to '' if you +# don't want to use the equation cache file. +equationCacheDB: '' + +externalPrograms: + curl: /usr/bin/curl + cp: /bin/cp + mv: /bin/mv + rm: /bin/rm + tar: /bin/tar + latex: /usr/bin/latex --no-shell-escape + pdflatex: /usr/bin/pdflatex --no-shell-escape + dvisvgm: /usr/bin/dvisvgm + pdf2svg: /usr/bin/pdf2svg + convert: /usr/bin/convert + dvipng: /usr/bin/dvipng + +specialPGEnvironmentVars: + # switch to remove explanation essay block from questions that have one + waiveExplanations: 0 + + # To disable the Parser-based versions of num_cmp and fun_cmp, and use the + # original versions instead, set this value to 1. + useOldAnswerMacros: 0 + + # Determines whether or not MathObjects contexts will parse the alternative tokens + # listed in the "alternatives" property (mostly for unicode alternatives for parse tokens). + parseAlternatives: 0 + + # Determines whether or not the MathObjects parser will convert the Full Width Unicode block + # (U+FF01 to U+FF5E) to their corresponding ASCII characters (U+0021 to U+007E) automatically. + convertFullWidthCharacters: 0 + + # Binary that the PGtikz.pl and PGlateximage.pl macros will use to create svg images. + # This should be either 'pdf2svg' or 'dvipdfm'. + latexImageSVGMethod: pdf2svg + + # When ImageMagick is used for image conversions, this sets the default options. + # See https://imagemagick.org/script/convert.php for a full list of options. + # convert will be called as: + # convert file.ext1 file.ext2 + latexImageConvertOptions: + input: + density: 300 + output: + quality: 100 + + # Strings to insert at the start and end of the body of a problem. + problemPreamble: + TeX: '' + HTML: '' + problemPostamble: + TeX: '' + HTML: '' + + # Math entry assistance + entryAssist: MathQuill + + # Whether to use javascript for rendering Live3D graphs. + use_javascript_for_live3d: 1 + + # Size in pixels of dynamically-generated images, i.e. graphs. + onTheFlyImageSize: 400 + + # Locations of CAPA resources. (Only necessary if you need to use converted CAPA problems.) + CAPA_Tools: $Contrib_dir/CAPA/macros/CAPA_Tools/ + CAPA_MCTools: $Contrib_dir/Contrib/CAPA/macros/CAPA_MCTools/ + CAPA_GraphicsDirectory: $Contrib_dir/Contrib/CAPA/CAPA_Graphics/ + CAPA_Graphics_URL: $pg_root_url/CAPA_Graphics/ + +# Answer evaluatior defaults +ansEvalDefaults: + functAbsTolDefault: 0.001 + functLLimitDefault: 0.0000001 + functMaxConstantOfIntegration: 1E8 + functNumOfPoints: 3 + functRelPercentTolDefault: 0.1 + functULimitDefault: 0.9999999 + functVarDefault: x + functZeroLevelDefault: 1E-14 + functZeroLevelTolDefault: 1E-12 + numAbsTolDefault: 0.001 + numFormatDefault: '' + numRelPercentTolDefault: 0.1 + numZeroLevelDefault: 1E-14 + numZeroLevelTolDefault: 1E-12 + useBaseTenLog: 0 + defaultDisplayMatrixStyle: '[s]' # left delimiter, middle line delimiters, right delimiter + +options: + # The default grader to use, if a problem doesn't specify. + grader: avg_problem_grader + + # Note that the first of useMathQuill, useMathView, and useWirisEditor that is set (in that order) to 1 will be used. + + # Set to 1 use MathQuill in answer boxes. + useMathQuill: 1 + + # Set to 1 to use the MathView preview system with answer boxes. + useMathView: 0 + + # This is the operations file to use for mathview, each contains a different locale. + mathViewLocale: mv_locale_us.js + + # Set to 1 to show the WirisEditor preview system. + useWirisEditor: 0 + + # Catch translation warnings internally. + catchWarnings: 1 + +# "images" mode has several settings: +displayModeOptions: + images: + # Determines the method used to align images in output. Can be any valid value for the css vertical-align rule such + # as 'baseline' or 'middle'. + dvipng_align: baseline + + # If dbsource is set to a nonempty value, then this database connection information will be used to store depths. + # It is assumed that the 'depths' table exists in the database. + dvipng_depth_db: + dbsource: '' + user: '' + passwd: '' + +# PG modules to load +# The first item of each list is the module to load. The remaining items are additional packages to import. +# That is: If you wish to include a module MyModule.pm which depends on additional modules Dependency1.pm and +# Dependency2.pm, these should appear as [Mymodule, Dependency1, Dependency2] +modules: + - [Encode] + - ['Encode::Encoding'] + - ['HTML::Parser'] + - ['HTML::Entities'] + - [DynaLoader] + - [Encode] + - [Exporter] + - [GD] + - [AlgParser, AlgParserWithImplicitExpand, Expr, ExprWithImplicitExpand, utf8] + - [AnswerHash, AnswerEvaluator] + - [LaTeXImage] + - [WWPlot] # required by Circle (and others) + - [Circle] + - ['Class::Accessor'] + - [Complex] + - [Complex1] + - [Distributions] + - [Fraction] + - [Fun] + - [Hermite] + - [Label] + - [ChoiceList] + - [Match] + - [MatrixReal1] # required by Matrix + - [Matrix] + - [Multiple] + - [PGrandom] + - [Regression] + - [Select] + - [Units] + - [VectorField] + - [Parser, Value] + - ['Parser::Legacy'] + - [Statistics] + - [Chromatic] # for Northern Arizona graph problems + - [Applet] + - [PGcore, PGalias, PGresource, PGloadfiles, PGanswergroup, PGresponsegroup, 'Tie::IxHash'] + - ['Locale::Maketext'] + - [JSON] + - [Rserve, 'Class::Tiny', 'IO::Handle'] + - [DragNDrop] + - ['Types::Serialiser'] diff --git a/conf/pg_defaults.dist.yml b/conf/pg_defaults.dist.yml deleted file mode 100644 index fe31876a56..0000000000 --- a/conf/pg_defaults.dist.yml +++ /dev/null @@ -1,19 +0,0 @@ -# This file is loaded if PG is loaded without a webwork2 lib -# -# The following are configuration options that are needed by PG -# and are a slimmed down list from those of WEBWORK_ROOT/conf/defaults.config - -options: - webworkDirs: - tmp: /tmp - externalPrograms: - curl: /usr/bin/curl - cp: /bin/cp - mv: /bin/mv - rm: /bin/rm - tar: /bin/tar - latex: /usr/bin/latex --no-shell-escape - pdflatex: /usr/bin/pdflatex --no-shell-escape - dvisvgm: /usr/bin/dvisvgm - pdf2svf: /usr/bin/pdf2svg - convert: /usr/bin/convert diff --git a/htdocs/js/apps/WirisEditor/quizzes.js b/htdocs/js/apps/WirisEditor/quizzes.js index 8529987301..9af86b8a7b 100755 --- a/htdocs/js/apps/WirisEditor/quizzes.js +++ b/htdocs/js/apps/WirisEditor/quizzes.js @@ -19103,7 +19103,7 @@ com.wiris.quizzes.impl.ConfigurationImpl.DEF_HAND_LOGTRACES = "false"; com.wiris.quizzes.impl.ConfigurationImpl.DEF_SERVICE_OFFLINE = "false"; com.wiris.quizzes.impl.ConfigurationImpl.DEF_CROSSORIGINCALLS_ENABLED = "false"; com.wiris.quizzes.impl.ConfigurationImpl.DEF_RESOURCES_STATIC = "false"; -com.wiris.quizzes.impl.ConfigurationImpl.DEF_RESOURCES_URL = "/webwork2_files/js/apps/WirisEditor/"; +com.wiris.quizzes.impl.ConfigurationImpl.DEF_RESOURCES_URL = "/pg_files/js/apps/WirisEditor/"; com.wiris.quizzes.impl.ConfigurationImpl.DEF_GRAPH_URL = ""; com.wiris.quizzes.impl.ConfigurationImpl.config = null; com.wiris.quizzes.impl.CorrectAnswer.tagName = "correctAnswer"; @@ -19368,7 +19368,7 @@ com.wiris.quizzes.impl.ConfigurationImpl.DEF_SERVICE_OFFLINE = "false"; com.wiris.quizzes.impl.ConfigurationImpl.DEF_WIRISLAUNCHER_URL = "http://stateful.wiris.net/demo/wiris"; com.wiris.quizzes.impl.ConfigurationImpl.DEF_CROSSORIGINCALLS_ENABLED = "true"; com.wiris.quizzes.impl.ConfigurationImpl.DEF_RESOURCES_STATIC = "true"; -com.wiris.quizzes.impl.ConfigurationImpl.DEF_RESOURCES_URL = "/webwork2_files/js/apps/WirisEditor/"; +com.wiris.quizzes.impl.ConfigurationImpl.DEF_RESOURCES_URL = "/pg_files/js/apps/WirisEditor/"; com.wiris.quizzes.impl.ConfigurationImpl.DEF_HAND_LOGTRACES = "true"; com.wiris.quizzes.impl.ConfigurationImpl.DEF_GRAPH_URL = ""; if(!window.com) window.com={}; @@ -19380,4 +19380,4 @@ window.com.wiris.quizzes.api.QuizzesBuilder = com.wiris.quizzes.api.QuizzesBuild window.com.wiris.quizzes.api.ConfigurationKeys = com.wiris.quizzes.api.ConfigurationKeys; window.com.wiris.quizzes.api.ui.QuizzesUIConstants = com.wiris.quizzes.api.ui.QuizzesUIConstants; com.wiris.quizzes.JsQuizzesFilter.main(); -})(); \ No newline at end of file +})(); diff --git a/lib/Applet.pm b/lib/Applet.pm index 75c47d41f3..3f041ff094 100644 --- a/lib/Applet.pm +++ b/lib/Applet.pm @@ -41,17 +41,14 @@ Applet.pl - Provides code for inserting GeogebraWebApplets into webwork problems This file provides an object to store in one place all of the information needed to call an applet. -The module GeogebraWebApplet has defaults for inserting Geogebra web applets. +The module GeogebraWebAppletBase has defaults for inserting Geogebra web applets. The module Applet stores common code for the different types of applets. =cut package Applet; -use URI::Escape; use MIME::Base64 qw(encode_base64 decode_base64); -use PGcore; -@ISA = qw(PGcore); =head2 Default JavaScript functions placed in header @@ -74,13 +71,13 @@ question. Usage: $current_value = $applet->method(new_value or empty) These can also be set when creating the class. For example: - $applet = new GeogebraWebApplet( + $applet = GeogebraWebApplet( appletName => $appletName, width => 400, height => 250 ); - When using AppletObjects.pl this can be replaced by $applet = GeogebraWebApplet(...). + The AppletObjects.pl macro file must be used to load the derived packages of the Applet package. appletName The name of the applet @@ -180,7 +177,7 @@ as a runtime version of the perlApplet since it can be accessed and modified aft HTML page has been created by the PG rendering process. The perlApplet is initialized by - $newApplet = new GeogebraWebApplet(appletName => 'myApplet', ...); + $newApplet = GeogebraWebApplet(appletName => 'myApplet', ...); The jsApplet is automatically defined in ww_applet_list["myApplet"] by copying the instance variables of $newApplet to a corresponding JavaScript object. So $newApplet->{appletName} corresponds to ww_applet_list["myApplet"].appletName. (This paragraph is not yet fully @@ -530,28 +527,16 @@ sub insertObject { return $objectText; } -############################################################################################################### -# GeogebraWeb APPLET PACKAGE -############################################################################################################### +# These methods are defined so that they can be used in the derived objects in the AppletObjects.pl macro file. -package GeogebraWebApplet; -@ISA = qw(Applet); - -use constant GEOGEBRAWEB_OBJECT_TEXT => <<'END_OBJECT_TEXT'; -
-END_OBJECT_TEXT +sub base64_encode { + my $self = shift; + return encode_base64(shift); +} -sub new { - my $class = shift; - $class->SUPER::new( - objectText => GEOGEBRAWEB_OBJECT_TEXT(), - type => 'geogebraweb', - @_ - ); +sub base64_decode { + my $self = shift; + return decode_base64(shift); } 1; diff --git a/lib/Chromatic.pm b/lib/Chromatic.pm index 36480ea0d5..f3d5bf6296 100644 --- a/lib/Chromatic.pm +++ b/lib/Chromatic.pm @@ -1,109 +1,380 @@ -BEGIN { - be_strict(); -} +################################################################################ +# WeBWorK Online Homework Delivery System +# Copyright © 2000-2022 The WeBWorK Project, https://github.com/openwebwork +# +# This program is free software; you can redistribute it and/or modify it under +# the terms of either: (a) the GNU General Public License as published by the +# Free Software Foundation; either version 2, or (at your option) any later +# version, or (b) the "Artistic License" which comes with this package. +# +# This program 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 either the GNU General Public License or the +# Artistic License for more details. +################################################################################ package Chromatic; -our $webwork_directory = $WeBWorK::Constants::WEBWORK_DIRECTORY; #'/opt/webwork/webwork2'; -# fake course name 'foobar' prevents undefined courseName warnings -# FIXME is there a more efficient way to find the location of the PG directory? Perhaps an ENV variable? -# or a WEBWORK_PG_DIRECTORY variable? -- perhaps not since all of those are in the defaults.config file -# we would have to read that at compile time. - -my $pg_envir = new PGEnvironment(); - -# our $seed_ce = new WeBWorK::CourseEnvironment({ webwork_dir => $webwork_directory, courseName =>'foobar'}); -# die "Can't create seed course environment for webwork in $webwork_directory" unless ref($seed_ce); -# our $PGdirectory = $seed_ce->{pg_dir}; -my $PGdirectory = $pg_envir->{pg_dir}; - -# now that we have the PGdirectory we can get to work compiling color -our $command = "$PGdirectory/lib/chromatic/color"; -our $compileCommand = "/usr/bin/gcc -O3 -o $PGdirectory/lib/chromatic/color $PGdirectory/lib/chromatic/color.c"; -unless (-x $command) { - if (-w "$PGdirectory/lib/chromatic" and -r "$PGdirectory/lib/chromatic/color.c" and -x "/usr/bin/gcc") { - # compile color if it is not there - system $compileCommand; - } else { - warn "ERROR: Unable to compile $PGdirectory/lib/chromatic/color.c."; - warn "The command $compileCommand failed"; - warn "Chromatic.pm and a compiled version of color.c are required for this problem"; - warn "The file color.c will need to be compiled by a systems administrator."; - warn "Can't find compiler at /usr/bin/gcc" unless -x '/usr/bin/gcc'; - warn "Can't write into directory $PGdirectory/lib/chromatic" unless -w "$PGdirectory/lib/chromatic"; - warn "Can't read C file $PGdirectory/lib/chromatic/color.c" unless -r "$PGdirectory/lib/chromatic/color.c"; - } -} -our $tempDirectory = $pg_envir->{webworkDirs}->{DATA}; -use UUID::Tiny ':std'; +use warnings; +use strict; -sub matrix_graph { - my ($graph) = @_; - $graph =~ s/\A\s*//; - $graph =~ s/;\s*\Z//; +use Carp; - my (@m, $size, $i, $j, @r, @matrix); - @m = split /\s*[;]\s*/, $graph; - $size = scalar @m; - @matrix = (); - for ($i = 0; $i < $size; $i++) { - @r = split /\s+/, $m[$i]; - for ($j = 0; $j < $size; $j++) { - $matrix[$i][$j] = $r[$j]; +sub computeBestColoring { + my @adj = @_; + my $num_node = scalar @adj; + + my $BestColoring = $num_node + 1; + my @ColorClass; + my $prob_count = 0; + my @Order; + my @Handled = (0) x $num_node; + my @ColorAdj; + my @ColorCount = (0) x $num_node; + my $lb; + my $num_prob = 0; + my $max_prob = 10000; + my @valid = (1) x $num_node; + my $best_clique = 0; + + my $greedy_clique = sub { + my ($valid, $clique) = @_; + my $place = 0; + my @order = (0) x ($num_node + 1); + my @weight; + + $clique->[$_] = 0 for (0 .. $num_node - 1); + + for my $i (0 .. $num_node - 1) { + if ($valid->[$i]) { + $order[$place] = $i; + ++$place; + } } - } - @matrix; -} -sub ChromNum { - my ($graph) = @_; - my ($i, $j, @adj, $val, $size, $count, @edges, $ctime, $fh, $fname); - my $unique_id_seed = time; - my $unique_id_stub = create_uuid_as_string(UUID_V3, UUID_NS_URL, $unique_id_seed); - my $fileout = "$tempDirectory/$unique_id_stub"; - unless (-x $command) { - - die "Can't execute $command to calculate chromatic color"; - } + $weight[$_] = 0 for (0 .. $num_node - 1); + + for my $i (0 .. $num_node - 1) { + next unless $valid->[$i]; + for my $j (0 .. $num_node - 1) { + next unless $valid->[$j]; + ++$weight[$i] if $adj[$i][$j]; + } + } + + my $done = 0; + while (!$done) { + $done = 1; + for my $i (0 .. $place - 2) { + my $j = $order[$i]; + my $k = $order[ $i + 1 ]; + if ($weight[$j] < $weight[$k]) { + $order[$i] = $k; + $order[ $i + 1 ] = $j; + $done = 0; + } + } + } + + $clique->[ $order[0] ] = 1; + for my $i (1 .. $place - 1) { + my $j = $order[$i]; + my $k = 0; + for (0 .. $i - 1) { + if ($clique->[ $order[$_] ] && !$adj[$j][ $order[$_] ]) { + $k = $_; + last; + } + } + if ($k == $i) { + $clique->[$j] = 1; + } else { + $clique->[$j] = 0; + } + } + + my $max = 0; + for my $i (0 .. $place - 1) { + ++$max if $clique->[ $order[$i] ]; + } + + return $max; + }; + + # Target is a goal value: once a clique is found with value target it is possible to return + # + # Lower is a bound representing an already found clique: once it is determined that no clique exists with value + # better than lower, it is permitted to return with a suboptimal clique. + # + # Note, to find a clique of value 1, it is not permitted to just set the lower to 1: the recursion will not work. + # Lower represents a value that is the goal for the recursion. + my $max_w_clique; + $max_w_clique = sub { + my ($valid, $clique, $lower, $target) = @_; + + my @order = (0) x ($num_node + 1); + my @value = (0) x $num_node; + + ++$num_prob; + + return -1 if $num_prob > $max_prob; + + $clique->[$_] = 0 for (0 .. $num_node - 1); + + my $total_left = 0; + for my $i (0 .. $num_node - 1) { + ++$total_left if ($valid->[$i]); + } + + return 0 if ($total_left < $lower); + + my $incumb = $greedy_clique->($valid, $clique); + return $incumb if $incumb >= $target; + + $best_clique = $incumb if ($incumb > $best_clique); + + my $place = 0; + for my $i (0 .. $num_node) { + if ($clique->[$i]) { + $order[$place] = $i; + --$total_left; + ++$place; + } + } + + my $start = $place; + for my $i (0 .. $num_node - 1) { + if (!$clique->[$i] && $valid->[$i]) { + $order[$place] = $i; + ++$place; + } + } + + my $finish = $place; + for ($start .. $finish - 1) { + my $i = $order[$_]; + $value[$i] = 0; + for my $j (0 .. $num_node - 1) { + ++$value[$i] if $valid->[$j] && $adj[$i][$j]; + } + } + + my $done = 0; + + while (!$done) { + $done = 1; + for ($start .. $finish - 2) { + my $i = $order[$_]; + my $j = $order[ $_ + 1 ]; + if ($value[$i] < $value[$j]) { + $order[$_] = $j; + $order[ $_ + 1 ] = $i; + $done = 0; + } + } + } + + for ($start .. $finish - 1) { + return 0 if $incumb + $total_left < $lower; + + my $j = $order[$_]; + --$total_left; + + next if $clique->[$j]; - @adj = matrix_graph($graph); - $count = 0; - $size = scalar @adj; + my @valid1 = (0) x $num_node; + my @clique1 = (0) x $num_node; + $valid1[$_] = 0 for (0 .. $num_node - 1); - for ($i = 0; $i < $size; $i++) { - for ($j = $i + 1; $j < $size; $j++) { - if ($adj[$i][$j] != 0) { - $count++; - push @edges, $i + 1, $j + 1; + for (0 .. $_ - 1) { + my $k = $order[$_]; + if ($valid->[$k] && $adj[$j][$k]) { + $valid1[$k] = 1; + } else { + $valid1[$k] = 0; + } } + + my $new_weight = $max_w_clique->(\@valid1, \@clique1, $incumb - 1, $target - 1); + + if ($new_weight + 1 > $incumb) { + $incumb = $new_weight + 1; + $clique->[$_] = $clique1[$_] for (0 .. $num_node - 1); + $clique->[$j] = 1; + $best_clique = $incumb if $incumb > $best_clique; + } + + last if $incumb >= $target; + } + + return $incumb; + }; + + my $AssignColor = sub { + my ($node, $color) = @_; + + $ColorClass[$node] = $color; + + for my $node1 (0 .. $num_node - 1) { + next if ($node == $node1); + if ($adj[$node][$node1]) { + ++$ColorCount[$node1] if $ColorAdj[$node1][$color] == 0; + ++$ColorAdj[$node1][$color]; + --$ColorAdj[$node1][0]; + warn 'ERROR on assign' if $ColorAdj[$node1][0] < 0; + } + } + + return; + }; + + my $RemoveColor = sub { + my ($node, $color) = @_; + + $ColorClass[$node] = 0; + + for my $node1 (0 .. $num_node - 1) { + next if ($node == $node1); + if ($adj[$node][$node1]) { + --$ColorAdj[$node1][$color]; + --$ColorCount[$node1] if $ColorAdj[$node1][$color] == 0; + warn 'ERROR on assign' if $ColorAdj[$node1][$color] < 0; + ++$ColorAdj[$node1][0]; + } + } + + return; + }; + + my $print_colors = sub { + for my $i (0 .. $num_node - 1) { + for my $j (0 .. $num_node - 1) { + next if $i == $j; + warn "Error with nodes $i and $j and color $ColorClass[$i]" + if $adj[$i][$j] && $ColorClass[$i] == $ColorClass[$j]; + } + } + + return; + }; + + my $color; + $color = sub { + my ($i, $current_color) = @_; + ++$prob_count; + return $current_color if $current_color >= $BestColoring; + return $BestColoring if $BestColoring <= $lb; + + return $current_color if $i >= $num_node; + + # Find node with maximum $color_adj + my $max = -1; + my $place = -1; + for my $k (0 .. $num_node - 1) { + next if $Handled[$k]; + if ($ColorCount[$k] > $max || ($ColorCount[$k] == $max && ($ColorAdj[$k][0] > $ColorAdj[$place][0]))) { + $max = $ColorCount[$k]; + $place = $k; + } + } + if ($place == -1) { + croak 'Graph is disconnected. This code needs to be updated for that case.'; + } + + my $new_val; + $Order[$i] = $place; + $Handled[$place] = 1; + + for my $j (1 .. $current_color) { + if (!$ColorAdj[$place][$j]) { + $ColorClass[$place] = $j; + $AssignColor->($place, $j); + + $new_val = $color->($i + 1, $current_color); + if ($new_val < $BestColoring) { + $BestColoring = $new_val; + $print_colors->(); + } + + $RemoveColor->($place, $j); + if ($BestColoring <= $current_color) { + $Handled[$place] = 0; + return $BestColoring; + } + } + } + + if ($current_color + 1 < $BestColoring) { + $ColorClass[$place] = $current_color + 1; + $AssignColor->($place, $current_color + 1); + + $new_val = $color->($i + 1, $current_color + 1); + if ($new_val < $BestColoring) { + $BestColoring = $new_val; + $print_colors->(); + } + + $RemoveColor->($place, $current_color + 1); + } + + $Handled[$place] = 0; + return $BestColoring; + }; + + for my $i (0 .. $num_node - 1) { + for my $j (0 .. $num_node - 1) { + $ColorAdj[$i][$j] = 0; } } - # This is not quite good enough to avoid race conditions but it'll do. - while (-e "$fileout") { - sleep 1; + for my $i (0 .. $num_node - 1) { + for my $j (0 .. $num_node - 1) { + ++$ColorAdj[$i][0] if $adj[$i][$j]; + } } - open OUT, ">$fileout"; - print OUT "$size $count\n"; - for ($i = 0; $i < scalar @edges; $i += 2) { - print OUT "$edges[$i] $edges[$i+1]\n"; + my @clique; + $lb = $max_w_clique->(\@valid, \@clique, 0, $num_node); + + my $place = 0; + for my $i (0 .. $num_node - 1) { + if ($clique[$i]) { + $Order[$place] = $i; + $Handled[$i] = 1; + ++$place; + $AssignColor->($i, $place); + for my $j (0 .. $num_node - 1) { + warn 'Result is not a clique!' if $i != $j && $clique[$j] && !$adj[$i][$j]; + } + } } - close(OUT); - # This does not work, don't know why. It's probably unsecure anyway. - # unless (-e '/opt/webwork/pg/lib/chromatic/color') { - # `cd /opt/webwork/pg/lib/chromatic; gcc color.c -o color`; - # } + return $color->($place, $place); +} - $val = qx[$command $fileout]; +sub matrix_graph { + my $graph = shift; + $graph =~ s/\A\s*//; + $graph =~ s/;\s*\Z//; - $val =~ /value (\d+)/g; - qx[rm $fileout]; - $1; + my @m = split /\s*[;]\s*/, $graph; + my $size = scalar @m; + my @matrix; + for my $i (0 .. $size - 1) { + my @r = split /\s+/, $m[$i]; + for my $j (0 .. $size - 1) { + $matrix[$i][$j] = $r[$j]; + } + } + + return @matrix; } -sub chn { - "Blah"; +# $graph input is a string adjacency matrix with rows terminted with semicolons +# and entries of each row separated by a space. +sub ChromNum { + my $graph = shift; + return computeBestColoring(matrix_graph($graph)); } + 1; diff --git a/lib/LaTeXImage.pm b/lib/LaTeXImage.pm index 7851f8611a..2668a0aa90 100644 --- a/lib/LaTeXImage.pm +++ b/lib/LaTeXImage.pm @@ -180,7 +180,7 @@ sub footer { sub draw { my $self = shift; - my $working_dir = WeBWorK::PG::ImageGenerator::makeTempDirectory(WeBWorK::PG::IO::ww_tmp_dir(), "latex"); + my $working_dir = WeBWorK::PG::ImageGenerator::makeTempDirectory(WeBWorK::PG::IO::pg_tmp_dir(), "latex"); my $data; my $ext = $self->ext; diff --git a/lib/PGEnvironment.pm b/lib/PGEnvironment.pm deleted file mode 100644 index 51c382c13e..0000000000 --- a/lib/PGEnvironment.pm +++ /dev/null @@ -1,80 +0,0 @@ -################################################################################ -# WeBWorK Online Homework Delivery System -# Copyright © 2000-2022 The WeBWorK Project, https://github.com/openwebwork -# -# This program is free software; you can redistribute it and/or modify it under -# the terms of either: (a) the GNU General Public License as published by the -# Free Software Foundation; either version 2, or (at your option) any later -# version, or (b) the "Artistic License" which comes with this package. -# -# This program 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 either the GNU General Public License or the -# Artistic License for more details. -################################################################################ -package PGEnvironment; - -use strict; -use warnings; - -=pod - -=head1 PGEnvironment - -This is a substitute for the CourseEnvironment module on the webwork2 side -however is much slimmed down. It loads only configuration options need for -PG when not run in full mode. - -If the the WeBWorK::CourseEnvironment module is found the lib path, then the -necessary configuration options are loaded. - -Otherwise, defaults are loaded from PG_ROOT/conf/pg_defaults.yml - -=cut - -my $ce; -my $pg_dir; - -use YAML::XS qw/LoadFile/; - -BEGIN { - eval { - require WeBWorK::CourseEnvironment; - $ce = WeBWorK::CourseEnvironment->new({ webwork_dir => $ENV{WEBWORK_ROOT} }); - } or do { - $pg_dir = $ENV{PG_ROOT}; - die "The environmental variable PG_ROOT must be a directory" unless -d $pg_dir; - }; -} - -sub new { - my ($invocant, @rest) = @_; - my $class = ref($invocant) || $invocant; - - my $self = {}; - - if (defined($ce)) { - $self->{webworkDirs} = $ce->{webworkDirs}; - $self->{externalPrograms} = $ce->{externalPrograms}; - $self->{pg_dir} = $ce->{pg_dir}; - $self->{webwork_courses_dir} = $ce->{webwork_courses_dir}; - } else { - # Load from the conf file. - $self->{pg_dir} = $ENV{PG_ROOT}; - - my $defaults_file = "$self->{pg_dir}/conf/pg_defaults.yml"; - $defaults_file = "$self->{pg_dir}/conf/pg_defaults.dist.yml" unless -r $defaults_file; - die "Cannot read the configuration file $defaults_file" unless -r $defaults_file; - - my $options = LoadFile($defaults_file); - $self->{webworkDirs} = $options->{webworkDirs}; - $self->{externalPrograms} = $options->{externalPrograms}; - $self->{webwork_courses_dir} = $ce->{webwork_courses_dir}; - } - - bless $self, $class; - - return $self; -} - -1; diff --git a/lib/PGalias.pm b/lib/PGalias.pm index 8839f7df84..f58bdb3303 100644 --- a/lib/PGalias.pm +++ b/lib/PGalias.pm @@ -82,81 +82,46 @@ sub get_resource { sub initialize { my $self = shift; my $envir = $self->{envir}; - # warn "envir-- ", join(" ", %$envir); - $self->{pgFileName} = $envir->{probFileName}; - $self->{htmlDirectory} = $envir->{htmlDirectory}; - $self->{htmlURL} = $envir->{htmlURL}; - $self->{tempDirectory} = $envir->{tempDirectory}; - $self->{templateDirectory} = $envir->{templateDirectory}; - $self->{tempURL} = $envir->{tempURL}; - $self->{studentLogin} = $envir->{studentLogin}; - $self->{psvn} = $envir->{psvn}; - $self->{setNumber} = $envir->{setNumber}; - $self->{probNum} = $envir->{probNum}; - $self->{displayMode} = $envir->{displayMode}; - $self->{externalGif2EpsPath} = $envir->{externalGif2EpsPath}; - $self->{externalPng2EpsPath} = $envir->{externalPng2EpsPath}; - $self->{externalGif2PngPath} = $envir->{externalGif2PngPath}; - $self->{courseID} = $envir->{courseName}; - $self->{problemSeed} = $envir->{problemSeed}; - $self->{problemUUID} = $envir->{problemUUID} // 0; - - $self->{appletPath} = $self->{envir}->{pgDirectories}->{appletPath}; - # - # Find auxiliary files even when the main file is in tempates/tmpEdit - # - $self->{pgFileName} =~ s!(^|/)tmpEdit/!$1!; - - $self->{ext} = ""; - my $unique_id_seed = join("-", - $self->{studentLogin}, $self->{psvn}, $self->{courseID}, - 'set' . $self->{setNumber}, - 'prob' . $self->{probNum}, - $self->{problemSeed}, $self->{problemUUID},); - -################################## - # Cached vs. uncached uuid's -- or should the uuid be unique to each file/psvn/login, but always the same? - # If every uuid is uniqu then the same file will be linked to multiple times and it will be important - # to use asynchronous garbage cleanup to remove all links that won't be used again - # If one tries to reuse links then one can get duplicates, for example if many files using the same name - # (prob3.pg) appear in a list of library problems. -################################### + $self->{pgFileName} = $envir->{probFileName}; + $self->{htmlDirectory} = $envir->{htmlDirectory}; + $self->{htmlURL} = $envir->{htmlURL}; + $self->{tempDirectory} = $envir->{tempDirectory}; + $self->{templateDirectory} = $envir->{templateDirectory}; + $self->{tempURL} = $envir->{tempURL}; + $self->{psvn} = $envir->{psvn}; + $self->{displayMode} = $envir->{displayMode}; + $self->{problemSeed} = $envir->{problemSeed}; + $self->{problemUUID} = $envir->{problemUUID} // 0; + + # Find auxiliary files even when the main file is in templates/tmpEdit + # FIXME: This shouldn't be done here. Instead the front end should pass in the problem source with the file name. + # The other instance of this in PGloadfiles.pm needs to be removed. + $self->{pgFileName} =~ s!(^|/)tmpEdit/!$1!; -########################## - # create an ID which is unique to the student and context for the problem -########################## - my $unique_id_stub = create_uuid_as_string(UUID_V3, UUID_NS_URL, $unique_id_seed); - $self->{unique_id_stub} = $unique_id_stub; + $self->{ext} = ''; + # Create an ID which is unique for the given psvn, problemSeed, and problemUUID. + # It is the responsibility of the caller to pass in a problemUUID that will provide the required uniqueness. + # That could include a course name, a student login name, etc. + $self->{unique_id_stub} = create_uuid_as_string(UUID_V3, UUID_NS_URL, + join('-', $self->{psvn}, $self->{problemSeed}, $self->{problemUUID})); } sub check_parameters { my $self = shift; - # problem specific data - $self->warning_message("The path to the current problem file template probFileName is not defined.") + # Problem specific data + $self->warning_message('The path to the current problem file template probFileName is not defined.') unless $self->{pgFileName}; - $self->warning_message("The current studentLogin is not defined ") unless $self->{studentLogin}; - $self->warning_message("The current problem set number setNumber is not defined") - if $self->{setNumber} eq ""; # allow for sets equal to 0 - $self->warning_message("The current problem number probNum is not defined") if $self->{probNum} eq ""; - $self->warning_message("The current problem set version number (psvn) is not defined") - unless defined($self->{psvn}); - $self->warning_message("The displayMode is not defined") unless $self->{displayMode}; - -# required macros -# warn "The macro &surePathToTmpFile can't be found" unless defined(&{$self->surePathToTmpFile()} ); -# warn "The macro &convertPath can't be found" unless defined(&{$self->convertPath()}); -# warn "The macro &directoryFromPath can't be found" unless defined(&{$self->directoryFromPath()}); -# warn $self->surePathToTmpFile("foo"); -# warn "The webwork server does not have permission to execute the gif2eps script at ${externalGif2EpsPath}." unless ( -x "${externalGif2EpsPath}" ); -# warn "The webwork server does not have permission to execute the png2eps script at ${externalPng2EpsPath}." unless ( -x "${externalPng2EpsPath}" ); + $self->warning_message('The current problem set version number (psvn) is not defined') + unless defined $self->{psvn}; + $self->warning_message('The displayMode is not defined') unless $self->{displayMode}; # required directory addresses (and URL address) - warn "htmlDirectory is not defined." unless $self->{htmlDirectory}; - warn "htmlURL is not defined." unless $self->{htmlURL}; - warn "tempURL is not defined." unless $self->{tempURL}; + warn 'htmlDirectory is not defined.' unless $self->{htmlDirectory}; + warn 'htmlURL is not defined.' unless $self->{htmlURL}; + warn 'tempURL is not defined.' unless $self->{tempURL}; } sub make_resource_object { @@ -334,17 +299,17 @@ sub alias_for_html { # replace "." with the current pg question directory my $current_pg_directory = $self->directoryFromPath($pgFileName); - $current_pg_directory = $self->{templateDirectory} . "/" . $current_pg_directory; + $current_pg_directory = $self->{templateDirectory} . $current_pg_directory; @aux_files_directories = map { ($_ eq '.') ? $current_pg_directory : $_ } @aux_files_directories; #$self->debug_message("search directories", @aux_files_directories); # Find complete path to the original file my $file_path; if ($aux_file_id =~ /https?:/) { #external link_file - $resource_object->uri($aux_file_id); #no unique id is needed -- external link doc - $resource_object->{copy_link}->{type} = 'external'; - $resource_object->{uri}->{is_accessible} = $self->check_url($resource_object->uri()); - return $resource_object->uri; # external links need no further processing + $resource_object->uri($aux_file_id); #no unique id is needed -- external link doc + $resource_object->{copy_link}->{type} = 'external'; + $resource_object->{uri}{is_accessible} = 1; # Assume a url is accessible. + return $resource_object->uri; # external links need no further processing } elsif ($aux_file_id =~ m|^/|) { $file_path = $aux_file_id; } else { @@ -364,7 +329,7 @@ sub alias_for_html { ############################################## if ($file_path =~ m|^$tempDirectory|) { #case: file is stored in the course temporary directory $resource_uri = $file_path; - $resource_uri =~ s|$tempDirectory|$tempURL/|; + $resource_uri =~ s|$tempDirectory|$tempURL|; $resource_object->uri($resource_uri); #no unique id is needed -- public doc $resource_object->path($file_path); $resource_object->{copy_link}->{type} = 'orig'; @@ -416,7 +381,6 @@ sub alias_for_html { # Return full url to image file (resource_id) ################################################################################ -# $self->debug_message("link created --alias_for_image_html: url is ".$resource_object->uri(). " check =".$self->check_url($resource_object->uri()) ); $resource_object->uri(); # return the uri of the resource -- in this case the URL for the file in the temp directory } @@ -462,18 +426,6 @@ sub alias_for_tex { my $resource_object = $self->get_resource($aux_file_id); #warn ( "\nresource for $aux_file_id is ", ref($resource_object), $resource_object ); -################################################################################ - # Create PDF output directly -- convert .gif to .png format which pdflatex accepts natively -################################################################################ - - unless ($self->{envir}->{texDisposition} eq "pdf") { - $self->warning_message("Support for pure latex output (as opposed to pdflatex output) is not implemented."); - return ""; # blank resource_uri - } - # We're going to create PDF files with our TeX (using pdflatex); so we - # need images in PNG format. - # No longer support for pure latex/DVI construction - ############################################## # Find complete path to the original files ############################################## @@ -496,10 +448,10 @@ sub alias_for_tex { # Find complete path to the original file my $file_path; if ($aux_file_id =~ /https?:/) { # external link_file - $resource_object->uri($aux_file_id); #no unique id is needed -- external link doc - $resource_object->{copy_link}->{type} = 'external'; - $resource_object->{uri}->{is_accessible} = $self->check_url($resource_object->uri()); - return $resource_object->uri; # external links need no further processing + $resource_object->uri($aux_file_id); #no unique id is needed -- external link doc + $resource_object->{copy_link}->{type} = 'external'; + $resource_object->{uri}{is_accessible} = 1; # Assume a url is accessible. + return $resource_object->uri; # external links need no further processing } elsif ($aux_file_id =~ m|^/|) { $file_path = $aux_file_id; } else { @@ -625,9 +577,9 @@ sub create_link_to_tmp_file { $resource_object->{path}->{is_accessible} = (-r $linkPath); $resource_object->uri($resource_uri); - $resource_object->{uri}->{is_accessible} = $self->check_url($resource_object->uri()); - $resource_object->{path}->{is_complete} = 1; - $resource_object->{uri}->{is_complete} = 1; + $resource_object->{uri}{is_accessible} = 1; # Assume a url is accessible. + $resource_object->{path}->{is_complete} = 1; + $resource_object->{uri}->{is_complete} = 1; } else { $self->warning_message( "The macro alias cannot create a link from |$linkPath| to |" . $resource_object->path() . "|
"); @@ -653,7 +605,7 @@ sub convert_file_to_png_for_tex { my %args = @_; my $resource_object = $args{resource}; my $targetDirectory = $args{targetDirectory}; - my $conversion_command = $self->{externalGif2PngPath}; + my $conversion_command = WeBWorK::PG::IO::externalCommand('gif2png'); ################################################################################ # Create path to new .png file # Create new .png file @@ -700,16 +652,6 @@ our ( $macrosPath, # ^variable my $pwd $pwd, - # ^variable my $appletPath - $appletPath, - # ^variable my $server_root_url - $server_root_url, - # ^variable my $templateDirectory - $templateDirectory, - # ^variable my $scriptDirectory - $scriptDirectory, - # ^variable my $externalTTHPath - $externalTTHPath, ); # ^function findMacroFile @@ -741,35 +683,6 @@ sub find_file_in_directories { return; # no file found } -# ^function check_url -# ^uses %envir -sub check_url { - my $self = shift; - my $url = shift; - my $OK_CONSTANT = "200 OK"; - return undef if $url =~ /;/; # make sure we can't get a second command in the url - return undef unless $url =~ /\S/; -#FIXME -- check for other exploits of the system call #FIXME -- ALARM feature so that the response cannot be held up for too long. -#ALARM: /opt/local/bin/lwp-request -d -t 40 -mHEAD "; -# the -t 40 means the call times out after 40 seconds. -# Set this alarm in site.conf -#FIXME doesn't seem to work with relative addresses. -#FIXME Can we get the machine name of the server? - $server_root_url = $self->envir("server_root_url"); - $self->warning_message("check_url: server_root_url is not defined in site.conf") unless $server_root_url; - unless ($url =~ /^http/) { - # $self->debug_message("check_url: augmenting url $url"); - $url = "$server_root_url/$url"; - - } - my $check_url_command = $self->{envir}->{externalCheckUrl}; -# $self->warning_message("check_url_command: $check_url_command -- externalCheckUrl is not properly defined in configuration file") -# unless (-x $check_url_command ); - my $response = `$check_url_command $url`; - # $self->debug_message("check_url: response for url $url is $response"); - return ($response =~ /$OK_CONSTANT/) ? 1 : 0; -} - # This is a stub for deprecated problems that call this method. Some of the Geogebra problems that do so actually work # even though this method fails. sub findAppletCodebase { diff --git a/lib/PGcore.pm b/lib/PGcore.pm index 46c2dc4453..cdbd241d42 100755 --- a/lib/PGcore.pm +++ b/lib/PGcore.pm @@ -126,18 +126,13 @@ sub initialize { #$self->debug_message("PG alias created", $self->{PG_alias} ); $self->{PG_loadMacros} = new PGloadfiles($self->{envir}); $self->{flags} = { - showpartialCorrectAnswers => 1, - showHint => 1, + showPartialCorrectAnswers => 1, hintExists => 0, - showHintLimit => 0, solutionExists => 0, recordSubmittedAnswers => 1, refreshCachedImages => 0, - # ANSWER_ENTRY_ORDER => [], # may not be needed if we ue Tie:IxHash - comment => '', # implement as array? - + comment => '', # implement as array? }; - } #################################################################### @@ -572,15 +567,13 @@ sub PG_restricted_eval { WeBWorK::PG::Translator::PG_restricted_eval(@_); } -# =head2 base64 coding -# -# $str = decode_base64($coded_str); -# $coded_str = encode_base64($str); -# -# # Sometimes a question author needs to code or decode base64 directly -# -# =cut -# +=head2 base64 encoding and decoding + + $str = decode_base64($coded_str); + $coded_str = encode_base64($str); + +=cut + sub decode_base64 ($) { my $self = shift; my $str = shift; @@ -678,10 +671,6 @@ sub DESTROY { # doing nothing about destruction, hope that isn't dangerous } -# sub WARN { -# warn(@_); -# } - # This creates on the fly graphs =head2 insertGraph @@ -764,7 +753,6 @@ sub getUniqueName { includePGtext read_whole_problem_file convertPath - getDirDelim fileFromPath directoryFromPath createDirectory @@ -794,11 +782,6 @@ sub convertPath { WeBWorK::PG::IO::convertPath(@_); } -sub getDirDelim { - my $self = shift; - WeBWorK::PG::IO::getDirDelim(@_); -} - sub fileFromPath { my $self = shift; WeBWorK::PG::IO::fileFromPath(@_); diff --git a/lib/PGloadfiles.pm b/lib/PGloadfiles.pm index c5b2c3257f..14efed150f 100644 --- a/lib/PGloadfiles.pm +++ b/lib/PGloadfiles.pm @@ -86,12 +86,11 @@ sub new { my $envir = shift; #pointer to environment hash warn "PGloadmacros must be called with an environment" unless ref($envir) eq 'HASH'; my $self = { - envir => $envir, - macroFileList => {}, # records macros used in compilation - pgFileName => '', # current pg file being processed - server_root_url => '', # how do we find this? - macrosPath => '', - pwd => '', # current directory -- defined in initialize + envir => $envir, + macroFileList => {}, # records macros used in compilation + pgFileName => '', # current pg file being processed + macrosPath => '', + pwd => '', # current directory -- defined in initialize }; bless $self, $class; $self->initialize; @@ -105,9 +104,12 @@ sub initialize { my $pwd = $self->{envir}->{probFileName}; $pwd =~ s!/[^/]*$!!; $pwd = $templateDirectory . $pwd unless substr($pwd, 0, 1) eq '/'; + + # FIXME: This shouldn't be here. See the note in PGalias.pm in the initialize subroutine. $pwd =~ s!/tmpEdit/!/!; + $self->{pwd} = $pwd; - $self->{macrosPath} = $self->{envir}->{pgDirectories}->{macrosPath}; + $self->{macrosPath} = $self->{envir}{macrosPath}; } @@ -122,7 +124,6 @@ sub PG_macro_file_eval { } # ^function loadMacros -# ^uses time_it # ^uses $debugON # ^uses $externalTTHPath # ^uses findMacroFile @@ -131,7 +132,6 @@ sub loadMacros { my @files = @_; my $fileName; my $macrosPath = $self->{envir}->{macrosPath}; - eval { main::time_it("begin load macros"); }; ############################################################################### # At this point the directories have been defined from %envir and we can define # the directories for this file @@ -170,31 +170,26 @@ sub loadMacros { $self->compile_file($filePath); warn "loadMacros is compiling $filePath" if $debugON; } else { - my $pgDirectory = $self->{envir}->{pgDirectories}->{macros}; - my $templateDirectory = $self->{envir}->{templateDirectory}; + my $pgDirectory = $self->{envir}{pgMacrosDir}; + my $templateDirectory = $self->{envir}{templateDirectory}; my @shortenedPaths = @{$macrosPath}; @shortenedPaths = map { $_ =~ s|^$templateDirectory|[TMPL]/|; $_ } @shortenedPaths; @shortenedPaths = map { $_ =~ s|^$pgDirectory|[PG]/macros/|; $_ } @shortenedPaths; warn "Can't locate macro file |$fileName| via path: |" . join("|,
|", @shortenedPaths) . "|\n"; } - } - $init_subroutine = eval { \&{ 'main::' . $init_subroutine_name } }; + $init_subroutine = eval { \&{ 'main::' . $init_subroutine_name } }; - ############################################################################### - - $macro_file_loaded = defined($init_subroutine) && defined(&$init_subroutine); - warn "PGloadfiles: macro init $init_subroutine_name defined |$init_subroutine| |$macro_file_loaded|" - if $debugON; + $macro_file_loaded = defined($init_subroutine) && defined(&$init_subroutine); + warn "PGloadfiles: macro init $init_subroutine_name defined |$init_subroutine| |$macro_file_loaded|" + if $debugON; - if ($macro_file_loaded) { - warn "PGloadfiles: $macro_file_name loaded, initializing $macro_file_name\n" if $debugON; - &$init_subroutine(); + if ($macro_file_loaded) { + warn "PGloadfiles: $macro_file_name loaded, initializing $macro_file_name\n" if $debugON; + &$init_subroutine(); + } } - #warn "main:: contains
\n $macro_file_name ".join("
\n $macro_file_name ", %main::); } - #warn "files loaded:", join(" ", keys %{ $self->{macroFileList} }); - eval { main::time_it("end load macros"); }; } # ^function findMacroFile @@ -217,6 +212,7 @@ sub findMacroFile { } return 0; # no file found } + # errors in compiling macros is not always being reported. # ^function compile_file # ^uses @__eval__ @@ -227,40 +223,23 @@ sub compile_file { my $filePath = shift; warn "loading $filePath" if $debugON; - local (*MACROFILE); - local ($/); - $/ = undef; # allows us to treat the file as a single line - - open(MACROFILE, "<:raw", $filePath) || die "Cannot open file: $filePath"; - my $string = 'BEGIN {push @__eval__, __FILE__};' . "\n" . ; - utf8::decode($string); # can't yet use :encoding(UTF-8) - #warn "compiling $string"; - my ($result, $error, $fullerror) = $self->PG_macro_file_eval($string); - eval('$main::__files__->{pop @main::__eval__} = $filePath'); #used to keep track of which file is being evaluated. - if ($error) { # the $fullerror report has formatting and is never empty - # this is now handled by PG_errorMessage() in the PG translator - #$fullerror =~ s/\(eval \d+\)/ $filePath\n/; # attempt to insert file name instead of eval number + + local $/ = undef; # allows us to treat the file as a single line + + open(my $MACROFILE, "<:raw", $filePath) || die "Cannot open file: $filePath"; + my $string = <$MACROFILE>; + close $MACROFILE; + utf8::decode($string); # can't yet use :encoding(UTF-8) + + my ($result, $error, $fullerror) = $self->PG_macro_file_eval($string, $filePath); + + if ($error) { + # The $fullerror report has formatting and is never empty when there is an error. + # The die message is handled by PG_errorMessage() in the PG translator. die "Error detected while loading $filePath:\n$fullerror"; } - # local(*MACROFILE); - # local($/); - # $/ = undef; # allows us to treat the file as a single line - # open(MACROFILE, "<$filePath") || die "Cannot open file: $filePath"; - # my $string = 'BEGIN {push @__eval__, __FILE__};' . "\n" . ; - # my ($result,$error,$fullerror) = &PG_restricted_eval($string); - # eval ('$main::__files__->{pop @main::__eval__} = $filePath'); - # if ($error) { # the $fullerror report has formatting and is never empty - # # this is now handled by PG_errorMessage() in the PG translator - # #$fullerror =~ s/\(eval \d+\)/ $filePath\n/; # attempt to insert file name instead of eval number - # die "Error detected while loading $filePath:\n$fullerror"; - # - # } - # - # close(MACROFILE); - $self->{macroFileList}->{$filePath} = 1; - close(MACROFILE); - + $self->{macroFileList}{$filePath} = 1; } =head2 sourceAlias @@ -280,7 +259,6 @@ course's F directory to allow formatted viewing of the problem source. # ^uses $envir{probNum} # ^uses $envir{displayMode} # ^uses $envir{courseName} -# ^uses $envir{sessionKey} sub sourceAlias { my $self = shift; my $path_to_file = shift; @@ -299,9 +277,7 @@ sub sourceAlias { . '&user=' . $user . '&displayPath=' - . $path_to_file - . '&key=' - . $envir->{sessionKey}; + . $path_to_file; $out; } diff --git a/lib/WeBWorK/PG.pm b/lib/WeBWorK/PG.pm new file mode 100644 index 0000000000..d0b65bb9a7 --- /dev/null +++ b/lib/WeBWorK/PG.pm @@ -0,0 +1,622 @@ +################################################################################ +# WeBWorK Online Homework Delivery System +# Copyright © 2000-2022 The WeBWorK Project, https://github.com/openwebwork +# +# This program is free software; you can redistribute it and/or modify it under +# the terms of either: (a) the GNU General Public License as published by the +# Free Software Foundation; either version 2, or (at your option) any later +# version, or (b) the "Artistic License" which comes with this package. +# +# This program 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 either the GNU General Public License or the +# Artistic License for more details. +################################################################################ + +package WeBWorK::PG; + +use strict; +use warnings; +use feature 'signatures'; +no warnings qw(experimental::signatures); + +use WeBWorK::PG::Environment; +use WeBWorK::PG::Translator; +use WeBWorK::PG::RestrictedClosureClass; +use WeBWorK::PG::Constants; + +use constant DISPLAY_MODES => { + # display name # mode name + tex => 'TeX', + plainText => 'HTML', + images => 'HTML_dpng', + MathJax => 'HTML_MathJax', + PTX => 'PTX', +}; + +sub new ($invocant, %options) { + local $SIG{ALRM} = sub ($) { + my $msg = + "Timeout after processing this problem for $WeBWorK::PG::TIMEOUT seconds. " + . "Check for infinite loops in problem source.\n"; + warn $msg; + die $msg; + }; + alarm $WeBWorK::PG::TIMEOUT; + my $pg = eval { $invocant->new_helper(%options) }; + alarm 0; + die $@ if $@; + return $pg; +} + +sub new_helper ($invocant, %options) { + my $class = ref($invocant) || $invocant; + + my $pg_envir = WeBWorK::PG::Environment->new($options{courseName}); + + # Make sure these are defined. + $options{sourceFilePath} //= ''; + $options{templateDirectory} //= ''; + $options{inputs_ref} //= {}; + + # Set up the warning handler. + my $warning_messages = ''; + + local $SIG{__WARN__} = sub ($warning) { $warning_messages .= $warning; return; } + if $pg_envir->{options}{catchWarnings}; + + my $translator = WeBWorK::PG::Translator->new; + + # Modules have already been loaded at compile time for the standalone renderer. + if (!exists $ENV{MOJO_MODE}) { + for (@{ $pg_envir->{modules} }) { + my ($module, @extra_packages) = @$_; + + # The first item is the main package + $translator->evaluate_modules($module); + + # The remaining items are extra packages + $translator->load_extra_packages(@extra_packages); + } + } + + # Prepare an imagegenerator object if "images" mode was selected. + my $image_generator = ($options{displayMode} // '') eq 'images' + ? WeBWorK::PG::ImageGenerator->new( + tempDir => $pg_envir->{directories}{tmp}, + latex => $pg_envir->{externalPrograms}{latex}, + dvipng => $pg_envir->{externalPrograms}{dvipng}, + useCache => 1, + cacheDir => $pg_envir->{directories}{equationCache}, + cacheURL => ($options{use_site_prefix} // '') . $pg_envir->{URLs}{equationCache}, + cacheDB => $pg_envir->{equationCacheDB}, + useMarkers => 1, + dvipng_align => $pg_envir->{displayModeOptions}{images}{dvipng_align}, + dvipng_depth_db => $pg_envir->{displayModeOptions}{images}{dvipng_depth_db}, + ) + : undef; + + $translator->environment(defineProblemEnvironment($pg_envir, \%options, $image_generator)); + + $translator->initialize; + + # PG.pl has already been loaded at compile time for the standalone renderer. + if (!exists $ENV{MOJO_MODE}) { + my $err = $translator->unrestricted_load($pg_envir->{directories}{root} . '/macros/PG.pl'); + warn "Error while loading macros/PG.pl: $err" if $err; + } + + # Set the opcode mask to use default values + $translator->set_mask; + + if (ref $options{r_source}) { + # The source for the problem was given as a reference to a string. + $translator->source_string(${ $options{r_source} }); + } elsif ($options{sourceFilePath}) { + # A file path was given, so read the source from the file. + my $sourceFilePath = + $options{sourceFilePath} =~ /^\// + ? $options{sourceFilePath} + : "$options{templateDirectory}$options{sourceFilePath}"; + + eval { $translator->source_file($sourceFilePath) }; + + if ($@) { + # The problem source file could not be read. + return bless { + translator => $translator, + head_text => '', + post_header_text => '', + body_text => "Unabled to read problem source file:\n$@\n", + answers => {}, + result => {}, + state => {}, + errors => 'Failed to read the problem source file.', + warnings => $warning_messages, + flags => { error_flag => 1 }, + pgcore => $translator->{rh_pgcore}, + }, $class; + } + } + + $translator->rf_safety_filter(sub { return shift, 0; }); + + $translator->translate(); + + # IMPORTANT: The translator environment should not be trusted after the problem code runs. + + my ($result, $state); + if ($options{processAnswers}) { + $translator->process_answers($options{inputs_ref}); + + $translator->rh_problem_state({ + recorded_score => $options{recorded_score} // 0, + num_of_correct_ans => $options{num_of_correct_ans} // 0, + num_of_incorrect_ans => $options{num_of_incorrect_ans} // 0 + }); + + my @answerOrder = + $translator->rh_flags->{ANSWER_ENTRY_ORDER} + ? @{ $translator->rh_flags->{ANSWER_ENTRY_ORDER} } + : keys %{ $translator->rh_evaluated_answers }; + + # Install a grader. Use the one specified in the problem, or fall back to the average problem grader. + my $grader = $translator->rh_flags->{PROBLEM_GRADER_TO_USE} || 'avg_problem_grader'; + $grader = $translator->rf_std_problem_grader if $grader eq 'std_problem_grader'; + $grader = $translator->rf_avg_problem_grader if $grader eq 'avg_problem_grader'; + die "Problem grader $grader is not a CODE reference." unless ref $grader eq 'CODE'; + $translator->rf_problem_grader($grader); + + ($result, $state) = $translator->grade_problem( + answers_submitted => 1, + ANSWER_ENTRY_ORDER => \@answerOrder, + %{ $options{inputs_ref} } + ); + } + + # HTML_dpng uses an ImageGenerator. We have to render the queued equations. + if ($image_generator) { + my $sourceFile = "$options{templateDirectory}$options{sourceFilePath}"; + $image_generator->render( + refresh => $options{refreshMath2img} // 0, + body_text => $translator->r_text, + ); + } + + return bless { + translator => $translator, + head_text => ${ $translator->r_header }, + post_header_text => ${ $translator->r_post_header }, + body_text => ${ $translator->r_text }, + answers => $translator->rh_evaluated_answers, + result => $result, + state => $state, + errors => $translator->errors, + warnings => $warning_messages, + flags => $translator->rh_flags, + pgcore => $translator->{rh_pgcore} + }, $class; +} + +sub free ($pg) { + # If certain MathObjects (e.g. LimitedPolynomials) are left in the PG structure, then freeing them later can cause + # "Can't locate package ..." errors in the log during perl garbage collection. So free them here. + $pg->{pgcore}{OUTPUT_ARRAY} = []; + $pg->{answers} = {}; + undef $pg->{translator}; + undef $pg->{pgcore}{PG_ANSWERS_HASH}{$_} for (keys %{ $pg->{pgcore}{PG_ANSWERS_HASH} }); + return; +} + +sub defineProblemEnvironment ($pg_envir, $options = {}, $image_generator = undef) { + my $now = time; + + # Take the values for the following from the pg environment, and override with any that are defined in the + # corresponding key in the options. + + my $ansEvalDefaults = $pg_envir->{ansEvalDefaults}; + $ansEvalDefaults->{$_} = $options->{ansEvalDefaults}{$_} for keys %{ $options->{ansEvalDefaults} }; + + my $specialPGEnvironmentVars = $pg_envir->{specialPGEnvironmentVars}; + $specialPGEnvironmentVars->{$_} = $options->{specialPGEnvironmentVars}{$_} + for keys %{ $options->{specialPGEnvironmentVars} }; + + return { + # This copies everything from the provided options that are not explicitly dealt with below. + # With this the caller can add any desired key value pairs to the translator environment. + # webwork2 uses this to add formatted dates and other things used for set headers. + %$options, + + # All of the following values are taken from the provided options if defined. Fall back to the pg environment + # value, or just hard coded defaults. + + # Problem information + probFileName => $options->{sourceFilePath} // '', + displayMode => DISPLAY_MODES()->{ $options->{displayMode} || 'MathJax' } // 'HTML_MathJax', + problemSeed => $options->{problemSeed} || 1234, + psvn => $options->{psvn} // 1, + problemUUID => $options->{problemUUID} // 0, + probNum => $options->{probNum} // 1, + showHints => $options->{showHints} // 1, + showSolutions => $options->{showSolutions} // 0, + forceScaffoldsOpen => $options->{forceScaffoldsOpen} // 0, + setOpen => $options->{setOpen} // 1, + pastDue => $options->{pastDue} // 0, + answersAvailable => $options->{answersAvailable} // 0, + isInstructor => $options->{isInstructor} // 0, + + inputs_ref => $options->{inputs_ref}, + + (map { $_ => $ansEvalDefaults->{$_} } keys %$ansEvalDefaults), + + QUIZ_PREFIX => $options->{answerPrefix} // '', + PROBLEM_GRADER_TO_USE => $options->{grader} // $pg_envir->{options}{grader}, + + useMathQuill => $options->{useMathQuill} // $pg_envir->{options}{useMathQuill}, + useMathView => $options->{useMathView} // $pg_envir->{options}{useMathView}, + mathViewLocale => $options->{mathViewLocale} // $pg_envir->{options}{mathViewLocale}, + useWirisEditor => $options->{useWirisEditor} // $pg_envir->{options}{useWirisEditor}, + + # Internationalization + language => $options->{language} // 'en', + language_subroutine => $options->{language_subroutine} // sub (@args) { return $args[0]; }, + + # Directories and URLs + pgMacrosDir => "$pg_envir->{directories}{root}/macros", + macrosPath => $options->{macrosPath} // $pg_envir->{directories}{macrosPath}, + htmlPath => $options->{htmlPath} // $pg_envir->{URLs}{htmlPath}, + imagesPath => $options->{imagesPath} // $pg_envir->{URLs}{imagesPath}, + htmlDirectory => $options->{htmlDirectory} // "$pg_envir->{directories}{html}/", + htmlURL => $options->{htmlURL} // "$pg_envir->{URLs}{html}/", + templateDirectory => $options->{templateDirectory} // '', + tempDirectory => $options->{tempDirectory} // "$pg_envir->{directories}{html_temp}/", + tempURL => $options->{tempURL} // "$pg_envir->{URLs}{tempURL}/", + localHelpURL => $options->{localHelpURL} // "$pg_envir->{URLs}{localHelpURL}/", + + # Other things ... + + imagegen => $image_generator + ? WeBWorK::PG::RestrictedClosureClass->new($image_generator, 'add', 'addToTeXPreamble', 'refresh') + : undef, + + use_site_prefix => $options->{use_site_prefix} // '', + use_opaque_prefix => $options->{use_opaque_prefix} // 0, + + __files__ => $options->{__files__} // { + root => $pg_envir->{directories}{root}, + pg => $pg_envir->{directories}{root}, + tmpl => $pg_envir->{directories}{root} + }, + + (map { $_ => $specialPGEnvironmentVars->{$_} } keys %$specialPGEnvironmentVars), + + (map { $_ => $options->{debuggingOptions}{$_} } keys %{ $options->{debuggingOptions} // {} }), + + # FIXME: These are used by PG, but should not be. + courseName => $options->{courseName} // 'pg_local', + setNumber => $options->{setNumber} // 1, + studentLogin => $options->{studentLogin} // 'pg_local', + studentName => $options->{studentName} // 'pg_local', + studentID => $options->{studentID} // 'pg_local', + }; +} + +1; + +__END__ + +=head1 SYNOPSIS + + $pg = WeBWorK::PG->new( + displayMode => 'MathJax', # (images|MathJax) + showHints => 1, + showSolutions => 0, + processAnswers => 1, + isInstructor => 1, + useMathQuill => 1, + templateDirectory => '/opt/webwork/pg/', + problemSeed => 1234, + inputs_ref => $formFields, + sourceFilePath => + '/opt/webwork/libraries/webwork-open-problem-library/OpenProblemLibrary/Michigan/Chap8Sec4/Q21.pg' + + ); + + $translator = $pg->{translator}; # WeBWorK::PG::Translator + $body = $pg->{body_text}; # text string + $header = $pg->{head_text}; # text string + $post_header_text = $pg->{post_header_text}; # text string + $answerHash = $pg->{answers}; # WeBWorK::PG::AnswerHash + $result = $pg->{result}; # hash reference + $state = $pg->{state}; # hash reference + $errors = $pg->{errors}; # text string + $warnings = $pg->{warnings}; # text string + $flags = $pg->{flags}; # hash reference + $pgcore = $pg->{pgcore} # PGcore + +=head1 DESCRIPTION + +WeBWorK::PG is a module that provides a convenient API for rendering a PG problem. + +=head1 OPTIONS + +The constructor can be passed the following options. One of the r_source or +sourceFilePath options described below must be provided. In addition, any of +the translator environment variables may be passed as options in this argument. +Furthermore, any keys in the passed hash not documented below will be copied +into the translator environment. + +=over + +=item r_source (reference to string) + +The source of the pg problem to render provided as a reference to a string. If +this is given it will be used for the problem source instead of the +sourceFilePath + +=item sourceFilePath (string) + +Location of the pg problem file to render. It must either be provided with an +absoute path, or a path relative to the given templateDirectory. + +=item templateDirectory (string, default: '') + +Either a readable location containing the problem file and all static assets for +the problem, or the empty string. WARNING: If this is the empty string then +any static assets for the problem may not be found. + +=item problemSeed (number, default: 1234) + +Seed to use for the problem. + +=item displayMode (string, default: 'MathJax') + +The PG display mode to use, e.g., 'tex', 'plainText', 'images', 'MathJax', or +'PTX'. + +=item showHints (boolean, default: 1) + +This determines if hints that may be encoded in the problem will be rendered. + +=item showSolutions (boolean, default: 0) + +This determines if solutionas that may be encoded in the problem will be +rendered. + +=item forceScaffoldsOpen (boolean, default: 0) + +If set to 1, then all scaffolds will be allowed to be opened. + +=item setOpen (boolean, default: 1) + +Determines if the set containing the problem is open for the user to work. +(This is only used by problemPanic.pl) + +=item pastDue (boolean, default: 0) + +Determines if the problem is past due. +(This is only used by answerDiscussion.pl, problemPanic.pl, and problemRandomize.pl) + +=item answersAvailable (boolean, default: 0) + +Determines if the problem answers are available. +(This is only used by scaffold.pl) + +=item problemUUID (scalar, default: 0) + +This is used to generate unique identifiers for resources. The caller should +ensure that this is sufficiently unique for the purposes of the system. +Generally that means it should be unique for each course, user, set, and problem +number. + +=item psvn (number, default: 1) + +Problem set version number. This is also incorporated into the unique +identifiers used for resources. + +=item probNum (number, default: 1, deprecated) + +Problem number. This will eventually be removed from pg. + +=item refreshMath2img (boolean, default: 0) + +If 1, force images created by math2img (in "images" mode) to be recreated. + +=item processAnswers (boolean, default: 0) + +If 1, call answer evaluators and graders. + +=item isInstructor (boolean, default: 0) + +Determines if the user is an instructor (certain restrictions are removed for +these users). + +=item inputs_ref (hash, default: {}) + +Hash containing all input values in the form containing the problem. +Most importantly this contains answers. + +=item ansEvalDefaults (hash, default: taken from WeBWorK::PG::Environment) + +This may contain the following keys (example values are shown) + + functAbsTolDefault: 0.001 + functLLimitDefault: 0.0000001 + functMaxConstantOfIntegration: 1E8 + functNumOfPoints: 3 + functRelPercentTolDefault: 0.1 + functULimitDefault: 0.9999999 + functVarDefault: x + functZeroLevelDefault: 1E-14 + functZeroLevelTolDefault: 1E-12 + numAbsTolDefault: 0.001 + numFormatDefault: '' + numRelPercentTolDefault: 0.1 + numZeroLevelDefault: 1E-14 + numZeroLevelTolDefault: 1E-12 + useBaseTenLog: 0 + defaultDisplayMatrixStyle: '[s]' # left delimiter, middle line delimiters, right delimiter + +=item answerPrefix (string, default: '') + +A prefix to prepend to all answer labels. Note that other prefixes may be +prepended in front of this one, so it is not safe to assume that it is at the +beginning of all answer labels. For example, the parserMultiAnswer.pl macro +does this. Also note that in the actual PGcore environment this is QUIZ_PREFIX. + +=item grader (string or CODE, default taken from WeBWorK::PG::Environment) + +The default grader to use. This can be overridden by the problem. + +=item useMathQuill, useMathView, useWirisEditor + (boolean, defaults taken from WeBWorK::PG::Environment) + +Determines which entry assist method to use. If useMathQuill is 1, then +MathQuill will be used. Otherwise, if useMathView is 1, then MathView will be +used. Otherwise, if useWirisEditor is 1, then Wiris will be used. If all are +0, then basic html inputs will be used. + +=item language (string, default: 'en') + +The language for the problem. + +=item language_subroutine (CODE, default: sub (@args) { return $args[0]; }) + +Language subroutine that will be used for translations (the maketext method). + +=item macrosPath (array, default taken from WeBWorK::PG::Environment) + +An array of paths to search for macros that may be loaded by the problem. + +=item htmlPath (array, default taken from WeBWorK::PG::Environment) + +Paths to search for auxiliary html files. Note that this array may contain the +special value of '.' which means the directory the problem file is contained in. + +=item imagesPath (array, default taken from WeBWorK::PG::Environment) + +Paths to search for auxiliarly image files. Note that this array may contain the +special value of '.' which means the directory the problem file is contained in. + +=item htmlDirectory (string, default taken from WeBWorK::PG::Environment) + +Html directory that may contain additional static resources that may be used in +problems. Usually the course's html directory. + +=item htmlURL (string, default taken from WeBWorK::PG::Environment) + +Public html address of the htmlDirectory above. + +=item tempDirectory (string, default taken from WeBWorK::PG::Environment) + +Location to place generated resources. This directory must be writable. + +=item tempURL (string, default taken from WeBWorK::PG::Environment) + +Public html address of the tempDirectory above. + +=item localHelpURL (string, default taken from WeBWorK::PG::Environment) + +Public html address for the PG help files. + +=item use_site_prefix (string, default: '') + +Site prefix prepended to image and video url's inserted into problems by the +PGbasicmacros.pl methods "image" and "video". + +=item use_opaque_prefix (boolean, default: 0) + +If set to 1, then "%%IDPREFIX%%" will be prepended to answer labels. + +=item __files__ (hash default: default taken from WeBWorK::PG::Environment) + +A hash that should contain key value pairs for the keys 'root', 'pg', and +'tmpl'. These are used to shorten filenames in error messages. + +=item specialPGEnvironmentVars (hash, default taken from WeBWorK::PG::Environment) + +A hash that can contain any of the keys described int conf/pg_config.dist.yml. + +=item debuggingOptions (hash, default: {}) + +A hash that may contain key value pairs for the keys show_resource_info, +view_problem_debugging_info, show_pg_info, show_answer_hash_info, +show_answer_group_info. The keys enable the things describe in the key name. + +=item courseName (string, default: 'pg_local', deprecated) + +=item setNumber (number, default: 1, deprecated) + +=item studentLogin (string, default: 'pg_local', deprecated) + +=item studentName (string, default: 'pg_local', deprecated) + +=item studentID (string, default: 'pg_local', deprecated) + +These options are still used in some places in PG (mostly by macros that will +eventually be deprecated and removed), but eventually that will all be fixed and +these will no longer be needed. Note that webwork2 still needs to pass the +courseName so the relevant course values (course html directories and urls) can +be optained from the WeBWorK::CourseEnvironment. + +=back + +=head1 RETURN VALUE + +The C method returns a blessed hash reference containing the following +fields. More information can be found in the documentation for +WeBWorK::PG::Translator. + +=over + +=item translator + +The WeBWorK::PG::Translator object used to render the problem. + +=item head_text + +HTML code to be injected into the EheadE tag of the web page containing +the problem. + +=item post_header_text + +HTML code to be injected into the EbodyE tag before the form containing +the problem. + +=item body_text + +HTML code to be inserted into the EbodyE tag of the web page to show the +problem. + +=item answers + +An C object containing submitted answers, and results of answer +evaluation. + +=item result + +A hash containing the results of grading the problem. + +=item state + +A hash containing the problem state. + +=item errors + +A string containing any errors encountered while rendering the problem. + +=item warnings + +A string containing any warnings encountered while rendering the problem. + +=item flags + +A hash containing PG_flags (see the Translator docs). + +=item pgcore + +The PGcore object for the problem. + +=back + +=cut diff --git a/lib/WeBWorK/PG/Constants.pm b/lib/WeBWorK/PG/Constants.pm new file mode 100644 index 0000000000..a7a64cdf3a --- /dev/null +++ b/lib/WeBWorK/PG/Constants.pm @@ -0,0 +1,69 @@ +################################################################################ +# WeBWorK Online Homework Delivery System +# Copyright © 2000-2022 The WeBWorK Project, https://github.com/openwebwork +# +# This program is free software; you can redistribute it and/or modify it under +# the terms of either: (a) the GNU General Public License as published by the +# Free Software Foundation; either version 2, or (at your option) any later +# version, or (b) the "Artistic License" which comes with this package. +# +# This program 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 either the GNU General Public License or the +# Artistic License for more details. +################################################################################ + +package WeBWorK::PG::Constants; + +=head1 NAME + +WeBWorK::PG::Constants - provide constant values used by PG. + +=cut + +use strict; +use warnings; + +# ImageGenerator + +# Arguments to pass to dvipng. This is dependant on the version of dvipng. +# +# For dvipng versions 0.x +# $ImageGenerator::DvipngArgs = "-x4000.5 -bgTransparent -Q6 -mode toshiba -D180"; +# For dvipng versions 1.0 to 1.5 +# $ImageGenerator::DvipngArgs = "-bgTransparent -D120 -q -depth"; +# +# For dvipng versions 1.6 (and probably above) +# $ImageGenerator::DvipngArgs = "-bgtransparent -D120 -q -depth"; +# Note: In 1.6 and later, bgTransparent gives alpha-channel transparency while +# bgtransparent gives single-bit transparency. If you use alpha-channel transparency, +# the images will not be viewable with MSIE. bgtransparent works for version 1.5, +# but does not give transparent backgrounds. It does not work for version 1.2. It has not +# been tested with other versions. +$WeBWorK::PG::ImageGenerator::DvipngArgs = "-bgTransparent -D120 -q -depth"; + +# If true, don't delete temporary files +$WeBWorK::PG::ImageGenerator::PreserveTempFiles = 0; + +# TeX to prepend to equations to be processed. +$WeBWorK::PG::ImageGenerator::TexPreamble = <<'EOF'; +\documentclass[12pt]{article} +\nonstopmode +\usepackage{amsmath,amsfonts,amssymb} +\def\gt{>} +\def\lt{<} +\usepackage[active,textmath,displaymath]{preview} +\begin{document} +EOF + +# TeX to append to equations to be processed. +$WeBWorK::PG::ImageGenerator::TexPostamble = <<'EOF'; +\end{document} +EOF + +# WeBWorK::PG +# The maximum amount of time (in seconds) to work on a single problem. +# At the end of this time a timeout message is sent to the browser. +$WeBWorK::PG::TIMEOUT = 60; + +1; diff --git a/lib/WeBWorK/PG/Environment.pm b/lib/WeBWorK/PG/Environment.pm new file mode 100644 index 0000000000..a1f99a1353 --- /dev/null +++ b/lib/WeBWorK/PG/Environment.pm @@ -0,0 +1,154 @@ +################################################################################ +# WeBWorK Online Homework Delivery System +# Copyright © 2000-2022 The WeBWorK Project, https://github.com/openwebwork +# +# This program is free software; you can redistribute it and/or modify it under +# the terms of either: (a) the GNU General Public License as published by the +# Free Software Foundation; either version 2, or (at your option) any later +# version, or (b) the "Artistic License" which comes with this package. +# +# This program 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 either the GNU General Public License or the +# Artistic License for more details. +################################################################################ + +package WeBWorK::PG::Environment; + +use strict; +use warnings; +use feature 'signatures'; +no warnings qw(experimental::signatures); + +=pod + +=head1 WeBWorK::PG::Environment + +This is a substitute for the CourseEnvironment module on the webwork2 side. It +loads configuration options needed for PG. This is used in WeBWorK::PG and +WeBWorK::PG::IO. + +The configuration is initially loaded from +$ENV{PG_ROOT}/conf/pg_config.dist.yml. If it is desired to change the default +values, then copy the $ENV{PG_ROOT}/conf/pg_config.dist.yml to +$ENV{PG_ROOT}/conf/pg_config.yml, and make changes in the copy. The default +values will be overriden with the changed values in the copy. Note that invalid +values added to the copy will cause a warning to be issued. + +If the the WeBWorK::CourseEnvironment module is found, then the configuration +options are overridden with the values from a webwork2 course environment +instance. This is provided to maintain compatibility with webwork2, and should +be removed at the end of life for webwork2. + +Optionally a course name may be provided to use the webwork2 course environment +for that course. + +Note that the only values used in WeBWorK::PG::IO are +$pg_envir->{directories}{permitted_read_dir}, $pg_envir->{directories}{tmp}, and +the programs in the $pg_envir->{externalPrograms} hash. + +Also note that for the standalone renderer this is used in +WeBWorK::PG::Translator, and there the values of $pg_envir->{directories}{root} +and $pg_envir->{modules} are used. + +=cut + +use YAML::XS qw/LoadFile/; + +sub new ($invocant, $courseName = '___') { + my $class = ref $invocant || $invocant; + + my $pg_root; + my $ce; + + eval { + require WeBWorK::CourseEnvironment; + $ce = WeBWorK::CourseEnvironment->new({ webwork_dir => $ENV{WEBWORK_ROOT}, courseName => $courseName }); + $pg_root = $ce->{pg_root}; + } or do { + $pg_root = $ENV{PG_ROOT}; + die 'The pg directory must be defined in PG_ROOT.' unless -d $pg_root; + }; + + # First load the pg config dist file (used for default values). + my $defaults_file = "$pg_root/conf/pg_config.dist.yml"; + die "Cannot read the pg defaults file $defaults_file" unless -r $defaults_file; + + my $pg_envir = LoadFile($defaults_file); + + # Now Load the pg config file if it exists. + my $config_file = "$pg_root/conf/pg_config.yml"; + $pg_envir = deepCopy($pg_envir, LoadFile($config_file)) if -r $config_file; + + # Override pg settings and things needed by WeBWorK::PG::IO with settings from the course environment. Pick and + # choose the important values from the webwork2 course environment. Some values in the PG configuration are not + # overriden. These are the values that are used in the WeBWorK::PG and WeBWorK::PG::IO. Note that in WeBWorK::PG + # most values for the translator environment are taken from the options passed in, and the values in the pg + # environment are used for the default values. + if (defined $ce) { + deepCopy($pg_envir, $ce->{pg}); + + $pg_envir->{directories}{OPL} = $ce->{problemLibrary}{root}; + $pg_envir->{directories}{Contrib} = $ce->{contribLibrary}{root}; + $pg_envir->{directories}{tmp} = $ce->{webworkDirs}{tmp}; + $pg_envir->{directories}{permitted_read_dir} = $ce->{webwork_courses_dir}; + $pg_envir->{directories}{equationCache} = $ce->{webworkDirs}{equationCache}; + $pg_envir->{externalPrograms} = $ce->{externalPrograms}; + $pg_envir->{URLs}{equationCache} = $ce->{webworkURLs}{equationCache}; + $pg_envir->{equationCacheDB} = $ce->{webworkFiles}{equationCacheDB}; + } + + # Note that placeholders used in $pg_envir->{URLs}{html}, $pg_envir->{directories}{OPL}, and + # $pg_envir->{directories}{Contrib} are set on the first iteration, and those carry over to anywhere those + # placeholders are are used in other settings on the second iteration. + for (1 .. 2) { + $pg_envir = replacePlaceholders( + $pg_envir, + { + pg_root => $pg_root, + render_root => $ENV{RENDER_ROOT} // $pg_root, + pg_root_url => $ENV{baseURL} // $pg_envir->{URLs}{html}, + OPL_dir => $pg_envir->{directories}{OPL}, + Contrib_dir => $pg_envir->{directories}{Contrib} + } + ); + } + + return bless $pg_envir, $class; +} + +# Recursively copy the source hash into the target hash, overriding key values in the target. If a value in the source +# has a ref that does not match that of the corresponding target value, then it is skipped and a warning is issued. +# Anything not in the target is copied in. +sub deepCopy ($target, $source) { + if (ref $target eq 'HASH' && ref $source eq 'HASH') { + for (keys %$source) { + $target->{$_} = deepCopy($target->{$_}, $source->{$_}); + } + } elsif (ref $target eq ref $source || !defined $target) { + $target = $source; + } else { + warn 'invalid source field detected -- skipping'; + } + + return $target; +} + +# Recursively deplace variable placeholders in the $input object. +sub replacePlaceholders ($input, $values) { + if (ref $input eq 'HASH') { + for (keys %$input) { + $input->{$_} = replacePlaceholders($input->{$_}, $values); + } + } elsif (ref $input eq 'ARRAY') { + for (0 .. $#$input) { + $input->[$_] = replacePlaceholders($input->[$_], $values); + } + } else { + $input =~ s/\$(\w+)/defined $values->{$1} ? $values->{$1} : ''/gex; + } + + return $input; +} + +1; diff --git a/lib/WeBWorK/EquationCache.pm b/lib/WeBWorK/PG/EquationCache.pm similarity index 84% rename from lib/WeBWorK/EquationCache.pm rename to lib/WeBWorK/PG/EquationCache.pm index 1ec664b775..36ca1f480c 100644 --- a/lib/WeBWorK/EquationCache.pm +++ b/lib/WeBWorK/PG/EquationCache.pm @@ -13,15 +13,15 @@ # Artistic License for more details. ################################################################################ -package WeBWorK::EquationCache; +package WeBWorK::PG::EquationCache; =head1 NAME -WeBWorK::EquationCache - create and cache images of TeX equations. +WeBWorK::PG::EquationCache - create and cache images of TeX equations. =head1 SYNPOSIS - my $cache = WeBWorK::EquationCache->new(cacheDB => "/path/to/equationcache.db"); + my $cache = WeBWorK::PG::EquationCache->new(cacheDB => "/path/to/equationcache.db"); my $imageName = $cache->lookup('\[3x^2\]'); =head1 DESCRIPTION @@ -46,9 +46,11 @@ extending to the end of the line is also ignored. use strict; use warnings; + use Digest::MD5 qw(md5_hex); -use Encode qw(encode_utf8 ); -use Fcntl qw(:DEFAULT :flock); +use Encode qw(encode_utf8 ); +use Fcntl qw(:DEFAULT :flock); + BEGIN { my @_junk = (O_RDWR, O_CREAT, LOCK_EX) } # get rid of "subroutine redefined" warnings =head1 METHODS @@ -86,21 +88,16 @@ is returned. If necessary, the string is added to the database. sub lookup { my ($self, $tex) = @_; - # There are several ways to normalize TeX strings. Use only - # one of them. - # Option 1 (default): remove leading and trailing whitespace, and - # compress all other whitespace to single spaces. - $tex =~ s/^\s+//g; - $tex =~ s/\s+$//g; + # Remove leading and trailing whitespace, and compress all other whitespace to single spaces. + $tex =~ s/^\s+|\s+$//g; $tex =~ s/\s+/ /g; - # Option 2 (the old default): remove all whitespace - # $tex =~ s/\s+//g; my $md5 = md5_hex(encode_utf8($tex)); my $db = $self->{cacheDB}; - unless ($db) { return ($md5 . "1"); } + return $md5 unless $db; + sysopen(DB, $db, O_RDWR | O_CREAT) or die "failed to create/open cacheDB $db: $!"; flock(DB, LOCK_EX) diff --git a/lib/WeBWorK/PG/IO.pm b/lib/WeBWorK/PG/IO.pm index cf00b1e324..e5254f1cf5 100644 --- a/lib/WeBWorK/PG/IO.pm +++ b/lib/WeBWorK/PG/IO.pm @@ -14,94 +14,54 @@ ################################################################################ package WeBWorK::PG::IO; -use warnings qw(FATAL utf8); -use parent qw(Exporter); -use Encode qw( encode decode); -use JSON qw(decode_json); +use parent qw(Exporter); + +use strict; +use warnings; + +use Encode qw( encode decode); +use JSON qw(decode_json); use File::Spec::Functions qw(canonpath); -use PGUtil qw(not_null); -# use WeBWorK::Utils qw(path_is_subdir); -# use WeBWorK::CourseEnvironment; -use PGEnvironment; +use PGUtil qw(not_null); +use WeBWorK::PG::Environment; use utf8; #binmode(STDOUT,":encoding(UTF-8)"); #binmode(STDIN,":encoding(UTF-8)"); #binmode(INPUT,":encoding(UTF-8)"); -my $pg_envir = new PGEnvironment(); +my $pg_envir = WeBWorK::PG::Environment->new; =head1 NAME -WeBWorK::PG::IO - Private functions used by WeBWorK::PG::Translator for file IO. +WeBWorK::PG::IO - Functions used by WeBWorK::PG::Translator for file IO. =cut -use strict; -use warnings; - -BEGIN { - our @EXPORT = qw( - includePGtext - read_whole_problem_file - read_whole_file - convertPath - getDirDelim - fileFromPath - directoryFromPath - createFile - createDirectory - path_is_course_subdir - ); - - our @SHARED_FUNCTIONS = qw( - includePGtext - read_whole_problem_file - read_whole_file - convertPath - fileFromPath - directoryFromPath - createDirectory - ); - - our %SHARE = map { $_ => __PACKAGE__ } @SHARED_FUNCTIONS; - my $ww_version = "2.x"; # hack -- only WW2 versions are supported. - if (defined $ww_version) { - my $mod; - for ($ww_version) { - /^1\./ and $mod = "WeBWorK::PG::IO::WW1"; - /^2\./ and $mod = "WeBWorK::PG::IO::WW2"; - /^Daemon\s*2\./ and $mod = "WeBWorK::PG::IO::Daemon2"; - } - - eval "package Main; require $mod; import $mod"; # this is runtime_use - die $@ if $@; - } else { - warn "\$main::VERSION not defined -- not loading version-specific IO functions"; - } -} +our @EXPORT = qw( + includePGtext + read_whole_problem_file + read_whole_file + convertPath + fileFromPath + directoryFromPath + createDirectory +); =head1 SYNOPSIS - BEGIN { $main::VERSION = "2.0" } use WeBWorK::PG::IO; my %functions_to_share = %WeBWorK::PG::IO::SHARE; =head1 DESCRIPTION This module defines several functions to be shared with a safe compartment by -the PG translator. It also loads a version-specific module (if found) based on -the value of the C<$main::VERSION> variable. - -This module also maintains a hash C<%WeBWorK::PG::IO::SHARE>. The keys of this -hash are the names of functions, and the values are the name of the package that -contains the function. +the PG translator. All exported methods are shared. =head1 FUNCTIONS =over -=item includePGtext($string_ref, $envir_ref) - +=item includePGtext($string_ref) This is used in processing some of the sample CAPA files and in creating aliases to redirect calls to duplicate problems so that @@ -116,9 +76,7 @@ sub includePGtext { if (ref($evalString) eq 'SCALAR') { $evalString = $$evalString; } - # $evalString =~ s/\nBEGIN_TEXT/\nTEXT\(EV3\(<<'END_TEXT'\)\);/g; - # $evalString =~ s/\\/\\\\/g; # \ can't be used for escapes because of TeX conflict - # $evalString =~ s/~~/\\/g; # use ~~ as escape instead, use # for comments + no strict; $evalString = eval(q! &{$main::PREPROCESS_CODE}($evalString) !); $evalString = $evalString || ''; @@ -143,8 +101,7 @@ contents of the file. sub read_whole_problem_file { my $filePath = shift; - $filePath =~ s/^\s*//; # get rid of initial spaces - $filePath =~ s/\s*$//; # get rid of final spaces + $filePath =~ s/^\s*|\s$//g; # get rid of leading and trailing spaces $filePath = "$filePath.pg" unless $filePath =~ /\.pg$/; read_whole_file($filePath); } @@ -154,7 +111,7 @@ sub read_whole_file { warn "Can't read file $filePath
" unless -r $filePath; return "" unless -r $filePath; die "File path $filePath is unsafe." - unless path_is_course_subdir($filePath); + unless path_is_readable_subdir($filePath); local (*INPUT); open(INPUT, "<:raw", $filePath) || die "$0: read_whole_file subroutine:
Can't read file $filePath"; @@ -186,37 +143,29 @@ sub convertPath { return wantarray ? @_ : shift; } -sub getDirDelim { - return ("/"); -} - =item fileFromPath($path) -Uses C<&getDirDelim> to determine the path delimiter. Returns the last segment -of the path (i.e. the text after the last delimiter). +Returns the last segment of the path (i.e. the text after the last forward slash). =cut sub fileFromPath { - my $path = shift; - my $delim = &getDirDelim(); + my $path = shift; $path = convertPath($path); - $path =~ m|([^$delim]+)$|; + $path =~ m|([^/]+)$|; $1; } =item directoryFromPath($path) -Uses C<&getDirDelim> to determine the path delimiter. Returns the initial -segments of the of the path (i.e. the text up to the last delimiter). +Returns the initial segments of the of the path (i.e. the text up to the last forward slash). =cut sub directoryFromPath { - my $path = shift; - my $delim = &getDirDelim(); + my $path = shift; $path = convertPath($path); - $path =~ s|[^$delim]*$||; + $path =~ s|[^/]*$||; $path; } @@ -229,7 +178,7 @@ Creates a file with the given name, permission bits, and group ID. sub createFile { my ($fileName, $permission, $numgid) = @_; - die 'Path is unsafe' unless path_is_course_subdir($fileName); + die 'Path is unsafe' unless path_is_readable_subdir($fileName); open(TEMPCREATEFILE, ">:encoding(UTF-8)", $fileName) or die "Can't open $fileName: $!"; @@ -299,18 +248,18 @@ sub path_is_subdir { return 1; } -=item path_is_course_subdir($path) +=item path_is_readable_subdir($path) -Checks to see if the given path is a sub directory of the courses directory +Checks to see if the given path is a sub directory of the directory the caller says we are allowed to read from. =cut -sub path_is_course_subdir { - return path_is_subdir(shift, $pg_envir->{webwork_courses_dir}, 1); +sub path_is_readable_subdir { + return path_is_subdir(shift, $pg_envir->{directories}{permitted_read_dir}, 1); } -sub ww_tmp_dir { - return $pg_envir->{webworkDirs}{tmp}; +sub pg_tmp_dir { + return $pg_envir->{directories}{tmp}; } =item curlCommand diff --git a/lib/WeBWorK/PG/IO/Daemon2.pm b/lib/WeBWorK/PG/IO/Daemon2.pm deleted file mode 100644 index 7afd5e8939..0000000000 --- a/lib/WeBWorK/PG/IO/Daemon2.pm +++ /dev/null @@ -1,34 +0,0 @@ -################################################################################ -# WeBWorK Online Homework Delivery System -# Copyright © 2000-2022 The WeBWorK Project, https://github.com/openwebwork -# -# This program is free software; you can redistribute it and/or modify it under -# the terms of either: (a) the GNU General Public License as published by the -# Free Software Foundation; either version 2, or (at your option) any later -# version, or (b) the "Artistic License" which comes with this package. -# -# This program 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 either the GNU General Public License or the -# Artistic License for more details. -################################################################################ - -package WeBWorK::PG::IO::Daemon2; - -=head1 NAME - -WeBWorK::PG::IO::Daemon2 - Private functions used by WeBWorK::PG::Translator -for file IO under the render Daemon for WeBWorK 2.0. - -=cut - -use strict; -use warnings; - -=head1 FUNCTIONS - -No functions. See C. - -=cut - -1; diff --git a/lib/WeBWorK/PG/IO/WW1.pm b/lib/WeBWorK/PG/IO/WW1.pm deleted file mode 100644 index 6041e9e5b0..0000000000 --- a/lib/WeBWorK/PG/IO/WW1.pm +++ /dev/null @@ -1,127 +0,0 @@ -################################################################################ -# WeBWorK Online Homework Delivery System -# Copyright © 2000-2022 The WeBWorK Project, https://github.com/openwebwork -# -# This program is free software; you can redistribute it and/or modify it under -# the terms of either: (a) the GNU General Public License as published by the -# Free Software Foundation; either version 2, or (at your option) any later -# version, or (b) the "Artistic License" which comes with this package. -# -# This program 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 either the GNU General Public License or the -# Artistic License for more details. -################################################################################ - -package WeBWorK::PG::IO::WW1; -use base qw(Exporter); - -=head1 NAME - -WeBWorK::PG::IO::WW1 - Private functions used by WeBWorK::PG::Translator for -file IO under WeBWorK 1.x. - -=cut - -use strict; -use warnings; -use Net::SMTP; - -BEGIN { - our @EXPORT = qw( - send_mail_to - surePathToTmpFile - ); - - $WeBWorK::PG::IO::SHARE{$_} = __PACKAGE__ foreach @EXPORT; -} - -=head1 FUNCTIONS - -=over - -=item send_mail_to($user_address,'subject'=>$subject,'body'=>$body) - -Returns true if the address is ok, otherwise a fatal error is signaled using -die. - -Sends $body to the address specified by $user_address provided that the address -appears in C<@{$Global::PG_environment{'ALLOW_MAIL_TO'}}>. - -This subroutine is likely to be fragile and to require tweaking when installed -in a new environment. It uses the C module. - -=cut - -sub send_mail_to { - my $user_address = shift; # user must be an instructor - my %options = @_; - - my $subject = ''; - $subject = $options{'subject'} if defined($options{'subject'}); - - my $msg_body = ''; - $msg_body = $options{'body'} if defined($options{'body'}); - - my @mail_to_allowed_list = (); - @mail_to_allowed_list = @{ $options{'ALLOW_MAIL_TO'} } if defined($options{'ALLOW_MAIL_TO'}); - my $out; - - # check whether user is an instructor - my $mailing_allowed_flag = 0; - - while (@mail_to_allowed_list) { - if ($user_address eq shift @mail_to_allowed_list) { - $mailing_allowed_flag = 1; - last; - } - } - - my $REMOTE_HOST = (defined($ENV{'REMOTE_HOST'})) ? $ENV{'REMOTE_HOST'} : 'unknown host'; - my $REMOTE_ADDR = (defined($ENV{'REMOTE_ADDR'})) ? $ENV{'REMOTE_ADDR'} : 'unknown address'; - - if ($mailing_allowed_flag) { - ## mail header text: - my $email_msg = - "To: $user_address\n" - . "X-Remote-Host: $REMOTE_HOST($REMOTE_ADDR)\n" - . "Subject: $subject\n\n" - . $msg_body; - my $smtp = Net::SMTP->new($Global::smtpServer, Timeout => 10) - or warn "Couldn't contact SMTP server."; - $smtp->mail($Global::webmaster); - - if ($smtp->recipient($user_address)) { # this one's okay, keep going - $smtp->data($email_msg) - or warn("Unknown problem sending message data to SMTP server."); - } else { # we have a problem a problem with this address - $smtp->reset; - warn "SMTP server doesn't like this address: <$user_address>."; - } - $smtp->quit; - } else { - die "There has been an error in creating this problem.\n" - . "Please notify your instructor.\n\n" - . "Mail is not permitted to address $user_address.\n" - . "Permitted addresses are specified in the courseWeBWorK.ph file."; - $out = 0; - } - - return $out; -} - -=item surePathToTmpFile($path) - -Calls C<&main::surePathToTmpFile>. - -=cut - -sub surePathToTmpFile { - return main::surePathToTmpFile(); -} - -=back - -=cut - -1; diff --git a/lib/WeBWorK/PG/IO/WW2.pm b/lib/WeBWorK/PG/IO/WW2.pm deleted file mode 100644 index 223d950c97..0000000000 --- a/lib/WeBWorK/PG/IO/WW2.pm +++ /dev/null @@ -1,34 +0,0 @@ -################################################################################ -# WeBWorK Online Homework Delivery System -# Copyright © 2000-2022 The WeBWorK Project, https://github.com/openwebwork -# -# This program is free software; you can redistribute it and/or modify it under -# the terms of either: (a) the GNU General Public License as published by the -# Free Software Foundation; either version 2, or (at your option) any later -# version, or (b) the "Artistic License" which comes with this package. -# -# This program 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 either the GNU General Public License or the -# Artistic License for more details. -################################################################################ - -package WeBWorK::PG::IO::WW2; - -=head1 NAME - -WeBWorK::PG::IO::WW2 - Private functions used by WeBWorK::PG::Translator -for file IO under WeBWorK 2.0. - -=cut - -use strict; -use warnings; - -=head1 FUNCTIONS - -No functions. See C. - -=cut - -1; diff --git a/lib/WeBWorK/PG/ImageGenerator.pm b/lib/WeBWorK/PG/ImageGenerator.pm index 93abb71c0d..ce9a69fc6c 100644 --- a/lib/WeBWorK/PG/ImageGenerator.pm +++ b/lib/WeBWorK/PG/ImageGenerator.pm @@ -22,44 +22,43 @@ LaTeX, and then to process them all at once. =head1 SYNPOSIS -FIXME: add this + my $image_generator = WeBWorK::PG::ImageGenerator->new( + tempDir => $pg_envir->{directories}{tmp}, + latex => $pg_envir->{externalPrograms}{latex}, + dvipng => $pg_envir->{externalPrograms}{dvipng}, + useCache => 1, + cacheDir => $pg_envir->{directories}{equationCache}, + cacheURL => $pg_envir->{URLs}{equationCache}, + cacheDB => $pg_envir->{equationCacheDB}, + useMarkers => 0, + dvipng_align => $pg_envir->{displayModeOptions}{images}{dvipng_align}, + dvipng_depth_db => $pg_envir->{displayModeOptions}{images}{dvipng_depth_db}, + ); =cut -# Note, this now has the ability to communicate with mysql for storing depths of -# images for alignments. If you want to provide another way of storing the depths, -# make up another "magic" alignment name, look for explicit mentions of mysql here -# and add statements for the new special alignment name. Most of the action is -# in the function update_depth_cache near the end of this file. Also look for the -# place where PG creates a new ImageGenerator object, and possibly adjust there as -# well. - use strict; use warnings; +use feature 'signatures'; +no warnings qw(experimental::signatures); + use DBI; use PGcore; -use WeBWorK::Constants; -use WeBWorK::EquationCache; +use WeBWorK::PG::Constants; +use WeBWorK::PG::EquationCache; -# can't use WeBWorK::Utils from here, so we define the needed functions here -#use WeBWorK::Utils qw/readFile readDirectory makeTempDirectory removeTempDirectory/; - -use constant MKDIR_ATTEMPTS => 10; use File::Path qw(rmtree); -sub readFile($) { - my $filename = shift; +sub readFile ($filename) { my $contents = ''; - local (*FILEH); - open FILEH, "<$filename" or die "Unable to read $filename"; - local ($/) = undef; - $contents = ; - close(FILEH); - return ($contents); + open(my $fh, '<', $filename) or die "Unable to read $filename"; + local $/ = undef; + $contents = <$fh>; + close $fh; + return $contents; } -sub readDirectory($) { - my $dirName = shift; +sub readDirectory ($dirName) { opendir my $dh, $dirName or die "Failed to read directory $dirName: $!"; my @result = readdir $dh; @@ -67,14 +66,12 @@ sub readDirectory($) { return @result; } -sub makeTempDirectory($$) { - my ($parent, $basename) = @_; +sub makeTempDirectory ($parent, $basename) { # Loop until we're able to create a directory, or it fails for some # reason other than there already being something there. - my $triesRemaining = MKDIR_ATTEMPTS; my ($fullPath, $success); do { - my $suffix = join "", map { ('A' .. 'Z', 'a' .. 'z', '0' .. '9')[ int rand 62 ] } 1 .. 8; + my $suffix = join '', map { ('A' .. 'Z', 'a' .. 'z', '0' .. '9')[ int rand 62 ] } 1 .. 8; $fullPath = "$parent/$basename.$suffix"; $success = mkdir $fullPath; } until ($success or not $!{EEXIST}); @@ -87,9 +84,9 @@ sub makeTempDirectory($$) { return $fullPath; } -sub removeTempDirectory($) { - my ($dir) = @_; +sub removeTempDirectory ($dir) { rmtree($dir, 0, 0); + return; } ################################################################################ @@ -104,7 +101,7 @@ Arguments to pass to dvipng. =cut -our $DvipngArgs = "" unless defined $DvipngArgs; +our $DvipngArgs = '' unless defined $DvipngArgs; =item $PreserveTempFiles @@ -120,7 +117,7 @@ TeX to prepend to equations to be processed. =cut -our $TexPreamble = "" unless defined $WeBWorK::PG::ImageGenerator::TexPreamble; +our $TexPreamble = '' unless defined $TexPreamble; =item $TexPostamble @@ -128,7 +125,7 @@ TeX to append to equations to be processed. =cut -our $TexPostamble = "" unless defined $TexPostamble; +our $TexPostamble = '' unless defined $TexPostamble; =back @@ -164,14 +161,16 @@ If C is true, C<%options> must also contain the following entries: Options may also contain: - dvipng_align => vertical alignment option (a string to use like baseline, or 'mysql') - dvipng_depth_db => database connection information for a "depths database" - useMarkers => if you want to have the dvipng images vertically aligned, this involves adding markers + dvipng_align => Vertical alignment option. This should be any of the valid values + for the css vertical-align rule like 'baseline' or 'middle'. + dvipng_depth_db => Database connection information for a database that has the 'depths' table. + useMarkers => If you want to have the dvipng images vertically aligned, this involves adding markers. + This only works if dvipng depths are stored and the body_text is provided. + =cut -sub new { - my ($invocant, %options) = @_; +sub new ($invocant, %options) { my $class = ref $invocant || $invocant; my $self = { names => [], @@ -181,19 +180,22 @@ sub new { %options, }; - # set some values - $self->{dvipng_align} = 'absmiddle' unless defined($self->{dvipng_align}); - $self->{store_depths} = 1 if ($self->{dvipng_align} eq 'mysql'); - $self->{useMarkers} = $self->{useMarkers} || 0; + $self->{dvipng_align} //= 'baseline'; + + # Fix invalid mysql values. + $self->{dvipng_align} = 'baseline' if $self->{dvipng_align} eq 'mysql'; + + $self->{store_depths} = 1 if $self->{dvipng_depth_db}{dbsource} ne ''; + $self->{useMarkers} = 0 unless $self->{store_depths}; if ($self->{useCache}) { $self->{dir} = $self->{cacheDir}; $self->{url} = $self->{cacheURL}; - $self->{basename} = ""; - $self->{equationCache} = WeBWorK::EquationCache->new(cacheDB => $self->{cacheDB}); + $self->{basename} = ''; + $self->{equationCache} = WeBWorK::PG::EquationCache->new(cacheDB => $self->{cacheDB}); } - bless $self, $class; + return bless $self, $class; } =item addToTeXPreamble($string) @@ -210,25 +212,22 @@ not a .pg file =cut -sub addToTeXPreamble { - my $self = shift; - my $str = shift; +sub addToTeXPreamble ($self, $str = undef) { $self->{texPreambleAdditions} = $str if defined $str; - $self->{texPreambleAdditions}; + return $self->{texPreambleAdditions}; } =item refresh(1) Forces every equation picture to be recalculated. Useful for debugging. + $rh_envir->{imagegen}->refresh(1); =cut -sub refresh { - my $self = shift; - my $in = shift; +sub refresh ($self, $in) { $self->{refresh} = $in if defined($in); - $self->{refresh}; + return $self->{refresh}; } =item add($string, $mode) @@ -239,9 +238,7 @@ for displaying the image. =cut -sub add { - my ($self, $string, $mode) = @_; - +sub add ($self, $string, $mode = 'inline') { my $names = $self->{names}; my $strings = $self->{strings}; my $dir = $self->{dir}; @@ -250,7 +247,7 @@ sub add { my $useCache = $self->{useCache}; my $depths = $self->{depths}; - # if the string came in with delimiters, chop them off and set the mode + # If the string came in with delimiters, chop them off and set the mode # based on whether they were \[ .. \] or \( ... \). this means that if # the string has delimiters, the mode *argument* is ignored. if ($string =~ s/^\\\[(.*)\\\]$/$1/s) { @@ -258,48 +255,35 @@ sub add { } elsif ($string =~ s/^\\\((.*)\\\)$/$1/s) { $mode = "inline"; } - # otherwise, leave the string and the mode alone. - - # assume that a bare string with no mode specified is inline - $mode ||= "inline"; - # now that we know what mode we're dealing with, we can generate a "real" - # string to pass to latex + # Generate the string to pass to latex. my $realString = ($mode eq "display") ? '\(\displaystyle{' . $string . '}\)' : '\(' . $string . '\)'; - # alignment tag could be a fixed default - my ($imageNum, $aligntag) = (0, qq|align="$self->{dvipng_align}"|); - # if the default is for variable heights, the default should be meaningful - # in an answer preview, $self->{dvipng_align} might be 'mysql', but we still - # use a static alignment - $aligntag = 'align="baseline"' if ($self->{dvipng_align} eq 'mysql'); + # Alignment tag could be a fixed default + my ($imageNum, $aligntag) = (0, qq{style="vertical-align=$self->{dvipng_align}"}); - # determine what the image's "number" is + # Determine what the image's "number" is. if ($useCache) { - $imageNum = $self->{equationCache}->lookup($realString); - $aligntag = 'MaRkEr' . $imageNum if $self->{useMarkers}; - $depths->{"$imageNum"} = 'none' if ($self->{dvipng_align} eq 'mysql'); - # insert a slash after 2 characters - # this effectively divides the images into 16^2 = 256 subdirectories + $imageNum = $self->{equationCache}->lookup($realString); + $aligntag = 'MaRkEr' . $imageNum if $self->{useMarkers}; + $depths->{$imageNum} = 'none' if $self->{store_depths}; + # Insert a slash after 2 characters. This effectively divides the images into 16^2 = 256 subdirectories. substr($imageNum, 2, 0) = '/'; } else { $imageNum = @$strings + 1; } # We are banking on the fact that if useCache is true, then basename is empty. - # Maybe we should simplify and drop support for useCache =0 and having a basename. + # Maybe we should simplify and drop support for useCache = 0 and having a basename. # get the full file name of the image - my $imageName = ($basename) ? "$basename.$imageNum.png" : "$imageNum.png"; + my $imageName = $basename ? "$basename.$imageNum.png" : "$imageNum.png"; - # store the full file name of the image, and the "real" tex string to the object + # Store the full file name of the image, and the tex string to the object. push @$names, $imageName; push @$strings, $realString; - #warn "ImageGenerator: added string $realString with name $imageName\n"; - - # ... and the full URL. - my $imageURL = "$url/$imageName"; + my $imageURL = "$url/$imageName"; my $safeString = PGcore::encode_pg_and_html($string); my $imageTag = @@ -319,23 +303,11 @@ rendering the images and figuring out their depths, we go through and fix the ta of the images to get the vertical alignment right. If it is left out, then we skip that step. -=for comment - -If the key "mtime" in C<%options> is given, its value will be interpreted as a -unix date and compared with the modification date on any existing copy of the -first image to be generated. It is recommended that the modification time of the -source file from which the equations originate be used for this value. If the -key "refresh" in C<%options> is true, images will be regenerated regardless of -when they were last modified. If neither option is supplied, "refresh" is -assumed. - -NOTE: It's not clear to me that mtime has been implemented -- MEG - 2011/06 +=back =cut -sub render { - my ($self, %options) = @_; - +sub render ($self, %options) { my $tempDir = $self->{tempDir}; my $dir = $self->{dir}; my $basename = $self->{basename}; @@ -345,27 +317,22 @@ sub render { my $strings = $self->{strings}; my $depths = $self->{depths}; $self->{body_text} = $options{body_text}; - my $forceRefresh = $self->{refresh} || 0; # recreate every equation image -- default is do not refresh - ############################################### - # check that the equations directory exists and create if it doesn't - ############################################### - unless (-e "$dir") { - my $success = mkdir "$dir"; + # Recreate every equation image (default is do not refresh). + my $forceRefresh = $self->{refresh} || 0; + + # Check that the equations directory exists and create if it doesn't. + unless (-e $dir) { + my $success = mkdir $dir; warn "Could not make directory $dir" unless $success; } - ############################################### - # determine which images need to be generated - ############################################### + # Determine which images need to be generated. my (@newStrings, @newNames); for (my $i = 0; $i < @$strings; $i++) { my $string = $strings->[$i]; my $name = $names->[$i]; - if (!$forceRefresh and -e "$dir/$name") { - #warn "ImageGenerator: found a file named $name, skipping string $string\n"; - } else { - #warn "ImageGenerator: didn't find a file named $name, including string $string\n"; + if ($forceRefresh || !-e "$dir/$name") { push @newStrings, $string; push @newNames, $name; } @@ -373,10 +340,10 @@ sub render { if (@newStrings) { # Don't run latex if there are no images to generate - # create temporary directory in which to do TeX processing + # Create a temporary directory in which to do TeX processing. my $wd = makeTempDirectory($tempDir, "ImageGenerator"); - # store equations in a tex file + # Store equations in a tex file. my $texFile = "$wd/equation.tex"; open my $tex, ">", $texFile or die "failed to open file $texFile for writing: $!"; @@ -387,9 +354,7 @@ sub render { close $tex; warn "tex file $texFile was not written" unless -e $texFile; - ############################################### - # call LaTeX - ############################################### + # Call LaTeX my $latexCommand = "cd $wd && $latex equation > latex.out 2> latex.err"; my $latexStatus = system $latexCommand; @@ -403,7 +368,7 @@ sub render { my $errorMessage = ''; if (-r "$wd/equation.log") { $errorMessage = readFile("$wd/equation.log"); - warn "
 Logfile contents:\n$errorMessage\n
"; + warn "
Logfile contents:\n$errorMessage\n
"; } else { warn "Unable to read logfile $wd/equation.log "; } @@ -412,53 +377,48 @@ sub render { warn "$latexCommand failed to generate a DVI file" unless -e "$wd/equation.dvi"; - ############################################ - # call dvipng - ############################################ + # Call dvipng my $dvipngCommand = "cd $wd && $dvipng " . $DvipngArgs . " equation > dvipng.out 2> dvipng.err"; my $dvipngStatus = system $dvipngCommand; warn "$dvipngCommand returned non-zero status $dvipngStatus: $!" if $dvipngStatus; - # get depths + + # Get depths my $dvipngout = ''; $dvipngout = readFile("$wd/dvipng.out") if (-r "$wd/dvipng.out"); my @dvipngdepths = ($dvipngout =~ /depth=(\d+)/g); - # kill them all if something goes wrnog + + # Kill them all if something goes wrong @dvipngdepths = () if (scalar(@dvipngdepths) != scalar(@newNames)); - ############################################ # move/rename images - ############################################ - - chmod(0664, <$wd/*>); # first make everything group writable so that a WeBWorK admin can delete images + chmod(0664, <$wd/*>); # Make everything group writable so that a WeBWorK admin can delete images foreach my $image (readDirectory($wd)) { - # only work on equation#.png files + # Only work on equation*.png files next unless $image =~ m/^equation(\d+)\.png$/; - # get image number from above match + # Get image number from above match my $imageNum = $1; - # note, problems with solutions/hints can have empty values in newNames + # Note, problems with solutions/hints can have empty values in newNames. next unless $newNames[ $imageNum - 1 ]; - # record the dvipng offset + # Record the dvipng offset. my $hashkey = $newNames[ $imageNum - 1 ]; $hashkey =~ s|/||; $hashkey =~ s|\.png$||; - $depths->{"$hashkey"} = $dvipngdepths[ $imageNum - 1 ] if (defined($dvipngdepths[ $imageNum - 1 ])); - - #warn "ImageGenerator: found generated image $imageNum with name $newNames[$imageNum-1]\n"; + $depths->{$hashkey} = $dvipngdepths[ $imageNum - 1 ] if defined $dvipngdepths[ $imageNum - 1 ]; - # move/rename image - #my $mvCommand = "cd $wd && /bin/mv $wd/$image $dir/$basename.$imageNum.png"; - # check to see if this requires a directory we haven't made yet + # Check to see if this requires a directory we haven't made yet. my $newdir = $newNames[ $imageNum - 1 ]; $newdir =~ s|/.*$||; if ($newdir and not -d "$dir/$newdir") { my $success = mkdir "$dir/$newdir"; - chmod(0775, <$dir/$newdir>) - ; # make the directory group writable so that a WeBWorK admin can delete images + # Make the directory group writable so that a WeBWorK admin can delete images + chmod(0775, <$dir/$newdir>); warn "Could not make directory $dir/$newdir" unless $success; } + + # move/rename image my $mvCommand = "cd $wd && /bin/mv $wd/$image $dir/" . $newNames[ $imageNum - 1 ]; my $mvStatus = system $mvCommand; if ($mvStatus) { @@ -467,65 +427,63 @@ sub render { } } - ############################################ - # remove temporary directory (and its contents) - ############################################ if ($PreserveTempFiles) { warn "ImageGenerator: preserved temp files in working directory '$wd'.\n"; chmod(0775, $wd); chmod(0664, <$wd/*>); } else { + # Remove the temporary directory and its contents. removeTempDirectory($wd); } } - $self->update_depth_cache() if $self->{store_depths}; - $self->fix_markers() if ($self->{useMarkers} and defined $self->{body_text}); + + $self->update_depth_cache; + $self->fix_markers; + + return; } -# internal utility function for updating both our internal record of dvipng depths, -# but also the database. This is the main function to change (provide an alternate -# method for) if you want to use another method for storing dvipng depths +# Internal utility function for updating both the internal record of dvipng depths +# and the database. This is the main function to change (provide an alternate +# method for) if you want to add another method for storing dvipng depths +sub update_depth_cache ($self) { + return unless $self->{store_depths}; -sub update_depth_cache { - my $self = shift; - return () unless ($self->{dvipng_align} eq 'mysql'); my $dbh = DBI->connect_cached( - $self->{dvipng_depth_db}->{dbsource}, - $self->{dvipng_depth_db}->{user}, - $self->{dvipng_depth_db}->{passwd} + $self->{dvipng_depth_db}{dbsource}, + $self->{dvipng_depth_db}{user}, + $self->{dvipng_depth_db}{passwd} ); - my $sth = $dbh->prepare("INSERT IGNORE INTO depths(md5, depth) VALUES (?,?)"); - my $depthhash = $self->{depths}; - for my $md5 (keys %{$depthhash}) { - if ($depthhash->{$md5} eq 'none') { - my $got_values = $dbh->selectall_arrayref('select depth from depths where md5 = ?', undef, "$md5"); - $depthhash->{"$md5"} = $got_values->[0]->[0] if (scalar(@{$got_values})); - #warn "Get depth from mysql for $md5" . $depthhash->{"$md5"}; + my $sth = + $dbh->prepare($self->{dvipng_depth_db}{dbsource} =~ /:SQLite:/ + ? 'INSERT OR IGNORE INTO depths(md5, depth) VALUES (?,?)' + : 'INSERT IGNORE INTO depths(md5, depth) VALUES (?,?)'); + + for my $md5 (keys %{ $self->{depths} }) { + if ($self->{depths}{$md5} eq 'none') { + my $got_values = $dbh->selectall_arrayref('SELECT depth FROM depths WHERE md5 = ?', undef, $md5); + $self->{depths}{$md5} = $got_values->[0][0] if @$got_values; } else { - #warn "Put depth $depthhash->{$md5} for $md5 into mysql"; - $sth->execute($md5, $depthhash->{$md5}); + $sth->execute($md5, $self->{depths}{$md5}); } } - return (); + return; } -sub fix_markers { - my $self = shift; +sub fix_markers ($self) { + return unless $self->{useMarkers} && defined $self->{body_text}; + my %depths = %{ $self->{depths} }; for my $depthkey (keys %depths) { - if ($depths{$depthkey} eq 'none') { # we never found its depth :( - ${ $self->{body_text} } =~ s/MaRkEr$depthkey/align="ABSMIDDLE"/g; + if ($depths{$depthkey} eq 'none') { + ${ $self->{body_text} } =~ s/MaRkEr$depthkey/style="vertical-align="$self->{dvipng_align}"/g; } else { my $ndepth = 0 - $depths{$depthkey}; ${ $self->{body_text} } =~ s/MaRkEr$depthkey/style="vertical-align:${ndepth}px"/g; } } - return (); + return; } -=back - -=cut - 1; diff --git a/lib/WeBWorK/PG/RestrictedClosureClass.pm b/lib/WeBWorK/PG/RestrictedClosureClass.pm new file mode 100644 index 0000000000..cce8d5bfff --- /dev/null +++ b/lib/WeBWorK/PG/RestrictedClosureClass.pm @@ -0,0 +1,116 @@ +################################################################################ +# WeBWorK Online Homework Delivery System +# Copyright © 2000-2022 The WeBWorK Project, https://github.com/openwebwork +# +# This program is free software; you can redistribute it and/or modify it under +# the terms of either: (a) the GNU General Public License as published by the +# Free Software Foundation; either version 2, or (at your option) any later +# version, or (b) the "Artistic License" which comes with this package. +# +# This program 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 either the GNU General Public License or the +# Artistic License for more details. +################################################################################ + +package WeBWorK::PG::RestrictedClosureClass; + +=head1 NAME + +WeBWorK::PG::RestrictedClosureClass - Protect instance data and only allow +calling of specified methods. + +=head1 SYNPOSIS + + package MyScaryClass; + + sub new { return bless { @_[1..$#_] }, ref $_[0] || $_[0] } + sub get_secret { return $_[0]->{secret_data} } + sub set_secret { $_[0]->{secret_data} = $_[1] } + sub use_secret { print "Secret length is ".length($_[0]->get_secret) } + sub call_for_help { print "HELP!!" } + + package main; + use WeBWorK::PG::RestrictedClosureClass; + + my $unlocked = new MyScaryClass(secret_data => "pErL iS gReAt"); + my $locked = new WeBWorK::PG::RestrictedClosureClass($obj, qw/use_secret call_for_help/); + + $unlocked->get_secret; # OK + $unlocked->set_secret("fOoBaR"); # OK + $unlocked->use_secret; # OK + $unlocked->call_for_help; # OK + print $unlocked->{secret_data}; # OK + $unlocked->{secret_data} = "WySiWyG"; # OK + + $locked->get_secret; # NG (not in method list) + $locked->set_secret("fOoBaR"); # NG (not in method list) + $locked->use_secret; # OK + $locked->call_for_help; # OK + print $locked->{secret_data}; # NG (not a hash reference) + $locked->{secret_data} = "WySiWyG"; # NG (not a hash reference) + +=head1 DESCRIPTION + +RestrictedClosureClass generates a wrapper object for a given object that +prevents access to the objects instance data and only allows specified method +calls. The wrapper object is a closure that calls methods of the underlying +object, if permitted. + +This is great for exposing a limited API to an untrusted environment, i.e. the +PG Safe compartment. + +=head1 CONSTRUCTOR + +=over + +=item $wrapper_object = CLASS->new($object, @methods) + +Generate a wrapper object for the given $object. Only calls to the methods +listed in @methods will be permitted. + +=back + +=head1 LIMITATIONS + +You can't call SUPER methods, or methods with an explicit class given: + + $locked->SUPER::call_for_help # NG, would be superclass of RestrictedClosureClass + +=head1 SEE ALSO + +L + +=cut + +use strict; +use warnings; +use Carp; +use Scalar::Util qw/blessed/; + +sub new { + my ($invocant, $object, @methods) = @_; + croak 'wrapper class with no methods is dumb' unless @methods; + my $class = ref $invocant || $invocant; + croak 'object is not a blessed reference' unless blessed $object; + my %methods; + @methods{@methods} = (); + my $self = sub { # CLOSURE over $object, %methods; + my $method = shift; + if (!exists $methods{$method}) { + croak qq{Can't locate object method "$method" via package "} . ref($object) . '" fnord'; + } + return $object->$method(@_); + }; + return bless $self, $class; +} + +sub AUTOLOAD { + my $self = shift; + my $name = our $AUTOLOAD; + $name =~ s/.*:://; + return if $name eq "DESTROY"; # real obj's DESTROY method called when closure goes out of scope + return $self->($name, @_); +} + +1; diff --git a/lib/WeBWorK/PG/Translator.pm b/lib/WeBWorK/PG/Translator.pm index 0147b2cbd0..70f2a9e892 100644 --- a/lib/WeBWorK/PG/Translator.pm +++ b/lib/WeBWorK/PG/Translator.pm @@ -14,27 +14,20 @@ ################################################################################ package WeBWorK::PG::Translator; -use parent qw(PGcore); use strict; use warnings; -use Opcode; -use WWSafe; -use Net::SMTP; -use PGcore; -use PGUtil qw(pretty_print); -use WeBWorK::PG::IO qw(fileFromPath); + use utf8; use v5.12; binmode(STDOUT, ":encoding(UTF-8)"); -#use PadWalker; # used for processing error messages -#use Data::Dumper; -# loading GD within the Safe compartment has occasionally caused infinite recursion -# Putting these use statements here seems to avoid this problem -# It is not clear that this is essential once things are working properly. -#use Exporter; -#use DynaLoader; +use Opcode; +use Carp; + +use WWSafe; +use PGUtil qw(pretty_print); +use WeBWorK::PG::IO qw(fileFromPath); =head1 NAME @@ -42,27 +35,27 @@ WeBWorK::PG::Translator - Evaluate PG code and evaluate answers safely =head1 SYNPOSIS - my $pt = new WeBWorK::PG::Translator; # create a translator; - $pt->environment(\%envir); # provide the environment variable for the problem - $pt->initialize(); # initialize the translator - $pt-> set_mask(); # set the operation mask for the translator safe compartment - $pt->source_string($source); # provide the source string for the problem + my $pt = new WeBWorK::PG::Translator; # create a translator + $pt->environment(\%envir); # provide the environment variable for the problem + $pt->initialize(); # initialize the translator + $pt-> set_mask(); # set the operation mask for the translator safe compartment + $pt->source_string($source); # provide the source string for the problem - $pt -> unrestricted_load("${courseScriptsDirectory}PG.pl"); - # load the unprotected macro files - # these files are evaluated with the Safe compartment wide open - # other macros are loaded from within the problem using loadMacros + # Load the unprotected macro files. + # These files are evaluated with the Safe compartment wide open. + # Other macros are loaded from within the problem using loadMacros. + $pt->unrestricted_load("${courseScriptsDirectory}PG.pl"); - $pt ->translate(); # translate the problem (the out following 4 pieces of information are created) + $pt->translate(); # translate the problem (the following pieces of information are created) - $PG_PROBLEM_TEXT_ARRAY_REF = $pt->ra_text(); # output text for the body of the HTML file (in array form) - $PG_PROBLEM_TEXT_REF = $pt->r_text(); # output text for the body of the HTML file - $PG_HEADER_TEXT_REF = $pt->r_header;#\$PG_HEADER_TEXT; # text for the header of the HTML file + $PG_PROBLEM_TEXT_ARRAY_REF = $pt->ra_text(); # output text for the body of the HTML file (in array form) + $PG_PROBLEM_TEXT_REF = $pt->r_text(); # output text for the body of the HTML file + $PG_HEADER_TEXT_REF = $pt->r_header; # text for the header of the HTML file $PG_POST_HEADER_TEXT_REF = $pt->r_post_header - $PG_ANSWER_HASH_REF = $pt->rh_correct_answers; # a hash of answer evaluators - $PG_FLAGS_REF = $pt ->rh_flags; # misc. status flags. + $PG_ANSWER_HASH_REF = $pt->rh_correct_answers; # a hash of answer evaluators + $PG_FLAGS_REF = $pt->rh_flags; # misc. status flags. - $pt -> process_answers(\%inputs); # evaluates all of the answers using submitted answers from %input + $pt->process_answers(\%inputs); # evaluates all of the answers using submitted answers from %input my $rh_answer_results = $pt->rh_evaluated_answers; # provides a hash of the results of evaluating the answers. my $rh_problem_result = $pt->grade_problem; # grades the problem using the default problem grading method. @@ -78,41 +71,35 @@ This module defines an object which will translate a problem written in the Prob This creates a substitute for C which cannot be used in PG problem sets or PG macro files. Use this way to imitate the behavior of C - BEGIN { - be_strict(); # an alias for use strict. - # This means that all global variable - # must contain main:: as a prefix. - } + BEGIN { be_strict(); } =cut BEGIN { # Setup the safe compartment for the standalone renderer. - if (exists($ENV{MOJO_MODE})) { - my $ce = new WeBWorK::CourseEnvironment({ - webwork_dir => $ENV{WEBWORK_ROOT}, - }); - - # This safe compartment is used to read the large macro files such as - # PG.pl, PGbasicmacros.pl and PGanswermacros and cache the results so that - # future calls have preloaded versions of these large files. This saves - # approximately 200ms per render. - my $safeCache = new WWSafe; - - my @modules = @{ $ce->{pg}->{modules} }; + if (exists $ENV{MOJO_MODE}) { + my $pg_envir = WeBWorK::PG::Environment->new; + + # Each instance of the translator is run in a new process in the standalone renderer. So the safe compartment + # can be cached and reused for each instance without the possibility of memory leaks from one instance to the + # next. + my $safeCache = WWSafe->new; + + # Load the modules into the safe cache. This saves approximately 200ms per render. + my @modules = @{ $pg_envir->{modules} }; my $ra_included_modules = []; - foreach my $module_packages_ref (@modules) { + for my $module_packages_ref (@modules) { my ($module, @extra_packages) = @$module_packages_ref; - # the first item is the main package + # The first item is the main package. $module =~ s/\.pm$//; eval "package Main; require $module; import $module;"; warn "Failed to evaluate module $module: $@" if $@; push @$ra_included_modules, "\%${module}::"; - # the remaining items are "extra" packages - foreach (@extra_packages) { + # The remaining items are "extra" packages. + for (@extra_packages) { s/\.pm$//; import $_; warn "Failed to evaluate module $_: $@" if $@; @@ -126,11 +113,11 @@ BEGIN { $safeCache->mask(Opcode::empty_opset()); my $safe_cmpt_package_name = $safeCache->root(); - # these days, the only unrestricted load is from PG.pl -- include it in pre-cache - my $filePath = $WeBWorK::Constants::PG_DIRECTORY . "/macros/PG.pl"; + # The only unrestricted load is PG.pl. Load that into the cache as well. + my $filePath = $pg_envir->{directories}{root} . '/macros/PG.pl'; my $init_subroutine_name = "${safe_cmpt_package_name}::_PG_init"; - my $errors = ""; + my $errors = ''; if (-r $filePath) { my $rdoResult = $safeCache->rdo($filePath); $errors .= "\nThere were problems compiling the file:\n $filePath\n $@\n" if $@; @@ -139,7 +126,6 @@ BEGIN { } $safeCache->mask($store_mask); - # intialize PG.pl my $init_subroutine = eval { \&{$init_subroutine_name} }; my $macro_file_loaded = ref($init_subroutine) =~ /CODE/; if ($macro_file_loaded) { @@ -148,88 +134,90 @@ BEGIN { $errors .= "\nUnknown error. Unable to load $filePath\n" if ($errors eq '' and not $macro_file_loaded); die "Translator.pm [BEGIN errors]: $errors\n" if $errors; - # stash the cache in a global variable + # Stash the safe cache in a package variable. $WeBWorK::Translator::safeCache = $safeCache; } - # allows the use of strict within macro packages. + # Allows the use of strict within macro packages. sub be_strict { - require 'ww_strict.pm'; + require ww_strict; strict::import(); + return; } - # also define in Main::, for PG modules. - sub Main::be_strict {&be_strict} + # Also define in Main:: for PG modules. + sub Main::be_strict { return &be_strict; } } =head2 evaluate_modules - Usage: $obj -> evaluate_modules('WWPlot', 'Fun', 'Circle'); - $obj -> evaluate_modules('reset'); + Usage: $obj->evaluate_modules('WWPlot', 'Fun', 'Circle'); Adds the modules WWPlot.pm, Fun.pm and Circle.pm in the courseScripts directory to the list of modules -which can be used by the PG problems. The keyword 'reset' or 'erase' erases the list of modules already loaded +which can be used by the PG problems. =cut sub evaluate_modules { - my $self = shift; - my @modules = @_; - local $SIG{__DIE__} = "DEFAULT"; # we're going to be eval()ing code - foreach (@modules) { - #warn "attempting to load $_\n"; - # ensure that the name is in fact a base name - s/\.pm$// and warn "fixing your broken package name: $_.pm => $_"; - # call runtime_use on the package name - # don't worry -- runtime_use won't load a package twice! - #eval { runtime_use $_ }; # - eval "package Main; require $_; import $_"; # change for WW1 + my ($self, @modules) = @_; + + local $SIG{__DIE__} = 'DEFAULT'; + + for (@modules) { + # Ensure that the name is in fact a base name. + s/\.pm$//; + + eval "package Main; require $_; import $_"; warn "Failed to evaluate module $_: $@" if $@; - # record this in the appropriate place + + # Record this in the appropriate place. push @{ $self->{ra_included_modules} }, "\%${_}::"; } + + return; } =head2 load_extra_packages - Usage: $obj -> load_extra_packages('AlgParserWithImplicitExpand', - 'Expr','ExprWithImplicitExpand'); + Usage: $obj->load_extra_packages('AlgParserWithImplicitExpand', + 'Expr','ExprWithImplicitExpand'); Loads extra packages for modules that contain more than one package. Works in conjunction with evaluate_modules. It is assumed that the file containing the extra packages (along with the base package name which is the same as the name of the file minus the .pm extension) has already been loaded using evaluate_modules + =cut sub load_extra_packages { - my $self = shift; - my @package_list = @_; - my $package_name; - - foreach (@package_list) { - # ensure that the name is in fact a base name - s/\.pm$// and warn "fixing your broken package name: $_.pm => $_"; - # import symbols from the extra package + my ($self, @package_list) = @_; + + for (@package_list) { + # Ensure that the name is in fact a base name. + s/\.pm$//; + + # Import symbols from the extra package import $_; warn "Failed to evaluate module $_: $@" if $@; - # record this in the appropriate place + + # Record this in the appropriate place push @{ $self->{ra_included_modules} }, "\%${_}::"; } + + return; } -=head2 new +=head2 new - Creates the translator object. + Creates the translator object. =cut sub new { my $class = shift; - # The standalone renderer caches the safe compartment when the module is compiled. - # It is safe for all requests to use the safeCache because the perl - # process is forked for each render request. (thanks async!) - my $safe_cmpt = exists($ENV{MOJO_MODE}) ? $WeBWorK::Translator::safeCache : new WWSafe; + # Use the cached safe for the standalone renderer. + my $safe_cmpt = exists($ENV{MOJO_MODE}) ? $WeBWorK::Translator::safeCache : WWSafe->new; my $self = { preprocess_code => \&default_preprocess_code, @@ -241,135 +229,98 @@ sub new { PG_POST_HEADER_TEXT_REF => 0, PG_ANSWER_HASH_REF => {}, PG_FLAGS_REF => {}, - rh_pgcore => undef, # ref to PGcore object + rh_pgcore => undef, safe => $safe_cmpt, safe_compartment_name => $safe_cmpt->root, - errors => "", - source => "", + errors => '', + source => '', rh_correct_answers => {}, rh_student_answers => {}, rh_evaluated_answers => {}, rh_problem_result => {}, rh_problem_state => { - recorded_score => 0, # the score recorded in the data base - num_of_correct_ans => 0, # the number of correct attempts at doing the problem - num_of_incorrect_ans => 0, # the number of incorrect attempts + recorded_score => 0, + num_of_correct_ans => 0, + num_of_incorrect_ans => 0, }, - rf_problem_grader => \&std_problem_grader, - rf_safety_filter => \&safetyFilter, - # ra_included_modules is now populated independantly of @class_modules: - ra_included_modules => [], # [ @class_modules ], - #rh_directories => {}, + rf_problem_grader => \&std_problem_grader, + rf_safety_filter => \&safetyFilter, + ra_included_modules => [] }; - bless $self, $class; + return bless $self, $class; } =pod (b) The following routines defined within the PG module are shared: - &be_strict - &read_whole_problem_file - &convertPath - &surePathToTmpFile - &fileFromPath - &directoryFromPath - #&includePGtext - &PG_answer_eval - &PG_restricted_eval - &send_mail_to - &PGsort + &be_strict + &read_whole_problem_file + &convertPath + &surePathToTmpFile + &fileFromPath + &directoryFromPath + &PG_answer_eval + &PG_restricted_eval + &send_mail_to + &PGsort In addition the environment hash C<%envir> is shared. This variable is unpacked when PG.pl is run and provides most of the environment variables for each problem template. =for html - - environment variables - -=cut - -=pod + environment variables (c) Sharing macros: The macros shared with the safe compartment are - '&read_whole_problem_file' - '&convertPath' - '&surePathToTmpFile' - '&fileFromPath' - '&directoryFromPath' - '&PG_answer_eval' - '&PG_restricted_eval' - '&be_strict' - '&send_mail_to' - '&PGsort' - '&dumpvar' - #'&includePGtext' + '&read_whole_problem_file' + '&convertPath' + '&surePathToTmpFile' + '&fileFromPath' + '&directoryFromPath' + '&PG_answer_eval' + '&PG_restricted_eval' + '&be_strict' + '&send_mail_to' + '&PGsort' =cut -# SHARE variables and routines with safe compartment -# -# Some symbols are defined here (or in the IO module), and used inside the safe -# compartment. Under WeBWorK 1.x, functions defined here had access to the -# Global:: namespace, which contained course-specific data such things as -# directory locations, the address of the SMTP server, and so on. Under WeBWorK -# 2, there is no longer a global namespace. To get around this, IO functions -# which need access to course-specific data are now defined in the IO.pl macro -# file, which has access to the problem environment. Several entries have been -# added to the problem environment to support this move. -# - -# Useful for timing portions of the translating process -# The timer $WeBWorK::timer is defined in the module WeBWorK.pm -# You must make sure that the code in that script for initialzing the -# timer is active. +# Share variables and routines with the safe compartment. +# Some symbols are defined here and some in the WeBWorK::PG::IO module. -sub time_it { - my $msg = shift; - $WeBWorK::timer->continue("PG macro:" . $msg) if defined($WeBWorK::timer); -} - -# functions shared from WeBWorK::PG::Translator -my %Translator_shared_subroutine_hash = ( - 'time_it' => __PACKAGE__, - '&PG_answer_eval' => __PACKAGE__, - '&PG_restricted_eval' => __PACKAGE__, - '&PG_macro_file_eval' => __PACKAGE__, - '&be_strict' => __PACKAGE__, - '&PGsort' => __PACKAGE__, - '&dumpvar' => __PACKAGE__, +# Functions shared from WeBWorK::PG::Translator +my @Translator_shared_subroutine_array = qw( + &PG_answer_eval + &PG_restricted_eval + &PG_macro_file_eval + &be_strict + &PGsort ); -# add names from WeBWorK::PG::IO and WeBWorK::PG::IO::* -my %IO_shared_subroutine_hash = %WeBWorK::PG::IO::SHARE; - sub initialize { my $self = shift; my $safe_cmpt = $self->{safe}; - #print "initializing safeCompartment",$safe_cmpt -> root(), "\n"; - $safe_cmpt->share_from('WeBWorK::PG::Translator', [ keys %Translator_shared_subroutine_hash ]); - $safe_cmpt->share_from('WeBWorK::PG::IO', [ keys %IO_shared_subroutine_hash ]); + $safe_cmpt->share_from('WeBWorK::PG::Translator', \@Translator_shared_subroutine_array); + $safe_cmpt->share_from('WeBWorK::PG::IO', \@WeBWorK::PG::IO::EXPORT); + no strict; local (%envir) = %{ $self->{envir} }; $safe_cmpt->share('%envir'); - #local($rf_answer_eval) = sub { $self->PG_answer_eval(@_); }; - #local($rf_restricted_eval) = sub { $self->PG_restricted_eval(@_); }; local ($PREPROCESS_CODE) = sub { &{ $self->{preprocess_code} }(@_) }; - $safe_cmpt->share('$PREPROCESS_CODE'); # for the benefit of IO::includePGtext() - #$safe_cmpt -> share('$rf_answer_eval'); - #$safe_cmpt -> share('$rf_restricted_eval'); + $safe_cmpt->share('$PREPROCESS_CODE'); # Used by WeBWorK::PG::IO::includePGtext use strict; # The standalone renderer does this when the module is compiled. unless (exists($ENV{MOJO_MODE})) { $safe_cmpt->share_from('main', $self->{ra_included_modules}); } + + return; } sub environment { @@ -379,15 +330,13 @@ sub environment { if (ref($envirref) eq 'HASH') { %{ $self->{envir} } = %$envirref; } else { - $self->{errors} .= "ERROR: The environment method for PG_translate objects requires a reference to a hash"; + $self->{errors} .= 'ERROR: The environment method for PG_translate objects requires a reference to a hash'; } } - $self->{envir}; #reference to current environment + return $self->{envir}; } -=head2 Safe compartment pass through macros - - +=head2 Safe compartment pass through macros =cut @@ -395,22 +344,21 @@ sub mask { my $self = shift; my $mask = shift; my $safe_compartment = $self->{safe}; - $safe_compartment->mask($mask); + return $safe_compartment->mask($mask); } sub permit { my $self = shift; my @array = shift; my $safe_compartment = $self->{safe}; - $safe_compartment->permit(@array); + return $safe_compartment->permit(@array); } sub deny { - my $self = shift; my @array = shift; my $safe_compartment = $self->{safe}; - $safe_compartment->deny(@array); + return $safe_compartment->deny(@array); } sub share_from { @@ -418,164 +366,149 @@ sub share_from { my $pckg_name = shift; my $array_ref = shift; my $safe_compartment = $self->{safe}; - $safe_compartment->share_from($pckg_name, $array_ref); + return $safe_compartment->share_from($pckg_name, $array_ref); } -#### end safe compartment pass through macros +# End safe compartment pass through macros. sub source_string { my $self = shift; my $temp = shift; - my $out; if (ref($temp) eq 'SCALAR') { $self->{source} = $$temp; - $out = $self->{source}; } elsif ($temp) { $self->{source} = $temp; - $out = $self->{source}; } - $self->{source}; + return $self->{source}; } sub source_file { my $self = shift; my $filePath = shift; - local (*SOURCEFILE); - local ($/); - $/ = undef; # allows us to treat the file as a single line - my $err = ""; - if (open(SOURCEFILE, "<:encoding(UTF-8)", $filePath)) { - $self->{source} = ; - close(SOURCEFILE); + local $/ = undef; + if (open(my $SOURCEFILE, "<:encoding(UTF-8)", $filePath)) { + $self->{source} = <$SOURCEFILE>; + close($SOURCEFILE); } else { $self->{errors} .= "Can't open file: $filePath"; croak("Can't open file: $filePath\n"); } - - $err; + return; } sub unrestricted_load { - my $self = shift; - my $filePath = shift; + my $self = shift; + my $filePath = shift; + my $safe_cmpt = $self->{safe}; my $store_mask = $safe_cmpt->mask(); $safe_cmpt->mask(Opcode::empty_opset()); my $safe_cmpt_package_name = $safe_cmpt->root(); - my $macro_file_name = fileFromPath($filePath); - $macro_file_name =~ s/\.pl//; # trim off the extenstion - my $export_subroutine_name = "_${macro_file_name}_export"; - my $init_subroutine_name = "${safe_cmpt_package_name}::_${macro_file_name}_init"; + my $macro_file_name = fileFromPath($filePath) =~ s/\.pl//r; # Trim off the extension - my $local_errors = ""; - no strict; + my $init_subroutine_name = "${safe_cmpt_package_name}::_${macro_file_name}_init"; + + my $local_errors = ''; my $init_subroutine = eval { \&{$init_subroutine_name} }; - warn "No init routine for $init_subroutine_name: $@" if $debugON and $@; - use strict; - my $macro_file_loaded = ref($init_subroutine) =~ /CODE/ - && defined(&$init_subroutine); - #print STDERR "$macro_file_name has not yet been loaded\n" unless $macro_file_loaded; + my $macro_file_loaded = ref($init_subroutine) =~ /CODE/ && defined(&$init_subroutine); + unless ($macro_file_loaded) { - ## load the $filePath file - ## Using rdo insures that the $filePath file is loaded for every problem, allowing initializations to occur. - ## Ordinary mortals should not be fooling with the fundamental macros in these files. - my $local_errors = ""; + # Load the $filePath file + # Using rdo insures that the $filePath file is loaded for every problem, allowing initializations to occur. + # Ordinary mortals should not be fooling with the fundamental macros in these files. if (-r $filePath) { my $rdoResult = $safe_cmpt->rdo($filePath); - #warn "unrestricted load: $filePath\n"; $local_errors = "\nThere were problems compiling the file:\n $filePath\n $@\n" if $@; - $self->{errors} .= $local_errors if $local_errors; - use strict; + $self->{errors} .= $local_errors if $local_errors; } else { $local_errors = "Can't open file $filePath for reading\n"; $self->{errors} .= $local_errors if $local_errors; } - $safe_cmpt->mask($store_mask); - } - # try again to define the initization subroutine - $init_subroutine = eval { \&{"$init_subroutine_name"} }; - $macro_file_loaded = ref($init_subroutine) =~ /CODE/; - if ($macro_file_loaded) { - #warn "unrestricted load: initializing $macro_file_name $init_subroutine" ; - &$init_subroutine(); + $safe_cmpt->mask($store_mask); + + unless ($macro_file_loaded) { + # Try again to define the initialization subroutine. + $init_subroutine = eval { \&{"$init_subroutine_name"} }; + $macro_file_loaded = ref($init_subroutine) =~ /CODE/; + if ($macro_file_loaded) { + &$init_subroutine(); + } } - $local_errors .= "\nUnknown error. Unable to load $filePath\n" if ($local_errors eq '' and not $macro_file_loaded); - #print STDERR "$filePath is properly loaded\n\n" if $macro_file_loaded; - $local_errors; + + $local_errors .= "\nUnknown error. Unable to load $filePath\n" if $local_errors eq '' && !$macro_file_loaded; + return $local_errors; } sub nameSpace { my $self = shift; - $self->{safe}->root; + return $self->{safe}->root; } sub a_text { my $self = shift; - @{ $self->{PG_PROBLEM_TEXT_ARRAY_REF} }; + return @{ $self->{PG_PROBLEM_TEXT_ARRAY_REF} }; } sub header { my $self = shift; - ${ $self->{PG_HEADER_TEXT_REF} }; + return ${ $self->{PG_HEADER_TEXT_REF} }; } sub post_header { my $self = shift; - ${ $self->{PG_POST_HEADER_TEXT_REF} }; + return ${ $self->{PG_POST_HEADER_TEXT_REF} }; } sub h_flags { my $self = shift; - %{ $self->{PG_FLAGS_REF} }; + return %{ $self->{PG_FLAGS_REF} }; } sub rh_flags { my $self = shift; - $self->{PG_FLAGS_REF}; + return $self->{PG_FLAGS_REF}; } sub h_answers { my $self = shift; - %{ $self->{PG_ANSWER_HASH_REF} }; + return %{ $self->{PG_ANSWER_HASH_REF} }; } sub ra_text { my $self = shift; - $self->{PG_PROBLEM_TEXT_ARRAY_REF}; - + return $self->{PG_PROBLEM_TEXT_ARRAY_REF}; } sub r_text { my $self = shift; - $self->{PG_PROBLEM_TEXT_REF}; + return $self->{PG_PROBLEM_TEXT_REF}; } sub r_header { my $self = shift; - $self->{PG_HEADER_TEXT_REF}; + return $self->{PG_HEADER_TEXT_REF}; } sub r_post_header { my $self = shift; - $self->{PG_POST_HEADER_TEXT_REF}; + return $self->{PG_POST_HEADER_TEXT_REF}; } sub rh_correct_answers { - my $self = shift; - my @in = @_; + my ($self, @in) = @_; return $self->{rh_correct_answers} if @in == 0; if (ref($in[0]) eq 'HASH') { - $self->{rh_correct_answers} = { %{ $in[0] } }; # store a copy of the hash + $self->{rh_correct_answers} = { %{ $in[0] } }; } else { - $self->{rh_correct_answers} = {@in}; # store a copy of the hash + $self->{rh_correct_answers} = {@in}; } - $self->{rh_correct_answers}; + return $self->{rh_correct_answers}; } sub rf_problem_grader { @@ -587,65 +520,53 @@ sub rf_problem_grader { } else { die "ERROR: Attempted to install a problem grader which was not a reference to a subroutine."; } - $self->{rf_problem_grader}; + return $self->{rf_problem_grader}; } sub errors { my $self = shift; - $self->{errors}; + return $self->{errors}; } -=head2 set_mask - - - - - +=head2 set_mask (e) Now we close the safe compartment. Only the certain operations can be used within PG problems and the PG macro files. These include the subroutines shared with the safe compartment as defined above and most Perl commands which do not involve file access, access to the system or evaluation. -Specifically the following are allowed +Specifically the following are allowed: - time() - # gives the current Unix time - # used to determine whether solutions are visible. - atan, sin cos exp log sqrt - # arithemetic commands -- more are defined in PGauxiliaryFunctions.pl + time + - Gives the current Unix time. + atan, sin, cos, exp, log, sqrt + - Arithemetic commands. More are defined in PGauxiliaryFunctions.pl The following are specifically not allowed: - eval() - unlink, symlink, system, exec - print require - - + eval, unlink, symlink, system, exec, print, require =cut -############################################################################## - -## restrict the operations allowed within the safe compartment - +# Restrict the operations allowed within the safe compartment sub set_mask { my $self = shift; my $safe_cmpt = $self->{safe}; - $safe_cmpt->mask(Opcode::full_opset()); # allow no operations - $safe_cmpt->permit(qw( :default )); - $safe_cmpt->permit(qw(time)); # used to determine whether solutions are visible. - $safe_cmpt->permit(qw( atan2 sin cos exp log sqrt )); + $safe_cmpt->mask(Opcode::full_opset()); # Allow no operations + $safe_cmpt->permit(qw(:default)); + $safe_cmpt->permit(qw(time)); + $safe_cmpt->permit(qw(atan2 sin cos exp log sqrt)); - # just to make sure we'll deny some things specifically + # Just to make sure, deny some things specifically. $safe_cmpt->deny(qw(entereval)); - $safe_cmpt->deny(qw ( unlink symlink system exec )); + $safe_cmpt->deny(qw(unlink symlink system exec)); $safe_cmpt->deny(qw(print require)); + return; } ############################################################################ -=head2 PG_errorMessage +=head2 PG_errorMessage This routine processes error messages by fixing file names and adding traceback information. It loops through the function calls via @@ -673,156 +594,90 @@ the PG root directory by [PG]. =cut sub PG_errorMessage { - my $return = shift; - my $frame = 2; # return can be 'message' or 'traceback' - my $message = join("\n", @_); - $message =~ s/\.?\s+$//; - my $files = eval('$main::__files__'); - $files = {} unless $files; - my $tmpl = $files->{tmpl} || '$'; - my $root = $files->{root} || '$'; - my $pg = $files->{pg} || '$'; - # - # Fix initial message file names - # + my ($return, @messages) = @_; # $return can be 'message' or 'traceback' + + my $message = join("\n", @messages) =~ s/\s+$//r; + + my $files = $main::__files__ // {}; + my $tmpl = $files->{tmpl} || '$'; + my $root = $files->{root} || '$'; + my $pg = $files->{pg} || '$'; + + # Fix initial message file names $message =~ s! $tmpl! [TMPL]!g; $message =~ s! $root! [WW]!g; $message =~ s! $pg! [PG]!g; - $message =~ s/(\(eval \d+\)) (line (\d+))/$2 of $1/; - while ($message =~ m/of (?:file )?(\(eval \d+\))/ && defined($files->{$1})) { - my $name = $files->{$1}; + $message =~ s/(\(eval \d+\)) (line (\d+))/$2 of $1/g; + my @eval_ids = $message =~ m/of (?:file )?(\(eval \d+\))/g; + for (@eval_ids) { + my $name = $files->{$_}; + next unless defined $name; $name =~ s!^$tmpl![TMPL]!; $name =~ s!^$root![WW]!; $name =~ s!^$pg![PG]!; - $message =~ s/\(eval \d+\)/$name/g; + $message =~ s/\($_\)/$name/g; } - # - # Return just the message if that's all we want, or - # if the message already includes a stack trace - # + + # Return the message if that is what was requested, or if the message already includes a stack trace. return $message . "\n" if $return eq 'message' || $message =~ m/\n Died within/; - # - # Look through caller stack for traceback information - # + + $message =~ s/\.$//; + + # Look through caller stack for traceback information my @trace = ($message); my $skipParser = (caller(3))[3] =~ m/^(Parser|Value)::/; + + my $frame = 2; while (my ($pkg, $file, $line, $subname) = caller($frame++)) { last if ($subname =~ m/^(Safe::reval|main::__ANON__)/); - next if $skipParser && $subname =~ m/^(Parser|Value)::/; # skip Parser and Value calls - next if $subname =~ m/__ANON__/; + next if $skipParser && $subname =~ m/^(Parser|Value)::/; # Skip Parser and Value calls. + next if $subname =~ m/^WeBWorK::PG::Translator/; # Skip Translator calls. + next if $subname =~ m/^main::(safe_ev|old_safe_ev|ev_substring)$/; # Skip PGbasicmacros.pl ev calls. + next if $subname =~ m/__ANON__/; $file = $files->{$file} || $file; $file =~ s!^$tmpl![TMPL]!; $file =~ s!^$root![WW]!; $file =~ s!^$pg![PG]!; $message = " from within $subname called at line $line of $file"; + next if $message =~ m/within \(eval\)/; push @trace, $message; $skipParser = 0; } - splice(@trace, 1, 1) while $trace[1] && $trace[1] =~ m/within \(eval\)/; - pop @trace while $trace[-1] && $trace[-1] =~ m/within \(eval\)/; - $trace[1] =~ s/ from/ Died/ if $trace[1]; - # - # report the full traceback - # - return join("\n", @trace, ''); -} - -=head2 PG_undef_var_check - -=pod - - Produces warnings of this type in order to help you guess which local variable is undefined - Warning: Use of uninitialized value in concatenation (.) or string at mpu.cgi line 25. - Possible variables are: - '$GLOBAL_VARIABLE' => \'global', - '$t' => \undef, - '$s' => \'regular output' - - - - -=cut - -sub PG_undef_var_check { - if ($_[0] !~ /^Use of uninitialized value/) { - return @_; - } else { - # If there are objects, the output can be VERY large when you increase this - local $Data::Dumper::Maxdepth = 2; - # takes all lexical variables from caller-nemaspace - my $possibles = Data::Dumper::Dumper({ %{ PadWalker::peek_my(1) }, %{ PadWalker::peek_our(1) } }); - - $possibles ne "\$VAR1 = {};\n" ? ($possibles =~ s/^.*?\n(.*)\n.*?\n$/$1/ms) : ($possibles = ''); - return "Warning: " . join(', ', @_) . "Possible variables are:\n$possibles\n"; - } + # Report the full traceback. + return join("\n", @trace, ''); } -############################################################################ - -=head2 Translate - - -=cut - -sub translate { - my $self = shift; - my @PROBLEM_TEXT_OUTPUT = (); - my $safe_cmpt = $self->{safe}; - my $evalString = $self->{source}; - $self->{errors} .= qq{ERROR: This problem file was empty!\n} unless ($evalString); - $self->{errors} .= qq{ERROR: You must define the environment before translating.} - unless defined($self->{envir}); - - # install handlers for warn and die that call PG_errorMessage. - # if the existing signal handler is not a coderef, the built-in warn or - # die function is called. this does not account for the case where the - # handler is set to "IGNORE" or to the name of a function. in these cases - # the built-in function will be called. - - my $outer_sig_warn = $SIG{__WARN__}; - local $SIG{__WARN__} = sub { - ref $outer_sig_warn eq "CODE" - ? &$outer_sig_warn(PG_errorMessage('message', $_[0])) - : warn PG_errorMessage('message', $_[0]); - }; - my $outer_sig_die = $SIG{__DIE__}; - local $SIG{__DIE__} = sub { - ref $outer_sig_die eq "CODE" - ? &$outer_sig_die(PG_errorMessage('traceback', $_[0])) - : die PG_errorMessage('traceback', $_[0]); - }; - -=pod +=head2 Translate (3) B -The input text is subjected to two global replacements. +The input text is subjected to some global replacements. + First every incidence of - BEGIN_TEXT - problem text - END_TEXT + BEGIN_TEXT + problem text + END_TEXT is replaced by - TEXT( EV3( <<'END_TEXT' ) ); - problem text - END_TEXT + TEXT(EV3(<<'END_TEXT')); + problem text + END_TEXT The first construction is syntactic sugar for the second. This is explained in C. -Second every incidence -of \ (backslash) is replaced by \\ (double backslash). Third each incidence of -~~ is replaced by a single backslash. +Second every incidence of \ (backslash) is replaced by \\ (double backslash). + +Third each incidence of ~~ is replaced by a single backslash. -This is done to alleviate a basic -incompatibility between TeX and Perl. TeX uses backslashes constantly to denote -a command word (as opposed to text which is to be entered literally). Perl -uses backslash to escape the following symbol. This escape -mechanism takes place immediately when a Perl script is compiled and takes -place throughout the code and within every quoted string (both double and single +This is done to alleviate a basic incompatibility between TeX and Perl. TeX uses +backslashes to denote a command word (as opposed to text which is to be entered +literally). Perl uses backslashes to escape the following symbol. This escape +mechanism takes place immediately when a Perl script is compiled and takes place +throughout the code and within every quoted string (both double and single quoted strings) with the single exception of single quoted "here" documents. That is backlashes which appear in @@ -833,252 +688,231 @@ That is backlashes which appear in are the only ones not immediately evaluated. This behavior makes it very difficult to use TeX notation for defining mathematics within text. -The initial global -replacement, before compiling a PG problem, allows one to use backslashes within -text without doubling them. (The anomolous behavior inside single quoted "here" -documents is compensated for by the behavior of the evaluation macro EV3.) This -makes typing TeX easy, but introduces one difficulty in entering normal Perl code. +The initial global replacement, before compiling a PG problem, allows one to use +backslashes within text without doubling them. (The anomalous behavior inside +single quoted "here" documents is compensated for by the behavior of the +evaluation macro EV3.) This makes typing TeX easy, but introduces one difficulty +in entering normal Perl code. -The second global replacement provides a work around for this -- use ~~ when you -would ordinarily use a backslash in Perl code. -In order to define a carriage return use ~~n rather than \n; in order to define -a reference to a variable you must use ~~@array rather than \@array. This is -annoying and a source of simple compiler errors, but must be lived with. +The second global replacement provides a work around for this. That is to use +~~ when you would ordinarily use a backslash in Perl code. In order to define a +carriage return use ~~n rather than \n; in order to define a reference to a +variable you must use ~~@array rather than \@array. This is annoying and a +source of simple compiler errors, but must be lived with. The problems are not evaluated in strict mode, so global variables can be used without warnings. +Note that there are several other replacements that are now done that are not +documented here. See the C method for all +replacements that are done. +(4) B -=cut +Evaluate the text within the safe compartment. Save the errors. The safe +compartment is a new one unless the $safeCompartment was set to zero in which +case the previously defined safe compartment is used. (See item 1.) -############################################################################ +(5) B - ########################################## - ###### PG preprocessing code ############# - ########################################## +The error provided by Perl is truncated slightly and returned. In the text +string which would normally contain the rendered problem. - $evalString = &{ $self->{preprocess_code} }($evalString); +The original text string is given line numbers and concatenated to the errors. - # # default_preprocess_code - # # BEGIN_TEXT and END_TEXT must occur on a line by themselves. - # $evalString =~ s/\n\s*END_TEXT[\s;]*\n/\nEND_TEXT\n/g; - # $evalString =~ s/\n\s*BEGIN_TEXT[\s;]*\n/\nTEXT\(EV3\(<<'END_TEXT'\)\);\n/g; - # $evalString =~ s/ENDDOCUMENT.*/ENDDOCUMENT();/s; # remove text after ENDDOCUMENT - # - # $evalString =~ s/\\/\\\\/g; # \ can't be used for escapes because of TeX conflict - # $evalString =~ s/~~/\\/g; # use ~~ as escape instead, use # for comments +(6) B -=pod +Sets the following hash keys of the translator object: + PG_PROBLEM_TEXT_ARRAY_REF: Reference to an array of strings containing the + rendered text. + PG_PROBLEM_TEXT_REF: Reference to a string resulting from joining the above + array with the empty string. + PG_HEADER_TEXT_REF: Reference to a string containing material to be placed + in the header. + PG_POST_HEADER_TEXT_REF: Reference to a string containing material to + be placed in body above form. + rh_correct_answers: Reference to an array containing the answer evaluators. + Constructed from keys of $PGcore->{PG_ANSWERS_HASH}. + PG_FLAGS_REF: Reference to a hash containing flags and other references: + 'error_flag' is set to 1 if there were errors in rendering. + rh_pgcore: The PGcore object. -(4) B +=cut -Evaluate the text within the safe compartment. Save the errors. The safe -compartment is a new one unless the $safeCompartment was set to zero in which -case the previously defined safe compartment is used. (See item 1.) +sub translate { + my $self = shift; + my @PROBLEM_TEXT_OUTPUT = (); + my $safe_cmpt = $self->{safe}; + my $evalString = $self->{source}; + $self->{errors} .= qq{ERROR: This problem file was empty!\n} unless ($evalString); + $self->{errors} .= qq{ERROR: You must define the environment before translating.} + unless defined($self->{envir}); -=cut + # Create a global reference to the __files__ hash in the envir so that + # it can be accessed in the $PG_errorMessage method. + $main::__files__ = $self->{envir}{__files__}; + + # Install handlers for warn and die that call PG_errorMessage. + # If the existing signal handler is not a coderef, the built-in warn or + # die function is called. This does not account for the case where the + # handler is set to "IGNORE" or to the name of a function. In these cases + # the built-in function will be called. + + my $outer_sig_warn = $SIG{__WARN__}; + my (@frontend_warnings, @backend_warnings); + local $SIG{__WARN__} = sub { $_[1] ? push(@backend_warnings, $_[0]) : push(@frontend_warnings, $_[0]); }; + + my $outer_sig_die = $SIG{__DIE__}; + local $SIG{__DIE__} = sub { + ref $outer_sig_die eq "CODE" + ? &$outer_sig_die(PG_errorMessage('traceback', $_[0])) + : die PG_errorMessage('traceback', $_[0]); + }; + + # PG preprocessing code + $evalString = + 'BEGIN { my $eval = __FILE__; $main::envir{__files__}{$eval} = "' + . $self->{envir}{probFileName} . '" };' . "\n" + . &{ $self->{preprocess_code} }($evalString); my ($PG_PROBLEM_TEXT_REF, $PG_HEADER_TEXT_REF, $PG_POST_HEADER_TEXT_REF, $PG_ANSWER_HASH_REF, $PG_FLAGS_REF, $PGcore) - = $safe_cmpt->reval(" $evalString"); + = $safe_cmpt->reval($evalString); -# This section could use some more error messages. In particular if a problem doesn't produce the right output, the user needs -# information about which problem was at fault. -# -# + # This section could use some more error messages. In particular if a problem doesn't produce the right output, + # the user needs information about which problem was at fault. -################# # FIXME The various warning message tracks are still being sorted out # WARNING and DEBUG tracks are being handled elsewhere (in Problem.pm?) -####################################################################### - $self->{errors} .= "ERRORS from evaluating PG file:
$@
\n" if $@; + $self->{errors} .= "ERRORS from evaluating PG file:\n$@\n" if $@; -####################################################################### - - # push(@PROBLEM_TEXT_OUTPUT , split(/(\n)/,$$PG_PROBLEM_TEXT_REF) ) if defined($$PG_PROBLEM_TEXT_REF ); push(@PROBLEM_TEXT_OUTPUT, split(/^/, $$PG_PROBLEM_TEXT_REF)) if ref($PG_PROBLEM_TEXT_REF) eq 'SCALAR'; - ## This is better than using defined($$PG_PROBLEM_TEXT_REF) - ## Because more pleasant feedback is given - ## when the problem doesn't render. - # try to get the \n to appear at the end of the line + # This is better than using defined($$PG_PROBLEM_TEXT_REF) + # Because more pleasant feedback is given when the problem doesn't render. + # Try to get the \n to appear at the end of the line. - use strict; - ############################################################################# - ########## end EVALUATION code ########### - ############################################################################# + if (@frontend_warnings) { + ref $outer_sig_warn eq "CODE" + ? &$outer_sig_warn(PG_errorMessage('message', @frontend_warnings)) + : warn PG_errorMessage('message', @frontend_warnings); + } + if (@backend_warnings) { + if (ref $outer_sig_warn eq "CODE" && $self->{envir}{view_problem_debugging_info}) { + &$outer_sig_warn(PG_errorMessage( + 'message', + 'Non fatal warnings. ' + . 'These are only displayed for users with permission to view problem debugging info.', + @backend_warnings + )); + } else { + local $SIG{__WARN__} = 'DEFAULT'; + warn PG_errorMessage('message', @backend_warnings); + } + } - ########################################## - ###### PG postprocessing code ############# - ########################################## + # PG postprocessing code $PG_PROBLEM_TEXT_REF = &{ $self->{postprocess_code} }($PG_PROBLEM_TEXT_REF); -=pod - -(5) B - -The error provided by Perl -is truncated slightly and returned. In the text -string which would normally contain the rendered problem. - -The original text string is given line numbers and concatenated to -the errors. - -=cut - - ########################################## - ###### PG error processing code ########## - ########################################## - my (@input, $lineNumber, $line); - my $permissionLevel = $self->{envir}->{permissionLevel} || 0; #user permission level - # Only show the problem text to users with permission - if ($self->{errors} && $self->{envir}->{VIEW_PROBLEM_DEBUGGING_INFO} <= $permissionLevel) { - #($self -> {errors}) =~ s/ {errors}) =~ s/>/>/g; - #try to clean up errors so they will look ok - #$self ->{errors} =~ s/\[[^\]]+?\] [^ ]+?\.pl://gm; #erase [Fri Dec 31 12:58:30 1999] processProblem7.pl: - #$self -> {errors} =~ s/eval\s+'(.|[\n|r])*$//; - #end trying to clean up errors so they will look ok - + # PG error processing code + if ($self->{errors} && $self->{envir}{view_problem_debugging_info}) { push(@PROBLEM_TEXT_OUTPUT, - qq!\n
        Problem!
-				. $self->{envir}->{'probNum'}
-				. qq!\n1. ERROR caught by Translator while processing problem file:!
-				. $self->{envir}->{'probFileName'}
-				. "\n****************\r\n"
-				. $self->{errors} . "\r\n"
-				. "****************
\n");
-
-		push(@PROBLEM_TEXT_OUTPUT, "------Input Read\r\n");
+			"
ERROR caught by Translator while processing problem file: $self->{envir}{probFileName}
"
+				. $self->{errors}
+				. '
');
+
+		push(@PROBLEM_TEXT_OUTPUT, 'Input Read:
');
 		$self->{source} =~ s/{source});
-		$lineNumber = 1;
-		foreach $line (@input) {
+		my @input      = split("\n", $self->{source});
+		my $lineNumber = 1;
+		for my $line (@input) {
 			chomp($line);
 			push(@PROBLEM_TEXT_OUTPUT, "$lineNumber\t\t$line\r\n");
 			$lineNumber++;
 		}
-		push(@PROBLEM_TEXT_OUTPUT, "\n-----
\r\n");
+		push(@PROBLEM_TEXT_OUTPUT, "
\n"); } elsif ($self->{errors}) { - warn "ERRORS in rendering problem: " - . $self->{envir}->{'probNum'} . " |" - . ($self->{envir}->{'probFileName'}) . "| " - . $self->{errors}; - push(@PROBLEM_TEXT_OUTPUT, - qq!\n
        Problem !
-				. $self->{envir}->{'probNum'}
-				. qq!\n2. ERROR caught by Translator while processing this problem
\r\n!); + warn "ERRORS in rendering problem: $self->{envir}{probFileName}\n$self->{errors}"; + push(@PROBLEM_TEXT_OUTPUT, '
ERROR caught by Translator while processing this problem
'); } -=pod - -(6) B - - Returns: - $PG_PROBLEM_TEXT_ARRAY_REF -- Reference to a string containing the rendered text. - $PG_HEADER_TEXT_REF -- Reference to a string containing material to placed in the header (for use by JavaScript) - $PG_POST_HEADER_TEXT_REF -- Reference to a string containing material to placed in body above form (for use by Sage) - $PG_ANSWER_HASH_REF -- Reference to an array containing the answer evaluators. - constructed from keys of $PGcore->{PG_ANSWERS_HASH} - $PG_FLAGS_REF -- Reference to a hash containing flags and other references: - 'error_flag' is set to 1 if there were errors in rendering - $PGcore -- the PGcore object - -=cut - - ## we need to make sure that the other output variables are defined - - ## If the eval failed with errors, one or more of these variables won't be defined. - $PG_ANSWER_HASH_REF = {} unless defined($PG_ANSWER_HASH_REF); - $PG_HEADER_TEXT_REF = \("") unless defined($PG_HEADER_TEXT_REF); - $PG_POST_HEADER_TEXT_REF = \("") unless defined($PG_POST_HEADER_TEXT_REF); - $PG_FLAGS_REF = {} unless defined($PG_FLAGS_REF); - $PG_FLAGS_REF->{'error_flag'} = 1 if $self->{errors}; my $PG_PROBLEM_TEXT = join("", @PROBLEM_TEXT_OUTPUT); $self->{PG_PROBLEM_TEXT_REF} = \$PG_PROBLEM_TEXT; $self->{PG_PROBLEM_TEXT_ARRAY_REF} = \@PROBLEM_TEXT_OUTPUT; - $self->{PG_HEADER_TEXT_REF} = $PG_HEADER_TEXT_REF; - $self->{PG_POST_HEADER_TEXT_REF} = $PG_POST_HEADER_TEXT_REF; - $self->{rh_correct_answers} = $PG_ANSWER_HASH_REF; - $self->{PG_FLAGS_REF} = $PG_FLAGS_REF; - $self->{rh_pgcore} = $PGcore; - #warn "PGcore is ", ref($PGcore), " in Translator"; - #$self ->{errors}; -} # end translate + # Make sure that these variables are defined. If the eval failed with + # errors, one or more of these variables won't be defined. + $self->{PG_HEADER_TEXT_REF} = $PG_HEADER_TEXT_REF // \(''); + $self->{PG_POST_HEADER_TEXT_REF} = $PG_POST_HEADER_TEXT_REF // \(''); + $self->{rh_correct_answers} = $PG_ANSWER_HASH_REF // {}; + $self->{PG_FLAGS_REF} = $PG_FLAGS_REF // {}; + + $self->{rh_pgcore} = $PGcore; + + return; +} -=head2 Answer evaluation methods +=head2 Answer evaluation methods =cut =head3 access methods - $obj->rh_student_answers + $obj->rh_student_answers =cut sub rh_evaluated_answers { - my $self = shift; - my @in = @_; + my ($self, @in) = @_; return $self->{rh_evaluated_answers} if @in == 0; if (ref($in[0]) eq 'HASH') { - $self->{rh_evaluated_answers} = { %{ $in[0] } }; # store a copy of the hash + $self->{rh_evaluated_answers} = { %{ $in[0] } }; } else { - $self->{rh_evaluated_answers} = {@in}; # store a copy of the hash + $self->{rh_evaluated_answers} = {@in}; } - $self->{rh_evaluated_answers}; + return $self->{rh_evaluated_answers}; } sub rh_problem_result { - my $self = shift; - my @in = @_; + my ($self, @in) = @_; return $self->{rh_problem_result} if @in == 0; if (ref($in[0]) eq 'HASH') { - $self->{rh_problem_result} = { %{ $in[0] } }; # store a copy of the hash + $self->{rh_problem_result} = { %{ $in[0] } }; } else { - $self->{rh_problem_result} = {@in}; # store a copy of the hash + $self->{rh_problem_result} = {@in}; } - $self->{rh_problem_result}; + return $self->{rh_problem_result}; } sub rh_problem_state { - my $self = shift; - my @in = @_; + my ($self, @in) = @_; return $self->{rh_problem_state} if @in == 0; if (ref($in[0]) eq 'HASH') { - $self->{rh_problem_state} = { %{ $in[0] } }; # store a copy of the hash + $self->{rh_problem_state} = { %{ $in[0] } }; } else { - $self->{rh_problem_state} = {@in}; # store a copy of the hash + $self->{rh_problem_state} = {@in}; } - $self->{rh_problem_state}; + return $self->{rh_problem_state}; } =head3 process_answers - - $obj->process_answers() - + $obj->process_answers() =cut sub process_answers { - my $self = shift; - my @in = @_; + my ($self, @in) = @_; my %h_student_answers; if (ref($in[0]) eq 'HASH') { - %h_student_answers = %{ $in[0] }; #receiving a reference to a hash of answers + %h_student_answers = %{ $in[0] }; # Receiving a reference to a hash of answers } else { - %h_student_answers = @in; # receiving a hash of answers + %h_student_answers = @in; # Receiving a hash of answers } my $rh_correct_answers = $self->rh_correct_answers(); my @answer_entry_order = @@ -1086,10 +920,9 @@ sub process_answers { ? @{ $self->{PG_FLAGS_REF}->{ANSWER_ENTRY_ORDER} } : keys %{$rh_correct_answers}; - # define custom warn/die handlers for answer evaluation. these used to be inside - # the foreach loop around the conditional involving $rf_fun, but for efficiency - # we've moved it out here. This means that the handlers will be active during the - # code before and after the actual answer evaluation. + # Define custom warn/die handlers for answer evaluation. These used to be inside the for loop around the conditional + # involving $new_rf_fun, but for efficiency we've moved it out here. This means that the handlers will be active + # during the code before and after the actual answer evaluation. my $outer_sig_warn = $SIG{__WARN__}; local $SIG{__WARN__} = sub { @@ -1098,84 +931,45 @@ sub process_answers { : warn PG_errorMessage('message', $_[0]); }; - # the die handler is a closure over %errorTable and $outer_sig_die. + # The die handler is a closure over %errorTable and $outer_sig_die. # - # %errorTable accumulates a "full" error message for each error that occurs during - # answer evaluation. then, right after the evaluation (which is done within a call - # to Safe::reval), $@ is checked and it's value is looked up in %errorTable to get - # the full error to report. + # %errorTable accumulates a "full" error message for each error that occurs during answer evaluation. then, right + # after the evaluation (which is done within a call to Safe::reval), $@ is checked and it's value is looked up in + # %errorTable to get the full error to report. # - # my question: why is this a hash? this is die, so once one occurs, we exit the reval. - # wouldn't it be sufficient to have a scalar like $backtrace_for_last_error? + # my question: Why is this a hash? This is die, so once one occurs, we exit the reval. + # Wouldn't it be sufficient to have a scalar like $backtrace_for_last_error? # # Note that %errorTable is cleared for each answer. my %errorTable; my $outer_sig_die = $SIG{__DIE__}; local $SIG{__DIE__} = sub { - - # this chunk taken from dpvc's original handler my $fullerror = PG_errorMessage('traceback', @_); my ($error, $traceback) = split /\n/, $fullerror, 2; $fullerror =~ s/\n /   /g; $fullerror =~ s/\n//g; $error .= "\n"; $errorTable{$error} = $fullerror; - # end of dpvc's original code ref $outer_sig_die eq "CODE" ? &$outer_sig_die($error) : die $error; }; my $PG = $self->{rh_pgcore}; - # apply each instructors answer to the corresponding student answer - # my $printAnsHash = 1; # this turns on error printing of the answer hashes - - #$PG->debug_message("Student answers are: ", join(" ", %h_student_answers) ) if $printAnsHash==1; - # we will want to redefine the entry order in terms of the answer evaluators - - #### foreach my $ans_name ( @answer_entry_order ) { - #### @answer_entry_order was created from PG_ANSWERS_HASH which maintains the - #### order of its keys - - our ($rf_fun, $temp_ans); our ($new_rf_fun, $new_temp_ans); - foreach my $ans_name (keys %{ $PG->{PG_ANSWERS_HASH} }) { - my $local_debug = 0; #enables reporting of each $ans_name evaluator and responses + for my $ans_name (keys %{ $PG->{PG_ANSWERS_HASH} }) { + my $local_debug = 0; # Enables reporting of each $ans_name evaluator and responses. $PG->debug_message("Executing answer evaluator $ans_name ") if $local_debug; - #################################### - # gather answers (old method) - #################################### - - # local($rf_fun,$temp_ans)= (undef,undef); - # - # my ($ans, $errors) = $self->filter_answer( $h_student_answers{$ans_name} ); - # $temp_ans = $ans; - # $temp_ans = '' unless defined($temp_ans); #make sure that answer is always defined - # # in case the answer evaluator forgets to check - # #################################### - # # get answer evaluator (old method) - # #################################### - # - # if ( defined($rh_correct_answers ->{$ans_name} ) ) { - # $rf_fun = $rh_correct_answers->{$ans_name}; - # } else { - # warn "There is no answer evaluator for the question labeled $ans_name"; - # } - # $self->{safe}->share('$rf_fun','$temp_ans'); - # - #################################### - # gather answers and answer evaluator (new method) - #################################### + # gather answers and answer evaluator local ($new_rf_fun, $new_temp_ans) = (undef, undef); - my $answergrp = - $PG->{PG_ANSWERS_HASH}->{$ans_name}; #this has all answer evaluators AND answer blanks (just to be sure ) + # This has all answer evaluators AND answer blanks (just to be sure). + my $answergrp = $PG->{PG_ANSWERS_HASH}->{$ans_name}; my $responsegrp = $answergrp->response_obj; -################# - # refactor to answer group? -################## + + # Refactor to answer group? $new_rf_fun = $answergrp->ans_eval; my ($ans, $errors) = $self->filter_answer($responsegrp->get_response($ans_name)); - $new_temp_ans = $ans; # avoid undefined errors in translator + $new_temp_ans = $ans; # Avoid undefined errors in translator my $skip_evaluation = 0; if (not defined($new_rf_fun)) { $PG->warning_message("No answer evaluator for the question labeled: $ans_name "); @@ -1183,7 +977,7 @@ sub process_answers { } elsif (not ref($new_rf_fun) =~ /AnswerEvaluator/) { $PG->warning_message( "Error in Translator.pm::process_answers: Answer $ans_name: - Unrecognized evaluator type |" . ref($rf_fun) . "|" + Unrecognized evaluator type |" . ref($new_rf_fun) . "|" ); $skip_evaluation = 1; } @@ -1193,10 +987,11 @@ sub process_answers { } $PG->debug_message("Answers associated with $ans_name are $new_temp_ans ref=" . ref($new_temp_ans)) if defined $new_temp_ans and $local_debug; - #FIXME -- this is a hack for handling check boxes. + + #FIXME: This is a hack for handling check boxes. if (ref($new_temp_ans) =~ /HASH/i) { my @tmp = (); - foreach my $key (sort keys %$new_temp_ans) { + for my $key (sort keys %$new_temp_ans) { push @tmp, $key if $new_temp_ans->{$key} eq 'CHECKED'; } $new_temp_ans = join("\0", @tmp); @@ -1205,117 +1000,59 @@ sub process_answers { . pretty_print($new_temp_ans)) if $local_debug; } - #FIXME -- hack to allow answers such as <4,6,7> -- < and > have been escaped. - unless ($skip_evaluation) { - # $new_temp_ans =~ s/\<\;//g; # > - # $new_temp_ans =~ s/\&\#91\;/\[/g; # < - # $new_temp_ans =~ s/\&\#42\;/\*/g; # * - # $new_temp_ans =~ s/\&\#36\;/\$/g; # $ - # $new_temp_ans =~ s/\&\#39\;/'/g; # ' - # $new_temp_ans =~ s/\&\#95\;/\_/g; # _ - } + $self->{safe}->share('$new_rf_fun', '$new_temp_ans'); - # clear %errorTable for each problem - %errorTable = (); # is the error table being used? perhaps by math objects? + # Clear %errorTable for each problem + %errorTable = (); # Is the error table being used? Perhaps by math objects? my ($rh_ans_evaluation_result, $new_rh_ans_evaluation_result); if (ref($new_rf_fun) eq 'CODE') { - # $rh_ans_evaluation_result = $self->{safe} ->reval( '&{ $rf_fun }($temp_ans, ans_label => \''.$ans_name.'\')' ) ; - # warn "Error in Translator.pm::process_answers: Answer $ans_name: |$temp_ans|\n $@\n" if $@; - $PG->warning_message("Can no longer used CODE objects directly as answer evaluators. Use AnswerEvaluator"); - } elsif (not $skip_evaluation) { -###################################### - # old answer evaluator process -###################################### - # $rh_ans_evaluation_result = $self->{safe} ->reval('$rf_fun->evaluate($temp_ans, ans_label => \''.$ans_name.'\')'); - # $@ = $errorTable{$@} if $@ && defined($errorTable{$@}); #Are we redefining error messages here? - # warn "Error in Translator.pm::process_answers: Answer $ans_name: |$temp_ans|\n $@\n" if $@; - # # The following needs more work for the new rh_ans_evaluation - # warn "Evaluation error: Answer $ans_name:
\n", - # $rh_ans_evaluation_result->error_flag(), " :: ", - # $rh_ans_evaluation_result->error_message(),"
\n" - # if defined($rh_ans_evaluation_result) - # and defined($rh_ans_evaluation_result->error_flag()); - # - # $rh_ans_evaluation_result = {%$rh_ans_evaluation_result}; #needed to protect result - # # from next evaluation apparently -######################################### - - # Get full traceback, but save it in local variable $errorTable so that - # we can add it later. This is because some evaluators use - # eval to trap errors and then report them in the message - # column of the results table, and we don't want to include - # the traceback there. + $PG->warning_message('CODE objects cannot be used directly as answer evaluators. Use AnswerEvaluator'); + } elsif (!$skip_evaluation) { + # Get full traceback, but save it in local variable $errorTable so that we can add it later. This is + # because some evaluators use eval to trap errors and then report them in the message column of the results + # table, and we don't want to include the traceback there. $new_rh_ans_evaluation_result = $self->{safe}->reval('$new_rf_fun->evaluate($new_temp_ans, ans_label => \'' . $ans_name . '\')'); - $@ = $errorTable{$@} if $@ && defined($errorTable{$@}); #Are we redefining error messages here? - # warn "Error in Translator.pm:: (new) process_answers: Answer $ans_name: |$temp_ans|\n $@\n" if $@; - # The following needs more work for the new rh_ans_evaluation + $@ = $errorTable{$@} if $@ && defined $errorTable{$@}; # Are we redefining error messages here? + + # The following needs more work for the new rh_ans_evaluation if (ref($new_rh_ans_evaluation_result) =~ /AnswerHash/i) { $PG->warning_message( "Evaluation error in new process: Answer $ans_name:
\n", $new_rh_ans_evaluation_result->error_flag(), - " :: ", $new_rh_ans_evaluation_result->error_message(), "
\n" + ' :: ', $new_rh_ans_evaluation_result->error_message(), "
\n" ) - if defined($new_rh_ans_evaluation_result) - && ref($new_rh_ans_evaluation_result) - && defined($new_rh_ans_evaluation_result->error_flag()); + if defined $new_rh_ans_evaluation_result + && ref $new_rh_ans_evaluation_result + && defined $new_rh_ans_evaluation_result->error_flag(); } else { - $PG->warning_message(" The evaluated answer is not an answer hash " + $PG->warning_message(' The evaluated answer is not an answer hash ' . ($new_rh_ans_evaluation_result // '') . ': |' . ref($new_rh_ans_evaluation_result) - . "|."); + . '|.'); } -# $PG->debug_message( $self->{envir}->{'probFileName'} ." new_temp_ans and temp_ans don't agree: ". -# ref($new_temp_ans)." $new_temp_ans ". ref($temp_ans). " $temp_ans".length($new_temp_ans).length($temp_ans)) -# unless $new_temp_ans eq $temp_ans; } else { - $PG->warning_message("Answer evaluator $ans_name was not executed due to errors. ", "========"); + $PG->warning_message("Answer evaluator $ans_name was not executed due to errors. ", '========'); } -######################################################### - # End refactor to answer group ? -############################################# - -######################################################### - # check that old and new answers are the same - # foreach my $key (keys %$rh_ans_evaluation_result) { - # next unless defined $key; - # #warn ref($rh_ans_evaluation_result->{$key}) if $key eq 'student_formula'; - # next if $key eq 'student_formula'; #FIXME hack -- problem evaluating student_formula for fractions - # next unless defined($rh_ans_evaluation_result->{$key}); - # $PG->debug_message($self->{envir}->{'probFileName'} ." '$key' are not the same. old: ". - # $rh_ans_evaluation_result->{$key}." new: ".$new_rh_ans_evaluation_result->{$key}) - # unless $rh_ans_evaluation_result->{$key} eq $new_rh_ans_evaluation_result->{$key}; - # } - -######################################################### -#$PG->debug_message("old $ans_name: $rf_fun -- ans: $temp_ans",pretty_print($rh_ans_evaluation_result)) if $printAnsHash==1; + # End refactor to answer group? + $PG->debug_message( "new $ans_name: $new_rf_fun -- ans: $new_temp_ans", pretty_print($new_rh_ans_evaluation_result) - ) - if ($PG->{envir}->{inputs_ref}->{showAnsHashInfo}) // '' - and ($PG->{envir}->{permissionLevel}) // 0 >= 10; -######################################################### + ) if $PG->{envir}{inputs_ref}{showAnsHashInfo} && $PG->{envir}{show_answer_hash_info}; - # decide whether to return the new or old answer evaluator hash + # Decide whether to return the new or old answer evaluator hash $rh_ans_evaluation_result = $new_rh_ans_evaluation_result; - # This warning may not be needed. - # unless ( ( ref($rh_ans_evaluation_result) eq 'HASH') or ( ref($rh_ans_evaluation_result) eq 'AnswerHash') ) { - # warn "Error in Translator.pm::process_answers: Answer $ans_name:
\n - # Answer evaluators must return a hash or an AnswerHash type, not type |", - # ref($rh_ans_evaluation_result), "|"; - # } $rh_ans_evaluation_result->{ans_message} .= "$errors \n" if $errors; $rh_ans_evaluation_result->{ans_name} = $ans_name; $self->{rh_evaluated_answers}->{$ans_name} = $rh_ans_evaluation_result; } - $self->rh_evaluated_answers; + return $self->rh_evaluated_answers; } sub stringify_answers { @@ -1323,153 +1060,109 @@ sub stringify_answers { no strict; local $rh_answers = $self->{rh_evaluated_answers}; $self->{safe}->share('$rh_answers'); - $self->{safe}->reval(<<' END_EVAL;'); - (sub { - foreach my $label (keys %$rh_answers) { - $rh_answers->{$label}->stringify_hash if ref($rh_answers->{$label}) =~ m/AnswerHash/; - } - })->(); - END_EVAL; + $self->{safe}->reval(<<'END_EVAL;'); +(sub { + for my $label (keys %$rh_answers) { + $rh_answers->{$label}->stringify_hash if ref($rh_answers->{$label}) =~ m/AnswerHash/; + } +})->(); +END_EVAL; die $@ if $@; + use strict; + + return; } =head3 grade_problem - $obj->rh_problem_state(%problem_state); # sets the current problem state - $obj->grade_problem(%form_options); - + $obj->rh_problem_state(%problem_state); # sets the current problem state + $obj->grade_problem(%form_options); =cut sub grade_problem { - my $self = shift; + my ($self, %options) = @_; + no strict; - local %rf_options = @_; + + local %rf_options = %options; local $rf_grader = $self->{rf_problem_grader}; local $rh_answers = $self->{rh_evaluated_answers}; local $rh_state = $self->{rh_problem_state}; $self->{safe}->share('$rf_grader', '$rh_answers', '$rh_state', '%rf_options'); -############################################ - # - # FIXME - # warning messages are not being transmitted from this evaluation - # ?????? -############################################ + # FIXME: Warning messages are not being transmitted from this evaluation. ($self->{rh_problem_result}, $self->{rh_problem_state}) = - $self->{safe}->reval('&{$rf_grader}($rh_answers,$rh_state,%rf_options)'); + $self->{safe}->reval('&{$rf_grader}($rh_answers, $rh_state, %rf_options)'); + use strict; + die $@ if $@; $self->stringify_answers; - ($self->{rh_problem_result}, $self->{rh_problem_state}); + return ($self->{rh_problem_result}, $self->{rh_problem_state}); } +# These are models for plug-in problem graders. + sub rf_std_problem_grader { my $self = shift; return \&std_problem_grader; } -sub old_std_problem_grader { - my $rh_evaluated_answers = shift; - my %flags = @_; # not doing anything with these yet - my %evaluated_answers = %{$rh_evaluated_answers}; - my $allAnswersCorrectQ = 1; - foreach my $ans_name (keys %evaluated_answers) { - # I'm not sure if this check is really useful. - if (ref($evaluated_answers{$ans_name}) eq 'HASH') { - $allAnswersCorrectQ = 0 unless (1 == $evaluated_answers{$ans_name}->{score}); - } else { - warn "Error: Answer $ans_name is not a hash"; - warn "$evaluated_answers{$ans_name}"; - } - } - # Notice that "all answers are correct" if there are no questions. - { - score => $allAnswersCorrectQ, - prev_tries => 0, - partial_credit => $allAnswersCorrectQ, - errors => "", - type => 'old_std_problem_grader', - flags => {}, # not doing anything with these yet - }; # hash output - -} +sub std_problem_grader { + my ($rh_evaluated_answers, $rh_problem_state, %form_options) = @_; -##################################### -# This is a model for plug-in problem graders -##################################### + my %evaluated_answers = %{$rh_evaluated_answers}; -sub std_problem_grader { - my $rh_evaluated_answers = shift; - my $rh_problem_state = shift; - my %form_options = @_; - my %evaluated_answers = %{$rh_evaluated_answers}; - # The hash $rh_evaluated_answers typically contains: - # 'answer1' => 34, 'answer2'=> 'Mozart', etc. - - # By default the old problem state is simply passed back out again. + # By default the old problem state is simply passed back out again. my %problem_state = %$rh_problem_state; - # %form_options might include - # The user login name - # The permission level of the user - # The studentLogin name for this psvn. - # Whether the form is asking for a refresh or is submitting a new answer. - - # initial setup of the answer + # Initial setup of the answer. my %problem_result = ( score => 0, errors => '', type => 'std_problem_grader', msg => '', ); - # Checks - my $ansCount = keys %evaluated_answers; # get the number of answers + my $ansCount = keys %evaluated_answers; unless ($ansCount > 0) { - $problem_result{msg} = "This problem did not ask any questions."; + $problem_result{msg} = 'This problem did not ask any questions.'; return (\%problem_result, \%problem_state); } - if ($ansCount > 1) { - $problem_result{msg} = 'In order to get credit for this problem all answers must be correct.'; - } + $problem_result{msg} = 'In order to get credit for this problem all answers must be correct.' + if $ansCount > 1; - unless (defined($form_options{answers_submitted}) and $form_options{answers_submitted} == 1) { - return (\%problem_result, \%problem_state); - } + return (\%problem_result, \%problem_state) + unless defined $form_options{answers_submitted} && $form_options{answers_submitted} == 1; my $allAnswersCorrectQ = 1; - foreach my $ans_name (keys %evaluated_answers) { - # I'm not sure if this check is really useful. - if ((ref($evaluated_answers{$ans_name}) eq 'HASH') or (ref($evaluated_answers{$ans_name}) eq 'AnswerHash')) { - $allAnswersCorrectQ = 0 unless (1 == $evaluated_answers{$ans_name}->{score}); + for my $ans_name (keys %evaluated_answers) { + if (ref $evaluated_answers{$ans_name} eq 'HASH' or ref $evaluated_answers{$ans_name} eq 'AnswerHash') { + $allAnswersCorrectQ = 0 unless $evaluated_answers{$ans_name}->{score} == 1; } else { warn "Error: Answer $ans_name is not a hash"; warn "$evaluated_answers{$ans_name}"; - warn "This probably means that the answer evaluator is for this answer is not working correctly."; + warn 'This probably means that the answer evaluator for this answer is not working correctly.'; $problem_result{error} = "Error: Answer $ans_name is not a hash: $evaluated_answers{$ans_name}"; } } - # report the results + + # Report the results. $problem_result{score} = $allAnswersCorrectQ; + $problem_state{recorded_score} //= 0; - # I don't like to put in this bit of code. - # It makes it hard to construct error free problem graders - # I would prefer to know that the problem score was numeric. - unless ($problem_state{recorded_score} =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) { - $problem_state{recorded_score} = 0; # This gets rid of non-numeric scores - } - # - if ($allAnswersCorrectQ == 1 or $problem_state{recorded_score} == 1) { + if ($allAnswersCorrectQ == 1 || $problem_state{recorded_score} == 1) { $problem_state{recorded_score} = 1; } else { $problem_state{recorded_score} = 0; } - $problem_state{num_of_correct_ans}++ if $allAnswersCorrectQ == 1; - $problem_state{num_of_incorrect_ans}++ if $allAnswersCorrectQ == 0; - (\%problem_result, \%problem_state); + ++$problem_state{num_of_correct_ans} if $allAnswersCorrectQ == 1; + ++$problem_state{num_of_incorrect_ans} if $allAnswersCorrectQ == 0; + + return (\%problem_result, \%problem_state); } sub rf_avg_problem_grader { @@ -1478,23 +1171,14 @@ sub rf_avg_problem_grader { } sub avg_problem_grader { - my $rh_evaluated_answers = shift; - my $rh_problem_state = shift; - my %form_options = @_; - my %evaluated_answers = %{$rh_evaluated_answers}; - # The hash $rh_evaluated_answers typically contains: - # 'answer1' => 34, 'answer2'=> 'Mozart', etc. - - # By default the old problem state is simply passed back out again. - my %problem_state = %$rh_problem_state; + my ($rh_evaluated_answers, $rh_problem_state, %form_options) = @_; - # %form_options might include - # The user login name - # The permission level of the user - # The studentLogin name for this psvn. - # Whether the form is asking for a refresh or is submitting a new answer. + my %evaluated_answers = %{$rh_evaluated_answers}; - # initial setup of the answer + # By default the old problem state is simply passed back out again. + my %problem_state = %$rh_problem_state; + + # Initial setup of the answer my $total = 0; my %problem_result = ( score => 0, @@ -1502,32 +1186,36 @@ sub avg_problem_grader { type => 'avg_problem_grader', msg => '', ); + my $count = keys %evaluated_answers; $problem_result{msg} = 'You can earn partial credit on this problem.' if $count > 1; - # Return unless answers have been submitted - unless ($form_options{answers_submitted} == 1) { - return (\%problem_result, \%problem_state); - } + + return (\%problem_result, \%problem_state) unless $form_options{answers_submitted} == 1; + # Answers have been submitted -- process them. - foreach my $ans_name (keys %evaluated_answers) { - $total += $evaluated_answers{$ans_name}->{score}; + for my $ans_name (keys %evaluated_answers) { + $total += $evaluated_answers{$ans_name}{score}; } + # Calculate score rounded to three places to avoid roundoff problems - $problem_result{score} = ($count) ? $total / $count : 0; # give zero if no answers have been evaluated. - # increase recorded score if the current score is greater. - $problem_state{recorded_score} = 0 unless defined $problem_state{recorded_score}; - $problem_state{recorded_score} = $problem_result{score} if $problem_result{score} > $problem_state{recorded_score}; + $problem_result{score} = $count ? $total / $count : 0; + $problem_state{recorded_score} //= 0; + + # Increase recorded score if the current score is greater. + $problem_state{recorded_score} = $problem_result{score} + if $problem_result{score} > $problem_state{recorded_score}; + + ++$problem_state{num_of_correct_ans} if $total == $count; + ++$problem_state{num_of_incorrect_ans} if $total < $count; - $problem_state{num_of_correct_ans}++ if $total == $count; - $problem_state{num_of_incorrect_ans}++ if $total < $count; warn "Error in grading this problem the total $total is larger than $count" if $total > $count; - (\%problem_result, \%problem_state); + return (\%problem_result, \%problem_state); } =head3 safetyFilter - ($filtered_ans, $errors) = $obj ->filter_ans($ans) + ($filtered_ans, $errors) = $obj ->filter_ans($ans) $obj ->rf_safety_filter() =cut @@ -1537,47 +1225,41 @@ sub filter_answer { my $ans = shift; my @filtered_answers; my $errors = ''; - if (ref($ans) eq 'ARRAY') { #handle the case where the answer comes from several inputs with the same name - # In many cases this will be passed as a reference to an array - # if it is passed as a single string (separated by \0 characters) as - # some early versions of CGI behave, then - # it is unclear what will happen when the answer is filtered. - foreach my $item (@{$ans}) { + if (ref($ans) eq 'ARRAY') { + # Handle the case where the answer comes from several inputs with the same name. In many cases this will be + # passed as a reference to an array. If it is passed as a single string (separated by \0 characters) as some + # early versions of CGI behave, then it is unclear what will happen when the answer is filtered. + for my $item (@{$ans}) { my ($filtered_ans, $error) = &{ $self->{rf_safety_filter} }($item); push(@filtered_answers, $filtered_ans); - $errors .= " " . $error if $error; # add error message if error is non-zero. + $errors .= ' ' . $error if $error; # Add error message if error is non-zero. } - (\@filtered_answers, $errors); - + return (\@filtered_answers, $errors); } else { - &{ $self->{rf_safety_filter} }($ans); + return &{ $self->{rf_safety_filter} }($ans); } - } sub rf_safety_filter { my $self = shift; my $rf_filter = shift; - $self->{rf_safety_filter} = $rf_filter if $rf_filter and ref($rf_filter) eq 'CODE'; - warn "The safety_filter must be a reference to a subroutine" unless ref($rf_filter) eq 'CODE'; - $self->{rf_safety_filter}; + $self->{rf_safety_filter} = $rf_filter if $rf_filter && ref $rf_filter eq 'CODE'; + warn 'The safety_filter must be a reference to a subroutine' unless ref $rf_filter eq 'CODE'; + return $self->{rf_safety_filter}; } sub safetyFilter { - my $answer = shift; # accepts one answer and checks it + my $answer = shift; # Accepts one answer and checks it my $submittedAnswer = $answer; $answer = '' unless defined $answer; - my ($errorno); + my $errorno; $answer =~ tr/\000-\037/ /; - #### Return if answer field is empty ######## + # Return if answer field is empty. unless ($answer =~ /\S/) { - # $errorno = "
No answer was submitted."; - $errorno = 0; ## don't report blank answer as error - return ($answer, $errorno); + # Don't report blank answer as error. + return ($answer, 0); } - ######### replace ^ with ** (for exponentiation) - # $answer =~ s/\^/**/g; - ######### Return if forbidden characters are found + # Return if forbidden characters are found. unless ($answer =~ /^[a-zA-Z0-9_\-\+ \t\/@%\*\.\n^\(\)]+$/) { $answer =~ tr/a-zA-Z0-9_\-\+ \t\/@%\*\.\n^\(\)/#/c; $errorno = "
There are forbidden characters in your answer: $submittedAnswer
"; @@ -1588,20 +1270,6 @@ sub safetyFilter { return ($answer, $errorno); } -## Check submittedAnswer for forbidden characters, etc. -# ($submittedAnswer,$errorno) = safetyFilter($submittedAnswer); -# $errors .= "No answer was submitted.
" if $errorno == 1; -# $errors .= "There are forbidden characters in your answer: $submittedAnswer
" if $errorno ==2; -# -## Check correctAnswer for forbidden characters, etc. -# unless (ref($correctAnswer) ) { #skip check if $correctAnswer is a function -# ($correctAnswer,$errorno) = safetyFilter($correctAnswer); -# $errors .= "No correct answer is given in the statement of the problem. -# Please report this to your instructor.
" if $errorno == 1; -# $errors .= "There are forbidden characters in the problems answer. -# Please report this to your instructor.
" if $errorno == 2; -# } - =head2 PGsort Because of the way sort is optimized in Perl, the symbols $a and $b @@ -1616,72 +1284,37 @@ If C is used in a problem, before the sort routine is defined in a macro things get badly confused. To correct this the macro PGsort is defined below. It is evaluated before the problem template is read. In PGbasicmacros.pl, the two subroutines - PGsort sub { $_[0] < $_[1] }, @list; - PGsort sub { $_[0] lt $_[1] }, @list; + PGsort sub { $_[0] < $_[1] }, @list; + PGsort sub { $_[0] lt $_[1] }, @list; (called num_sort and lex_sort) provide slightly slower, but safer, routines for the PG language. (The subroutines for ordering are B. Note the commas!) =cut -# This sort can cause troubles because of its special use of $a and $b. -# In particular ANS( ans_eva1 ans_eval2) caused trouble. -# One answer at a time did not --- very strange. -# This was replaced by a quick sort routine because the original subroutine -# did not work with Safe when Perl was built with ithreads +sub PGsort { + my ($cmp, @list) = @_; + die "Must supply an ordering function with PGsort: PGsort sub {\$_[0] < \$_[1] }, \@list\n" + unless ref $cmp eq 'CODE'; -#sub PGsort { -# my $sort_order = shift; -# die "Must supply an ordering function with PGsort: PGsort sub {\$a cmp \$b }, \@list\n" unless ref($sort_order) eq 'CODE'; -# sort {&$sort_order($a,$b)} @_; -#} + return if @list == 0; -# quicksort -sub PGsort { - my $cmp = shift; - die "Must supply an ordering function with PGsort: PGsort sub {\$_[0] < \$_[1] }, \@list\n" - unless ref($cmp) eq 'CODE'; - if (@_ == 0) { return () } - else { - my $b_item = shift; - my ($small, $large); - my $a_item; - for $a_item (@_) { - push @{ &$cmp($a_item, $b_item) ? $small : $large }, $a_item; - } - return (PGsort($cmp, @$small), $b_item, PGsort($cmp, @$large)); + my $b_item = shift @list; + my ($small, $large); + for my $a_item (@list) { + push @{ &$cmp($a_item, $b_item) ? $small : $large }, $a_item; } + return PGsort($cmp, @$small), $b_item, PGsort($cmp, @$large); } -=head2 includePGtext - - includePGtext($string_ref, $envir_ref) - -This is now defined in PG::IO.pm - -=cut - -#this is a method for importing additional PG files from within one PG file. -# sub includePGtext { -# my $self = shift; -# my $string_ref =shift; -# my $envir_ref = shift; -# $self->environment($envir_ref); -# $self->createPGtext($string_ref); -# } -# evaluation macros - -no strict; # this is important -- I guess because eval operates on code which is not written with strict in mind. - =head2 PG_restricted_eval - PG_restricted_eval($string) + PG_restricted_eval($string) Evaluated in package 'main'. Result of last statement is returned. When called from within a safe compartment the safe compartment package is 'main'. - =cut # Remember, eval STRING evaluates code in the current lexical context, so any @@ -1689,7 +1322,17 @@ is 'main'. # move the actual eval into a helper function called PG_restricted_eval_helper, # which doesn't need to have any lexicals. sub PG_restricted_eval { - my $string = shift; + my $string = shift; + + my $outer_sig_warn = $SIG{__WARN__}; + local $SIG{__WARN__} = sub { + # Note that the second argument to outer_sig_warn is 1 so that these warnings will not be shown to students. + ref $outer_sig_warn eq 'CODE' + ? &$outer_sig_warn(PG_errorMessage('traceback', $_[0]), 1) + : warn PG_errorMessage('traceback', $_[0]); + }; + local $SIG{__DIE__} = 'DEFAULT'; + my $out = PG_restricted_eval_helper($string); my $err = $@; my $err_report = $err if $err =~ /\S/; @@ -1698,34 +1341,67 @@ sub PG_restricted_eval { # This is a helper that doesn't use any lexicals. See above. sub PG_restricted_eval_helper { + my $code = shift; + no strict; - local $SIG{__WARN__} = "DEFAULT"; - local $SIG{__DIE__} = "DEFAULT"; - return eval("package main;\n" . $_[0]); + + # Many macros redefine methods using PG_restricted_eval. This hides those warnings. + no warnings 'redefine'; + + return eval("package main;\n$code"); } -sub PG_macro_file_eval { # would like to modify this so that it requires use strict on the files that it evaluates. - my $string = shift; +sub PG_macro_file_eval { + my ($string, $filePath) = @_; + + my $outer_sig_warn = $SIG{__WARN__}; + my $warnings = ''; + local $SIG{__WARN__} = sub { $warnings .= $_[0]; }; + + local $SIG{__DIE__} = 'DEFAULT'; + + my ($out, $errors) = + PG_macro_file_eval_helper('package main; be_strict();' + . 'BEGIN { my $eval = __FILE__; $main::envir{__files__}{$eval} = "' + . $filePath . '" };' . "\n" + . $string); + + if ($warnings) { + # Send these files to the outer warning signal handler so the (eval nnn) will be replaced with the filename. + # Note that the second argument t outer_sig_warn is 1 so that these warnings will not be shown to students. + ref $outer_sig_warn eq 'CODE' ? &$outer_sig_warn($warnings, 1) : warn $warnings; + } + my ($pck, $file, $line) = caller; + my $full_error_report = ''; + $full_error_report = + "PG_macro_file_eval detected error at line $line of file $file\n${errors}\nThe calling package is $pck\n" + if defined $errors && $errors =~ /\S/; + + return (wantarray) ? ($out, $errors, $full_error_report) : $out; +} - local $SIG{__WARN__} = "DEFAULT"; - local $SIG{__DIE__} = "DEFAULT"; +# This is another helper that doesn't use any lexicals. +# It would nice to be able to remove the "no strict" call so "use strict" applies to the files that it evaluates. +# Note that the "be_strict" method is not the same. +sub PG_macro_file_eval_helper { + my $string = shift; no strict; - my $out = eval("package main; be_strict();\n" . $string); + # Many subroutines are redefined in macros. In addition if multiple WeBWorK::PG::Translator instances are created + # in the same process, the safe compartment is not entirely isolated between instances, and this causes redefine + # warnings if a macro is loaded in both instances. So those warnings are disabled. + no warnings 'redefine'; + my $out = eval($string); my $errors = $@; - my $full_error_report = - "PG_macro_file_eval detected error at line $line of file $file \n" . $errors . "The calling package is $pck\n" - if defined($errors) && $errors =~ /\S/; use strict; - return (wantarray) ? ($out, $errors, $full_error_report) : $out; + return ($out, $errors); } =head2 PG_answer_eval - - PG_answer_eval($string) + PG_answer_eval($string) Evaluated in package defined by the current safe compartment. Result of last statement is returned. @@ -1739,22 +1415,18 @@ since at some point one might like to make the answer evaluations more stringent =cut sub PG_answer_eval { - my ($string) = shift; # I made this local just in case -- see PG_restricted_eval + my $string = shift; + my $errors = ''; my $full_error_report = ''; my ($pck, $file, $line) = caller; - # Because of the global variable $PG::compartment_name and $PG::safe_cmpt - # only one problem safe compartment can be active at a time. - # This might cause problems at some point. In that case a cleverer way - # of insuring that the package stays in scope until the answer is evaluated - # will be required. - # This is pretty tricky and doesn't always work right. - # We seem to need PG_priv instead of main when PG_answer_eval is called within a completion - # 'package PG_priv; ' + # Because of the global variable $PG::compartment_name and $PG::safe_cmpt only one problem safe compartment can be + # active at a time. This might cause problems at some point. In that case a cleverer way of insuring that the + # package stays in scope until the answer is evaluated will be required. local $SIG{__WARN__} = sub { die(@_) }; # make warn die, so all errors are reported. - local $SIG{__DIE__} = "DEFAULT"; + local $SIG{__DIE__} = 'DEFAULT'; no strict; my $out = eval('package main;' . $string); @@ -1766,23 +1438,12 @@ sub PG_answer_eval { use strict; return (wantarray) ? ($out, $errors, $full_error_report) : $out; - } -# sub original_preprocess_code { -# my $evalString = shift; -# # BEGIN_TEXT and END_TEXT must occur on a line by themselves. -# $evalString =~ s/\n\s*END_TEXT[\s;]*\n/\nEND_TEXT\n/g; -# $evalString =~ s/\n\s*BEGIN_TEXT[\s;]*\n/\nTEXT\(EV3\(<<'END_TEXT'\)\);\n/g; -# $evalString =~ s/ENDDOCUMENT.*/ENDDOCUMENT();/s; # remove text after ENDDOCUMENT -# -# $evalString =~ s/\\/\\\\/g; # \ can't be used for escapes because of TeX conflict -# $evalString =~ s/~~/\\/g; # use ~~ as escape instead, use # for comments -# $evalString; -# } sub default_preprocess_code { my $evalString = shift // ''; - # BEGIN_TEXT and END_TEXT must occur on a line by themselves. + + # BEGIN_TEXT, END_TEXT, and the others that follow must occur on a line by themselves. $evalString =~ s/\n\h*END_TEXT[\h;]*\n/\nEND_TEXT\n/g; $evalString =~ s/\n\h*END_PGML[\h;]*\n/\nEND_PGML\n/g; $evalString =~ s/\n\h*END_PGML_SOLUTION[\h;]*\n/\nEND_PGML_SOLUTION\n/g; @@ -1795,70 +1456,23 @@ sub default_preprocess_code { $evalString =~ s/\n\h*BEGIN_PGML_HINT[\h;]*\n/\nHINT\(PGML::Format2\(<<'END_PGML_HINT'\)\);\n/g; $evalString =~ s/\n\h*BEGIN_SOLUTION[\h;]*\n/\nSOLUTION\(EV3P\(<<'END_SOLUTION'\)\);\n/g; $evalString =~ s/\n\h*BEGIN_HINT[\h;]*\n/\nHINT\(EV3P\(<<'END_HINT'\)\);\n/g; - $evalString =~ s/ENDDOCUMENT.*/ENDDOCUMENT();/s; # remove text after ENDDOCUMENT $evalString =~ s/\n\h*(.*)\h*->\h*BEGIN_TIKZ[\h;]*\n/\n$1->tex\(<\h*BEGIN_LATEX_IMAGE[\h;]*\n/\n$1->tex\(<\n"; - - while (($varName, $globValue) = each %stash) { - emit "$varName\n"; - - *alias = $globValue; - next if $varName =~ /main/; - - #if (defined($alias) ) { # get rid of defined since this is deprecated - if ($alias) { - emit " \$$varName $alias \n"; - } - - if (@alias) { - emit " \@$varName @alias \n"; - } - if (%alias) { - emit " %$varName \n"; - foreach $key (keys %alias) { - emit " $key => $alias{$key}\n"; - } - } - } - emit ""; - + return $evalString_ref; } -use strict; -#### for error checking and debugging purposes -# sub pretty_print_rh { -# my $rh = shift; -# foreach my $key (sort keys %{$rh}) { -# warn " $key => ",$rh->{$key},"\n"; -# } -# } -# end evaluation subroutines 1; diff --git a/lib/chromatic/color.c b/lib/chromatic/color.c deleted file mode 100644 index 1a53aa21c6..0000000000 --- a/lib/chromatic/color.c +++ /dev/null @@ -1,567 +0,0 @@ -/* - * The author of this software is Michael Trick. Copyright (c) 1994 by - * Michael Trick. - * - * Permission to use, copy, modify, and distribute this software for any - * purpose without fee is hereby granted, provided that this entire notice - * is included in all copies of any software which is or includes a copy - * or modification of this software and in all copies of the supporting - * documentation for such software. - * THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED - * WARRANTY. IN PARTICULAR, NEITHER THE AUTHOR DOES NOT MAKE ANY - * REPRESENTATION OR WARRANTY OF ANY KIND CONCERNING THE MERCHANTABILITY - * OF THIS SOFTWARE OR ITS FITNESS FOR ANY PARTICULAR PURPOSE. - */ - -/* - COLOR.C: Easy code for graph coloring - Author: Michael A. Trick, Carnegie Mellon University, trick+@cmu.edu - Last Modified: November 2, 1994 - - -Graph is input in a file. First line contains the number of nodes and -edges. All following contain the node numbers (from 1 to n) incident to -each edge. Sample: - -4 4 -1 2 -2 3 -3 4 -1 4 - -represents a four node cycle graph. - -Code is probably insufficiently debugged, but may be useful to some people. - -For more information on this code, see Anuj Mehrotra and Michael A. Trick, -"A column generation approach to graph coloring", GSIA Technical report series. - -*/ - -#include -#include -#include -#include -#include - -#define MAX_RAND (2.0*(1 << 30)) -#define MAX_NODE 600 -#define TRUE 1 -#define FALSE 0 -#define INF 100000.0 - -struct tms buffer; /* structure for timing */ -int current_time,start_time; -double utime; - -int adj[MAX_NODE][MAX_NODE]; -int BestColoring; -int num_node; -int ColorClass[MAX_NODE]; -int prob_count; -int Order[MAX_NODE]; -int Handled[MAX_NODE]; -int ColorAdj[MAX_NODE][MAX_NODE]; -int ColorCount[MAX_NODE]; -int lb; -int num_prob,max_prob; - - -int best_clique; - - -int greedy_clique(valid,clique) -int *valid,*clique; - -{ - int i,j,k; - int max; - int place,done; - int *order; - int weight[MAX_NODE]; - - for (i=0;i max_prob) return -1; - for (j=0;j=target) return incumb; - if (incumb > best_clique) { - best_clique=incumb; -/* printf("Clique of size %5d found.\n",best_clique);*/ - } -/* printf("Greedy gave %f\n",incumb);*/ - - place = 0; - for (i=0;i incumb) { -/* printf("Taking new\n");*/ - incumb = new_weight+1; - for (k=0;k best_clique) { - best_clique=incumb; -/* printf("Clique of size %5d found.\n",best_clique);*/ - } - } - - /* else printf("Taking incumb\n");*/ - free(valid1); - free(clique1); - if (incumb >=target) break; - } - free(order); - return(incumb); -} - - - -AssignColor(node,color) -int node,color; - -{ - int node1; - -/* printf(" %d color +%d\n",node,color);*/ - ColorClass[node] = color; - for (node1=0;node1=BestColoring) return(current_color); - if (BestColoring <=lb) return(BestColoring); - - if (i >= num_node) return(current_color); -/* printf("Node %d, num_color %d\n",i,current_color);*/ - -/* Find node with maximum color_adj */ - max = -1; - place = -1; - for(k=0;k 0) count++; - if (count!=ColorCount[k]) printf("Trouble with color count\n"); -*/ -/* printf("ColorCount[%3d] = %d\n",k,ColorCount[k]);*/ - if ((ColorCount[k] > max) || ((ColorCount[k]==max)&&(ColorAdj[k][0]>ColorAdj[place][0]))) - { -/* printf("Best now at %d\n",k);*/ - max = ColorCount[k]; - place = k; - } - } - if (place==-1) - { - printf("Graph is disconnected. This code needs to be updated for that case.\n"); - exit(1); - } - - - Order[i] = place; - Handled[place] = TRUE; -/* printf("Using node %d at level %d\n",place,i);*/ - for (j=1;j<=current_color;j++) - { - if (!ColorAdj[place][j]) - { - ColorClass[place] = j; - AssignColor(place,j); - new_val = color(i+1,current_color); - if (new_val < BestColoring){ - BestColoring = new_val; - print_colors(); - } - RemoveColor(place,j); - if (BestColoring<=current_color) { - Handled[place] = FALSE; - return(BestColoring); - } - } - } - if (current_color+1 < BestColoring) - { - ColorClass[place] = current_color+1; - AssignColor(place,current_color+1); - new_val = color(i+1,current_color+1); - if (new_val < BestColoring) { - BestColoring = new_val; - print_colors(); - } - - RemoveColor(place,current_color+1); - } - Handled[place] = FALSE; - return(BestColoring); -} - - - -main(argc,argv) - int argc; - char *argv[]; -{ - FILE *fp; - int m,i,j,k,val; - int valid[MAX_NODE],clique[MAX_NODE]; - int place; - - if (argc < 2) - { - printf("Provide data file in command.\n"); - exit(1); - } - - if ((fp = fopen(argv[1],"r"))==NULL) - { - printf("No such graph as %s\n",argv[1]); - exit(1); - } - - fscanf(fp,"%d %d",&num_node,&m); - for (i=0;i=max_prob) printf(" (not confirmed)\n"); - else printf("\n"); - val = color(place,place); - times(&buffer); - current_time=buffer.tms_utime; - - printf("Best coloring has value %d, subproblems: %d time:%7.1f\n",val,prob_count,(current_time-start_time)/60.0); - -} - - - diff --git a/macros/AppletObjects.pl b/macros/AppletObjects.pl index 15bfcdcde7..c9b94a5f28 100644 --- a/macros/AppletObjects.pl +++ b/macros/AppletObjects.pl @@ -39,44 +39,39 @@ =head3 GeogebraWebApplet sub GeogebraWebApplet { ADD_JS_FILE("https://www.geogebra.org/apps/deployggb.js", 1); - return GeogebraWebApplet->new(@_); + return GeogebraWebAppletBase->new(@_); } # Deprecated applets (these are just stubs to show a warning if used) sub FlashApplet { warn 'Flash applets are no longer supported'; - return Applet->new(type => 'flash'); + return PGApplet->new(type => 'flash'); } sub JavaApplet { warn 'Java applets are no longer supported'; - return Applet->new(type => 'java'); + return PGApplet->new(type => 'java'); } sub CanvasApplet { warn 'Canvas applets are no longer supported'; - return Applet->new(type => 'canvas'); + return PGApplet->new(type => 'canvas'); } -package Applet; +package PGApplet; +our @ISA = qw(Applet); =head1 Methods -=cut - -# This method is defined in this file because it uses methods in PG.pl and PGbasicmacros.pl that -# are not available to Applet.pm when it is compiled (at the time the apache child process is -# first initialized). +This method is defined in this file because it uses methods in PG.pl and PGbasicmacros.pl that +are not available to Applet.pm when it is compiled (at the time the apache child process is +first initialized). =head3 insertAll Useage: TEXT($applet->insertAll()); \{ $applet->insertAll() \} (used within BEGIN_TEXT/END_TEXT blocks) -=cut - -=pod - Inserts applet at this point in the HTML code. (In TeX mode a message "Applet" is written.) This method also adds the applets header material into the header portion of the HTML page. It effectively inserts the outputs of both C<$applet-EinsertHeader> and @@ -112,7 +107,7 @@ sub insertAll { my $getConfig = $self->getConfigAlias; my $setConfig = $self->setConfigAlias; - my $base64_initialState = encode_base64($self->initialState); + my $base64_initialState = $self->base64_encode($self->initialState); # This insures that the state will be saved from one invocation to the next. # FIXME -- with PGcore the persistant data mechanism can be used instead main::RECORD_FORM_LABEL($appletStateName); @@ -138,17 +133,17 @@ sub insertAll { my $base_64_encoded_answer_value; my $decoded_answer_value; if ($answer_value =~ /base64_encode($answer_value); $decoded_answer_value = $answer_value; } else { - $decoded_answer_value = decode_base64($answer_value); + $decoded_answer_value = $self->base64_decode($answer_value); if ($decoded_answer_value =~ /base64_encode($answer_value); $decoded_answer_value = $answer_value; } } @@ -185,6 +180,25 @@ sub insertAll { ); } +# GeogebraWeb APPLET PACKAGE +package GeogebraWebAppletBase; +our @ISA = qw(PGApplet); + +sub new { + my $class = shift; + $class->SUPER::new( + objectText => << 'END_OBJECT_TEXT', +
+END_OBJECT_TEXT + type => 'geogebraweb', + @_ + ); +} + =head3 Example problem DOCUMENT(); diff --git a/macros/CanvasObject.pl b/macros/CanvasObject.pl index e1063ab4fc..7aca86848f 100644 --- a/macros/CanvasObject.pl +++ b/macros/CanvasObject.pl @@ -2,13 +2,13 @@ $appletName = "drawCanvas"; $canvasName = "cv"; +$answerBox //= 'answerBox'; -HEADER_TEXT(< - - - +ADD_JS_FILE('http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js', 1); +ADD_JS_FILE('js/legacy/sketchgraphhtml5b/SketchGraph.pjs'); +ADD_JS_FILE('js/legacy/sketchgraphhtml5b/processing-dgfix.js'); +HEADER_TEXT(< // define your canvasObject here var $appletName = new Object diff --git a/macros/LiveGraphics3D.pl b/macros/LiveGraphics3D.pl index 12319ace54..ad64b0d3bb 100644 --- a/macros/LiveGraphics3D.pl +++ b/macros/LiveGraphics3D.pl @@ -181,8 +181,8 @@ sub Live3Ddata { # $LIVEMESSAGE = MODES( TeX => '', - Latex2HTML => $BCENTER . $BSMALL . "Drag the surface to rotate it" . $ESMALL . $ECENTER, - HTML => $BCENTER . $BSMALL . "Drag the surface to rotate it" . $ESMALL . $ECENTER + Latex2HTML => $BCENTER . "Drag the surface to rotate it" . $ECENTER, + HTML => $BCENTER . "Drag the surface to rotate it" . $ECENTER ); 1; diff --git a/macros/MatrixReduce.pl b/macros/MatrixReduce.pl index fbceb5b237..6f1eb4671f 100644 --- a/macros/MatrixReduce.pl +++ b/macros/MatrixReduce.pl @@ -293,9 +293,9 @@ sub row_add { warn "i = $i, j = $j, r = $r. Index out of bounds in row_add(). Returning original matrix."; return $M; } - if ($s == 0 and $permissionLevel >= 10) { - warn - "Scaling a row by zero is not a valid row operation. (This warning is only shown to professors.) Returning original matrix."; + if ($s == 0 && $envir{view_problem_debugging_info}) { + warn 'Scaling a row by zero is not a valid row operation. ' + . '(This warning is only shown to professors.) Returning original matrix.'; return $M; } @@ -340,8 +340,8 @@ sub row_mult { warn "Index out of bounds in row multiplication. Returning original matrix."; return $M; } - if ($s == 0 and $permissionLevel >= 10) { - warn "Scaling a row by zero is not a valid row operation. (This warning is only shown to professors.)"; + if ($s == 0 && $envir{view_problem_debugging_info}) { + warn 'Scaling a row by zero is not a valid row operation. (This warning is only shown to professors.)'; } my @m = $M->value; foreach my $rowval (@{ $m[ $i - 1 ] }) { $rowval *= $s; } # row multiplication diff --git a/macros/PG.pl b/macros/PG.pl index 19687b6c80..a14b1a1ba0 100644 --- a/macros/PG.pl +++ b/macros/PG.pl @@ -46,7 +46,6 @@ sub DOCUMENT { $ANSWER_PREFIX = $PG->{ANSWER_PREFIX}; $QUIZ_PREFIX = $PG->{QUIZ_PREFIX}; $showPartialCorrectAnswers = $PG->{flags}->{showPartialCorrectAnswers}; - $showHint = $PG->{flags}->{showHint}; $solutionExists = $PG->{flags}->{solutionExists}; $hintExists = $PG->{flags}->{hintExists}; $pgComment = ''; @@ -505,7 +504,6 @@ sub ENDDOCUMENT { $PG->{flags}->{hintExists} = defined($hintExists) ? $hintExists : 0; $PG->{flags}->{solutionExists} = defined($solutionExists) ? $solutionExists : 0; $PG->{flags}->{comment} = defined($pgComment) ? $pgComment : ''; - $PG->{flags}->{showHintLimit} = defined($showHint) ? $showHint : 0; # install problem grader if (defined($PG->{flags}->{PROBLEM_GRADER_TO_USE})) { @@ -545,11 +543,7 @@ sub ENDDOCUMENT { TEXT(MODES(%{ $rh_envir->{problemPostamble} })); @PG_ANSWERS = (); - if ( - 0 or # allow one to force debug output manually - ($inputs_ref->{showResourceInfo}) // '' and ($rh_envir->{permissionLevel}) >= 5 - ) - { + if ($inputs_ref->{showResourceInfo} && $rh_envir->{show_resource_info}) { my %resources = %{ $PG->{PG_alias}->{resource_list} }; my $str = ''; my @resource_names = (); @@ -564,16 +558,11 @@ sub ENDDOCUMENT { $PG->debug_message($summary . $str); } } - if ( - 0 or # allow one to force debug output manually - ($inputs_ref->{showPGInfo} and ($permissionLevel >= 10)) - ) - { + if ($inputs_ref->{showPGInfo} && $rh_envir->{show_pg_info}) { my $context = $$Value::context->{flags}; $PG->debug_message( - "PGbasicmacros.pl 2184: ", $HR, "Form variables", $BR, pretty_print($inputs_ref), $HR, - "Environment variables", $BR, pretty_print(\%envir), $HR, "Context flags", $BR, - pretty_print($context), + $HR, "Form variables", $BR, pretty_print($inputs_ref), $HR, "Environment variables", + $BR, pretty_print(\%envir), $HR, "Context flags", $BR, pretty_print($context), ); } @@ -590,13 +579,9 @@ sub ENDDOCUMENT { # The remainder of the response keys are placed in the EXTRA ANSWERS ARRAY if (defined($answergroup)) { my @response_keys = $answergroup->{response}->response_labels; - if ( - 0 or # allow one to force debug output manually - ($inputs_ref->{showAnsGroupInfo}) // 0 and ($rh_envir->{permissionLevel}) >= 5 - ) - { - $PG->debug_message("PG.pl 418: ", pretty_print($answergroup)); - $PG->debug_message("PG.pl 389: ", pretty_print($answergroup->{response})); + if ($inputs_ref->{showAnsGroupInfo} && $rh_envir->{show_answer_group_info}) { + $PG->debug_message(pretty_print($answergroup)); + $PG->debug_message(pretty_print($answergroup->{response})); } my $response_key = $response_keys[0]; my $answer_key = $answergroup->{ans_label}; @@ -663,10 +648,6 @@ sub findMacroFile { $PG->{PG_alias}->findMacroFile(@_); } -sub check_url { - $PG->{PG_alias}->check_url(@_); -} - sub findAppletCodebase { my $appletName = shift; my $url = eval { $PG->{PG_alias}->findAppletCodebase($appletName) }; @@ -762,18 +743,18 @@ () # (needed for log() to implement $useBaseTenLog) # use subs 'abs', 'sqrt', 'exp', 'log', 'sin', 'cos', 'atan2', 'ParserDefineLog'; -sub abs($) { return CORE::abs($_[0]) } -sub sqrt($) { return CORE::sqrt($_[0]) } -sub exp($) { return CORE::exp($_[0]) } -#sub log($) {return CORE::log($_[0])}; -sub sin($) { return CORE::sin($_[0]) } -sub cos($) { return CORE::cos($_[0]) } -sub atan2($$) { return CORE::atan2($_[0], $_[1]) } +sub abs { return CORE::abs($_[0]) } +sub sqrt { return CORE::sqrt($_[0]) } +sub exp { return CORE::exp($_[0]) } +#sub log {return CORE::log($_[0])}; +sub sin { return CORE::sin($_[0]) } +sub cos { return CORE::cos($_[0]) } +sub atan2 { return CORE::atan2($_[0], $_[1]) } # used to be Parser::defineLog -- but that generated redefined notices sub ParserDefineLog { eval { - sub log($) { CommonFunction->Call("log", @_) } + sub log { CommonFunction->Call("log", @_) } } } @@ -910,7 +891,6 @@ sub includePGproblem { # Reset the problem path so that static images can be found via # their relative paths. eval('$main::envir{probFileName} = $filePath'); - eval('$main::envir{fileName} = $filePath'); # now update the PGalias object my $save_PGalias = $PG->{PG_alias}; my $temp_PGalias = PGalias->new( @@ -1171,10 +1151,6 @@ =head1 USAGE =item * -C: determines the number of attempts after which hint(s) will be shown - -=item * - C: a reference to the chosen problem grader. ENDDOCUMENT chooses the problem grader as follows: diff --git a/macros/PG_CAPAmacros.pl b/macros/PG_CAPAmacros.pl index 8c36fefeac..25f5197396 100644 --- a/macros/PG_CAPAmacros.pl +++ b/macros/PG_CAPAmacros.pl @@ -63,7 +63,6 @@ sub CAPA_import { my $r_string = read_whole_problem_file($filePath); $main::envir{'probFileName'} = $filePath; - $main::envir{'fileName'} = $filePath; includePGtext($r_string); %main::envir = %save_envir; } diff --git a/macros/PG_module_list.pl b/macros/PG_module_list.pl deleted file mode 100644 index 4c98e299a1..0000000000 --- a/macros/PG_module_list.pl +++ /dev/null @@ -1,45 +0,0 @@ - -use PGtranslator; - -=head1 DESCRIPTION - -# defines the modules to be used by PGtranslator - -# This file is read in processProblem, in welcomeAction and in l2hPrecreateSet - -=cut - -PGtranslator->evaluate_modules(qw( Exporter - DynaLoader - GD - WWPlot - Fun - Circle - Label - PGrandom - Units - Hermite - List - Match - Select - Multiple - AlgParser - AnswerHash - Fraction - VectorField - Complex1 - Complex - MatrixReal1 - Matrix - Distributions - Statistics - Regression -)); - -PGtranslator->load_extra_packages(qw( AlgParserWithImplicitExpand - Expr - ExprWithImplicitExpand - AnswerEvaluator -)); - -1; diff --git a/macros/PGanswermacros.pl b/macros/PGanswermacros.pl index c82fa5512c..00546d3805 100644 --- a/macros/PGanswermacros.pl +++ b/macros/PGanswermacros.pl @@ -147,14 +147,6 @@ =head1 DESCRIPTION my $functVarDefault; # ^variable my $useBaseTenLog my $useBaseTenLog; -# ^variable my $reducedScoringDate -my $reducedScoringDate; -# ^variable my $reducedScoringValue -my $reducedScoringValue; -# ^variable my $enable_reduced_scoring -my $enable_reduced_scoring; -# ^variable my $dueDate -my $dueDate; # ^function _PGanswermacros_init # ^uses loadMacros @@ -164,10 +156,6 @@ =head1 DESCRIPTION # ^uses $envir{functULimitDefault} # ^uses $envir{functVarDefault} # ^uses $envir{useBaseTenLog} -# ^uses $envir{reducedScoringDate} -# ^uses $envir{reducedScoringValue} -# ^uses $envir{enable_reduced_scoring} -# ^uses $envir{dueDate} sub _PGanswermacros_init { loadMacros('PGnumericevaluators.pl'); # even if these files are already loaded they need to be initialized. @@ -175,15 +163,11 @@ sub _PGanswermacros_init { loadMacros('PGstringevaluators.pl'); loadMacros('PGmiscevaluators.pl'); - $BR = PG_restricted_eval(q/$BR/); - $functLLimitDefault = PG_restricted_eval(q/$envir{functLLimitDefault}/); - $functULimitDefault = PG_restricted_eval(q/$envir{functULimitDefault}/); - $functVarDefault = PG_restricted_eval(q/$envir{functVarDefault}/); - $useBaseTenLog = PG_restricted_eval(q/$envir{useBaseTenLog}/); - $reducedScoringDate = PG_restricted_eval(q/$envir{reducedScoringDate}/); - $reducedScoringValue = PG_restricted_eval(q/$envir{reducedScoringValue}/); - $enable_reduced_scoring = $reducedScoringDate ? PG_restricted_eval(q/$envir{enable_reduced_scoring}/) : 0; - $dueDate = PG_restricted_eval(q/$envir{dueDate}/); + $BR = PG_restricted_eval(q/$BR/); + $functLLimitDefault = PG_restricted_eval(q/$envir{functLLimitDefault}/); + $functULimitDefault = PG_restricted_eval(q/$envir{functULimitDefault}/); + $functVarDefault = PG_restricted_eval(q/$envir{functVarDefault}/); + $useBaseTenLog = PG_restricted_eval(q/$envir{useBaseTenLog}/); } =head1 MACROS @@ -1459,96 +1443,60 @@ =head4 std_problem_grader and true-false questions, otherwise students will be able to deduce how many answers are correct by the grade reported by webwork. - install_problem_grader(~~&std_problem_grader); =cut -# ^function std_problem_grader sub std_problem_grader { - my $rh_evaluated_answers = shift; - my $rh_problem_state = shift; - my %form_options = @_; - my %evaluated_answers = %{$rh_evaluated_answers}; - # The hash $rh_evaluated_answers typically contains: - # 'answer1' => 34, 'answer2'=> 'Mozart', etc. - - # By default the old problem state is simply passed back out again. - my %problem_state = %$rh_problem_state; + my ($rh_evaluated_answers, $rh_problem_state, %form_options) = @_; + + my %evaluated_answers = %{$rh_evaluated_answers}; - # %form_options might include - # The user login name - # The permission level of the user - # The studentLogin name for this psvn. - # Whether the form is asking for a refresh or is submitting a new answer. + # By default the old problem state is simply passed back out again. + my %problem_state = %$rh_problem_state; - # initial setup of the answer + # Initial setup of the answer my %problem_result = ( score => 0, errors => '', type => 'std_problem_grader', msg => '', ); - # Checks - my $ansCount = keys %evaluated_answers; # get the number of answers + my $ansCount = keys %evaluated_answers; unless ($ansCount > 0) { - - $problem_result{msg} = "This problem did not ask any questions."; + $problem_result{msg} = 'This problem did not ask any questions.'; return (\%problem_result, \%problem_state); } - if ($ansCount > 1) { - $problem_result{msg} = 'In order to get credit for this problem all answers must be correct.'; - } + $problem_result{msg} = 'In order to get credit for this problem all answers must be correct.' if ($ansCount > 1); - unless ($form_options{answers_submitted} == 1) { - return (\%problem_result, \%problem_state); - } + return (\%problem_result, \%problem_state) unless $form_options{answers_submitted} == 1; my $allAnswersCorrectQ = 1; - foreach my $ans_name (keys %evaluated_answers) { - # I'm not sure if this check is really useful. - if ((ref($evaluated_answers{$ans_name}) eq 'HASH') or (ref($evaluated_answers{$ans_name}) eq 'AnswerHash')) { - $allAnswersCorrectQ = 0 unless (1 == $evaluated_answers{$ans_name}->{score}); + for my $ans_name (keys %evaluated_answers) { + if (ref $evaluated_answers{$ans_name} eq 'HASH' || ref $evaluated_answers{$ans_name} eq 'AnswerHash') { + $allAnswersCorrectQ = 0 unless $evaluated_answers{$ans_name}{score} == 1; } else { - die "Error at file ", __FILE__, "line ", __LINE__, - ": Answer |$ans_name| is not a hash reference\n" + die 'Error at file ', __FILE__, 'line ', __LINE__, + ": Answer |$ans_name| is not a hash reference\n" . $evaluated_answers{$ans_name} - . "This probably means that the answer evaluator for this answer\n" - . "is not working correctly."; - $problem_result{error} = "Error: Answer $ans_name is not a hash: $evaluated_answers{$ans_name}"; + . 'This probably means that the answer evaluator for this answer is not working correctly.'; + $problem_result{error} = "Error: Answer $ans_name is not a hash: $evaluated_answers{$ans_name}"; } } - # report the results + + # Report the results $problem_result{score} = $allAnswersCorrectQ; - $problem_state{num_of_correct_ans}++ if $allAnswersCorrectQ == 1; - $problem_state{num_of_incorrect_ans}++ if $allAnswersCorrectQ == 0; - $problem_state{recorded_score} = 0 unless defined $problem_state{recorded_score}; - # Determine if we are in the reduced scoring period and act accordingly - if (!$enable_reduced_scoring or time() < $reducedScoringDate) - { # the reduced scoring period is disabled or it is before the reduced scoring period - # increase recorded score if the current score is greater. - $problem_state{recorded_score} = $problem_result{score} - if $problem_result{score} > $problem_state{recorded_score}; - # the sub_recored_score holds the recored_score before entering the reduced scoring period - $problem_state{sub_recorded_score} = $problem_state{recorded_score}; - } elsif (time() < $dueDate) { # we are in the reduced scoring period. - # student gets credit for all work done before the reduced scoring period plus a portion of work done during period - my $newScore = 0; - $newScore = - $problem_state{sub_recorded_score} + - $reducedScoringValue * ($problem_result{score} - $problem_state{sub_recorded_score}) - if ($problem_result{score} > $problem_state{sub_recorded_score}); - $problem_state{recorded_score} = $newScore if $newScore > $problem_state{recorded_score}; - my $reducedScoringPerCent = int(100 * $reducedScoringValue + .5); - $problem_result{msg} = $problem_result{msg} - . "
You are in the Reduced Scoring Period: All additional work done counts $reducedScoringPerCent\% of the original."; - } + ++$problem_state{num_of_correct_ans} if $allAnswersCorrectQ == 1; + ++$problem_state{num_of_incorrect_ans} if $allAnswersCorrectQ == 0; + $problem_state{recorded_score} //= 0; - $problem_state{state_summary_msg} = ''; # an HTML formatted message printed at the bottom of the problem page + # Increase recorded score if the current score is greater. + $problem_state{recorded_score} = $problem_result{score} + if $problem_result{score} > $problem_state{recorded_score}; (\%problem_result, \%problem_state); } @@ -1560,7 +1508,6 @@ =head4 std_problem_grader2 and true-false questions, otherwise students will be able to deduce how many answers are correct by the grade reported by webwork. - install_problem_grader(~~&std_problem_grader2); The only difference between the two versions @@ -1570,25 +1517,15 @@ =head4 std_problem_grader2 =cut -# ^function std_problem_grader2 sub std_problem_grader2 { - my $rh_evaluated_answers = shift; - my $rh_problem_state = shift; - my %form_options = @_; - my %evaluated_answers = %{$rh_evaluated_answers}; - # The hash $rh_evaluated_answers typically contains: - # 'answer1' => 34, 'answer2'=> 'Mozart', etc. - - # By default the old problem state is simply passed back out again. - my %problem_state = %$rh_problem_state; + my ($rh_evaluated_answers, $rh_problem_state, %form_options) = @_; + + my %evaluated_answers = %{$rh_evaluated_answers}; - # %form_options might include - # The user login name - # The permission level of the user - # The studentLogin name for this psvn. - # Whether the form is asking for a refresh or is submitting a new answer. + # By default the old problem state is simply passed back out again. + my %problem_state = %$rh_problem_state; - # initial setup of the answer + # Initial setup of the answer. my %problem_result = ( score => 0, errors => '', @@ -1596,107 +1533,74 @@ sub std_problem_grader2 { msg => '', ); - # syntax errors are not counted. + # Syntax errors are not counted. my $record_problem_attempt = 1; + # Checks - # FIXME: syntax errors are never checked for so this grader does not perform as advertised + # FIXME: syntax errors are never checked for so this grader does not perform as advertised - my $ansCount = keys %evaluated_answers; # get the number of answers + my $ansCount = keys %evaluated_answers; unless ($ansCount > 0) { - $problem_result{msg} = "This problem did not ask any questions."; + $problem_result{msg} = 'This problem did not ask any questions.'; return (\%problem_result, \%problem_state); } - if ($ansCount > 1) { - $problem_result{msg} = 'In order to get credit for this problem all answers must be correct.'; - } + $problem_result{msg} = 'In order to get credit for this problem all answers must be correct.' if ($ansCount > 1); - unless ($form_options{answers_submitted} == 1) { - return (\%problem_result, \%problem_state); - } + return (\%problem_result, \%problem_state) unless $form_options{answers_submitted} == 1; my $allAnswersCorrectQ = 1; foreach my $ans_name (keys %evaluated_answers) { - # I'm not sure if this check is really useful. - if ((ref($evaluated_answers{$ans_name}) eq 'HASH') or (ref($evaluated_answers{$ans_name}) eq 'AnswerHash')) { + if (ref $evaluated_answers{$ans_name} eq 'HASH' || ref $evaluated_answers{$ans_name} eq 'AnswerHash') { $allAnswersCorrectQ = 0 unless (1 == $evaluated_answers{$ans_name}->{score}); } else { - die "Error at file ", __FILE__, "line ", __LINE__, - ": Answer |$ans_name| is not a hash reference\n" + die 'Error at file ', __FILE__, 'line ', __LINE__, + ": Answer |$ans_name| is not a hash reference\n" . $evaluated_answers{$ans_name} - . "This probably means that the answer evaluator for this answer\n" - . "is not working correctly."; - $problem_result{error} = "Error: Answer $ans_name is not a hash: $evaluated_answers{$ans_name}"; + . 'This probably means that the answer evaluator for this answer is not working correctly.'; + $problem_result{error} = "Error: Answer $ans_name is not a hash: $evaluated_answers{$ans_name}"; } } - # report the results - $problem_result{score} = $allAnswersCorrectQ; - $problem_state{recorded_score} = 0 unless defined $problem_state{recorded_score}; - - # Determine if we are in the reduced scoring period and act accordingly - if (!$enable_reduced_scoring or time() < $reducedScoringDate) - { # the reduced scoring period is disabled or it is before the reduced scoring period - # increase recorded score if the current score is greater. - $problem_state{recorded_score} = $problem_result{score} - if $problem_result{score} > $problem_state{recorded_score}; - # the sub_recored_score holds the recored_score before entering the reduced scoring period - $problem_state{sub_recorded_score} = $problem_state{recorded_score}; - } elsif (time() < $dueDate) { # we are in the reduced scoring period. - # student gets credit for all work done before the reduced scoring period plus a portion of work done during period - my $newScore = 0; - $newScore = - $problem_state{sub_recorded_score} + - $reducedScoringValue * ($problem_result{score} - $problem_state{sub_recorded_score}) - if ($problem_result{score} > $problem_state{sub_recorded_score}); - $problem_state{recorded_score} = $newScore if $newScore > $problem_state{recorded_score}; - my $reducedScoringPerCent = int(100 * $reducedScoringValue + .5); - $problem_result{msg} = $problem_result{msg} - . "
You are in the Reduced Scoring Period: All additional work done counts $reducedScoringPerCent\% of the original."; - } - # record attempt only if there have been no syntax errors. - if ($record_problem_attempt == 1) { - $problem_state{num_of_correct_ans}++ if $allAnswersCorrectQ == 1; - $problem_state{num_of_incorrect_ans}++ if $allAnswersCorrectQ == 0; - $problem_state{state_summary_msg} = ''; # an HTML formatted message printed at the bottom of the problem page + # Report the results + $problem_result{score} = $allAnswersCorrectQ; + $problem_state{recorded_score} //= 0; + # Increase recorded score if the current score is greater. + $problem_state{recorded_score} = $problem_result{score} + if $problem_result{score} > $problem_state{recorded_score}; + + # Record attempt only if there have been no syntax errors. + if ($record_problem_attempt == 1) { + ++$problem_state{num_of_correct_ans} if $allAnswersCorrectQ == 1; + ++$problem_state{num_of_incorrect_ans} if $allAnswersCorrectQ == 0; } else { - $problem_result{show_partial_correct_answers} = - 0; # prevent partial correct answers from being shown for syntax errors. + # Prevent partial correct answers from being shown for syntax errors. + $problem_result{show_partial_correct_answers} = 0; } - (\%problem_result, \%problem_state); + + return (\%problem_result, \%problem_state); } =head4 avg_problem_grader This grader gives a grade depending on how many questions from the problem are correct. (The highest grade is the one that is kept. One can never lower the recorded grade on a problem by repeating it.) -Many professors (and almost all students :-) ) prefer this grader. - +Many professors (and almost all students :-) ) prefer this grader. - install_problem_grader(~~&avg_problem_grader); + install_problem_grader(~~&avg_problem_grader); =cut -# ^function avg_problem_grader sub avg_problem_grader { - my $rh_evaluated_answers = shift; - my $rh_problem_state = shift; - my %form_options = @_; - my %evaluated_answers = %{$rh_evaluated_answers}; - # The hash $rh_evaluated_answers typically contains: - # 'answer1' => 34, 'answer2'=> 'Mozart', etc. - - # By default the old problem state is simply passed back out again. - my %problem_state = %$rh_problem_state; + my ($rh_evaluated_answers, $rh_problem_state, %form_options) = @_; + + my %evaluated_answers = %{$rh_evaluated_answers}; - # %form_options might include - # The user login name - # The permission level of the user - # The studentLogin name for this psvn. - # Whether the form is asking for a refresh or is submitting a new answer. + # By default the old problem state is simply passed back out again. + my %problem_state = %$rh_problem_state; - # initial setup of the answer + # Initial setup of the answer. my $total = 0; my %problem_result = ( score => 0, @@ -1706,58 +1610,36 @@ sub avg_problem_grader { ); my $count = keys %evaluated_answers; $problem_result{msg} = maketext('You can earn partial credit on this problem.') if $count > 1; - # Return unless answers have been submitted - unless ($form_options{answers_submitted} == 1) { - return (\%problem_result, \%problem_state); - } - # Answers have been submitted -- process them. - foreach my $ans_name (keys %evaluated_answers) { - # I'm not sure if this check is really useful. - if ((ref($evaluated_answers{$ans_name}) eq 'HASH') or (ref($evaluated_answers{$ans_name}) eq 'AnswerHash')) { - $total += ($evaluated_answers{$ans_name}->{score} // 0); + # Return unless answers have been submitted. + return (\%problem_result, \%problem_state) unless $form_options{answers_submitted} == 1; + + # Answers have been submitted -- process them. + for my $ans_name (keys %evaluated_answers) { + if (ref $evaluated_answers{$ans_name} eq 'HASH' || ref $evaluated_answers{$ans_name} eq 'AnswerHash') { + $total += $evaluated_answers{$ans_name}{score} // 0; } else { - die "Error: Answer |$ans_name| is not a hash reference\n" + die "Error: Answer |$ans_name| is not a hash reference\n" . $evaluated_answers{$ans_name} - . "This probably means that the answer evaluator for this answer\n" - . "is not working correctly."; - $problem_result{error} = "Error: Answer $ans_name is not a hash: $evaluated_answers{$ans_name}"; + . 'This probably means that the answer evaluator for this answer is not working correctly.'; + $problem_result{error} = "Error: Answer $ans_name is not a hash: $evaluated_answers{$ans_name}"; } } - # Calculate score rounded to three places to avoid roundoff problems - $problem_result{score} = $total / $count if $count; - $problem_state{recorded_score} = 0 unless defined $problem_state{recorded_score}; - - $problem_state{num_of_correct_ans}++ if $total == $count; - $problem_state{num_of_incorrect_ans}++ if $total < $count; - - # Determine if we are in the reduced scoring period and if the reduced scoring period is enabled and act accordingly - #warn("enable_reduced_scoring is $enable_reduced_scoring"); - # warn("dueDate is $dueDate"); - if (!$enable_reduced_scoring or time() < $reducedScoringDate) - { # the reduced scoring period is disabled or it is before the reduced scoring period - # increase recorded score if the current score is greater. - $problem_state{recorded_score} = $problem_result{score} - if $problem_result{score} > $problem_state{recorded_score}; - # the sub_recored_score holds the recored_score before entering the reduced scoring period - $problem_state{sub_recorded_score} = $problem_state{recorded_score}; - } elsif (time() < $dueDate) { # we are in the reduced scoring period. - # student gets credit for all work done before the reduced scoring period plus a portion of work done during period - my $newScore = 0; - $newScore = - $problem_state{sub_recorded_score} + - $reducedScoringValue * ($problem_result{score} - $problem_state{sub_recorded_score}) - if ($problem_result{score} > $problem_state{sub_recorded_score}); - $problem_state{recorded_score} = $newScore if $newScore > $problem_state{recorded_score}; - my $reducedScoringPerCent = int(100 * $reducedScoringValue + .5); - $problem_result{msg} = $problem_result{msg} - . "
You are in the Reduced Scoring Period: All additional work done counts $reducedScoringPerCent\% of the original."; - } - $problem_state{state_summary_msg} = ''; # an HTML formatted message printed at the bottom of the problem page + # Calculate the score. + $problem_result{score} = $total / $count if $count; - warn "Error in grading this problem the total $total is larger than $count" if $total > $count; - (\%problem_result, \%problem_state); + ++$problem_state{num_of_correct_ans} if $total == $count; + ++$problem_state{num_of_incorrect_ans} if $total < $count; + $problem_state{recorded_score} //= 0; + + # Increase recorded score if the current score is greater. + $problem_state{recorded_score} = $problem_result{score} + if $problem_result{score} > $problem_state{recorded_score}; + + warn "Error in grading this problem the total $total is larger than $count" if $total > $count; + + return (\%problem_result, \%problem_state); } =head2 Utility subroutines diff --git a/macros/PGbasicmacros.pl b/macros/PGbasicmacros.pl index d27aefb00b..568503e5e5 100644 --- a/macros/PGbasicmacros.pl +++ b/macros/PGbasicmacros.pl @@ -1160,26 +1160,13 @@ =head2 Hints, solutions, and statement macros statement takes a string, probably from EV3P, and possibly wraps opening and closing content, paralleling one feature of solution and hint. -Solution prints its concatenated input when the check box named 'ShowSol' is set and -the time is after the answer date. The check box 'ShowSol' is visible only after the -answer date or when the problem is viewed by a professor. +If $envir{showSolutions} is set to 1 then the solution is displayed. -$main::envir{'displaySolutionsQ'} is set to 1 when a solution is to be displayed. - -Hints are shown only after the number of attempts is greater than $:showHint -($main::showHint defaults to 1) and the check box named 'ShowHint' is set. The check box -'ShowHint' is visible only after the number of attempts is greater than $main::showHint. - -Hints are always shown immediately to instructors to facilitate editing the hint section. - -$main::envir{'displayHintsQ'} is set to 1 when a hint is to be displayed. +If $envir{showHints} is set to 1 then the hint is displayed. =cut -# solution prints its input when $displaySolutionsQ is set. -# use as TEXT(solution("blah, blah"); -# \$solutionExists -# is passed to processProblem which displays a "show Solution" button +# $main::solutionExists is passed to processProblem which displays a "show Solution" button # when a solution is available for viewing sub escapeSolutionHTML { @@ -1189,38 +1176,16 @@ sub escapeSolutionHTML { } sub solution { - my @in = @_; - my $out = ''; - my $permissionLevel = $envir->{permissionLevel} || 0; #user permission level - # protect against undefined values - my $ALWAYS_SHOW_SOLUTION_PERMISSION_LEVEL = - (defined($envir->{'ALWAYS_SHOW_SOLUTION_PERMISSION_LEVEL'})) - ? $envir->{'ALWAYS_SHOW_SOLUTION_PERMISSION_LEVEL'} - : 10000; - my $displaySolution = PG_restricted_eval(q!$main::envir{'displaySolutionsQ'}!); - my $printSolutionForInstructor = ( - ($displayMode ne 'TeX' && ($permissionLevel >= $ALWAYS_SHOW_SOLUTION_PERMISSION_LEVEL)) - || ($displayMode eq 'TeX' - && $displaySolution - && ($permissionLevel >= $ALWAYS_SHOW_SOLUTION_PERMISSION_LEVEL)) - ); - PG_restricted_eval(q!$main::solutionExists = 1!); # set solution exists variable.--don't need PGeval?? - - if ($printSolutionForInstructor) { # always print solutions for instructor types - $out = join('', - $BITALIC, "(", maketext("Instructor solution preview: show the student solution after due date."), - ")", $EITALIC, $displayMode =~ /TeX/ ? "\\par\\smallskip{}" : $BR, @in); - } elsif ($displaySolution) { - $out = join(' ', @in); # display solution - } - $out; + my @in = @_; + $main::solutionExists = 1; + return $envir->{showSolutions} ? join('', @in) : ''; } sub SOLUTION { my $solution_body = solution(@_); return "" if $solution_body eq ""; - if ($displayMode =~ /HTML/ and $envir->{use_knowls_for_solutions}) { + if ($displayMode =~ /HTML/) { TEXT($PAR, knowlLink(SOLUTION_HEADING(), value => $solution_body, type => 'solution')); } elsif ($displayMode =~ /TeX/) { TEXT( @@ -1229,8 +1194,6 @@ sub SOLUTION { "\\par\\smallskip", SOLUTION_HEADING(), $solution_body, "\\par\\medskip", "\n%%% END SOLUTION\n" #Marker used in PreTeXt LaTeX extraction; contact alex.jordan@pcc.edu before modifying ); - } elsif ($displayMode =~ /HTML/) { - TEXT($PAR, SOLUTION_HEADING(), $BR, $solution_body, $PAR); } elsif ($displayMode =~ /PTX/) { TEXT('', "\n", $solution_body, "\n", '', "\n\n"); } else { @@ -1239,63 +1202,15 @@ sub SOLUTION { } sub hint { - my @in = @_; - my $out = ''; - my $permissionLevel = $envir->{permissionLevel} || 0; #user permission level - # protect against undefined values - my $ALWAYS_SHOW_HINT_PERMISSION_LEVEL = - (defined($envir->{'ALWAYS_SHOW_HINT_PERMISSION_LEVEL'})) - ? $envir->{'ALWAYS_SHOW_HINT_PERMISSION_LEVEL'} - : 10000; - my $showHint = PG_restricted_eval(q!$main::showHint!); - my $displayHint = PG_restricted_eval(q!$main::envir{'displayHintsQ'}!); - my $printHintForInstructor = ((($displayMode ne 'TeX') && ($permissionLevel >= $ALWAYS_SHOW_HINT_PERMISSION_LEVEL)) - || (($displayMode eq 'TeX') && $displayHint && ($permissionLevel >= $ALWAYS_SHOW_HINT_PERMISSION_LEVEL))); - PG_restricted_eval(q!$main::hintExists =1!); - PG_restricted_eval(q!$main::numOfAttempts = 0 unless defined($main::numOfAttempts);!); - my $attempts = PG_restricted_eval(q!$main::numOfAttempts!); - - if ($displayMode =~ /TeX/) { - my $afterAnswerDate = (time() > $envir{answerDate}); - if ($printHintForInstructor) { - $out = join('', - $BITALIC, - maketext("(Instructor hint preview: show the student hint after the following number of attempts:"), - " ", - $showHint + 1, - ")", - $EITALIC, - "\\par\\smallskip{}", - @in); - } elsif ($displayHint and $afterAnswerDate) { # only display hints after the answer date. - $out = join(' ', @in); - } - - } elsif ($displayMode =~ /HTML/) { - if ($printHintForInstructor) { # always print hints for instructor types in HTML mode - $out = join('', - $BITALIC, - maketext("(Instructor hint preview: show the student hint after the following number of attempts:"), - " ", - $showHint + 1, - ")$BR", - $EITALIC, - @in); - } elsif ($displayHint and ($attempts > $showHint)) { - ## the second test above prevents a hint being shown if a doctored form is submitted - $out = join(' ', @in); - } - } elsif ($displayMode =~ /PTX/) { - $out = join(' ', @in); - } - - $out; + my @in = @_; + $main::hintExists = 1; + return $envir->{showHints} ? join('', @in) : ''; } sub HINT { my $hint_body = hint(@_); return unless $hint_body; - if ($displayMode =~ /HTML/ and $envir->{use_knowls_for_hints}) { + if ($displayMode =~ /HTML/) { TEXT($PAR, knowlLink(HINT_HEADING(), value => $hint_body, type => 'hint')); } elsif ($displayMode =~ /TeX/) { TEXT( @@ -2516,10 +2431,7 @@ sub PTX_cleanup { =head2 Formatting macros - beginproblem() # generates text listing number and the point value of - # the problem. It will also print the file name containing - # the problem for users listed in the PRINT_FILE_NAMES_FOR PG_environment - # variable. + beginproblem() # Adds a custom TeX preamble. This is deprecated and should not be used in newly written problems. OL(@array) # formats the array as an Ordered List (
) enumerated by letters. # See BeginList() and EndList in unionLists.pl for a more powerful version # of this macro. @@ -3042,21 +2954,13 @@ sub image { if ($displayMode eq 'TeX') { my $imagePath = $imageURL; # in TeX mode, alias gives us a path, not a URL - if (defined $envir->{texDisposition} and $envir->{texDisposition} eq "pdf") { - # We're going to create PDF files with our TeX (using pdflatex), so - # alias should have given us the path to a PNG image. What we need - # to do is find out the dimmensions of this image, since pdflatex - # is too dumb to live. - if ($imagePath) { - $out = "\\includegraphics[width=$width_ratio\\linewidth]{$imagePath}\n"; - } else { - $out = ""; - } - } else { - # Since we're not creating PDF files, alias should have given us the - # path to an EPS file. latex can get its dimmensions no problem! + # We're going to create PDF files with our TeX (using pdflatex), so + # alias should have given us the path to a PNG image. + if ($imagePath) { $out = "\\includegraphics[width=$width_ratio\\linewidth]{$imagePath}\n"; + } else { + $out = ""; } } elsif ($displayMode eq 'Latex2HTML') { my $wid = ($envir->{onTheFlyImageSize} || 0) + 30; diff --git a/macros/PGdiffeqmacros.pl b/macros/PGdiffeqmacros.pl index d973b9b71a..c3cdb7fe62 100644 --- a/macros/PGdiffeqmacros.pl +++ b/macros/PGdiffeqmacros.pl @@ -618,7 +618,7 @@ sub check_eigenvector { return ($rh_ans) unless @correct_vector == @vector; # make sure the vectors are the same dimension - my $vec = new Matrix(2, 1); + my $vec = Matrix->new(2, 1); $vec->assign(1, 1, $vector[0]); $vec->assign(2, 1, $vector[1]); my $out_vec = $matrix * $vec; diff --git a/macros/PGgraders.pl b/macros/PGgraders.pl index 7467567d61..aa4bf7bf60 100644 --- a/macros/PGgraders.pl +++ b/macros/PGgraders.pl @@ -5,28 +5,20 @@ =head1 PGgraders.pl DESCRIPTION =cut -=head3 full_partial_grader +=head2 full_partial_grader -=pod - - ########################################################### - # full_partial_grader - # If the final answer is correct, then the problem is given full credit - # and a message is generated to that effect. Otherwise, partial credit - # is given for previous parts. +If the final answer is correct, then the problem is given full credit +and a message is generated to that effect. Otherwise, partial credit +is given for previous parts. =cut sub full_partial_grader { - # Get the standard inputs to a grader: - my $rh_evaluated_answers = shift; - my $rh_orig_problem_state = shift; + my ($rh_evaluated_answers, $rh_orig_problem_state, %form_options) = @_; + my %original_problem_state = %$rh_orig_problem_state; - my %form_options = @_; - # The hash $rh_evaluated_answers typically contains: - # 'AnSwEr0001' => 34, 'AnSwEr0002'=> 'Mozart', etc. - # Evaluate these inputs using the "average problem grader" + # Evaluate the inputs using the "average problem grader" my ($rh_problem_result, $rh_problem_state) = &avg_problem_grader($rh_evaluated_answers, $rh_orig_problem_state, %form_options); @@ -34,16 +26,15 @@ sub full_partial_grader { my $count = @answer_labels; # Get the last label - -# my $last_label = pop sort @answer_labels; # This is what I would like to do but sort seems to be trapped by Safe.pm - + # This is what I would like to do but sort seems to be trapped by Safe.pm + #my $last_label = pop sort @answer_labels; my $last_label = ANS_NUM_TO_NAME(1); #usually AnSwEr0001 - foreach my $answer_label (@answer_labels) { + for my $answer_label (@answer_labels) { if ($answer_label gt $last_label) { $last_label = $answer_label; } } - if (defined($rh_evaluated_answers->{$last_label}) and ${ $rh_evaluated_answers->{$last_label} }{score} == 1) { + if (defined $rh_evaluated_answers->{$last_label} && ${ $rh_evaluated_answers->{$last_label} }{score} == 1) { $rh_problem_result->{score} = 1; ${ $rh_evaluated_answers->{$last_label} }{ans_message} = 'You get full credit for this problem because this answer is correct.'; @@ -52,7 +43,7 @@ sub full_partial_grader { if $rh_problem_result->{score} > $rh_problem_state->{recorded_score}; } - # change the problem message + # Change the problem message $rh_problem_result->{msg} = 'You can earn full credit by answering just the last part.' if $count > 1; $rh_problem_result->{type} = 'full_partial_grader'; # change grader type @@ -65,82 +56,56 @@ sub full_partial_grader { $rh_problem_state->{num_of_incorrect_ans} = $original_problem_state{num_of_incorrect_ans} + 1; } - # Return the results of grading the problem. - ($rh_problem_result, $rh_problem_state); + return ($rh_problem_result, $rh_problem_state); } -=head3 custom_problem_grader_0_60_100(@rh_evaluated_answers,$rh_problem_state,%form_options) - -=pod - - ################################################################ - # custom_problem_grader_0_60_100 - # - # We need a special problem grader on this problem, since we - # want the student to get full credit for all five answers correct, - # 60% credit for four correct, and 0% for three or fewer correct. - # To change this scheme, look through the following mess of code - # for the place where the variable $numright appears, and change - # that part. - # Also change the long line beginning "msg ==>", to show what will - # appear on the screen for the student. - # - # To look at the problem itself, look for the boxed comment below - # announcing the problem itself. - ################################################################ +=head2 custom_problem_grader_0_60_100 + +We need a special problem grader on this problem, since we +want the student to get full credit for all five answers correct, +60% credit for four correct, and 0% for three or fewer correct. +To change this scheme, look through the following mess of code +for the place where the variable $numright appears, and change +that part. +Also change the long line beginning "msg ==>", to show what will +appear on the screen for the student. + +To look at the problem itself, look for the boxed comment below +announcing the problem itself. =cut sub custom_problem_grader_0_60_100 { - my $rh_evaluated_answers = shift; - my $rh_problem_state = shift; - my %form_options = @_; - my %evaluated_answers = %{$rh_evaluated_answers}; - # The hash $rh_evaluated_answers typically contains: - # 'answer1' => 34, 'answer2'=> 'Mozart', etc. - - # By default the old problem state is simply passed back out again. - my %problem_state = %$rh_problem_state; + my ($rh_evaluated_answers, $rh_problem_state, %form_options) = @_; + + my %evaluated_answers = %{$rh_evaluated_answers}; - # %form_options might include - # The user login name - # The permission level of the user - # The studentLogin name for this psvn. - # Whether the form is asking for a refresh or - # is submitting a new answer. + # By default the old problem state is simply passed back out again. + my %problem_state = %$rh_problem_state; - # initial setup of the answer + # Initial setup of the answer my $total = 0; my %problem_result = ( score => 0, errors => '', type => 'custom_problem_grader', - msg => 'To get full credit, all answers must be correct. Having - all but one correct is worth 60%. Two or more incorrect answers gives a score -of 0%.', + msg => 'To get full credit, all answers must be correct. Having ' + . 'all but one correct is worth 60%. Two or more incorrect answers gives a score of 0%.', ); # Return unless answers have been submitted - unless ($form_options{answers_submitted} == 1) { + return (\%problem_result, \%problem_state) unless $form_options{answers_submitted} == 1; - # Since this code is in a .pg file we must use double tildes - # instead of Perl's backslash on the next line. - return (\%problem_result, \%problem_state); - } # Answers have been submitted -- process them. - ######################################################## - # Here's where we compute the score. The variable # - # $numright is the number of correct answers. # - ######################################################## - + # Compute the score. The variable $numright is the number of correct answers. my $numright = 0; - $numright += ($evaluated_answers{'AnSwEr0001'}->{score}); - $numright += ($evaluated_answers{'AnSwEr0002'}->{score}); - $numright += ($evaluated_answers{'AnSwEr0003'}->{score}); - $numright += ($evaluated_answers{'AnSwEr0004'}->{score}); - $numright += ($evaluated_answers{'AnSwEr0005'}->{score}); + $numright += $evaluated_answers{'AnSwEr0001'}{score}; + $numright += $evaluated_answers{'AnSwEr0002'}{score}; + $numright += $evaluated_answers{'AnSwEr0003'}{score}; + $numright += $evaluated_answers{'AnSwEr0004'}{score}; + $numright += $evaluated_answers{'AnSwEr0005'}{score}; if ($numright == 5) { $total = 1; @@ -151,75 +116,60 @@ sub custom_problem_grader_0_60_100 { } $problem_result{score} = $total; - # increase recorded score if the current score is greater. - $problem_state{recorded_score} = $problem_result{score} if $problem_result{score} > $problem_state{recorded_score}; + $problem_state{recorded_score} //= 0; - $problem_state{num_of_correct_ans}++ if $total == 1; - $problem_state{num_of_incorrect_ans}++ if $total < 1; + # Increase recorded score if the current score is greater. + $problem_state{recorded_score} = $problem_result{score} if $problem_result{score} > $problem_state{recorded_score}; - # Since this code is in a .pg file we must use double tildes - # instead of Perl's backslash on the next line. - (\%problem_result, \%problem_state); + ++$problem_state{num_of_correct_ans} if $total == 1; + ++$problem_state{num_of_incorrect_ans} if $total < 1; + return (\%problem_result, \%problem_state); } -=head3 NOTE: - -=pod - - ################################################################ - # This problem grader custom_problem_grader_fluid - # was contributed by Prof. Zig Fiedorowicz, - # Dept. of Mathematics, Ohio State University on 8/25/01. - # As written, the problem grader should be put in a separate macro file. - # If actually inserted into a problem, you need to replace a couple - # of backslashes by double tildes. - # - # This is a generalization of the previous custom grader. - # This grader expects two array references to be passed to it, eg. - # $ENV['grader_numright'] = [2,5,7,10]; - # $ENV['grader_scores'] = [0.1,0.4,0.6,1] - # Both arrays should be of the same length, and in strictly - # increasing order. The first array is an array of possible - # raw scores, the number of parts of the problem the student might - # get right. The second array is the corresponding array of scores - # the student would be credited with for getting that many parts - # right. The scores should be real numbers between 0 and 1. - # The last element of the 'grader_scores' array should be 1 (perfect - # score). The corresponding last element of 'grader_numright' would - # be the total number of parts of the problem the student would have - # to get right for a perfect score. Normally this would be the total - # number of parts to the problem. In the example shown above, the - # student would get 10% credit for getting 2-4 parts right, 40% - # credit for getting 5-6 parts right, 60% credit for getting 7-9 parts - # right, and 100% credit for getting 10 (or more) parts right. - # A message to be displayed to the student about the grading policy - # for the problems should be passed via - # $ENV{'grader_message'} = "The grading policy for this problem is..."; - # or something similar. - ################################################################ +=head2 custom_problem_grader_fluid + +This problem grader custom_problem_grader_fluid +was contributed by Prof. Zig Fiedorowicz, +Dept. of Mathematics, Ohio State University on 8/25/01. +As written, the problem grader should be put in a separate macro file. +If actually inserted into a problem, you need to replace a couple +of backslashes by double tildes. + +This is a generalization of the previous custom grader. +This grader expects two array references to be passed to it, eg. +$ENV['grader_numright'] = [2,5,7,10]; +$ENV['grader_scores'] = [0.1,0.4,0.6,1] +Both arrays should be of the same length, and in strictly +increasing order. The first array is an array of possible +raw scores, the number of parts of the problem the student might +get right. The second array is the corresponding array of scores +the student would be credited with for getting that many parts +right. The scores should be real numbers between 0 and 1. +The last element of the 'grader_scores' array should be 1 (perfect +score). The corresponding last element of 'grader_numright' would +be the total number of parts of the problem the student would have +to get right for a perfect score. Normally this would be the total +number of parts to the problem. In the example shown above, the +student would get 10% credit for getting 2-4 parts right, 40% +credit for getting 5-6 parts right, 60% credit for getting 7-9 parts +right, and 100% credit for getting 10 (or more) parts right. +A message to be displayed to the student about the grading policy +for the problems should be passed via +$ENV{'grader_message'} = "The grading policy for this problem is..."; +or something similar. =cut sub custom_problem_grader_fluid { - my $rh_evaluated_answers = shift; - my $rh_problem_state = shift; - my %form_options = @_; - my %evaluated_answers = %{$rh_evaluated_answers}; - # The hash $rh_evaluated_answers typically contains: - # 'answer1' => 34, 'answer2'=> 'Mozart', etc. - - # By default the old problem state is simply passed back out again. - my %problem_state = %$rh_problem_state; + my ($rh_evaluated_answers, $rh_problem_state, %form_options) = @_; + + my %evaluated_answers = %{$rh_evaluated_answers}; - # %form_options might include - # The user login name - # The permission level of the user - # The studentLogin name for this psvn. - # Whether the form is asking for a refresh or - # is submitting a new answer. + # By default the old problem state is simply passed back out again. + my %problem_state = %$rh_problem_state; - # initial setup of the answer + # Initial setup of the answer my $total = 0; my %problem_result = ( score => 0, @@ -229,47 +179,34 @@ sub custom_problem_grader_fluid { ); # Return unless answers have been submitted - unless ($form_options{answers_submitted} == 1) { + return (\%problem_result, \%problem_state) unless $form_options{answers_submitted} == 1; - # Since this code is in a .pg file we must use double tildes - # instead of Perl's backslash on the next line. - return (\%problem_result, \%problem_state); - } # Answers have been submitted -- process them. - ######################################################## - # Here's where we compute the score. The variable # - # $numright is the number of correct answers. # - ######################################################## - + # Compute the score. The variable $numright is the number of correct answers. my $numright = 0; my $i; my $ans_ref; my @grader_numright = @{ $ENV{'grader_numright'} }; my @grader_scores = @{ $ENV{'grader_scores'} }; - if ($#grader_numright != $#grader_scores) { - WARN_MESSAGE("Scoring guidelines inconsistent: unequal arrays!"); - } + WARN_MESSAGE('Scoring guidelines inconsistent: unequal arrays!') + if ($#grader_numright != $#grader_scores); + for ($i = 0; $i < $#grader_numright; $i++) { if ($grader_numright[$i] >= $grader_numright[ $i + 1 ]) { - WARN_MESSAGE("Scoring guidelines inconsistent: raw scores not increasing!"); + WARN_MESSAGE('Scoring guidelines inconsistent: raw scores not increasing!'); } if ($grader_scores[$i] >= $grader_scores[ $i + 1 ]) { - WARN_MESSAGE("Scoring guidelines inconsistent: scores not increasing!"); + WARN_MESSAGE('Scoring guidelines inconsistent: scores not increasing!'); } } + if ($grader_scores[$#grader_scores] != 1) { WARN_MESSAGE("Scoring guidelines inconsistent: best score < 1"); } - # $i = 1; - # while (defined($ans_ref = $evaluated_answers{'AnSwEr'."$i"})) { - # $numright += $ans_ref->{score}; - # $i++; - # } - - # Answers have been submitted -- process them. - foreach my $ans_name (keys %evaluated_answers) { + + for my $ans_name (keys %evaluated_answers) { $numright += $evaluated_answers{$ans_name}->{score}; } @@ -279,37 +216,17 @@ sub custom_problem_grader_fluid { } } - $problem_state{num_of_correct_ans}++ if $total == 1; - $problem_state{num_of_incorrect_ans}++ if $total < 1; + ++$problem_state{num_of_correct_ans} if $total == 1; + ++$problem_state{num_of_incorrect_ans} if $total < 1; $problem_result{score} = $total; + $problem_state{recorded_score} //= 0; - # Determine if we are in the reduced scoring period and if the reduced scoring period is enabled and act accordingly - #warn("enable_reduced_scoring is $enable_reduced_scoring"); - #warn("dueDate is $dueDate"); - - if (!$enable_reduced_scoring or time() < $reducedScoringDate) - { # the reduced scoring period is disabled or it is before the reduced scoring period - # increase recorded score if the current score is greater. - $problem_state{recorded_score} = $problem_result{score} - if $problem_result{score} > $problem_state{recorded_score}; - # the sub_recored_score holds the recored_score before entering the reduced scoring period - $problem_state{sub_recorded_score} = $problem_state{recorded_score}; - } elsif (time() < $dueDate) { # we are in the reduced scoring period. - # student gets credit for all work done before the reduced scoring period plus a portion of work done during period - my $newScore = 0; - $newScore = - $problem_state{sub_recorded_score} + - $reducedScoringValue * ($problem_result{score} - $problem_state{sub_recorded_score}) - if ($problem_result{score} > $problem_state{sub_recorded_score}); - $problem_state{recorded_score} = $newScore if $newScore > $problem_state{recorded_score}; - my $reducedScoringPerCent = int(100 * $reducedScoringValue + .5); - $problem_result{msg} = $problem_result{msg} - . "
You are in the Reduced Scoring Period: All additional work done counts $reducedScoringPerCent\% of the original."; - } + # Increase the recorded score if the current score is greater. + $problem_state{recorded_score} = $problem_result{score} + if $problem_result{score} > $problem_state{recorded_score}; - (\%problem_result, \%problem_state); + return (\%problem_result, \%problem_state); } -# return 1 so that this file can be included with require -1 +1; diff --git a/macros/PGtextevaluators.pl b/macros/PGtextevaluators.pl index 5921ef2eb6..d049c0d124 100644 --- a/macros/PGtextevaluators.pl +++ b/macros/PGtextevaluators.pl @@ -246,6 +246,9 @@ =head2 [DEPRECATED] mail_answers_to # Fix me?? why is the body hard wired to the string QUESTIONNAIRE_ANSWERS? sub mail_answers_to { #accepts the last answer and mails off the result + warn 'Sending email in PG problems is no longer supported.'; + return; + my $user_address = shift; my $ans_eval = sub { @@ -333,6 +336,9 @@ =head2 mail_answers_to2 =cut sub mail_answers_to2 { + warn 'Sending email in PG problems is no longer supported.'; + return; + my ($to, $subject, $ra_allow_mail_to) = @_; $subject = "$main::courseName WeBWorK questionnaire" unless defined $subject; diff --git a/macros/answerDiscussion.pl b/macros/answerDiscussion.pl index d3d893e42e..8b68228d91 100644 --- a/macros/answerDiscussion.pl +++ b/macros/answerDiscussion.pl @@ -86,7 +86,7 @@ sub new { $discussion->{isActing} = ($main::inputs_ref->{user} ne $main::inputs_ref->{effectiveUser}); $discussion->{isProfessor} = $discussion->{isActing} || $discussion->isProfessor; $discussion->{isSuperProf} = (defined($main::SuperProf) && $main::SuperProf eq $main::inputs_ref->{user}); - $discussion->{pastDue} = (time() > $main::dueDate) && !$self->{isProfessor}; + $discussion->{pastDue} = $main::pastDue && !$self->{isProfessor}; return $discussion; } diff --git a/macros/compoundProblem5.pl b/macros/compoundProblem5.pl index 34d661ce58..e41e83514e 100644 --- a/macros/compoundProblem5.pl +++ b/macros/compoundProblem5.pl @@ -276,7 +276,7 @@ package Scaffold; our @ISA = qw(PGcore); our $scaffold; # the active scaffold (set by Scaffold() below) -our $isInstructor = ($envir{effectivePermissionLevel} >= $envir{ALWAYS_SHOW_SOLUTION_PERMISSION_LEVEL}); +our $isInstructor = $envir{isInstructor}; my $PG_ANSWERS_HASH = $main::PG->{PG_ANSWERS_HASH}; # where PG stores answer evaluators @@ -604,7 +604,7 @@ sub SECTION_SOLUTION { main::WARN_MESSAGE("Can't find section '$sectionNo'") unless $section; my $output = ''; my $formatted_solution = main::solution($options->{PGML} ? PGML::Format2(join("", @_)) : main::EV3P(@_)); - if ($main::displayMode =~ /^HTML/ and $main::envir{use_knowls_for_solutions}) { + if ($main::displayMode =~ /^HTML/) { $output = join( $main::PAR, main::knowlLink( diff --git a/macros/contextPermutationUBC.pl b/macros/contextPermutationUBC.pl index 54307db59f..ca9fd179b3 100644 --- a/macros/contextPermutationUBC.pl +++ b/macros/contextPermutationUBC.pl @@ -334,7 +334,7 @@ sub mult { push(@cycles, $self->Package("Cycle")->new(@cycle)); } # return a Cycle if there is only one cycle as the result - return @cycles[0] if scalar(@cycles) == 1; + return $cycles[0] if scalar(@cycles) == 1; # else return a Permutation if there are more than 1 cycles return $self->Package("Permutation")->new(@cycles); } @@ -756,7 +756,7 @@ sub _check { # sub _eval { my $self = shift; - my @elements = @{ @_[0] }; + my @elements = @{ $_[0] }; # transform into cycles my @keys = 1 .. scalar(@elements); my @cycles = (); @@ -780,7 +780,7 @@ sub _eval { push(@cycles, $self->Package("Cycle")->new(@cycle)); } # return a Cycle if there is only one cycle as the result - return @cycles[0] if scalar(@cycles) == 1; + return $cycles[0] if scalar(@cycles) == 1; # else return a Permutation if there are more than 1 cycles return $self->Package("Permutation")->new(@cycles); } diff --git a/macros/contextTrigDegrees.pl b/macros/contextTrigDegrees.pl index 1abf0581f5..c02978879e 100644 --- a/macros/contextTrigDegrees.pl +++ b/macros/contextTrigDegrees.pl @@ -52,7 +52,7 @@ =head1 AUTHORS package context::TrigDegrees::common; -my $deg = $main::PI / 180; +our $deg = $main::PI / 180; # # Check the number of arguments, and call the proper method with the @@ -125,7 +125,7 @@ package context::TrigDegrees::hyperbolic; package context::TrigDegrees::numeric2; our @ISA = ('Parser::Function::numeric2'); -my $deg = $main::PI / 180; +our $deg = $main::PI / 180; sub atan2 { CORE::atan2($_[1], $_[2]) / $deg } diff --git a/macros/extraAnswerEvaluators.pl b/macros/extraAnswerEvaluators.pl index ab604af7a2..e85e255b34 100644 --- a/macros/extraAnswerEvaluators.pl +++ b/macros/extraAnswerEvaluators.pl @@ -43,6 +43,8 @@ =head1 DESCRIPTION =cut +sub _extraAnswerEvaluators_init { } + # ^uses loadMacros loadMacros('MathObjects.pl'); diff --git a/macros/niceTables.pl b/macros/niceTables.pl index 33380b03bb..d0da8edbcb 100644 --- a/macros/niceTables.pl +++ b/macros/niceTables.pl @@ -532,7 +532,7 @@ sub DataTable { ${ $dataref->[$i][$j] }{cellcss} = "border-left:solid 1px; " . ${ $dataref->[$i][$j] }{cellcss}; } - if ($alignmentcolumns[$m] != 0) { + if (defined $alignmentcolumns[$m] && $alignmentcolumns[$m] != 0) { ${ $dataref->[$i][$j] }{cellcss} = "border-right:solid 1px; " . ${ $dataref->[$i][$j] }{cellcss}; } diff --git a/macros/problemPanic.pl b/macros/problemPanic.pl index 558d71369a..b08778b802 100644 --- a/macros/problemPanic.pl +++ b/macros/problemPanic.pl @@ -124,14 +124,13 @@ package Panic; my $grader; # problem's original grader # -# Allow resets if permission level is high enough. +# Allow resets for instructors. # Look up the panic level and reset it if needed. # Save the panic level for the next time through. # sub Init { - $main::permissionLevel = 0 unless defined $main::permissionLevel; - $allowReset = $main::permissionLevel > $main::PRINT_FILE_NAMES_PERMISSION_LEVEL; - $isTeX = ($main::displayMode eq 'TeX'); + $allowReset = $main::isInstructor; + $isTeX = ($main::displayMode eq 'TeX'); unless ($isTeX) { $main::panicked = $main::inputs_ref->{_panicked} || 0; $main::panicked = 0 if $main::inputs_ref->{_panic_reset} && $allowReset; @@ -159,7 +158,7 @@ sub Button { $penalty[$buttonCount] = 1 if $penalty[$buttonCount] > 1; return if $isTeX || $main::panicked >= $level; my $time = time(); - my $name = ($main::openDate <= $time && $time <= $main::dueDate ? "submitAnswers" : "checkAnswers"); + my $name = $main::setOpen && !$main::pastDue ? 'submitAnswers' : 'checkAnswers'; $value = quoteHTML($value); return qq!!; } diff --git a/macros/problemRandomize.pl b/macros/problemRandomize.pl index 7df4b9b9b0..0da080bec3 100644 --- a/macros/problemRandomize.pl +++ b/macros/problemRandomize.pl @@ -180,8 +180,11 @@ sub new { when => "correct", onlyAfterDue => 1, style => "Button", - styleName => - ($main::inputs_ref->{effectiveUser} ne $main::inputs_ref->{user} ? "checkAnswers" : "submitAnswers"), + styleName => ( + defined $main::inputs_ref->{effectiveUser} + && defined $main::inputs_ref->{user} + && $main::inputs_ref->{effectiveUser} ne $main::inputs_ref->{user} + ) ? "checkAnswers" : "submitAnswers", label => undef, buttonLabel => $main::PG->maketext("Get a new version of this problem"), checkboxLabel => $main::PG->maketext("Get a new version of this problem"), @@ -211,7 +214,7 @@ sub getStatus { $self->{status} = $self->decode; $self->{submit} = $main::inputs_ref->{submitAnswers}; $self->{isReset} = $main::inputs_ref->{_reseed} || ($self->{submit} && $self->{submit} eq $label); - $self->{isReset} = 0 unless !$self->{onlyAfterDue} || time >= $main::dueDate; + $self->{isReset} = 0 unless !$self->{onlyAfterDue} || $main::pastDue; } # @@ -387,7 +390,7 @@ sub grader { my $score = ($isSubmit || $self->{isReset} ? $result->{score} : $state->{recorded_score}); my $isWhen = ($self->{when} eq 'always' || ($self->{when} eq 'correct' && $score >= 1 && !$main::inputs_ref->{previewAnswers})); - my $okDate = (!$self->{onlyAfterDue} || time >= $main::dueDate); + my $okDate = (!$self->{onlyAfterDue} || $main::pastDue); # # Add the problemRandomize message and data diff --git a/macros/scaffold.pl b/macros/scaffold.pl index 0ab903cc61..9323db48dc 100644 --- a/macros/scaffold.pl +++ b/macros/scaffold.pl @@ -282,22 +282,21 @@ sub _scaffold_init { # package Scaffold; -our $isLibrary = ($main::envir{effectivePermissionLevel} eq ""); # Library and problem set detail pages don't set this -our $isInstructor = - ($isLibrary || $main::envir{effectivePermissionLevel} >= $main::envir{ALWAYS_SHOW_SOLUTION_PERMISSION_LEVEL}); -our $isHardcopy = ($main::displayMode eq "TeX"); -our $isPTX = ($main::displayMode eq "PTX"); -our $afterAnswerDate = (time() > $main::envir{answerDate}); +our $forceOpen = $main::envir{forceScaffoldsOpen}; +our $isInstructor = $main::envir{isInstructor}; +our $isHardcopy = $main::displayMode eq "TeX"; +our $isPTX = $main::displayMode eq "PTX"; +our $afterAnswerDate = $main::envir{answersAvailable}; -our $scaffold; # the active scaffold (set by Begin() below) -my @scaffolds = (); # array of nested scaffolds -my $scaffold_no = 0; # each scaffold gets a unique number -my $scaffold_depth = 1; # each scaffold has a nesting depth +our $scaffold; # the active scaffold (set by Begin() below) +my @scaffolds = (); # array of nested scaffolds +my $scaffold_no = 0; # each scaffold gets a unique number +my $scaffold_depth = 1; # each scaffold has a nesting depth -our $PG_ANSWERS_HASH = $main::PG->{PG_ANSWERS_HASH}; # where PG stores answer evaluators -our $PG_OUTPUT = $main::PG->{OUTPUT_ARRAY}; # where PG stores the TEXT() output +our $PG_ANSWERS_HASH = $main::PG->{PG_ANSWERS_HASH}; # where PG stores answer evaluators +our $PG_OUTPUT = $main::PG->{OUTPUT_ARRAY}; # where PG stores the TEXT() output -our $PREFIX = "$main::envir{QUIZ_PREFIX}Prob-$main::envir{questionNumber}"; +our $PREFIX = "$main::envir{QUIZ_PREFIX}Prob-$main::envir{probNum}"; # # Scaffold::Begin() is used to start a new scaffold section, passing @@ -687,7 +686,7 @@ sub is_correct { # sub can_open { my $self = shift; - return 1 if $Scaffold::isLibrary; # always open in library browser and problem set details + return 1 if $Scaffold::forceOpen; my $method = ($Scaffold::isInstructor ? $self->{instructor_can_open} : $self->{can_open}); $method = $self->{after_AnswerDate_can_open} if $Scaffold::afterAnswerDate; $method = "Section::can_open::" . $method unless ref($method) eq 'CODE'; @@ -700,7 +699,7 @@ sub can_open { # sub is_open { my $self = shift; - return 1 if $Scaffold::isLibrary; # always open in library browser and problem set details + return 1 if $Scaffold::forceOpen; return 0 unless $self->{can_open}; # only open ones that are allowed to be open my $method = $self->{is_open}; $method = $self->{hardcopy_is_open} if $Scaffold::isHardcopy; diff --git a/t/build_PG_envir.pl b/t/build_PG_envir.pl index 417cb3844a..df228d975c 100644 --- a/t/build_PG_envir.pl +++ b/t/build_PG_envir.pl @@ -12,14 +12,13 @@ package main; # build up enough of a PG environment to get things running our %envir = (); -$envir{htmlDirectory} = "/opt/webwork/courses/daemon_course/html"; -$envir{htmlURL} = "http://localhost/webwork2/daemon_course/html"; -$envir{tempURL} = "http://localhost/webwork2/daemon_course/tmp"; -$envir{pgDirectories}->{macrosPath} = ["$main::macros_dir"]; -$envir{macrosPath} = ["$main::macros_dir"]; -$envir{displayMode} = "HTML_MathJax"; -$envir{language} = "en-us"; -$envir{language_subroutine} = sub { return @_; }; # return the string passed in instead going to maketext +$envir{htmlDirectory} = "/opt/webwork/courses/daemon_course/html"; +$envir{htmlURL} = "http://localhost/webwork2/daemon_course/html"; +$envir{tempURL} = "http://localhost/webwork2/daemon_course/tmp"; +$envir{macrosPath} = ["$main::macros_dir"]; +$envir{displayMode} = "HTML_MathJax"; +$envir{language} = "en-us"; +$envir{language_subroutine} = sub { return @_; }; # return the string passed in instead going to maketext sub be_strict { require 'ww_strict.pm'; diff --git a/t/macros/load_macros.t b/t/macros/load_macros.t new file mode 100644 index 0000000000..7ba810877b --- /dev/null +++ b/t/macros/load_macros.t @@ -0,0 +1,43 @@ +#!/usr/bin/env perl + +=head1 Test macro loading + +This tests the pg/macro files to see that they all load without errors or +warnings. + +Note that macros that are broken are listed in C<%brokenMacros> and testing of +these macros is skipped. These macros should be fixed or considered for +deletion. + +=cut + +die "PG_ROOT not found in environment.\n" unless $ENV{PG_ROOT}; +use lib "$ENV{PG_ROOT}/lib"; + +use Test2::V0; + +use WeBWorK::PG; + +my %baseMacros = ('PG.pl' => 1, 'PGstandard.pl' => 1); + +my %brokenMacros = ('answerDiscussion.pl' => 1); + +opendir my $dir, "$ENV{PG_ROOT}/macros" or die "Unable to open pg macro directory: $!"; +my @macro_files = sort grep { !/^\./ && /\.pl$/ && !$baseMacros{$_} && !$brokenMacros{$_} } readdir $dir; +closedir $dir; + +for (@macro_files) { + subtest $_ => sub { + my $pg = WeBWorK::PG->new( + r_source => \"DOCUMENT(); loadMacros('PGstandard.pl', '$_'); ENDDOCUMENT();", + debuggingOptions => { view_problem_debugging_info => 1 } + ); + + is($pg->{errors}, '', 'macro loads without errors'); + is($pg->{warnings}, '', 'macro loads without warnings'); + + $pg->free; + }; +} + +done_testing; diff --git a/t/pg_problems/problem_file.t b/t/pg_problems/problem_file.t new file mode 100644 index 0000000000..2c1597b5ad --- /dev/null +++ b/t/pg_problems/problem_file.t @@ -0,0 +1,116 @@ +#!/usr/bin/env perl + +die "PG_ROOT not found in environment.\n" unless $ENV{PG_ROOT}; +use lib "$ENV{PG_ROOT}/lib"; + +use Test2::V0; + +use WeBWorK::PG; + +ok my $pg = WeBWorK::PG->new( + sourceFilePath => "$ENV{PG_ROOT}/t/pg_test_problems/blankProblem.pg", + inputs_ref => { AnSwEr0001 => '3.14159' }, + processAnswers => 1, + ), + 'blankProblem.pg renders'; + +is($pg->{head_text}, '', 'head_text is empty'); + +is($pg->{post_header_text}, '', 'post_header_text is empty'); + +is( + $pg->{body_text}, + qq{
\n} + . qq{Enter a value for .\n} + . qq{
\n} + . qq{} + . qq{\n} + . qq{
\n} + . qq{}, + 'body_text has correct content' +); + +is($pg->{result}, { errors => '', type => 'avg_problem_grader', score => 1, msg => '' }, 'result is correct'); + +is( + $pg->{state}, + { recorded_score => 1, num_of_correct_ans => 1, num_of_incorrect_ans => 0 }, + 'state is properly updated' +); + +is( + $pg->{answers}, + { + AnSwEr0001 => { + ans_label => 'AnSwEr0001', + ans_name => 'AnSwEr0001', + ans_message => '', + error_message => '', + isPreview => '', + _filter_name => 'dereference_array_ans', + score => 1, + studentsMustReduceUnions => 1, + showUnionReduceWarnings => 1, + ignoreInfinity => 1, + showEqualErrors => 1, + ignoreStrings => 1, + showTypeWarnings => 1, + type => 'Value (Real)', + cmp_class => 'a Number', + done => undef, + error_flag => undef, + correct_ans => '3.14159', + correct_ans_latex_string => '3.14159', + correct_value => '3.14159', + preview_latex_string => '3.14159', + preview_text_string => '3.14159', + student_ans => '3.14159', + original_student_ans => '3.14159', + student_value => '3.14159', + student_formula => '3.14159' + } + }, + 'answers are correctly parsed' +); + +is($pg->{warnings}, '', 'there are no perl warnings'); + +is($pg->{errors}, '', 'there are no pg errors'); + +is($pg->{pgcore}->get_warning_messages, [], 'there are no PG core warning messages'); + +is($pg->{pgcore}->get_debug_messages, [], 'there are no PG core debug messages'); + +is( + $pg->{flags}, + { + comment => '', + showPartialCorrectAnswers => 1, + recordSubmittedAnswers => 1, + refreshCachedImages => 0, + solutionExists => 0, + hintExists => 0, + ANSWER_ENTRY_ORDER => ['AnSwEr0001'], + KEPT_EXTRA_ANSWERS => [ 'MaThQuIlL_AnSwEr0001', 'AnSwEr0001' ], + PROBLEM_GRADER_TO_USE => meta { reftype => 'CODE'; }, + extra_css_files => [ + { file => 'js/apps/Problem/problem.css', external => undef }, + { file => 'js/apps/Knowls/knowl.css', external => undef }, + { file => 'js/apps/ImageView/imageview.css', external => undef }, + { file => 'node_modules/mathquill/dist/mathquill.css', external => undef }, + { file => 'js/apps/MathQuill/mqeditor.css', external => undef } + ], + extra_js_files => [ + { file => 'js/apps/InputColor/color.js', external => 0, attributes => { defer => undef } }, + { file => 'js/apps/Base64/Base64.js', external => 0, attributes => { defer => undef } }, + { file => 'js/apps/Knowls/knowl.js', external => 0, attributes => { defer => undef } }, + { file => 'js/apps/ImageView/imageview.js', external => 0, attributes => { defer => undef } }, + { file => 'node_modules/mathquill/dist/mathquill.js', external => 0, attributes => { defer => undef } }, + { file => 'js/apps/MathQuill/mqeditor.js', external => 0, attributes => { defer => undef } } + ], + }, + 'flags are correctly set' +); + +done_testing; diff --git a/t/pg_problems/source.t b/t/pg_problems/source.t new file mode 100644 index 0000000000..3ea7748e0a --- /dev/null +++ b/t/pg_problems/source.t @@ -0,0 +1,40 @@ +#!/usr/bin/env perl + +die "PG_ROOT not found in environment.\n" unless $ENV{PG_ROOT}; +use lib "$ENV{PG_ROOT}/lib"; + +use Test2::V0; + +use WeBWorK::PG; + +my $source = << 'END_SOURCE'; +DOCUMENT(); + +loadMacros('PGstandard.pl', 'MathObjects.pl', 'PGML.pl', 'PGcourse.pl'); + +$pi = Real('pi'); + +BEGIN_PGML +Enter a value for [`\pi`]. + +[_____]{$pi} +END_PGML + +ENDDOCUMENT(); +END_SOURCE + +ok my $pg = WeBWorK::PG->new(r_source => \$source, problemSeed => 1234, processAnswers => 1), 'source string renders'; + +my $correct_answers = + { map { $_ => $pg->{answers}{$_}{correct_ans} } @{ $pg->{translator}{PG_FLAGS_REF}{ANSWER_ENTRY_ORDER} } }; + +ok my $pg2 = WeBWorK::PG->new( + r_source => \$source, + processAnswers => 1, + inputs_ref => $correct_answers + ), + 'source string renders with answers passed'; + +is($pg2->{result}{score}, 1, 'correct answer is correct'); + +done_testing; diff --git a/t/pg_test_problems/blankProblem.pg b/t/pg_test_problems/blankProblem.pg new file mode 100644 index 0000000000..5c36a95a95 --- /dev/null +++ b/t/pg_test_problems/blankProblem.pg @@ -0,0 +1,13 @@ +DOCUMENT(); + +loadMacros('PGstandard.pl', 'MathObjects.pl', 'PGML.pl', 'PGcourse.pl'); + +$pi = Real('pi'); + +BEGIN_PGML +Enter a value for [`\pi`]. + +[_____]{$pi} +END_PGML + +ENDDOCUMENT();