Parent Directory
| 
Revision Log
updated copyright header. -sam
1 ################################################################################ 2 # WeBWorK mod_perl (c) 2000-2002 WeBWorK Project 3 # $Id$ 4 ################################################################################ 5 6 package WeBWorK::ContentGenerator; 7 8 =head1 NAME 9 10 WeBWorK::ContentGenerator - base class for modules that generate page content. 11 12 =cut 13 14 use strict; 15 use warnings; 16 use Apache::Constants qw(:common); 17 use CGI qw(); 18 use URI::Escape; 19 use WeBWorK::Utils qw(readFile); 20 #use CGI::Carp qw(fatalsToBrowser); 21 22 ################################################################################ 23 # This is a very unruly file, so I'm going to use very large comments to divide 24 # it into logical sections. 25 ################################################################################ 26 27 # new(Apache::Request, WeBWorK::CourseEnvironment) - create a new instance of a 28 # content generator. Usually only called by the dispatcher, although one might 29 # be able to use it for things like "sub-requests". Uh... uh... I have to think 30 # about that one. The dispatcher uses this idiom: 31 # 32 # 33 # WeBWorK::ContentGenerator::WHATEVER->new($r, $ce)->go(@whatever); 34 # 35 # and throws away the result ;) 36 # 37 sub new($$$) { 38 my $invocant = shift; 39 my $class = ref($invocant) || $invocant; 40 my $self = {}; 41 ($self->{r}, $self->{courseEnvironment}) = @_; 42 bless $self, $class; 43 return $self; 44 } 45 46 ################################################################################ 47 # Invocation and template processing 48 ################################################################################ 49 50 # go(@otherArguments) - render a page, using methods from the particular 51 # subclass of ContentGenerator. @otherArguments is passed to each method, so 52 # that the dispatcher can pass CG-specific data. The order of calls looks like 53 # this: 54 # 55 # * &pre_header_initialize - give subclasses a chance to do initialization 56 # necessary for generating the HTTP header. 57 # * &header - this class provides a standard HTTP header with Content-Type 58 # text/html. Subclasses are welcome to overload this for things like 59 # an image-creation content generator or a PDF generator. 60 # * &initialize - let subclasses do post-header initialization. 61 # * any "template escapes" defined in the system template and supported by 62 # the subclass. Generic implementations of &title and &body are provided. 63 # 64 sub go { 65 my $self = shift; 66 my $r = $self->{r}; 67 my $courseEnvironment = $self->{courseEnvironment}; 68 69 $self->pre_header_initialize(@_) if $self->can("pre_header_initialize"); 70 $self->header(@_); 71 return OK if $r->header_only; 72 73 $self->initialize(@_) if $self->can("initialize"); 74 $self->template($courseEnvironment->{templates}->{system}, @_); 75 76 return OK; 77 } 78 79 # template(STRING, @otherArguments) - parse a template, looking for escapes of 80 # the form <!--#NAME ARG1="FOO" ARG2="BAR"--> and calling a member function NAME 81 # (if available) for each NAME. The escapes are called like: 82 # 83 # $self->NAME(@otherArguments, \%escapeArguments) 84 # 85 # where @otherArguments originates in the dispatcher and %escapeArguments is 86 # parsed out of the escape itself (i.e. ARG1 => FOO, ARG2 => BAR) 87 # 88 sub template { 89 my ($self, $templateFile) = (shift, shift); 90 my $r = $self->{r}; 91 my $courseEnvironment = $self->{courseEnvironment}; 92 93 # so even though the variable $/ APPEARS to contain a newline, 94 # <TEMPLATE> is slurping the whole file into the first element of 95 # @template ONLY AFTER THE TRANSLATOR RUNS. WTF!!! 96 # 97 #open(TEMPLATE, $templateFile) or die "Couldn't open template $templateFile"; 98 #my @template = <TEMPLATE>; 99 #close TEMPLATE; 100 # 101 # Let's try something else instead: 102 103 my @template = split /\n/, readFile($templateFile); 104 105 foreach my $line (@template) { 106 #warn "foo: $line\n"; 107 # This is incremental regex processing. 108 # the /c is so that pos($line) doesn't die when the regex fails. 109 while ($line =~ m/\G(.*?)<!--#(\w*)((?:\s+.*?)?)-->/gc) { 110 my ($before, $function, $raw_args) = ($1, $2, $3); 111 # $args here will be a hashref 112 my $args = $raw_args =~ /\S/ ? cook_args($raw_args) : {}; 113 print $before; 114 115 if ($self->can($function)) { 116 print $self->$function(@_, $args); 117 } 118 } 119 120 print substr $line, (defined(pos($line)) ? pos($line) : 0); 121 } 122 } 123 124 # cook_args(STRING) - parses a string of the form ARG1="FOO" ARG2="BAR". Returns 125 # a reference to a hash containing the parsed arguments. 126 # 127 sub cook_args($) { 128 # There are a bunch of commented-out lines that I am using to remind myself 129 # That I want to write a better regex sometime. 130 my ($raw_args) = @_; 131 my $args = {}; 132 #my $quotable_string = qr/(?:".*?(?<*\\)"|\W*)/; 133 #my $quotable_string = qr/(?:".*?(?<!\\)"|\W*)/; 134 #my $test_string = '"hel \" lo" hello'; 135 136 #warn $test_string =~ m/($quotable_string)/ ? $1 : "false"; 137 138 while ($raw_args =~ m/\G\s*(\w*)="(.*?)"/g) { 139 #while ($raw_args =~ m/\G\s*($quotable_string)=($quotable_string)/g) { 140 $args->{$1} = $2; 141 } 142 143 return $args; 144 } 145 146 ################################################################################ 147 # Macros used by content generators to render common idioms 148 ################################################################################ 149 150 # pathMacro(HASHREF, LIST) - helper macro for <!--#path--> escape: the hash 151 # reference contains the "style", "image", and "text" arguments to the escape. 152 # The LIST consists of ordered key-value pairs of the form: 153 # 154 # "Page Name" => URL 155 # 156 # If the page should not have a link associated with it, the URL should be left 157 # empty. Authentication data is added to the URL so you don't have to. A fully- 158 # formed path line is returned, suitable for returning by a function 159 # implementing the #path escape. 160 # 161 sub pathMacro { 162 my $self = shift; 163 my %args = %{ shift() }; 164 my @path = @_; 165 my $sep; 166 if ($args{style} eq "image") { 167 $sep = CGI::img({-src=>$args{image}, -alt=>$args{text}}); 168 } else { 169 $sep = $args{text}; 170 } 171 my $auth = $self->url_authen_args; 172 my @result; 173 while (@path) { 174 my $name = shift @path; 175 my $url = shift @path; 176 push @result, $url 177 ? CGI::a({-href=>"$url?$auth"}, $name) 178 : $name; 179 } 180 return join($sep, @result), "\n"; 181 } 182 183 sub siblingsMacro { 184 my $self = shift; 185 my @siblings = @_; 186 my $sep = CGI::br(); 187 my $auth = $self->url_authen_args; 188 my @result; 189 while (@siblings) { 190 my $name = shift @siblings; 191 my $url = shift @siblings; 192 push @result, $url 193 ? CGI::a({-href=>"$url?$auth"}, $name) 194 : $name; 195 } 196 return join($sep, @result), "\n"; 197 } 198 199 sub navMacro { 200 my $self = shift; 201 my %args = %{ shift() }; 202 my @links = @_; 203 my $auth = $self->url_authen_args; 204 my @result; 205 while (@links) { 206 my $name = shift @links; 207 my $url = shift @links; 208 push @result, $url 209 ? CGI::a({-href=>"$url?$auth"}, $name) 210 : $name; 211 } 212 return join($args{separator}, @result), "\n"; 213 } 214 215 # hidden_fields(LIST) - return hidden <INPUT> tags for each field mentioned in 216 # LIST (or all fields if list is empty), taking data from the current request. 217 # 218 sub hidden_fields($;@) { 219 my $self = shift; 220 my $r = $self->{r}; 221 my @fields = @_; 222 @fields or @fields = $r->param; 223 my $courseEnvironment = $self->{courseEnvironment}; 224 my $html = ""; 225 226 foreach my $param (@fields) { 227 my $value = $r->param($param); 228 $html .= CGI::input({-type=>"hidden",-name=>"$param",-value=>"$value"}); 229 } 230 return $html; 231 } 232 233 # hidden_authen_fields() - use hidden_fields to return hidden <INPUT> tags for 234 # request fields used in authentication. 235 # 236 sub hidden_authen_fields($) { 237 my $self = shift; 238 return $self->hidden_fields("user","effectiveUser","key"); 239 } 240 241 # url_args(LIST) - return a URL query string (without the leading `?') 242 # containing values for each field mentioned in LIST, or all fields if list is 243 # empty. Data is taken from the current request. 244 # 245 sub url_args($;@) { 246 my $self = shift; 247 my $r = $self->{r}; 248 my @fields = @_; 249 @fields or @fields = $r->param; 250 my $courseEnvironment = $self->{courseEnvironment}; 251 252 my @pairs; 253 foreach my $param (@fields) { 254 my $value = $r->param($param) || ""; 255 push @pairs, uri_escape($param) . "=" . uri_escape($value); 256 } 257 258 return join("&", @pairs); 259 } 260 261 # url_authen_args() - use url_args to return a URL query string for request 262 # fields used in authentication. 263 # 264 sub url_authen_args($) { 265 my $self = shift; 266 my $r = $self->{r}; 267 return $self->url_args("user","effectiveUser","key"); 268 } 269 270 # print_form_data(BEGIN, MIDDLE, END, OMIT) - return a string containing request 271 # fields not matched by OMIT, placing BEGIN before each field name, MIDDLE 272 # between each field and its value, and END after each value. Values are taken 273 # from the current request. OMIT is a quoted reguar expression. 274 # 275 sub print_form_data { 276 my ($self, $begin, $middle, $end, $qr_omit) = @_; 277 my $return_string = ""; 278 my $r=$self->{r}; 279 my @form_data = $r->param; 280 foreach my $name (@form_data) { 281 next if ($qr_omit and $name =~ /$qr_omit/); 282 my @values = $r->param($name); 283 foreach my $variable (qw(begin name middle value end)) { 284 no strict 'refs'; 285 ${$variable} = "" unless defined ${$variable}; 286 } 287 foreach my $value (@values) { 288 $return_string .= "$begin$name$middle$value$end"; 289 } 290 } 291 return $return_string; 292 } 293 294 ################################################################################ 295 # Generic versions of template escapes 296 ################################################################################ 297 298 # Reminder: here are the template functions currently defined: 299 # 300 # path 301 # style = text|image 302 # image = URL of image 303 # text = text separator 304 # quicklinks 305 # siblings 306 # nav 307 # style = text|image 308 # imageprefix = prefix to image URL 309 # imagesuffix = suffix to image URL 310 # separator = HTML to place in between links 311 # title 312 # body 313 314 sub header { 315 my $self = shift; 316 my $r = $self->{r}; 317 $r->content_type('text/html'); 318 $r->send_http_header(); 319 } 320 321 sub quicklinks { 322 my $self = shift; 323 my $ce = $self->{courseEnvironment}; 324 my $root = $ce->{webworkURLs}->{root}; 325 my $courseName = $ce->{courseName}; 326 my $probSets = "$root/$courseName/?" . $self->url_authen_args(); 327 # my $prefs = "$root/prefs/?" . $self->url_authen_args(); 328 # my $help = $ce->{webworkURLs}->{docs} . "?" . $self->url_authen_args(); 329 my $logout = "$root/$courseName/"; 330 return 331 CGI::a({-href=>$probSets}, "Problem Sets"), CGI::br(), 332 # CGI::a({-href=>$prefs}, "User Options"), CGI::br(), 333 # CGI::a({-href=>$help}, "Help"), CGI::br(), 334 CGI::a({-href=>$logout}, "Log Out"), CGI::br(), 335 ; 336 } 337 338 sub title { 339 return "WeBWorK"; 340 } 341 342 sub body { 343 return "Generated content"; 344 } 345 346 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |