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