Parent Directory
| 
Revision Log
Added the new &if_$key infrastructure -dennis
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 my @ifstack = (1); # Start off in printing mode 93 # say $ifstack[-1] to get the result of the last <#!--if--> 94 95 # so even though the variable $/ APPEARS to contain a newline, 96 # <TEMPLATE> is slurping the whole file into the first element of 97 # @template ONLY AFTER THE TRANSLATOR RUNS. WTF!!! 98 # 99 #open(TEMPLATE, $templateFile) or die "Couldn't open template $templateFile"; 100 #my @template = <TEMPLATE>; 101 #close TEMPLATE; 102 # 103 # Let's try something else instead: 104 my @template = split /\n/, readFile($templateFile); 105 106 foreach my $line (@template) { 107 #warn "foo: $line\n"; 108 # This is incremental regex processing. 109 # the /c is so that pos($line) doesn't die when the regex fails. 110 while ($line =~ m/\G(.*?)<!--#(\w*)((?:\s+.*?)?)-->/gc) { 111 my ($before, $function, $raw_args) = ($1, $2, $3); 112 # $args here will be a hashref 113 my @args = $raw_args =~ /\S/ ? cook_args($raw_args) : {}; 114 if ($ifstack[-1]) { 115 print $before; 116 } 117 118 if ($self->can($function)) { 119 if ($function eq "if") { 120 push @ifstack, $self->$function(@_, [@args]); 121 } elsif ($function eq "else" and @ifstack > 1) { 122 $ifstack[-1] = not $ifstack[-1]; 123 } elsif ($function eq "endif" and @ifstack > 1) { 124 pop @ifstack; 125 } elsif ($ifstack[-1]) { 126 print $self->$function(@_, {@args}); 127 } 128 } 129 } 130 131 if ($ifstack[-1]) { 132 print substr $line, (defined pos $line) ? pos $line : 0; 133 } 134 } 135 } 136 137 # cook_args(STRING) - parses a string of the form ARG1="FOO" ARG2="BAR". Returns 138 # a list which pairs into key/values and fits nicely in {}s. 139 # 140 sub cook_args($) { 141 my ($raw_args) = @_; 142 my @args = (); 143 144 # Boy I love m//g in scalar context! Go read the camel book, heathen. 145 # First, get the whole token with the quotes on both ends... 146 while ($raw_args =~ m/\G\s*(\w*)="((?:[^"\\]|\\.)*)"/g) { 147 my ($key, $value) = ($1, $2); 148 # ... then, rip out all the protecty backspaces 149 $value =~ s/\\(.)/$1/g; 150 push @args, $key => $value; 151 } 152 153 return @args; 154 } 155 156 ################################################################################ 157 # Macros used by content generators to render common idioms 158 ################################################################################ 159 160 # pathMacro(HASHREF, LIST) - helper macro for <!--#path--> escape: the hash 161 # reference contains the "style", "image", and "text" arguments to the escape. 162 # The LIST consists of ordered key-value pairs of the form: 163 # 164 # "Page Name" => URL 165 # 166 # If the page should not have a link associated with it, the URL should be left 167 # empty. Authentication data is added to the URL so you don't have to. A fully- 168 # formed path line is returned, suitable for returning by a function 169 # implementing the #path escape. 170 # 171 sub pathMacro { 172 my $self = shift; 173 my %args = %{ shift() }; 174 my @path = @_; 175 my $sep; 176 if ($args{style} eq "image") { 177 $sep = CGI::img({-src=>$args{image}, -alt=>$args{text}}); 178 } else { 179 $sep = $args{text}; 180 } 181 my $auth = $self->url_authen_args; 182 my @result; 183 while (@path) { 184 my $name = shift @path; 185 my $url = shift @path; 186 push @result, $url 187 ? CGI::a({-href=>"$url?$auth"}, $name) 188 : $name; 189 } 190 return join($sep, @result), "\n"; 191 } 192 193 sub siblingsMacro { 194 my $self = shift; 195 my @siblings = @_; 196 my $sep = CGI::br(); 197 my $auth = $self->url_authen_args; 198 my @result; 199 while (@siblings) { 200 my $name = shift @siblings; 201 my $url = shift @siblings; 202 push @result, $url 203 ? CGI::a({-href=>"$url?$auth"}, $name) 204 : $name; 205 } 206 return join($sep, @result), "\n"; 207 } 208 209 sub navMacro { 210 my $self = shift; 211 my %args = %{ shift() }; 212 my @links = @_; 213 my $auth = $self->url_authen_args; 214 my @result; 215 while (@links) { 216 my $name = shift @links; 217 my $url = shift @links; 218 push @result, $url 219 ? CGI::a({-href=>"$url?$auth"}, $name) 220 : $name; 221 } 222 return join($args{separator}, @result), "\n"; 223 } 224 225 # hidden_fields(LIST) - return hidden <INPUT> tags for each field mentioned in 226 # LIST (or all fields if list is empty), taking data from the current request. 227 # 228 sub hidden_fields($;@) { 229 my $self = shift; 230 my $r = $self->{r}; 231 my @fields = @_; 232 @fields or @fields = $r->param; 233 my $courseEnvironment = $self->{courseEnvironment}; 234 my $html = ""; 235 236 foreach my $param (@fields) { 237 my $value = $r->param($param); 238 $html .= CGI::input({-type=>"hidden",-name=>"$param",-value=>"$value"}); 239 } 240 return $html; 241 } 242 243 # hidden_authen_fields() - use hidden_fields to return hidden <INPUT> tags for 244 # request fields used in authentication. 245 # 246 sub hidden_authen_fields($) { 247 my $self = shift; 248 return $self->hidden_fields("user","effectiveUser","key"); 249 } 250 251 # url_args(LIST) - return a URL query string (without the leading `?') 252 # containing values for each field mentioned in LIST, or all fields if list is 253 # empty. Data is taken from the current request. 254 # 255 sub url_args($;@) { 256 my $self = shift; 257 my $r = $self->{r}; 258 my @fields = @_; 259 @fields or @fields = $r->param; 260 my $courseEnvironment = $self->{courseEnvironment}; 261 262 my @pairs; 263 foreach my $param (@fields) { 264 my $value = $r->param($param) || ""; 265 push @pairs, uri_escape($param) . "=" . uri_escape($value); 266 } 267 268 return join("&", @pairs); 269 } 270 271 # url_authen_args() - use url_args to return a URL query string for request 272 # fields used in authentication. 273 # 274 sub url_authen_args($) { 275 my $self = shift; 276 my $r = $self->{r}; 277 return $self->url_args("user","effectiveUser","key"); 278 } 279 280 # print_form_data(BEGIN, MIDDLE, END, OMIT) - return a string containing request 281 # fields not matched by OMIT, placing BEGIN before each field name, MIDDLE 282 # between each field and its value, and END after each value. Values are taken 283 # from the current request. OMIT is a quoted reguar expression. 284 # 285 sub print_form_data { 286 my ($self, $begin, $middle, $end, $qr_omit) = @_; 287 my $return_string = ""; 288 my $r=$self->{r}; 289 my @form_data = $r->param; 290 foreach my $name (@form_data) { 291 next if ($qr_omit and $name =~ /$qr_omit/); 292 my @values = $r->param($name); 293 foreach my $variable (qw(begin name middle value end)) { 294 no strict 'refs'; 295 ${$variable} = "" unless defined ${$variable}; 296 } 297 foreach my $value (@values) { 298 $return_string .= "$begin$name$middle$value$end"; 299 } 300 } 301 return $return_string; 302 } 303 304 ################################################################################ 305 # Generic versions of template escapes 306 ################################################################################ 307 308 # Reminder: here are the template functions currently defined: 309 # 310 # path 311 # style = text|image 312 # image = URL of image 313 # text = text separator 314 # links 315 # siblings 316 # nav 317 # style = text|image 318 # imageprefix = prefix to image URL 319 # imagesuffix = suffix to image URL 320 # separator = HTML to place in between links 321 # title 322 # body 323 324 sub header { 325 my $self = shift; 326 my $r = $self->{r}; 327 $r->content_type('text/html'); 328 $r->send_http_header(); 329 } 330 331 sub links { 332 my $self = shift; 333 my $ce = $self->{courseEnvironment}; 334 my $root = $ce->{webworkURLs}->{root}; 335 my $courseName = $ce->{courseName}; 336 my $probSets = "$root/$courseName/?" . $self->url_authen_args(); 337 # my $prefs = "$root/prefs/?" . $self->url_authen_args(); 338 # my $help = $ce->{webworkURLs}->{docs} . "?" . $self->url_authen_args(); 339 my $logout = "$root/$courseName/"; 340 return 341 CGI::a({-href=>$probSets}, "Problem Sets"), CGI::br(), 342 # CGI::a({-href=>$prefs}, "User Options"), CGI::br(), 343 # CGI::a({-href=>$help}, "Help"), CGI::br(), 344 CGI::a({-href=>$logout}, "Log Out"), CGI::br(), 345 ; 346 } 347 348 # This is different. It probably should print anything (except in debugging cases) 349 # and it should return a boolean, not a string. &if is called in a nonstandard way 350 # by &template, with $args as an arrayref instead of a hashref. this is a hack! yay! 351 352 # OK, this is a pluggin architecture. it iterates through attributes of the "if" tag, 353 # and for each predicate $p, it calls &if_$p in an object-oriented way, continuing the 354 # grand templating theme of an object-oriented pluggable architecture using ->can($). 355 sub if { 356 my ($self, $args) = @_[0,-1]; 357 # A single if "or"s it's components. Nesting produces "and". 358 359 my @args = @$args; # Hahahahaha, get it?! 360 361 if (@args % 2 != 0) { 362 # flip out and kill people, but do not commit seppuku 363 print '<!--&if recieved an uneven number of arguments. This shouldn\'t happen, but I\'ll let it slide.-->\n'; 364 } 365 366 while (@args > 1) { 367 my ($key, $value) = (shift @args, shift @args); 368 369 # a non-existent &if_$key is the same as a false result, but we're ORing, so it's OK 370 my $sub = "if_$key"; # perl doesn't like it when you try to construct a string right in a method invocation 371 if ($self->can("if_$key") and $self->$sub("$value")) { 372 return 1; 373 } 374 } 375 376 return 0; 377 } 378 379 # &if_can will return 1 if the current object->can("do $_[1]") 380 sub if_can ($$) { 381 my ($self, $arg) = (@_); 382 383 if ($self->can("$arg")) { 384 return 1; 385 } else { 386 return 0; 387 } 388 } 389 390 1; 391 392 __END__ 393 394 =head1 AUTHOR 395 396 Written by Dennis Lambe Jr., malsyned (at) math.rochester.edu 397 and Sam Hathaway, sh002i (at) math.rochester.edu. 398 399 =cut
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |