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

    1 package WeBWorK::ContentGenerator;
    2 
    3 use CGI qw(-compile :html :form);
    4 use Apache::Constants qw(:common);
    5 
    6 # Send 'die' message to the browser window
    7 #use CGI::Carp qw(fatalsToBrowser);
    8 
    9 
   10 # This is a superclass for Apache::WeBWorK's content generators.
   11 # You are /definitely/ encouraged to read this file, since there are
   12 # "abstract" functions here which show aproximately what form you would
   13 # want over-ridden sub-classes to follow.
   14 
   15 # new(Apache::Request, WeBWorK::CourseEnvironment)
   16 sub new($$$) {
   17   my $invocant = shift;
   18   my $class = ref($invocant) || $invocant;
   19   my $self = {};
   20   ($self->{r}, $self->{courseEnvironment}) = @_;
   21   bless $self, $class;
   22   return $self;
   23 }
   24 
   25 
   26 # This is a quick and dirty function to print out all (or almost all) of the
   27 # fields in a form in a specified format.  As you can see from the print
   28 # statement, it just prints out $begining$name$middle$value$end for every
   29 # field who's name doesn't match $qr_omit, a quoted regex.
   30 # In it's current incarnation, it should be called from subclasses only,
   31 # by saying $self->print_form_data.  Of course, you could construct a
   32 # hashref with ->{r} being an Apache::Request, I suppose.
   33 
   34 sub print_form_data {
   35   my ($self, $begin, $middle, $end, $qr_omit) = @_;
   36   my $return_string = "";
   37 
   38   $r=$self->{r};
   39   my @form_data = $r->param;
   40   foreach my $name (@form_data) {
   41     next if ($qr_omit and $name =~ /$qr_omit/);
   42     my @values = $r->param($name);
   43     foreach my $value (@values) {
   44       $return_string .= "$begin$name$middle$value$end";
   45     }
   46   }
   47 
   48   return $return_string;
   49 }
   50 
   51 sub hidden_authen_fields {
   52   my $self = shift;
   53   my $r = $self->{r};
   54   my $courseEnvironment = $self->{courseEnvironment};
   55   my $html = "";
   56 
   57   foreach $param ("user","effectiveUser","key") {
   58     my $value = $r->param($param);
   59     $html .= input({-type=>"hidden",-name=>"$param",-value=>"$value"});
   60   }
   61   return $html;
   62 }
   63 
   64 #sub hidden_authen_fields($) {
   65 # my $self = shift;
   66 # return $self->hidden_fields("user","effectiveUser","key");
   67 #}
   68 
   69 sub hidden_fields($;@) {
   70   my $self = shift;
   71   my $r = $self->{r};
   72   my @fields = @_;
   73   @fields or @fields = $r->param;
   74   my $courseEnvironment = $self->{courseEnvironment};
   75   my $html = "";
   76 
   77   foreach $param (@fields) {
   78     my $value = $r->param($param);
   79     $html .= input({-type=>"hidden",-name=>"$param",-value=>"$value"});
   80   }
   81   return $html;
   82 }
   83 
   84 ### Functions that subclasses /should/ override under most circumstances
   85 
   86 sub title {
   87   return "Superclass";
   88 }
   89 
   90 sub body {
   91   print "Generated content";
   92   "";
   93 }
   94 
   95 ### Functions that subclasses /may/ want to override, if they've got something
   96 ### special to say
   97 
   98 sub pre_header_initialize {}
   99 
  100 sub header {
  101   my $self = shift;
  102   my $r=$self->{r};
  103   $r->content_type('text/html');
  104   $r->send_http_header();
  105 }
  106 
  107 sub initialize {}
  108 
  109 ### Content-generating functions that should probably not be overridden
  110 ### by most subclasses
  111 
  112 sub logo {
  113   my $self = shift;
  114   return $self->{courseEnvironment}->{webworkUrls}->{logo};
  115 }
  116 
  117 sub htdocs_base {
  118   my $self = shift;
  119   return $self->{courseEnvironment}->{webworkUrls}->{base};
  120 }
  121 
  122 sub test_args {
  123   my %args = %{$_[-1]};
  124 
  125   print "<pre>";
  126   print "$_ => $args{$_}\n" foreach (keys %args);
  127   print "</pre>";
  128   "";
  129 }
  130 
  131 # Used by &go to parse the argument fields of the template escapes
  132 sub cook_args($) {
  133   # There are a bunch of commented-out lines that I am using to remind myself
  134   # That I want to write a better regex sometime.
  135   my ($raw_args) = @_;
  136   my $args = {};
  137   #my $quotable_string = qr/(?:".*?(?<![^\\](?:\\\\)*\\)"|\W*)/;
  138   #my $quotable_string = qr/(?:".*?(?<!\\)"|\W*)/;
  139   #my $test_string = '"hel \" lo" hello';
  140 
  141   #warn $test_string =~ m/($quotable_string)/ ? $1 : "false";
  142 
  143   while ($raw_args =~ m/\G\s*(\w*)="(.*?)"/g) {
  144   #while ($raw_args =~ m/\G\s*($quotable_string)=($quotable_string)/g) {
  145     $args->{$1} = $2;
  146   }
  147 
  148   return $args;
  149 }
  150 
  151 # Perform substitution in a template file and print it.  This should be called
  152 # for all content generators that are creating HTML output, and is called by
  153 # default by the &go method.
  154 sub template {
  155   my ($self, $templateFile) = (shift, shift);
  156   my $r = $self->{r};
  157   my $courseEnvironment = $self->{courseEnvironment};
  158 
  159   open(TEMPLATE, $templateFile) or die "Couldn't open template $templateFile";
  160   my @template = <TEMPLATE>;
  161   close TEMPLATE;
  162 
  163   foreach my $line (@template) {
  164     # This is incremental regex processing.
  165     # the /c is so that pos($line) doesn't die when the regex fails.
  166     while ($line =~ m/\G(.*?)<!--#(\w*)((?:\s+.*?)?)-->/gc) {
  167       my ($before, $function, $raw_args) = ($1, $2, $3);
  168       # $args here will be a hashref
  169       my $args = cook_args $raw_args if $raw_args =~ /\S/;
  170       print $before;
  171       print $self->$function(@_, $args) if $self->can($function);
  172     }
  173     print substr $line, pos($line);
  174   }
  175 }
  176 
  177 # Do whatever needs to be done in order to get a page to the client.  You
  178 # probably don't want to override this unless you're not making a web page
  179 # with the template.
  180 sub go {
  181   my $self = shift;
  182   my $r = $self->{r};
  183   my $courseEnvironment = $self->{courseEnvironment};
  184 
  185   $self->pre_header_initialize(@_);
  186   $self->header(@_); return OK if $r->header_only;
  187   $self->initialize(@_);
  188 
  189   $self->template($courseEnvironment->{templates}->{system}, @_);
  190 
  191   return OK;
  192 }
  193 
  194 1;