ViewVC Help
View File | Revision Log | Show Annotations | Root Listing
root/scriptome/html2scriptome.pl
Revision: 1.47
Committed: Tue Jul 7 18:52:50 2009 UTC (6 years, 9 months ago) by amirkarger
Branch: MAIN
CVS Tags: HEAD
Changes since 1.46: +1 -1 lines
Log Message:
* Tweak Makefile
* Add change_split_fasta tool (Change.pod, all_params)
* html2scriptome wasn't handling q{} correctly (tidy() broke it)
* Make t/*.pl use dated sample file dir
* Remove unneeded BEGIN from choose_lines_col_more_than_limit

Line File contents
1 #!/usr/local/bin/perl
2 # Convert HTML generated by pod2html into Scriptome pages
3 # Surround pod2html-generated text with a fancy page header, navbar, etc.
4 use strict;
5 use warnings;
6
7 use Getopt::Std;
8 use File::Basename;
9 use vars qw($opt_h $opt_w);
10 getopts('hw');
11 my $Is_Home_Page = defined $opt_h;
12 my $Is_Windows = defined $opt_w;
13 my $Platform = $Is_Home_Page ? "" : $Is_Windows ? "Windows" : "UNIX";
14 my $Param_File = "all_params.tab";
15
16 # Change tools, navbar for any file in a "Windows_Tools" dir
17 # (Quoting for Windows shell, links to other Windows tools, etc.)
18
19 #TODO "make 'file.tab' a LINK to an actual test file. Useful for readers AND we can use it for testing!\n";
20
21 my $file = shift @ARGV or die "Usage: $0 HTMLfile\n";
22 # Makefile tells pod2html to give files a '.pre_html' suffix
23 my ($topic, $path, $suffix) = fileparse($file, qr/\.pre_html/);
24 die "Must take '.pre_html' output from pod2html as input\n"
25 unless $suffix eq ".pre_html";
26 # How to get back to root HTML dir, for finding images, stylesheet, etc.
27 # The dir we're running html2scriptome in will be the root dir of the website
28 # The file hierarchy we create in Platform
29 # will be copied to UNIX/ and Windows/ under root dir (the platform_dirs)
30 # although at least one file (index) will sit in the root dir
31 # $root_dir CAN'T be "/scriptome" because in production that will
32 # point to www.cgr.harvard.edu/scriptome, which doesn't exist
33 my ($root_dir, $platform_dir);
34 # fileparse seems to return ./, but be safe
35 if ($path eq "./" || $path eq "" || $path eq ".\\") {
36 if ($topic eq "index") {
37 $path = "./" if $path eq ".\\";
38 $root_dir = $platform_dir = $path;
39 } else {
40 die "Unexpected root-dir non-index file $file!\n"
41 }
42 } else {
43 $root_dir = $path;
44 $root_dir =~ s#\\#/#g; # Makefile can now pretend dirs have UNIX-like slash
45 $root_dir =~ s#[^/]+/#../#g;
46 $platform_dir = $root_dir;
47 $platform_dir =~ s#../## or die"No ../ in platform dir $platform_dir\n";
48 if ($topic eq "index") {
49 # Use dir name as a topic, e.g. "UNIX"
50 $topic = $Is_Windows ? "Windows" : "UNIX";
51 #warn "Changed topic to $topic\n";
52 }
53 }
54 #warn "Path $path Root dir $root_dir platform dir $platform_dir\n";
55
56 my $image_dir = "${root_dir}images";
57 #my $RC_image_dir = "${root_dir}../images";
58 #my $CSB_image_dir = "${root_dir}../../../imagescomm";
59 my $RC_image_dir = "${root_dir}/images";
60 my $CSB_image_dir = "${root_dir}images/imagescomm";
61 $topic = ucfirst($topic);
62 my $Is_Tool_Page = $file =~ m#/Tools/#;
63 my $Is_Prot_Page = $file =~ m#/Protocols/#;
64
65 # Colors for various things
66 # "Blue" is actually green for windows pages
67 my $Gray = "#777777"; # Perl text in tools to be ignored
68 my $Red = "#FF0000"; # Perl text in tools to be changed
69 my $Blue = $Is_Windows ? "#70C0A2" : "#7098C2"; # unselected pages in navbar
70 my $DarkBlue = $Is_Windows ? "#508B60" : "#4B6FA3"; # spacer, selected page in navbar
71
72 my @Site_Map = (
73 "index",
74 map ("Information/$_", qw(
75 FAQ
76 Help
77 Overview
78 Principles
79 Resources
80 Tips
81 )
82 ),
83 map ("Tools/$_", qw(
84 Calc
85 Change
86 Choose
87 Fetch
88 Merge
89 Sort
90 )
91 ),
92 map ("Protocols/$_", qw(
93 Sequences
94 Microarray
95 )
96 ),
97 );
98
99 my %tool_params = &read_tool_params($Param_File);
100
101 ####################
102 # Read the <head> material from pod2html file and ignore (most of) it
103 open FILE, $file or die "Problem opening '$file': $!\n";
104 my $title = $topic;
105 while (<FILE>) {
106 m#^<title>(.*?)</title># and $title = $1;
107 last if m#^<body#;
108 }
109 if ($Platform) { $title .= " ($Platform)" }
110
111 # Get Page Header, NavBar, etc.
112 my ($PageHeader, $ScriptomeHeader, $NavBarAndMainStart, $NavBarAndMainEnd,
113 $PageFooter);
114 &set_stuff_to_add($topic, $title); # this sets above variables
115
116 print $PageHeader;#, $ScriptomeHeader;
117
118 print $NavBarAndMainStart unless $Is_Home_Page;
119
120 # Read up to TOC beginning
121 while (<FILE>) {
122 last if /<!-- INDEX BEGIN -->/;
123 print;
124 }
125
126 # Read the TOC made by pod2html
127 # Put it in an array for playing with
128 # Create a collapsible TOC and a menu with all the tool name abbreviations
129 my @TOC_lines = ($_); # put INDEX BEGiN in as first line
130 while (<FILE>) {
131 push @TOC_lines, $_;
132 last if /<!-- INDEX END -->/;
133 }
134 my $TOC = make_TOC($Is_Tool_Page, $topic, @TOC_lines);
135 print $TOC;
136
137 my $current_tool;
138 my $lctopic = lc $topic;
139 while (<FILE>) {
140 if (m#</body>#) {
141 print $NavBarAndMainEnd unless $Is_Home_Page;
142 print $PageFooter;
143 print;
144 last;
145 }
146
147
148 # pod2html automatically changes "foo" to ``foo'', but we can't
149 # do s/''/&quot;/ because there *might* be a '' in a Perl one-liner
150 # TODO We could do this "unless /toolframe/"
151 s/``(.*?)''(?!')/&quot;$1&quot;/g;
152
153 # pod2html is creating certain links (only in Platform/index.pre_html?)
154 # as '../Platform/stuff...'. The links need to be relative so they
155 # just go to UNIX or Windows. So fix it manually. Yuck.
156 # XXX HACK! I am sure I will regret this
157 s#(<a href="[^>]+)/Platform/([^>]+">)#$1/$Platform/$2#g;
158
159 # Need to remove <p> AND </P> AND \n from toolframes so that copying
160 # a blue box in IE doesn't have an extra \n in it.
161 s#(toolframe.*?)<p>(.*?)</p>\n#$1$2#;
162
163
164 #<h3><a name="calculate_blahblah__calc_blah_">Calculate blah blah (calc_col_sum)</a></h3> {
165 if (m#^<h\d><a name="\w+">.*\((${lctopic}\w+)\)</a></h\d>$#) {
166 $current_tool = $1;
167 }
168
169 # Create edit form, <span class="parameter"> for parameters
170 # Do this for Tool pages, but also for the one tool in a help page
171 if (!$Is_Prot_Page && /toolframe/) {
172 # csh does history substitution on !foo even with ''!!!
173 # But it only pays attention to ![a-z] I think
174 die "Must have space after exclamation points in $_\n"
175 if /!\w/;
176 if (exists $tool_params{$current_tool}) {
177 my @one_tool_pars = @{$tool_params{$current_tool}};
178 # warn "String is $_\n";
179 # Safest to do pars in REVERSE order they appear in the tool code
180 # outfile is easiest, then infiles, cuz they only contain [\w.]
181 # Finally do variables, which can contain .*
182 my $npar = 0;
183 my $edit_form = ""; # Form allowing user to edit param values
184 foreach my $pref (reverse @one_tool_pars) {
185 my %one_par = %$pref;
186 my ($par, $type, $desc) = @one_par{qw(name type desc)};
187 # warn join("\t", $par, $type, $desc), "\n$_\n\n" if $current_tool eq "fetch_sequence_web";
188 # Replace stuff. Get rid of _RED_ _NORED_ if we
189 # First try matching param alone in a _RED_ _NORED_, in which
190 # case we can get rid of _RED_ _NORED_.
191 # Otherwise try matching within a set of params in one block
192 # in which case just remove this param from the _RED_ _NORED_
193 my ($replace, $ed);
194 my $is_var = $type eq "Variable";
195 if ($type eq "Output file") {
196 ($replace, $ed) = paramify_var($type, $par, $desc,
197 $current_tool, $npar, $is_var);
198 s#_RED_ *$par *_NORED_#$replace# or
199 s#_RED_(([\w.]+ *)+)&gt; *$par *_NORED_#_RED_$1_NORED_ &gt; $replace# or
200 warn "No $par outfile in RED for $current_tool in $_\n";
201 } elsif ($type eq "Input file(s)") {
202 ($replace, $ed) = paramify_var($type, $par, $desc,
203 $current_tool, $npar, $is_var);
204 s#_RED_( *)$par( *)_NORED_#$1$replace$2# or
205 s#(_RED_([\w.]+ +)*)$par *_NORED_#$1_NORED_$replace# or
206 warn "No $par infile in RED for $current_tool in $_\n";
207 # put the variable itself
208 # in a span with an id, and then build up
209 # a <form> with a corresponding <input> for that id
210 } elsif ($type eq "Variable") {
211 # match a single Variable parameter
212 my $match_only = qr#_RED_ *\Q$par\E *= *(.*?) *_NORED_#;
213 # match the last of >1 Variable parameters
214 my $match_not_only =
215 qr#(_RED_.*?)\Q$par\E *= *(.*?) *_NORED_#;
216 if (m#$match_only#) {
217 ($replace, $ed) = paramify_var($par, $1, $desc,
218 $current_tool, $npar, $is_var);
219 s#$match_only#$replace#;
220 } elsif (m#$match_not_only#) {
221 ($replace, $ed) = paramify_var($par, $2, $desc,
222 $current_tool, $npar, $is_var);
223 s#$match_not_only#$1_NORED_$replace# or die 'weird';
224 } else {
225 warn "No $par var in RED for $current_tool in $_\n";
226 }
227 } else {
228 die "Unknown param type $type\n";
229 }
230
231 # We're looping through parameters backwards, but
232 # the parameter edit inputs should be in forward order
233 $edit_form = $ed . $edit_form;
234
235 $npar++;
236 }
237 $edit_form = qq#
238 <p>
239 <form name="$current_tool">
240 <table>
241 $edit_form
242 </table>
243
244 <input type="button" value="Reset values" onClick="javascript:this.form.reset();updateParameters(this);"></input>
245
246 <!--p><input type="text" id="${current_tool}_debugger" size=80 value="empty"></input></p-->
247
248 </form></p><p>
249 #;
250 $_ = "$edit_form\n$_";
251 m#_(NO)?RED_# and warn "Didn't remove all RED blocks in $current_tool: $_\n";
252 # warn "After substitution, string is $_\n";
253 } else {
254 s#_RED_(.*?)_NORED_#<span class="parameter">$1</span>#g
255 and warn "Found pars $1 for $current_tool with empty param table\n";
256 }
257 } else { # Make parameters red in any non-tool frame
258 s#_RED_(.*?)_NORED_#<span class="parameter">$1</span>#g;
259 }
260
261 # Change tools to work in Win32 Perl
262 if (/class="toolframe"/ && $Is_Windows) {
263 # I thought I needed to translate \n to \r\n, but Perl
264 # appears to Do The Right Thing whether reading in or writing!
265 # When running Perl on DOS:
266 # - /\r?\n/ matches EITHER Unix or DOS newline on reading in
267 # - print qq{\n} prints a \r\n
268 # The Camel Book says to use /\015?\012/ for safety. Oh well.
269
270 # We use different styles for windows/unix tool frames
271 s/"toolframe"/"wintoolframe"/g;
272
273 # Double quotes can appear anywhere in the script
274 # Non-backslashed double-quote, stuff, non-backslashed double quote
275 #s/([^\\])&quot;(.?|(.*?[^\\])?)&quot;/$1 qq~$2~/g;
276 s/(?<!\\)&quot;(.*?)(?<!\\)&quot;/ qq~$1~/g;
277 # Single quotes only appear AROUND script, UNLESS they're backslashed
278 # -e or -ne, single-quote, stuff, non-backslashed single quote
279 s/(-\w*e\s*)'(.*?)(?<!\\)'/$1&quot;$2&quot;/g;
280
281 # Put tool picture in front of headers, "class"ify <h>s,
282 # and add a new anchor that's only the tool abbreviated name
283 # (Bookmarking that will stay valid even if we change description.)
284 # TODO change TOC & Quickbrowse links to ONLY have the
285 # short anchor - BUT THAT BREAKS LINKS FROM OTHER PAGES!
286 # s/^<h(\d)>(<a .*\((.*))/<h$1 class="toolsection"><img src="${image_dir}\/wrench.jpg" height=30> $2<a href="$3">/ && warn "Tool $3\n";
287 #<h3><a name="new__insert_line_numbers__calc_line_numbers_">NEW: Insert line numbers (calc_line_numbers)</a></h3>
288
289 # TODO Test! No tools use \' or \" yet, so these may be broken
290 warn "\n\nDidn't test backslashed single or double quotes in $_\n\n"
291 if /\\(&quot;|')/;
292 }
293
294 # Add newlines to perl. Won't be seen in html, but javascript can make them
295 # visible for easier reading/learning
296 # Expanding protocols breaks stuff -- but there IS a tool in the Help pages
297 if (/toolframe/ && !$Is_Prot_Page) {
298 s/(<td class="(win)?toolframe">)/$1<form name="code_$current_tool">/
299 or die "Weird toolframe without td";
300 my $y;
301 s#-e *('|&quot;)(.*?)\1#$y=&tidy($2); "-e $1\n$y\n$1"#e;
302 die "Found extra -e in $file\n" if m#-e ('|&quot;)(.*?)\1#;
303 my $input = qq[
304 <br><input type="button" value="Expand code"
305 onClick="javascript:toggle_code_format(this)">
306 </input></form>];
307 $_ .= $input;
308 }
309
310 # Print the original line, or the changed line
311 print;
312 }
313
314 print while (<FILE>);
315 exit(0);
316
317 # Add newlines to perl to make it more readable
318 sub tidy {
319 my ($in) = @_;
320 my $out = "";
321 my $Perl_Indent = "";
322 $in =~ s/(gt|lt|quot|amp);/$1_SEMICOLON_/g;
323 # Add newlines. save/remove spaces as needed
324 while ($in =~
325 m/
326 ([\$\@]\w+\{[^{]*?\}|\{\d+\}|q\{.*?\}) | # hash name+key OR regex {} OR q{}, $1
327 \ *(;)\ * | # semicolon, $2
328 (\ *\{)\ * | # open brace, $3
329 \ *(\})\ * | # close brace, $4
330 (.) # everything else, $5
331 /gx
332 ) {
333 if ($1) { # hash name + key
334 $out .= $1;
335 }
336
337 elsif ($2) { # semicolon
338 $out .= "$2\n$Perl_Indent";
339 }
340
341 elsif ($3) { # open brace
342 $out .= $3;
343 $Perl_Indent =~ s/ $/\t/ or $Perl_Indent =~ s/$/ /; # indent
344 $out .= "\n$Perl_Indent";
345 }
346
347 elsif ($4) { # close brace
348 my $br = $4;
349 $Perl_Indent =~ s/\t$/ / or $Perl_Indent =~ s/ $// # unindent
350 or die "Try to unindent when indent level is 0!-$Perl_Indent-";
351 $out .= "\n$Perl_Indent$br\n$Perl_Indent";
352 }
353
354 else { # everything else
355 $out .= $5;
356 }
357 }
358 $out =~ s/_SEMICOLON_/;/g;
359 # Remove accidental newlines
360 $out =~ s/\n( *\n)+/\n/g;
361 $out =~ s/\n *;/;/g;
362 $out =~ s/\n+\z//; # remove last newline since we add one later
363
364 return $out;
365 }
366
367 ################################################################################
368
369 sub set_stuff_to_add {
370 my ($topic, $title) = @_;
371 # Javascript to run on loading the page
372 # Highlight correct cell in left navbar (but home page has no navbar cell)
373 # And preload background images for navbar
374 my @image_names = qw(research home contact directories search);
375 my $images = join",", map {"'$CSB_image_dir/ba_$_.gif'"} @image_names;
376 my $onLoad = "MM_preloadImages($images)";
377 $onLoad .= "; darkblue='$DarkBlue'" if !$Is_Home_Page;
378 if ($topic ne "Index") {
379 $onLoad .= "; d.getElementById(SectCellID).style.backgroundColor=darkblue";
380 }
381 $onLoad = qq{ onLoad = "$onLoad"\n};
382
383 # class = unix etc.
384 my $menu_class = $Is_Home_Page ? "" :
385 $Is_Windows ? ' class="windows"' : ' class="unix"';
386
387 $PageHeader = qq(
388 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
389 "http://www.w3.org/TR/html4/loose.dtd">
390 <html>
391 <head>
392 <title>FAS Center: $title</title>
393 <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
394 <script language="Javascript">
395 <!--
396 Sect = "$topic"
397 //-->
398 </script>
399
400 <script language="Javascript" src="${root_dir}Scripts.js"></script>
401 <script language="Javascript" src="${root_dir}CSB_Scripts.js"></script>
402
403 <link href="${root_dir}Stylesheet.css" rel="stylesheet" type="text/css">
404 </head>
405
406 <body $onLoad>
407
408 <div id="container">
409 <!-- CONTAINER LAYER gives page blue side borders, white background, and background graphics down left side -->
410
411 <!-- HEADER -->
412 <div id="header" onmouseover="MM_showHideLayers('popupresearch','','hide','popupresources','','hide','popupabout','','hide','popupjobs','','hide','popupeducation','','hide','popupnews','','hide')"><a href="../../../index.html"><img src="$CSB_image_dir/logo.gif" alt="FAS Center Home" title="" width="280" height="107" border="0" style="float: left;" /></a><img src="$CSB_image_dir/tagline.gif" alt="Systems Biology Research and Resources at Harvard" title="" width="297" height="107" style="float: right;" /></div>
413
414 <!-- MAIN MENU -->
415 <div id="mainmenu"$menu_class><a href="${root_dir}../computational.html"><img src="$RC_image_dir/t_compbio_unix.gif" alt="Computational Biology Group" width="246" height="36" border="0" /></a></div>
416
417 );
418
419 # css classes
420 my $spacer = qq(<tr> <td bgcolor="$DarkBlue"><img src="${image_dir}/spacer.gif" width="1" height="1"></td></tr>);
421
422 # upper left hand corner has link to home page, as well as
423 # main tool page for Windows OR UNIX
424 my $Win_unix_Name = $Is_Windows ? "Windows&nbsp;Home" : "UNIX/Mac&nbsp;Home";
425 my $Backwards_Dir = $Is_Windows ? "UNIX" : "Windows";
426 my $Backwards_Name = $Is_Windows ? "Unix/Mac&nbsp;Home" : "Windows&nbsp;Home";
427
428 $ScriptomeHeader = qq(
429 <tr>
430 <td id="CellIndex" class="${Platform}_navsubject">
431 <a href="${root_dir}" class="BigNavTxt" onmouseover="NavBarOver('Index')" onmouseout="NavBarOut('Index')"><b id="TxtIndex">Scriptome Home</b></a>
432 </td>
433 </tr>
434 $spacer
435 <tr>
436 <td id="Cell$Platform" class="${Platform}_navbutton" onmouseover="NavBarOver('$Platform')" onmouseout="NavBarOut('$Platform')" onclick="d.location='${platform_dir}/'">
437 <a href="${platform_dir}" class="NavTxt"><b id="Txt$Platform">$Win_unix_Name</b></a>
438 </td>
439 </tr>
440 $spacer
441 <tr>
442 <td id="Cell$Backwards_Dir" class="${Platform}_navbutton" onmouseover="NavBarOver('$Backwards_Dir')" onmouseout="NavBarOut('$Backwards_Dir')" onclick="d.location='$root_dir${Backwards_Dir}/'">
443 <a href="${root_dir}${Backwards_Dir}/" class="NavTxt"><b id="Txt$Backwards_Dir">$Backwards_Name</a>
444 </td>
445 </tr>
446 <tr> <td bgcolor="$DarkBlue"><img src="${image_dir}/spacer.gif" width="1" height="10"></td></tr>
447 );
448 # Subject header in Navbar (not actually a link, for now)
449 my %NavSubjects = map { $_ =>
450 qq($spacer
451 <tr> <td class="${Platform}_navsubject"><b>$_</b></td> </tr>
452 $spacer)
453 } ("Information", "Tools", "Protocols");
454
455 # Button in navbar
456 my %NavButtons;
457 for (@Site_Map) {
458 my ($dir, $page) = m#(.*/)?(.*)# or die "Weird page $_\n";
459 $dir ||= ""; # index.html
460 $NavButtons{$page} = qq(
461 <tr> <td id="Cell$page" class="${Platform}_navbutton" onmouseover="NavBarOver('$page')" onmouseout="NavBarOut('$page')" onclick=d.location="${platform_dir}${dir}$page.html">
462 <a href="${platform_dir}${dir}$page.html" class="NavTxt"><b id="Txt$page">$page</b></a></td> </tr>
463 $spacer);
464 }
465
466 my $NavBar = qq(
467 <!-- Begin NavBar -->
468
469 <table border="0" cellpadding="1" cellspacing="0">
470 $ScriptomeHeader
471 $spacer
472 $NavSubjects{"Information"}
473 $NavButtons{"FAQ"}
474 $NavButtons{"Help"}
475 $NavButtons{"Overview"}
476 $NavButtons{"Principles"}
477 $NavButtons{"Resources"}
478 $NavButtons{"Tips"}
479 $NavSubjects{"Tools"}
480 $NavButtons{"Calc"}
481 $NavButtons{"Change"}
482 $NavButtons{"Choose"}
483 $NavButtons{"Fetch"}
484 $NavButtons{"Merge"}
485 $NavButtons{"Sort"}
486 $NavSubjects{"Protocols"}
487 $NavButtons{'Sequences'}
488 $NavButtons{"Microarray"}
489 </table>
490 <!-- End NavBar -->
491 );
492
493 $NavBarAndMainStart = qq(
494 <table width="100%" height="85%" border="0" cellpadding="0" cellspacing="0" bgcolor="$DarkBlue">
495 <tr>
496 <td width="3"><img src="${image_dir}/spacer.gif" width="3" height="3"></td>
497 <td valign="top" bgcolor="$Blue">
498 $NavBar
499 </td>
500 <td><img src="${image_dir}/spacer.gif" width="3" height="1"></td>
501 <td valign="top" bgcolor="#FFFFFF"><table width="100%" border="0" cellpadding="8" cellspacing="0">
502 <tr>
503 <td>
504
505 <!-- Begin Content -->
506 <!-- MAIN PAGE CONTENT -->
507 <div id="maincontent">
508
509 );
510
511 $NavBarAndMainEnd = qq(
512 <!-- End Content -->
513 </div>
514
515 </td>
516 </tr>
517 </table> </td>
518 <td width="3"><img src="${image_dir}/spacer.gif" width="3" height="3"></td>
519 </tr>
520 <tr>
521 <td height="3" colspan="4"><img src="${image_dir}/spacer.gif" width="3" height="3"></td>
522 </tr>
523 </table>
524 );
525
526 $PageFooter = qq(
527 <p class="footer">FAS Center for Systems Biology :: Cambridge MA 02138 :: +617.384.5065<br />
528 &copy; Copyright 2006 President and Fellows of Harvard College</p>
529 <p>&nbsp;</p>
530 </div>
531
532 <!-- MINI NAVIGATION -->
533 <div id="mininav"><a href="../../../index.html" onmouseout="MM_swapImgRestore()" onmouseover="MM_swapImage('home','','$CSB_image_dir/ba_home.gif',1)"><img src="$CSB_image_dir/b_home.gif" alt="Home" name="home" width="38" height="16" border="0" id="home" /></a><a href="../../../contact/index.html" onmouseout="MM_swapImgRestore()" onmouseover="MM_swapImage('contact','','$CSB_image_dir/ba_contact.gif',1)"><img src="$CSB_image_dir/b_contact.gif" alt="Contact Us" name="contact" width="86" height="16" border="0" id="contact" /></a><a href="../../../directories/index.html" onmouseout="MM_swapImgRestore()" onmouseover="MM_swapImage('directories','','$CSB_image_dir/ba_directories.gif',1)"><img src="$CSB_image_dir/b_directories.gif" alt="Directories" name="directories" width="91" height="16" border="0" id="directories" /></a><a href="../../../search/index.html" onmouseout="MM_swapImgRestore()" onmouseover="MM_swapImage('search','','$CSB_image_dir/ba_search.gif',1)"><img src="$CSB_image_dir/b_search.gif" alt="Search" name="search" width="57" height="16" border="0" id="search" /></a></div>
534 );
535
536 return 1;
537 }
538
539 #### ENd of set_stuff_to_add
540
541 # Make a quickbrowse menu with all tools (just short names)
542 # Also make the TOC that pod2html made collapsible
543 sub make_TOC {
544 my ($is_tool_page, $topic, @TOC_lines) = @_;
545 # pod2html --noindex comments out TOC.
546 return "" unless @TOC_lines;
547 return "" if $TOC_lines[1] =~ /^<!--/ && $TOC_lines[-2] =~ /^-->/;
548 $topic = lc $topic;
549 my $TOC = ""; # The TOC string we're building
550 # my @abbrevs; # abbreviated tool names
551 my %abbrev_links; # links that abbrevs lead to
552 # Give certain TOC items a special class, so we can do fancy things
553 # with CSS later, to make the TOC easier to browse
554 # Also allow for collapsing the TOC menus
555 my ($inIndex, $indexLevel, $menu_count, $is_triangle) = ("", 0, 0, 0);
556 foreach my $line_num (0 .. $#TOC_lines) {
557 $_ = $TOC_lines[$line_num];
558
559 # Note: <li> has by a <ul> nested inside it, so we want
560 # the $menu_count to be the same for the li and the following ul
561 if (m#^\s*<ul>#) {
562 $indexLevel++;
563 my $display = $indexLevel < 3 ? "block" : "none";
564 s/ul/ul id="menu$menu_count" style="display:$display"/;
565 } elsif (m#^\s*</ul>#) {
566 $indexLevel--;
567 } elsif (/<li>/) {
568 # Add a TOC level so we can play with CSS
569 # If it's not a leaf node,
570 # add a triangle that toggles the menu open/closed
571 # AND change the TOC anchor to an expand/collapse button
572 #if ($indexLevel <2 || $TOC_lines[$line_num+1] !~ /<ul>/) {
573 if ($TOC_lines[$line_num+1] !~ /<ul>/) {
574 s#<li>#<li class="TOC$indexLevel">#;
575 } else {
576 $menu_count++; # new <li>,<ul> combination approaching...
577 my $triangle_dir;
578 if ($indexLevel < 2) { # expand the sub-menu
579 $triangle_dir = "down";
580 } else { # collapse the sub-menu
581 $triangle_dir = "right";
582 }
583 #<li><a href="#choose_columns_in_a_given_order__choose_cols_">Choose columns in a given order (choose_cols)</a></li>
584 my $img_src = "${image_dir}/triangle16_$triangle_dir.gif";
585 s~<li><a href="#.*">(.*</a></li>)~<li class="TOC$indexLevel" style="list-style:none"><img id="img$menu_count" src="$img_src" width=16 height=16 onClick="menu_toggle($menu_count)"> <a href="javascript:menu_toggle($menu_count)">$1~ or die "Can't substitute\n";
586 $is_triangle = 1; # do we have ANY triangles?
587 }
588
589 # Is it a tool for the quickbrowse menu?
590 if (/<a href="(.*?)">.*\(${topic}_(\w+)\)/ && $is_tool_page) {
591 #push @abbrevs, $2;
592 $abbrev_links{$2} = $1;
593 }
594 }
595
596 # Put changed line back in TOC
597 $TOC .= $_;
598 }
599 my $TOC_start = "<p><b>Contents:</b>";
600 $TOC_start .= " Click a blue triangle to expand or collapse a list"
601 if $is_triangle;
602 $TOC_start .= "</p>\n";
603
604 my $QB = ""; # quickbrowse menu string we're building
605 if ($is_tool_page) {
606 $QB = qq#
607 <p><b>Quickbrowse:</b> Go to a tool by selecting the abbreviated tool name from the menu.</p>
608 <form>
609 <strong>${topic}_</strong><select name="quickbrowse" onchange="go(this)">
610 <option selected value="">tool...</option>
611 #;
612 # case-insensitive sort
613 foreach my $abbrev (sort {uc($a) cmp uc($b)} keys %abbrev_links) {
614 $QB .= qq(
615 <option value="$abbrev_links{$abbrev}">$abbrev</option>);
616 }
617 $QB .= qq{
618 </select>
619 </form>
620 <hr>
621 };
622 }
623
624 return "$QB$TOC_start$TOC";
625 }
626
627 ################################################################################
628 sub read_tool_params {
629 my $infile = shift;
630 open(PARAM, "<$infile") or die "Param file $infile: $!\n";
631 my %params = ();
632 while (<PARAM>) {
633 s/\r?\n//;
634 # Param name is a filename or variable name (including $ or @)
635 # Desc is human-entered description of the parameter, may be empty.
636 # long_param is the original piece of the tool that had this
637 # parameter in it (for checking, mostly)
638 my ($tool_name, $param_name, $type, $desc, $param_text) =
639 split "\t", $_;
640 push @{$params{$tool_name}}, {
641 "name" => $param_name,
642 "type" => $type,
643 "desc" => $desc,
644 };
645 }
646 return %params;
647 }
648
649 sub paramify_var {
650 my ($name, $val, $desc, $toolname, $parnum, $is_var) = @_;
651 my $param_start = qq{<span class="parameter">};
652 my $param_end = "</span>";
653 my $val_start = qq#<span id="${toolname}_param$parnum">#;
654 my $val_end = "</span>";
655 my $param_set;
656 if ($is_var) {
657 # Make sure we have just one semicolon (but don't kill &quot;)
658 $val =~ s/ *(?<!quot); *$//;
659 # For string values, don't include quotation marks in the thing
660 # to edit - especially because it becomes qq~...~ in Windows tools!
661 if ($val =~ /^\s*&quot;(.*)&quot;\s*$/) {
662 $val = $1;
663 $val_start = "&quot;$val_start";
664 $val_end .= "&quot;";
665 #warn join("\t", $val_start, $val, $val_end),"\n";
666 # For array values, don't include parens in thing to edit
667 } elsif ($val =~ /^\s*\((.*)\)\s*$/) {
668 $val = $1;
669 $val_start = "($val_start";
670 $val_end .= ")";
671 }
672 $param_set = join "", ($param_start, $name, "=",
673 $val_start, $val, $val_end, ";$param_end");
674 } else {
675 $param_set = join "", ($param_start,
676 $val_start, $val, $val_end, $param_end);
677 }
678 ### create form info
679 ### TODO Worry about quotation marks in values
680 my $edit = qq#
681 <tr>
682 <td> <span class="parameter">$name</span> </td>
683 <td>
684 <input type="text" id="${toolname}_edit$parnum" name="parameter" onKeyUp="javascript:updateOneParam(this)" value="$val" size="25"> </input>
685 </td>
686 <td>$desc</td>
687 </tr>
688 #;
689 return $param_set, $edit;
690 }