View of /trunk/webwork-modperl/lib/WeBWorK/ContentGenerator.pm

    1 ################################################################################
    2 # WeBWorK Online Homework Delivery System
    3 # Copyright © 2000-2003 The WeBWorK Project, http://openwebwork.sf.net/
    4 # $CVSHeader: webwork-modperl/lib/WeBWorK/ContentGenerator.pm,v 1.110 2004/06/25 00:08:46 toenail Exp $
    5 #
    6 # This program is free software; you can redistribute it and/or modify it under
    7 # the terms of either: (a) the GNU General Public License as published by the
    8 # Free Software Foundation; either version 2, or (at your option) any later
    9 # version, or (b) the "Artistic License" which comes with this package.
   10 #
   11 # This program is distributed in the hope that it will be useful, but WITHOUT
   12 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
   13 # FOR A PARTICULAR PURPOSE.  See either the GNU General Public License or the
   14 # Artistic License for more details.
   15 ################################################################################
   16 
   17 package WeBWorK::ContentGenerator;
   18 
   19 =head1 NAME
   20 
   21 WeBWorK::ContentGenerator - base class for modules that generate page content.
   22 
   23 =head1 SYNOPSIS
   24 
   25  # start with a WeBWorK::Request object: $r
   26 
   27  use WeBWorK::ContentGenerator::SomeSubclass;
   28 
   29  my $cg = WeBWorK::ContentGenerator::SomeSubclass->new($r);
   30  my $result = $cg->go();
   31 
   32 =head1 DESCRIPTION
   33 
   34 WeBWorK::ContentGenerator provides the framework for generating page content.
   35 "Content generators" are subclasses of this class which provide content for
   36 particular parts of the system.
   37 
   38 Default versions of methods used by the templating system are provided. Several
   39 useful methods are provided for rendering common output idioms and some
   40 miscellaneous utilities are provided.
   41 
   42 =cut
   43 
   44 use strict;
   45 use warnings;
   46 use Apache::Constants qw(:response);
   47 use Carp;
   48 use CGI::Pretty qw(*ul *li);
   49 use URI::Escape;
   50 use WeBWorK::Template qw(template);
   51 
   52 ################################################################################
   53 
   54 use constant PROBLEM_SETS => "Homework Sets";
   55 use constant OPTIONS      => "Password/Email";
   56 use constant GRADES       => "Grades";
   57 use constant LOG_OUT      => "Logout";
   58 
   59 use constant ADD_USERS     => "Add Users";
   60 use constant USER_LIST     => "Class List Editor";
   61 use constant SET_LIST      => "Hmwk Sets Editor";
   62 use constant SET_MAKER     => "Library Browser";
   63 use constant ASSIGNER      => "Set Assigner";
   64 use constant MAIL          => "Email";
   65 use constant SCORING       => "Scoring Tools";
   66 use constant STATS         => "Statistics";
   67 use constant PROGRESS      =>"Student Progress";
   68 use constant FILE_TRANSFER => "File Transfer";
   69 
   70 # Note: Perl 5.6 doesn't seem to allow multiple definitions of constants.
   71 
   72 ###############################################################################
   73 
   74 =head1 CONSTRUCTOR
   75 
   76 =over
   77 
   78 =item new($r)
   79 
   80 Creates a new instance of a content generator. Supply a WeBWorK::Request object
   81 $r.
   82 
   83 =cut
   84 
   85 sub new {
   86   my ($invocant, $r) = @_;
   87   my $class = ref($invocant) || $invocant;
   88   my $self = {
   89     r => $r, # this is now a WeBWorK::Request
   90     ce => $r->ce(),       # these three are here for
   91     db => $r->db(),       # backward-compatability
   92     authz => $r->authz(), # with unconverted CGs
   93     noContent => undef, # this should get clobbered at some point
   94   };
   95   bless $self, $class;
   96   return $self;
   97 }
   98 
   99 =back
  100 
  101 =cut
  102 
  103 ################################################################################
  104 
  105 =head1 INVOCATION
  106 
  107 =over
  108 
  109 =item go()
  110 
  111 Generates a page, using methods from the particular subclass of ContentGenerator
  112 that is instantiated. Generatoion is broken up into several steps, to give
  113 subclasses ample control over the process.
  114 
  115 =over
  116 
  117 =item 1
  118 
  119 go() will attempt to call the method pre_header_initialize(). This method may be
  120 implemented in subclasses which must do processing before the HTTP header is
  121 emitted.
  122 
  123 =item 2
  124 
  125 go() will attempt to call the method header(). This method emits the HTTP
  126 header. It is defined in this class (see below), but may be overridden in
  127 subclasses which need to send different header information. For some reason, the
  128 return value of header() will be used as the result of this function, if it is
  129 defined.
  130 
  131 FIXME: figure out what the deal is with the return value of header(). If we sent
  132 a header, it's too late to set the status by returning. If we didn't, header()
  133 didn't perform its function!
  134 
  135 =item 3
  136 
  137 At this point, go() will terminate if the request is a HEAD request or if the
  138 field $self->{noContent} contains a true value.
  139 
  140 FIXME: I don't think we'll need noContent after reply_with_redirect() is
  141 adopted by all modules.
  142 
  143 =item 4
  144 
  145 go() then attempts to call the method initialize(). This method may be
  146 implemented in subclasses which must do processing after the HTTP header is sent
  147 but before any content is sent.
  148 
  149 =item 6
  150 
  151 The method content() is called to send the page content to client.
  152 
  153 =back
  154 
  155 =cut
  156 
  157 sub go {
  158   my ($self) = @_;
  159   my $r = $self->r;
  160   my $ce = $r->ce;
  161 
  162   my $returnValue = OK;
  163 
  164   $self->pre_header_initialize(@_) if $self->can("pre_header_initialize");
  165 
  166   # send a file instead of a normal reply (reply_with_file() sets this field)
  167   defined $self->{reply_with_file} and do {
  168     return $self->do_reply_with_file($self->{reply_with_file});
  169   };
  170 
  171   # send a Location: header instead of a normal reply (reply_with_redirect() sets this field)
  172   defined $self->{reply_with_redirect} and do {
  173     return $self->do_reply_with_redirect($self->{reply_with_redirect});
  174   };
  175 
  176   my $headerReturn = $self->header(@_);
  177   $returnValue = $headerReturn if defined $headerReturn;
  178   # FIXME: we won't need noContent after reply_with_redirect() is adopted
  179   return $returnValue if $r->header_only or $self->{noContent};
  180 
  181   $self->initialize() if $self->can("initialize");
  182 
  183   $self->content();
  184 
  185   return $returnValue;
  186 }
  187 
  188 =item r()
  189 
  190 Returns a reference to the WeBWorK::Request object associated with this
  191 instance.
  192 
  193 =cut
  194 
  195 sub r {
  196   my ($self) = @_;
  197 
  198   return $self->{r};
  199 }
  200 
  201 =item do_reply_with_file($fileHash)
  202 
  203 Handler for reply_with_file(), used by go(). DO NOT CALL THIS METHOD DIRECTLY.
  204 
  205 =cut
  206 
  207 sub do_reply_with_file {
  208   my ($self, $fileHash) = @_;
  209   my $r = $self->r;
  210 
  211   my $type = $fileHash->{type};
  212   my $source = $fileHash->{source};
  213   my $name = $fileHash->{name};
  214   my $delete_after = $fileHash->{delete_after};
  215 
  216   # if there was a problem, we return here and let go() worry about sending the reply
  217   return NOT_FOUND unless -e $source;
  218   return FORBIDDEN unless -r $source;
  219 
  220   # open the file now, so we can send the proper error status is we fail
  221   open my $fh, "<", $source or return SERVER_ERROR;
  222 
  223   # send our custom HTTP header
  224   $r->content_type($type);
  225   $r->header_out("Content-Disposition" => "attachment; filename=\"$name\"");
  226   $r->send_http_header;
  227 
  228   # send the file
  229   $r->send_fd($fh);
  230 
  231   # close the file and go home
  232   close $fh;
  233 
  234   if ($delete_after) {
  235     unlink $source or warn "failed to unlink $source after sending: $!";
  236   }
  237 }
  238 
  239 =item do_reply_with_redirect($url)
  240 
  241 Handler for reply_with_redirect(), used by go(). DO NOT CALL THIS METHOD DIRECTLY.
  242 
  243 =cut
  244 
  245 sub do_reply_with_redirect {
  246   my ($self, $url) = @_;
  247   my $r = $self->r;
  248 
  249   $r->status(REDIRECT);
  250   $r->header_out(Location => $url);
  251   $r->send_http_header();
  252 }
  253 
  254 =back
  255 
  256 =cut
  257 
  258 ################################################################################
  259 
  260 =head1 DATA MODIFIERS
  261 
  262 Modifiers allow the caller to register a piece of data for later retrieval in a
  263 standard way.
  264 
  265 =over
  266 
  267 =item reply_with_file($type, $source, $name, $delete_after)
  268 
  269 Enables file sending mode, causing go() to send the file specified by $source to
  270 the client after calling pre_header_initialize(). The content type sent is
  271 $type, and the suggested client-side file name is $name. If $delete_after is
  272 true, $source is deleted after it is sent.
  273 
  274 Must be called before the HTTP header is sent. Usually called from
  275 pre_header_initialize().
  276 
  277 =cut
  278 
  279 sub reply_with_file {
  280   my ($self, $type, $source, $name, $delete_after) = @_;
  281   $delete_after ||= "";
  282 
  283   $self->{reply_with_file} = {
  284     type => $type,
  285     source => $source,
  286     name => $name,
  287     delete_after => $delete_after,
  288   };
  289 }
  290 
  291 =item reply_with_redirect($url)
  292 
  293 Enables redirect mode, causing go() to redirect to the given URL after calling
  294 pre_header_initialize().
  295 
  296 Must be called before the HTTP header is sent. Usually called from
  297 pre_header_initialize().
  298 
  299 =cut
  300 
  301 sub reply_with_redirect {
  302   my ($self, $url) = @_;
  303 
  304   $self->{reply_with_redirect} = $url;
  305 }
  306 
  307 =item addmessage($message)
  308 
  309 Adds a message to the list of messages to be printed by the message() template
  310 escape handler.
  311 
  312 Must be called before the message() template escape is invoked.
  313 
  314 =cut
  315 
  316 # FIXME: we should probably
  317 
  318 sub addmessage {
  319   my ($self, $message) = @_;
  320   $self->{status_message} .= $message;
  321 }
  322 
  323 =item addgoodmessage($message)
  324 
  325 Adds a success message to the list of messages to be printed by the
  326 message() template escape handler.
  327 
  328 =cut
  329 
  330 
  331 sub addgoodmessage {
  332   my ($self, $message) = @_;
  333   $self->addmessage(CGI::div({class=>"ResultsWithoutError"}, $message));
  334 }
  335 
  336 =item addbadmessage($message)
  337 
  338 Adds a failure message to the list of messages to be printed by the
  339 message() template escape handler.
  340 
  341 =cut
  342 
  343 
  344 sub addbadmessage {
  345   my ($self, $message) = @_;
  346   $self->addmessage(CGI::div({class=>"ResultsWithError"}, $message));
  347 }
  348 
  349 =back
  350 
  351 =cut
  352 
  353 ################################################################################
  354 
  355 =head1 STANDARD METHODS
  356 
  357 The following are the standard content generator methods. Some are defined here,
  358 but may be overridden in a subclass. Others are not defined unless they are
  359 defined in a subclass.
  360 
  361 =over
  362 
  363 =item pre_header_initialize()
  364 
  365 Not defined in this package.
  366 
  367 May be defined by a subclass to perform any processing that must occur before
  368 the HTTP header is sent.
  369 
  370 =cut
  371 
  372 #sub pre_header_initialize {  }
  373 
  374 =item header()
  375 
  376 Defined in this package.
  377 
  378 Generates and sends a default HTTP header, specifying the "text/html" content
  379 type.
  380 
  381 =cut
  382 
  383 sub header {
  384   my $self = shift;
  385   my $r = $self->r;
  386 
  387   $r->content_type("text/html");
  388   $r->send_http_header();
  389   return OK;
  390 }
  391 
  392 =item initialize()
  393 
  394 Not defined in this package.
  395 
  396 May be defined by a subclass to perform any processing that must occur after the
  397 HTTP header is sent but before any content is sent.
  398 
  399 =cut
  400 
  401 #sub initialize {  }
  402 
  403 =item content()
  404 
  405 Defined in this package.
  406 
  407 Print the content of the generated page.
  408 
  409 The implementation in this package uses WeBWorK::Template to define the content
  410 of the page. See WeBWorK::Template for details.
  411 
  412 If a method named templateName() exists, it it called to determine the name of
  413 the template to use. If not, the default template, "system", is used. The
  414 location of the template is looked up in the course environment.
  415 
  416 =cut
  417 
  418 sub content {
  419   my ($self) = @_;
  420   my $ce = $self->r->ce;
  421 
  422   # if the content generator specifies a custom template name, use that
  423   # field in the $ce->{templates} hash instead of "system" if it exists.
  424   my $templateName;
  425   if ($self->can("templateName")) {
  426     $templateName = $self->templateName;
  427   } else {
  428     $templateName = "system";
  429   }
  430   $templateName = "system" unless exists $ce->{templates}->{$templateName};
  431   template($ce->{templates}->{$templateName}, $self);
  432 }
  433 
  434 =back
  435 
  436 =cut
  437 
  438 # ------------------------------------------------------------------------------
  439 
  440 =head2 Template escape handlers
  441 
  442 Template escape handlers are invoked when the template processor encounters a
  443 matching escape sequence in the template. The escapse sequence's arguments are
  444 passed to the methods as a reference to a hash.
  445 
  446 For more information, refer to WeBWorK::Template.
  447 
  448 The following template escapes handlers are defined here or may be defined in
  449 subclasses. For methods that are not defined in this package, the documentation
  450 defines the interface and behavior that any subclass implementation must follow.
  451 
  452 =over
  453 
  454 =item head()
  455 
  456 Not defined in this package.
  457 
  458 Any tags that should appear in the HEAD of the document.
  459 
  460 =cut
  461 
  462 #sub head {  }
  463 
  464 =item info()
  465 
  466 Not defined in this package.
  467 
  468 Auxiliary information related to the content displayed in the C<body>.
  469 
  470 =cut
  471 
  472 #sub info {  }
  473 
  474 =item links()
  475 
  476 Defined in this package.
  477 
  478 Links that should appear on every page.
  479 
  480 =cut
  481 
  482 sub links {
  483   my ($self) = @_;
  484   my $r = $self->r;
  485   my $db = $r->db;
  486   my $authz = $r->authz;
  487   my $ce = $r->ce;
  488   my $urlpath = $r->urlpath;
  489   my $user = $r->param('user');
  490 
  491   # we're linking to other places in the same course, so grab the courseID from the current path
  492   my $courseID = $urlpath->arg("courseID");
  493 
  494   # to make things more concise
  495   my %args = ( courseID => $courseID );
  496   my $pfx = "WeBWorK::ContentGenerator::";
  497 
  498   my $sets    = $urlpath->newFromModule("${pfx}ProblemSets", %args);
  499   my $options = $urlpath->newFromModule("${pfx}Options", %args);
  500   my $grades  = $urlpath->newFromModule("${pfx}Grades", %args);
  501   my $logout  = $urlpath->newFromModule("${pfx}Logout", %args);
  502 
  503   print "\n<!-- BEGIN " . __PACKAGE__ . "::links -->\n";
  504   # only users with appropriate permissions can report bugs
  505   print CGI::p(CGI::a({style=>"font-size:larger", href=>$ce->{webworkURLs}{bugReporter}}, "Report bugs")),CGI::hr() if $authz->hasPermissions($user, "report_bugs");
  506 
  507   print CGI::start_ul({class=>"LinksMenu"});
  508   print CGI::li(CGI::span({style=>"font-size:larger"},
  509     CGI::a({href=>$self->systemLink($sets)}, PROBLEM_SETS)));
  510   print CGI::li(CGI::a({href=>$self->systemLink($options)}, OPTIONS));
  511   print CGI::li(CGI::a({href=>$self->systemLink($grades)},  GRADES));
  512   print CGI::li(CGI::a({href=>$self->systemLink($logout)},  LOG_OUT));
  513 
  514   if ($authz->hasPermissions($user, "access_instructor_tools")) {
  515     my $ipfx = "${pfx}Instructor::";
  516 
  517     my $userID    = $r->param("effectiveUser");
  518     my $setID     = $urlpath->arg("setID");
  519     $setID = "" if (defined $setID && !(grep /$setID/, $db->listUserSets($userID)));
  520     my $problemID = $urlpath->arg("problemID");
  521     $problemID = "" if (defined $problemID && !(grep /$problemID/, $db->listUserProblems($userID, $setID)));
  522 
  523     my $instr = $urlpath->newFromModule("${ipfx}Index", %args);
  524     my $addUsers = $urlpath->newFromModule("${ipfx}AddUsers", %args);
  525     my $userList = $urlpath->newFromModule("${ipfx}UserList", %args);
  526 
  527     # set list links
  528     my $setList       = $urlpath->newFromModule("${ipfx}ProblemSetList", %args);
  529     my $setDetail     = $urlpath->newFromModule("${ipfx}ProblemSetEditor", %args, setID => $setID);
  530     my $problemEditor = $urlpath->newFromModule("${ipfx}PGProblemEditor", %args, setID => $setID, problemID => $problemID);
  531 
  532     my $maker = $urlpath->newFromModule("${ipfx}SetMaker", %args);
  533     my $assigner = $urlpath->newFromModule("${ipfx}Assigner", %args);
  534     my $mail     = $urlpath->newFromModule("${ipfx}SendMail", %args);
  535     my $scoring  = $urlpath->newFromModule("${ipfx}Scoring", %args);
  536 
  537     # statistics links
  538     my $stats     = $urlpath->newFromModule("${ipfx}Stats", %args);
  539     my $userStats = $urlpath->newFromModule("${ipfx}Stats", %args, statType => "student", userID => $userID);
  540     my $setStats  = $urlpath->newFromModule("${ipfx}Stats", %args, statType => "set", setID => $setID);
  541 
  542     # progress links
  543     my $progress     = $urlpath->newFromModule("${ipfx}StudentProgress", %args);
  544     my $userProgress = $urlpath->newFromModule("${ipfx}StudentProgress", %args, statType => "student", userID => $userID);
  545     my $setProgress  = $urlpath->newFromModule("${ipfx}StudentProgress", %args, statType => "set", setID => $setID);
  546 
  547 
  548     my $files = $urlpath->newFromModule("${ipfx}FileXfer", %args);
  549 
  550     print CGI::hr();
  551     print CGI::start_li();
  552     print CGI::span({style=>"font-size:larger"},
  553                      $self->helpMacro('instructor_links'),
  554                      CGI::a({href=>$self->systemLink($instr)},  space2nbsp($instr->name))
  555     );
  556     print CGI::start_ul();
  557     #print CGI::li(CGI::a({href=>$self->systemLink($addUsers)}, ADD_USERS)) if $authz->hasPermissions($user, "modify_student_data");
  558     print CGI::li(CGI::a({href=>$self->systemLink($userList)}, USER_LIST));
  559     print CGI::start_li();
  560     print CGI::a({href=>$self->systemLink($setList)}, SET_LIST);
  561     if (defined $setID and $setID ne "") {
  562       print CGI::start_ul();
  563       print CGI::start_li();
  564       print CGI::a({href=>$self->systemLink($setDetail)}, $setID);
  565       if (defined $problemID and $problemID ne "") {
  566         print CGI::ul(
  567           CGI::li(CGI::a({href=>$self->systemLink($problemEditor)}, $problemID))
  568         );
  569       }
  570       print CGI::end_li();
  571       print CGI::end_ul();
  572     }
  573     print CGI::end_li();
  574     print CGI::li(CGI::a({href=>$self->systemLink($maker)}, SET_MAKER)) if $authz->hasPermissions($user, "modify_problem_sets");
  575     print CGI::li(CGI::a({href=>$self->systemLink($assigner)}, ASSIGNER)) if $authz->hasPermissions($user, "assign_problem_sets");
  576 
  577     print CGI::li(CGI::a({href=>$self->systemLink($stats)}, STATS));
  578 #     print CGI::start_li();
  579 #     if (defined $userID and $userID ne "") {
  580 #       print CGI::ul(
  581 #         CGI::li(CGI::a({href=>$self->systemLink($userStats)}, $userID))
  582 #       );
  583 #     }
  584 #     if (defined $setID and $setID ne "") {
  585 #       print CGI::ul(
  586 #         CGI::li(CGI::a({href=>$self->systemLink($setStats)}, space2nbsp($setID)))
  587 #       );
  588 #     }
  589 #     print CGI::end_li();
  590 
  591   ## Added Link for Student Progress
  592       print CGI::li(CGI::a({href=>$self->systemLink($progress)}, PROGRESS));
  593     print CGI::start_li();
  594 
  595     if (defined $userID and $userID ne "") {
  596       print CGI::ul(
  597         CGI::li(CGI::a({href=>$self->systemLink($userProgress)}, $userID))
  598       );
  599     }
  600     if (defined $setID and $setID ne "") {
  601       print CGI::ul(
  602         CGI::li(CGI::a({href=>$self->systemLink($setProgress)}, space2nbsp($setID)))
  603       );
  604     }
  605     print CGI::end_li();
  606 
  607     print CGI::li(CGI::a({href=>$self->systemLink($scoring)}, SCORING)) if $authz->hasPermissions($user, "score_sets");
  608     print CGI::li(CGI::a({href=>$self->systemLink($mail)}, MAIL)) if $authz->hasPermissions($user, "send_mail");
  609     print CGI::li(CGI::a({href=>$self->systemLink($files)}, FILE_TRANSFER));
  610     print CGI::end_ul();
  611     print CGI::end_li();
  612   }
  613 
  614   print CGI::end_ul();
  615   print "<!-- end " . __PACKAGE__ . "::links -->\n";
  616 
  617   return "";
  618 }
  619 
  620 =item loginstatus()
  621 
  622 Defined in this package.
  623 
  624 Print a notification message announcing the current real user and effective
  625 user, a link to stop acting as the effective user, and a link to logout.
  626 
  627 =cut
  628 
  629 sub loginstatus {
  630   my ($self) = @_;
  631   my $r = $self->r;
  632   my $urlpath = $r->urlpath;
  633 
  634   my $key = $r->param("key");
  635 
  636   if ($key) {
  637     my $courseID = $urlpath->arg("courseID");
  638     my $userID = $r->param("user");
  639     my $eUserID = $r->param("effectiveUser");
  640 
  641     my $stopActingURL = $self->systemLink($urlpath, # current path
  642       params => { effectiveUser => $userID },
  643     );
  644     my $logoutURL = $self->systemLink($urlpath->newFromModule(__PACKAGE__ . "::Logout", courseID => $courseID));
  645 
  646     print "\n<!-- BEGIN " . __PACKAGE__ . "::loginstatus -->\n";
  647 
  648     print "Logged in as $userID. ", CGI::br();
  649     print CGI::a({href=>$logoutURL}, "Log Out");
  650 
  651     if ($eUserID ne $userID) {
  652       print " | Acting as $eUserID. ";
  653       print CGI::a({href=>$stopActingURL}, "Stop Acting");
  654     }
  655 
  656     print "<!-- END " . __PACKAGE__ . "::loginstatus -->\n";
  657   }
  658 
  659   return "";
  660 }
  661 
  662 =item nav($args)
  663 
  664 Not defined in this package.
  665 
  666 Links to the previous, next, and parent objects.
  667 
  668 $args is a reference to a hash containing the following fields:
  669 
  670  style       => text|image
  671  imageprefix => prefix to prepend to base image URL
  672  imagesuffix => suffix to append to base image URL
  673  separator   => HTML to place in between links
  674 
  675 If C<style> is "image", image URLs are constructed by prepending C<imageprefix>
  676 and postpending C<imagesuffix> to the image base names defined by the
  677 implementor. (Examples of base names include "Prev", "Next", "ProbSet", and
  678 "Up"). Each concatenated string should form an absolute URL to an image file.
  679 For example:
  680 
  681  <!--#nav style="images" imageprefix="/webwork2_files/images/nav"
  682           imagesuffix=".gif" separator="  "-->
  683 
  684 =cut
  685 
  686 #sub nav {  }
  687 
  688 =item options()
  689 
  690 Not defined in this package.
  691 
  692 Print an auxiliary options form, related to the content displayed in the
  693 C<body>.
  694 
  695 =item path($args)
  696 
  697 Defined in this package.
  698 
  699 Print "breadcrubs" from the root of the virtual hierarchy to the current page.
  700 $args is a reference to a hash containing the following fields:
  701 
  702  style    => type of separator: text|image
  703  image    => if style=image, URL of image to use as path separator
  704  text     => if style=text, text to use as path separator
  705              if style=image, the ALT text of each separator image
  706  textonly => suppress all HTML, return only plain text
  707 
  708 The implementation in this package takes information from the WeBWorK::URLPath
  709 associated with the current request.
  710 
  711 =cut
  712 
  713 sub path {
  714   my ($self, $args) = @_;
  715   my $r = $self->r;
  716 
  717   my @path;
  718 
  719   my $urlpath = $r->urlpath;
  720   do {
  721     unshift @path, $urlpath->name, $r->location . $urlpath->path;
  722   } while ($urlpath = $urlpath->parent);
  723 
  724   $path[$#path] = ""; # we don't want the last path element to be a link
  725 
  726   #print "\n<!-- BEGIN " . __PACKAGE__ . "::path -->\n";
  727   print $self->pathMacro($args, @path);
  728   #print "<!-- END " . __PACKAGE__ . "::path -->\n";
  729 
  730   return "";
  731 }
  732 
  733 =item siblings()
  734 
  735 Not defined in this package.
  736 
  737 Print links to siblings of the current object.
  738 
  739 =cut
  740 
  741 #sub siblings {  }
  742 
  743 =item timestamp()
  744 
  745 Defined in this package.
  746 
  747 Display the current time and date using default format "3:37pm on Jan 7, 2004".
  748 The display format can be adjusted by giving a style in the template.
  749 For example,
  750 
  751   <!--#timestamp style="%m/%d/%y at %I:%M%P"-->
  752 
  753 will give standard WeBWorK time format.  Wording and other formatting
  754 can be done in the template itself.
  755 =cut
  756 
  757 sub timestamp {
  758   my ($self, $args) = @_;
  759   my $formatstring = "%l:%M%P on %b %e, %Y";
  760   $formatstring = $args->{style} if(defined($args->{style}));
  761   return(Date::Format::time2str($formatstring, time()));
  762 }
  763 
  764 =item submiterror()
  765 
  766 Defined in this package.
  767 
  768 Print any error messages resulting from the last form submission.
  769 
  770 This method is deprecated -- use message() instead
  771 
  772 The implementation in this package prints the value of the field
  773 $self->{submitError}, if it is present.
  774 
  775 =cut
  776 
  777 sub submiterror {
  778   my ($self) = @_;
  779 
  780   print "\n<!-- BEGIN " . __PACKAGE__ . "::submiterror -->\n";
  781   print $self->{submitError} if exists $self->{submitError};
  782   print "<!-- END " . __PACKAGE__ . "::submiterror -->\n";
  783 
  784   return "";
  785 }
  786 
  787 =item message()
  788 
  789 Defined in this package.
  790 
  791 Print any messages (error or non-error) resulting from the last form submission.
  792 This could be used to give Sucess and Failure messages after an action is performed by a module.
  793 
  794 The implementation in this package prints the value of the field
  795 $self->{status_message}, if it is present.
  796 
  797 =cut
  798 
  799 sub message {
  800   my ($self) = @_;
  801 
  802   print "\n<!-- BEGIN " . __PACKAGE__ . "::message -->\n";
  803   print $self->{status_message} if exists $self->{status_message};
  804   print "<!-- END " . __PACKAGE__ . "::message -->\n";
  805 
  806   return "";
  807 }
  808 
  809 =item title()
  810 
  811 Defined in this package.
  812 
  813 Print the title of the current page.
  814 
  815 The implementation in this package takes information from the WeBWorK::URLPath
  816 associated with the current request.
  817 
  818 =cut
  819 
  820 sub title {
  821   my ($self, $args) = @_;
  822   my $r = $self->r;
  823 
  824 
  825   #print "\n<!-- BEGIN " . __PACKAGE__ . "::title -->\n";
  826   print $r->urlpath->name;
  827   #print "<!-- END " . __PACKAGE__ . "::title -->\n";
  828 
  829   return "";
  830 }
  831 
  832 =item warnings()
  833 
  834 Defined in this package.
  835 
  836 Print accumulated warnings.
  837 
  838 The implementation in this package checks for a note in the request named
  839 "warnings". If present, its contents are formatted and returned.
  840 
  841 =cut
  842 
  843 sub warnings {
  844   my ($self) = @_;
  845   my $r = $self->r;
  846 
  847   print "\n<!-- BEGIN " . __PACKAGE__ . "::warnings -->\n";
  848   print $self->warningOutput($r->notes("warnings")) if $r->notes("warnings");
  849   print "<!-- END " . __PACKAGE__ . "::warnings -->\n";
  850 
  851   return "";
  852 }
  853 
  854 =item help()
  855 
  856 Display a link to context-sensitive help. If the argument C<name> is defined,
  857 the link will be to the help document for that name. Otherwise the name of the
  858 WeBWorK::URLPath node for the current system location will be used.
  859 
  860 =cut
  861 
  862 sub help {
  863   my $self = shift;
  864   my $args = shift;
  865   my $name = $args->{name};
  866   $name = lc($self->r->urlpath->name) unless defined($name);
  867   $name =~ s/\s/_/g;
  868   $self->helpMacro($name);
  869 }
  870 
  871 =back
  872 
  873 =cut
  874 
  875 # ------------------------------------------------------------------------------
  876 
  877 =head2 Conditional predicates
  878 
  879 Conditional predicate methods are invoked when the C<#if> escape sequence is
  880 encountered in the template. If a method named C<if_predicate> is defined in
  881 here or in the instantiated subclass, it is invoked.
  882 
  883 The following predicates are currently defined:
  884 
  885 =over
  886 
  887 =item if_can($function)
  888 
  889 If a function named $function is present in the current content generator (or
  890 any superclass), a true value is returned. Otherwise, a false value is returned.
  891 
  892 The implementation in this package uses the method UNIVERSAL->can(function) to
  893 arrive at the result.
  894 
  895 A subclass could redefine this method to, for example, "hide" a method from the
  896 template:
  897 
  898  sub if_can {
  899   my ($self, $arg) = @_;
  900 
  901   if ($arg eq "floobar") {
  902     return 0;
  903   } else {
  904     return $self->SUPER::if_can($arg);
  905   }
  906  }
  907 
  908 =cut
  909 
  910 sub if_can {
  911   my ($self, $arg) = @_;
  912 
  913   return $self->can($arg) ? 1 : 0;
  914 }
  915 
  916 =item if_loggedin($arg)
  917 
  918 If the user is currently logged in, $arg is returned. Otherwise, the inverse of
  919 $arg is returned.
  920 
  921 The implementation in this package always returns $arg, since most content
  922 generators are only reachable when the user is authenticated. It is up to
  923 classes that can be reached without logging in to override this method and
  924 provide the correct behavior.
  925 
  926 This is suboptimal, and may change in the future.
  927 
  928 =cut
  929 
  930 sub if_loggedin {
  931   my ($self, $arg) = @_;
  932 
  933   return $arg;
  934 }
  935 
  936 =item if_submiterror($arg)
  937 
  938 If the last form submission generated an error, $arg is returned. Otherwise, the
  939 inverse of $arg is returned.
  940 
  941 The implementation in this package checks for the field $self->{submitError} to
  942 determine if an error condition is present.
  943 
  944 If a subclass uses some other method to classify submission results, this method could be
  945 redefined to handle that variance:
  946 
  947  sub if_submiterror {
  948   my ($self, $arg) = @_;
  949 
  950   my $status = $self->{processReturnValue};
  951   if ($status != 0) {
  952     return $arg;
  953   } else {
  954     return !$arg;
  955   }
  956  }
  957 
  958 =cut
  959 
  960 sub if_submiterror {
  961   my ($self, $arg) = @_;
  962 
  963   if (exists $self->{submitError}) {
  964     return $arg;
  965   } else {
  966     return !$arg;
  967   }
  968 }
  969 
  970 =item if_message($arg)
  971 
  972 If the last form submission generated a message, $arg is returned. Otherwise, the
  973 inverse of $arg is returned.
  974 
  975 The implementation in this package checks for the field $self->{status_message} to
  976 determine if a message is present.
  977 
  978 If a subclass uses some other method to classify submission results, this method could be
  979 redefined to handle that variance:
  980 
  981  sub if_message {
  982   my ($self, $arg) = @_;
  983 
  984   my $status = $self->{processReturnValue};
  985   if ($status != 0) {
  986     return $arg;
  987   } else {
  988     return !$arg;
  989   }
  990  }
  991 
  992 =cut
  993 
  994 sub if_message {
  995   my ($self, $arg) = @_;
  996 
  997   if (exists $self->{status_message}) {
  998     return $arg;
  999   } else {
 1000     return !$arg;
 1001   }
 1002 }
 1003 
 1004 =item if_warnings
 1005 
 1006 If warnings have been emitted while handling this request, $arg is returned.
 1007 Otherwise, the inverse of $arg is returned.
 1008 
 1009 The implementation in this package checks for a note in the request named
 1010 "warnings". This is set by the WARN handler in Apache::WeBWorK when a warning is
 1011 handled.
 1012 
 1013 =cut
 1014 
 1015 sub if_warnings {
 1016   my ($self, $arg) = @_;
 1017   my $r = $self->r;
 1018 
 1019   if ($r->notes("warnings")) {
 1020     return $arg;
 1021   } else {
 1022     !$arg;
 1023   }
 1024 }
 1025 
 1026 =back
 1027 
 1028 =cut
 1029 
 1030 ################################################################################
 1031 
 1032 =head1 HTML MACROS
 1033 
 1034 Various routines are defined in this package for rendering common WeBWorK
 1035 idioms.
 1036 
 1037 FIXME: some of these should be moved to WeBWorK::HTML:: modules!
 1038 
 1039 # ------------------------------------------------------------------------------
 1040 
 1041 =head2 Template escape handler macros
 1042 
 1043 These methods are used by implementations of the escape sequence handlers to
 1044 maintain a consistent style.
 1045 
 1046 =over
 1047 
 1048 =item pathMacro($args, @path)
 1049 
 1050 Helper macro for the C<#path> escape sequence: $args is a hash reference
 1051 containing the "style", "image", "text", and "textonly" arguments to the escape.
 1052 @path consists of ordered key-value pairs of the form:
 1053 
 1054  "Page Name" => URL
 1055 
 1056 If the page should not have a link associated with it, the URL should be left
 1057 empty. Authentication data is added to each URL so you don't have to. A fully-
 1058 formed path line is returned, suitable for returning by a function implementing
 1059 the C<#path> escape.
 1060 
 1061 FIXME: authentication data probably shouldn't be added here any more, now that
 1062 we have systemLink().
 1063 
 1064 =cut
 1065 
 1066 sub pathMacro {
 1067   my ($self, $args, @path) = @_;
 1068   my %args = %$args;
 1069   $args{style} = "text" if $args{textonly};
 1070 
 1071   my $auth = $self->url_authen_args;
 1072   my $sep;
 1073   if ($args{style} eq "image") {
 1074     $sep = CGI::img({-src=>$args{image}, -alt=>$args{text}});
 1075   } else {
 1076     $sep = $args{text};
 1077   }
 1078 
 1079   my @result;
 1080   while (@path) {
 1081     my $name = shift @path;
 1082     my $url = shift @path;
 1083     if ($url and not $args{textonly}) {
 1084       push @result, CGI::a({-href=>"$url?$auth"}, $name);
 1085     } else {
 1086       push @result, $name;
 1087     }
 1088   }
 1089 
 1090   return join($sep, @result), "\n";
 1091 }
 1092 
 1093 =item siblingsMacro(@siblings)
 1094 
 1095 Helper macro for the C<#siblings> escape sequence. @siblings consists of ordered
 1096 key-value pairs of the form:
 1097 
 1098  "Sibling Name" => URL
 1099 
 1100 If the sibling should not have a link associated with it, the URL should be left
 1101 empty. Authentication data is added to each URL so you don't have to. A fully-
 1102 formed siblings block is returned, suitable for returning by a function
 1103 implementing the C<#siblings> escape.
 1104 
 1105 FIXME: authentication data probably shouldn't be added here any more, now that
 1106 we have systemLink().
 1107 
 1108 =cut
 1109 
 1110 sub siblingsMacro {
 1111   my ($self, @siblings) = @_;
 1112 
 1113   my $auth = $self->url_authen_args;
 1114   my $sep = CGI::br();
 1115 
 1116   my @result;
 1117   while (@siblings) {
 1118     my $name = shift @siblings;
 1119     my $url = shift @siblings;
 1120     push @result, $url
 1121       ? CGI::a({-href=>"$url?$auth"}, $name)
 1122       : $name;
 1123   }
 1124 
 1125   return join($sep, @result) . "\n";
 1126 }
 1127 
 1128 
 1129 
 1130 =item navMacro($args, $tail, @links)
 1131 
 1132 Helper macro for the C<#nav> escape sequence: $args is a hash reference
 1133 containing the "style", "imageprefix", "imagesuffix", and "separator" arguments
 1134 to the escape. @siblings consists of ordered tuples of the form:
 1135 
 1136  "Link Name", URL, ImageBaseName
 1137 
 1138 If the sibling should not have a link associated with it, the URL should be left
 1139 empty. ImageBaseName is placed between the C<imageprefix> and C<imagesuffix>.
 1140 Authentication data is added to each URL so you don't have to. $tail is appended
 1141 to each URL, after the authentication information. A fully-formed nav line is
 1142 returned, suitable for returning by a function implementing the C<#nav> escape.
 1143 
 1144 =cut
 1145 
 1146 sub navMacro {
 1147   my ($self, $args, $tail, @links) = @_;
 1148   my $r = $self->r;
 1149   my $ce = $r->ce;
 1150   my %args = %$args;
 1151 
 1152   my $auth = $self->url_authen_args;
 1153   my $prefix = $ce->{webworkURLs}->{htdocs}."/images";
 1154 
 1155   my @result;
 1156   while (@links) {
 1157     my $name = shift @links;
 1158     my $url = shift @links;
 1159     my $img = shift @links;
 1160     my $html =
 1161       ($img && $args{style} eq "images")
 1162       ? CGI::img(
 1163         {src=>($prefix."/".$img.$args{imagesuffix}),
 1164         border=>"",
 1165         alt=>"$name"})
 1166       : $name;
 1167     unless($img && !$url) {
 1168       push @result, $url
 1169         ? CGI::a({-href=>"$url?$auth$tail"}, $html)
 1170         : $html;
 1171     }
 1172   }
 1173 
 1174   return join($args{separator}, @result) . "\n";
 1175 }
 1176 
 1177 =item helpMacro($name)
 1178 
 1179 This escape is represented by a question mark which links to an html page in the
 1180 helpFiles  directory.  Currently the link is made to the file $name.html
 1181 
 1182 =cut
 1183 
 1184 sub helpMacro {
 1185     my $self = shift;
 1186   my $name = shift;
 1187   my $ce   = $self->r->ce;
 1188   my $basePath = $ce->{webworkDirs}->{local_help};
 1189   $name        = 'no_help' unless -e "$basePath/$name.html";
 1190   my $path     = "$basePath/$name.html";
 1191   my $url = $ce->{webworkURLs}->{local_help}."/$name.html";
 1192   my $imageURL = $ce->{webworkURLs}->{htdocs}."/images/question_mark.png";
 1193   return CGI::a({href      => $url,
 1194                  target    => 'ww_help',
 1195                  onclick   => "window.open(this.href,this.target,'width=550,height=350,scrollbars=yes,resizable=on')"},
 1196                  CGI::img({src=>$imageURL}));
 1197 }
 1198 
 1199 =back
 1200 
 1201 =cut
 1202 
 1203 # ------------------------------------------------------------------------------
 1204 
 1205 =head2 Parameter management
 1206 
 1207 Methods for formatting request parameters as hidden form fields or query string
 1208 fragments.
 1209 
 1210 =over
 1211 
 1212 =item hidden_fields(@fields)
 1213 
 1214 Return hidden <INPUT> tags for each field mentioned in @fields (or all fields if
 1215 list is empty), taking data from the current request.
 1216 
 1217 =cut
 1218 
 1219 sub hidden_fields {
 1220   my ($self, @fields) = @_;
 1221   my $r = $self->r;
 1222 
 1223   @fields = $r->param unless @fields;
 1224 
 1225   my $html = "";
 1226   foreach my $param (@fields) {
 1227     my @values = $r->param($param);
 1228     $html .= CGI::hidden($param, @values);
 1229   }
 1230   return $html;
 1231 }
 1232 
 1233 =item hidden_authen_fields()
 1234 
 1235 Use hidden_fields to return hidden <INPUT> tags for request fields used in
 1236 authentication.
 1237 
 1238 =cut
 1239 
 1240 sub hidden_authen_fields {
 1241   my ($self) = @_;
 1242 
 1243   return $self->hidden_fields("user", "effectiveUser", "key");
 1244 }
 1245 
 1246 =item url_args(@fields)
 1247 
 1248 Return a URL query string (without the leading `?') containing values for each
 1249 field mentioned in @fields, or all fields if list is empty. Data is taken from
 1250 the current request.
 1251 
 1252 =cut
 1253 
 1254 sub url_args {
 1255   my ($self, @fields) = @_;
 1256   my $r = $self->r;
 1257 
 1258   @fields = $r->param unless @fields;
 1259 
 1260   my @pairs;
 1261   foreach my $param (@fields) {
 1262     my @values = $r->param($param);
 1263     foreach my $value (@values) {
 1264       push @pairs, uri_escape($param) . "=" . uri_escape($value);
 1265     }
 1266   }
 1267 
 1268   return join("&", @pairs);
 1269 }
 1270 
 1271 =item url_authen_args()
 1272 
 1273 Use url_args to return a URL query string for request fields used in
 1274 authentication.
 1275 
 1276 =cut
 1277 
 1278 sub url_authen_args {
 1279   my ($self) = @_;
 1280 
 1281   return $self->url_args("user", "effectiveUser", "key");
 1282 }
 1283 
 1284 =item print_form_data($begin, $middle, $end, $omit)
 1285 
 1286 Return a string containing every request field not matched by the quoted reguar
 1287 expression $omit, placing $begin before each field name, $middle between each
 1288 field name and its value, and $end after each value. Values are taken from the
 1289 current request.
 1290 
 1291 =cut
 1292 
 1293 sub print_form_data {
 1294   my ($self, $begin, $middle, $end, $qr_omit) = @_;
 1295   my $r=$self->r;
 1296   my @form_data = $r->param;
 1297 
 1298   my $return_string = "";
 1299   foreach my $name (@form_data) {
 1300     next if ($qr_omit and $name =~ /$qr_omit/);
 1301     my @values = $r->param($name);
 1302     foreach my $variable (qw(begin name middle value end)) {
 1303       # FIXME: can this loop be moved out of the enclosing loop?
 1304       no strict 'refs';
 1305       ${$variable} = "" unless defined ${$variable};
 1306     }
 1307     foreach my $value (@values) {
 1308       $return_string .= "$begin$name$middle$value$end";
 1309     }
 1310   }
 1311 
 1312   return $return_string;
 1313 }
 1314 
 1315 =back
 1316 
 1317 =cut
 1318 
 1319 # ------------------------------------------------------------------------------
 1320 
 1321 =head2 Utilities
 1322 
 1323 =over
 1324 
 1325 =item systemLink($urlpath, %options)
 1326 
 1327 Generate a link to another part of the system. $urlpath is WeBWorK::URLPath
 1328 object from which the base path will be taken. %options can consist of:
 1329 
 1330 =over
 1331 
 1332 =item params
 1333 
 1334 Can be either a reference to an array or a reference to a hash.
 1335 
 1336 If it is a reference to a hash, it maps parmaeter names to values. These
 1337 parameters will be included in the generated link. If a value is an arrayref,
 1338 the values of the array referenced will be used. If a value is undefined, the
 1339 value from the current request will be used.
 1340 
 1341 If C<params> is an arrayref, it is interpreted as a list of parameter names.
 1342 These parameters will be included in the generated link, using the values from
 1343 the current request.
 1344 
 1345 Unless C<authen> is false (see below), the authentication parameters (C<user>,
 1346 C<effectiveUser>, and C<key>) are included with their default values.
 1347 
 1348 =item authen
 1349 
 1350 If set to a false value, the authentication parameters (C<user>,
 1351 C<effectiveUser>, and C<key>) are included in the the generated link unless
 1352 explicitly listed in C<params>.
 1353 
 1354 =back
 1355 
 1356 =cut
 1357 
 1358 # FIXME: there should probably be an option for prepending "http://hostname:port"
 1359 sub systemLink {
 1360   my ($self, $urlpath, %options) = @_;
 1361   my $r = $self->r;
 1362 
 1363   my %params = ();
 1364   if (exists $options{params}) {
 1365     if (ref $options{params} eq "HASH") {
 1366       %params = %{ $options{params} };
 1367     } elsif (ref $options{params} eq "ARRAY") {
 1368       my @names = @{ $options{params} };
 1369       @params{@names} = ();
 1370     } else {
 1371       croak "option 'params' is not a hashref or an arrayref";
 1372     }
 1373   }
 1374 
 1375   my $authen = exists $options{authen} ? $options{authen} : 1;
 1376   if ($authen) {
 1377     $params{user}          = undef unless exists $params{user};
 1378     $params{effectiveUser} = undef unless exists $params{effectiveUser};
 1379     $params{key}           = undef unless exists $params{key};
 1380   }
 1381 
 1382   my $url = $r->location . $urlpath->path;
 1383   my $first = 1;
 1384 
 1385   foreach my $name (keys %params) {
 1386     my $value = $params{$name};
 1387 
 1388     my @values;
 1389     if (defined $value) {
 1390       if (ref $value eq "ARRAY") {
 1391         @values = @$value;
 1392       } else {
 1393         @values = $value;
 1394       }
 1395     } elsif (defined $r->param($name)) {
 1396       @values = $r->param($name);
 1397     }
 1398 
 1399     if (@values) {
 1400       if ($first) {
 1401         $url .= "?";
 1402         $first = 0;
 1403       } else {
 1404         $url .= "&";
 1405       }
 1406       $url .= join "&", map { "$name=$_" } @values;
 1407     }
 1408   }
 1409 
 1410   return $url;
 1411 }
 1412 
 1413 =item nbsp($string)
 1414 
 1415 If string consists of only whitespace, the HTML entity C<&nbsp;> is returned.
 1416 Otherwise $string is returned.
 1417 
 1418 =cut
 1419 
 1420 sub nbsp {
 1421   my $self = shift;
 1422   my $str  = shift;
 1423   (defined $str && $str =~/\S/) ? $str : '&nbsp;';
 1424 }
 1425 
 1426 =item space2nbsp($string)
 1427 
 1428 Replace spaces in the string with html non-breaking spaces.
 1429 
 1430 =cut
 1431 
 1432 sub space2nbsp {
 1433   my $str = shift;
 1434   $str =~ s/\s/&nbsp;/g;
 1435   return($str);
 1436 }
 1437 
 1438 =item errorOutput($error, $details)
 1439 
 1440 =cut
 1441 
 1442 sub errorOutput($$$) {
 1443   my ($self, $error, $details) = @_;
 1444   return
 1445     CGI::h3("Software Error"),
 1446     CGI::p(<<EOF),
 1447 WeBWorK has encountered a software error while attempting to process this
 1448 problem. It is likely that there is an error in the problem itself. If you are
 1449 a student, contact your professor to have the error corrected. If you are a
 1450 professor, please consut the error output below for more informaiton.
 1451 EOF
 1452     # FIXME: this message shouldn't refer the the "problem" since it is for general error reporting
 1453     CGI::h3("Error messages"), CGI::p(CGI::tt($error)),
 1454     CGI::h3("Error context"), CGI::p(CGI::tt($details));
 1455 }
 1456 
 1457 =item warningOutput($warnings)
 1458 
 1459 =cut
 1460 
 1461 sub warningOutput($$) {
 1462   my ($self, $warnings) = @_;
 1463 
 1464   my @warnings = split m/\n+/, $warnings;
 1465 
 1466   return
 1467     CGI::h3("Software Warnings"),
 1468     CGI::p(<<EOF),
 1469 WeBWorK has encountered warnings while attempting to process this problem. It
 1470 is likely that this indicates an error or ambiguity in the problem itself. If
 1471 you are a student, contact your professor to have the problem corrected. If you
 1472 are a professor, please consut the warning output below for more informaiton.
 1473 EOF
 1474     # FIXME: this message shouldn't refer the the "problem" since it is for general warning reporting
 1475     CGI::h3("Warning messages"),
 1476     CGI::ul(CGI::li(\@warnings));
 1477 }
 1478 
 1479 =back
 1480 
 1481 =head1 AUTHOR
 1482 
 1483 Written by Dennis Lambe Jr., malsyned (at) math.rochester.edu and Sam Hathaway,
 1484 sh002i (at) math.rochester.edu.
 1485 
 1486 =cut
 1487 
 1488 1;