[Bio] / FigWebServices / ProcessTemplate.cgi Repository:
ViewVC logotype

Annotation of /FigWebServices/ProcessTemplate.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (view) (download)

1 : parrello 1.1 #!/usr/bin/perl -w
2 :    
3 :     =head1 Produce Template
4 :    
5 :     This script applies prompt values to a template. The template is passed in via a
6 :     file name, and the template contains special tokens delimited by double brackets
7 :     with a percent sign (e.g. C<[[%ask1:Method Name]]>). The data from the CGI
8 :     parameters is used to process the tokens, and the result is returned as a
9 : parrello 1.2 downloadable file.
10 : parrello 1.1
11 :     This script supports the following CGI query parameters.
12 :    
13 :     =over 4
14 :    
15 :     =item askX
16 :    
17 :     The value of the C<ask> prompt with ID I<X>.
18 :    
19 :     =item flagX
20 :    
21 :     The value of the C<flag> checkbox with ID I<X>
22 :    
23 :     =item templateFile
24 :    
25 :     The name of the template file on the server.
26 :    
27 : parrello 1.3 =item fileTitle
28 :    
29 :     The title (file name without suffix) to give the file.
30 :    
31 :     =item flagList
32 :    
33 :     A comma-separated list of flag names used in the template.
34 :    
35 : parrello 1.1 =back
36 :    
37 :     =cut
38 :    
39 :     use strict;
40 :     use Tracer;
41 :     use CGI;
42 :    
43 :     my ($cgi, $varHash) = ScriptSetup();
44 :     eval {
45 : parrello 1.2 # Get the template file name.
46 : parrello 1.3 my $fileNamePart = $cgi->param('fileTitle') || 'NewFile';
47 : parrello 1.2 my $fileName = $cgi->param('templateFile');
48 : parrello 1.3 my $fileTitle = ($fileName =~ m#-(\w+)\.# ? "$fileNamePart.$1" : "$fileNamePart.pm");
49 :     Trace("Chosen output file name is $fileTitle.") if T(3);
50 : parrello 1.1 # Extract the ask and flag parameters.
51 :     my @names = $cgi->param;
52 :     my %parms = map { $_ => $cgi->param($_) } grep { $_ =~ /^(ask|flag)/ } @names;
53 : parrello 1.3 # Put in missing flag parameters. This is so we can tell when the template asks for
54 :     # a nonexistent flag.
55 :     my @flags = split /\s*,\s*/, $cgi->param("flagList");
56 :     for my $flag (@flags) {
57 :     if (! exists $parms{$flag}) {
58 :     $parms{$flag} = 0;
59 :     }
60 :     }
61 : parrello 1.1 # We'll accumulate the page text in here.
62 :     my $retVal = "";
63 :     # Set up the IF stack. The top entry on the stack tells us whether or not
64 :     # we're generating or skipping. We start with generating.
65 :     my @ifStack = (1);
66 :     # Denote we haven't stopped.
67 :     my $going = 1;
68 :     # Slurp in the template.
69 :     my @lines = Tracer::GetFile($fileName);
70 :     # Loop through the template lines, generating code.
71 :     for my $line (@lines) {
72 :     # Only proceed if we're not stopped.
73 :     if ($going) {
74 :     # We need to run through all the markers in the current line and act
75 :     # accordingly. We do this with a match loop. The variable "$pos" will
76 :     # point to the unparsed part of the line.
77 :     my $pos = 0;
78 : parrello 1.3 # This variable is set to 1 if we want to discard the line, which is
79 :     # sometimes the case.
80 :     my $discard = 0;
81 : parrello 1.1 # The horrific search expression below will match any marker. A marker
82 :     # is surrounded by doubled square brackets. Inside the brackets there is
83 :     # a percent sign, a label (with optional number), and an optional
84 : parrello 1.3 # argument.
85 :     while (!$discard && $line =~ /(\[\[%(\w+\d*)(:([^\]]+))?\]\])/g) {
86 : parrello 1.1 # Get the data we need from the pattern match.
87 :     my $tokenLen = length $1;
88 :     my $label = $2;
89 :     my $argument = $4;
90 :     my $endPos = pos $line;
91 : parrello 1.3 Trace("Token label is $label with argument \"$argument\".") if T(4);
92 : parrello 1.1 # If we are generating, start with the residual (that is, the text prior to
93 : parrello 1.3 # the current token). If the token starts the line, however, we won't generate
94 :     # anything here.
95 : parrello 1.1 if ($ifStack[$#ifStack]) {
96 :     $retVal .= substr($line, $pos, $endPos - $tokenLen - $pos);
97 :     }
98 :     # Now check the token type.
99 :     if ($label eq 'if') {
100 :     # IF: evaluate the argument and push its truth or falsehood onto the
101 :     # if-stack. No code is generated.
102 :     if (! exists $parms{$argument}) {
103 :     Confess("Token definition for $argument not found.");
104 :     } else {
105 : parrello 1.3 Trace("IF value pushed for $argument is \"$parms{$argument}\".") if T(3);
106 :     push @ifStack, ($parms{$argument} ? 1 : 0);
107 :     $discard = 1;
108 : parrello 1.1 }
109 :     } elsif ($label eq 'fi') {
110 :     # FI: pop the IF-stack. No code is generated.
111 :     if (@ifStack == 1) {
112 :     Confess("FI without matching IF.");
113 :     } else {
114 :     pop @ifStack;
115 : parrello 1.3 $discard = 1;
116 : parrello 1.1 }
117 :     } elsif ($label eq 'stop') {
118 : parrello 1.3 # STOP: Denote we're no longer going.
119 : parrello 1.1 $going = 0;
120 : parrello 1.3 $discard = 1;
121 : parrello 1.1 } elsif ($label =~ /ask/) {
122 : parrello 1.3 # ASK: substitute the labeled parameter value. (But
123 : parrello 1.1 # only if we're generating.
124 :     if (! exists $parms{$label}) {
125 :     Confess("Label $label not found.");
126 :     } elsif ($ifStack[$#ifStack]) {
127 :     $retVal .= $parms{$label};
128 :     }
129 :     } elsif ($label =~ /flag/) {
130 : parrello 1.3 # FLAG: all flags are ignored. They are used by the if-logic, but
131 :     # are not part of the generated code.
132 :     $discard = 1;
133 : parrello 1.1 } else {
134 :     Confess("Invalid token label $label.");
135 :     }
136 :     # Save the current position for the next iteration of the search pattern
137 :     # loop,
138 :     $pos = $endPos;
139 :     }
140 :     # We've reached the end of the line. If we're generating, add on the
141 :     # residual and the new-line code.
142 : parrello 1.3 if ($ifStack[$#ifStack] && ! $discard) {
143 : parrello 1.1 $retVal .= substr($line, $pos) . "\n";
144 :     }
145 :     }
146 :     }
147 : parrello 1.3 print $cgi->header(-type => 'application/octet-stream',
148 :     -attachment => $fileTitle);
149 :     # Put us in binary mode so that the output doesn't do screwy stuff with new-lines.
150 :     # The resulting file will be encoded for Unix.
151 :     binmode(STDOUT);
152 : parrello 1.1 # Write the generated text to the output.
153 :     print $retVal;
154 :     };
155 :     if ($@) {
156 :     my $errorMessage = $@;
157 :     Trace("Script Error: $errorMessage") if T(0);
158 : parrello 1.3 # Put us in web page output mode.
159 :     print $cgi->header();
160 :     print $cgi->html($cgi->body("Script Error: $errorMessage"));
161 : parrello 1.1 }
162 : parrello 1.3
163 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3