[Bio] / FigKernelPackages / TestUtils.pm Repository:
ViewVC logotype

Annotation of /FigKernelPackages/TestUtils.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (view) (download) (as text)

1 : parrello 1.1 package TestUtils;
2 :    
3 :     use strict;
4 :     use CGI;
5 :     use Tracer;
6 : parrello 1.3 use Stats;
7 : parrello 1.2
8 : parrello 1.1 =head1 Testing Utilities
9 :    
10 :     =head2 Introduction
11 :    
12 :     This package contains some utilities used by the various testing scripts. It is not
13 :     expected they will have any general application.
14 :    
15 : parrello 1.3 The major method of this object is the static L</Display>. However, that method
16 :     requires a fancy data structure to manage a symbol map of things found. Therefore,
17 :     this package is also an object package for that data structure.
18 :    
19 :     When displaying something in the normal way, we render arrays as numbered lists
20 :     and hashes as definition lists. A judicious use of styles is important to make the
21 :     result look good.
22 :    
23 :     Two styles are mentioned by name:
24 :    
25 :     =over 4
26 :    
27 :     =item item
28 :    
29 : parrello 1.8 This is used for list items, and allows you to give the item text a different
30 :     format than the item number.
31 : parrello 1.3
32 :     =item marker
33 :    
34 :     This is used for special markers.
35 :    
36 :     =back
37 :    
38 :     For example, the styles
39 :    
40 :     ol {
41 :     font-weight: bold;
42 :     }
43 :     .item {
44 :     font-weight: normal;
45 :     }
46 :    
47 :     will cause the list numbers to appear in bold face while the items themselves are
48 :     normal.
49 :    
50 :     The style
51 :    
52 :     .marker {
53 :     font-style: italic;
54 :     font-color: #CCCCCC;
55 :     }
56 :    
57 :     will cause special markers to appear as italicized and gray.
58 :    
59 : parrello 1.10 Finally, we make use of a javascript toggling method called C<TUToggle> that
60 :     is currently residing in [[ErdbJs]].
61 :    
62 : parrello 1.1 =cut
63 :    
64 : parrello 1.3 # These are special marks declared as constants. First, the suffix used to denote a
65 :     # broken string.
66 :     use constant BREAK_HTML => '&nbsp;<span class="marker">&gt;&gt;</span>';
67 :     # Now an actual arrow for dereferencing.
68 :     use constant ARROW_HTML => ' <span class="marker">=&gt;&gt;</span> ';
69 :     # This is for the infamous undefined value.
70 :     use constant UNDEF_HTML => '<span class="marker">undef</span>';
71 : parrello 1.6 # Empty string.
72 :     use constant EMPTY_HTML => '<span class="marker">empty</span>';
73 :     # Single space.
74 :     use constant SPACE_HTML => '<span class="marker">space</span>';
75 : parrello 1.3 # We also have codes for CRs TABs, and control characters in text mode.
76 :     use constant CR_HTML => '<span class="marker">R</span>';
77 :     use constant TAB_HTML => '<span class="marker">T</span>';
78 :     use constant ICKY_HTML => '<span class="marker">?</span>';
79 :     # This is what we do to end-of-line characters in text mode.
80 :     use constant EOL_HTML => '<span class="marker">&lt;&lt;</span><br />';
81 :    
82 :     # You can't use constants in a s/// expression, so we put them in a hash.
83 :     my %Marks = (CR => CR_HTML, TAB => TAB_HTML, ICKY => ICKY_HTML, EOL => EOL_HTML);
84 :    
85 :     =head2 Static Methods
86 :    
87 :     =head3 Display
88 :    
89 :     my $html = TestUtils::Display($value, $format, $maxCols, $maxWidth);
90 :    
91 :     Format a value for HTML display.
92 :    
93 :     =over 4
94 :    
95 :     =item value
96 :    
97 :     Value to display. It can be an object or a reference.
98 :    
99 :     =item format
100 :    
101 :     Format for displaying the value. The formats are B<Normal>, B<Matrix>,
102 :     B<Table>, and B<Text>. See [[DebugConsoleOutput]] for a complete
103 :     description of each type.
104 :    
105 :     =item maxCols (optional)
106 :    
107 :     Maximum number of table columns allowed for the C<Table> format.
108 :    
109 :     =item maxWidth (optional)
110 :    
111 :     Maximum number of characters per line in a table cell.
112 :    
113 :     =back
114 :    
115 :     =cut
116 :    
117 :     sub Display {
118 :     # Get the parameters.
119 :     my ($value, $format, $maxCols, $maxWidth) = @_;
120 :     # Declare the return value.
121 :     my $retVal;
122 :     # Create a symbol map.
123 :     my $map = TestUtils->new($maxCols, $maxWidth);
124 :     # Display according to the format.
125 :     if ($format eq 'Normal') {
126 :     $retVal = $map->DisplayNormal($value);
127 :     } elsif ($format eq 'Table') {
128 :     $retVal = $map->DisplayTable($value);
129 :     } elsif ($format eq 'Matrix') {
130 :     $retVal = $map->DisplayMatrix($value);
131 :     } elsif ($format eq 'Text') {
132 :     $retVal = $map->DisplayText($value);
133 :     } else {
134 :     # Here we have an invalid format, which we display normally with
135 :     # an error message thrown in.
136 :     $retVal = $map->DisplayNormal($value);
137 : parrello 1.5 my $safeFormat = Tracer::Clean($format);
138 : parrello 1.3 $retVal = join("\n", CGI::blockquote("Invalid format type \"$safeFormat\"."),
139 :     $retVal);
140 :     }
141 :     # Return the html text built.
142 :     return "$retVal\n";
143 :     }
144 :    
145 :     =head3 IsComplex
146 :    
147 :     my $type = TestUtils::IsComplex($value);
148 :    
149 :     Return the type of a value. If the value is an object, array, or hash reference,
150 :     the type will be C<ARRAY> or C<HASH>. Otherwise, the type will be undefined. This
151 :     method is used to determine how to treat a value when producing a table or matrix.
152 : parrello 1.1
153 : parrello 1.3 =over 4
154 :    
155 :     =item value
156 : parrello 1.1
157 : parrello 1.3 Value to be tested.
158 : parrello 1.1
159 : parrello 1.3 =item RETURN
160 : parrello 1.1
161 : parrello 1.3 Returns C<ARRAY> if the value can be treated as an array reference, C<HASH>
162 :     if the value can be treated as a hash reference, and an undefined value otherwise.
163 :    
164 :     =back
165 : parrello 1.1
166 :     =cut
167 :    
168 : parrello 1.3 sub IsComplex {
169 :     # Get the parameters.
170 :     my ($value) = @_;
171 :     # Check the possibilities. The default is failure.
172 :     my $retVal;
173 :     # Only proceed if the value is defined and not scalar.
174 :     if (defined $value && ref $value) {
175 :     # We have a reference. If it is hash-based, then the word
176 :     # HASH will appear in its string expansion. If it is array-based,
177 :     # then the word ARRAY will appear.
178 :     if ("$value" =~ /(HASH|ARRAY)/) {
179 :     $retVal = $1;
180 :     }
181 :     }
182 :     # Return the result.
183 :     return $retVal;
184 : parrello 1.1 }
185 :    
186 :    
187 : parrello 1.3 =head2 TestUtils Object Methods
188 :    
189 :     =head3 new
190 :    
191 :     my $symbolMap = TestUtils->new($maxCols, $maxWidth);
192 :    
193 :     Create a new, blank mapping of object reference strings to object names.
194 :    
195 :     This object needs to perform two functions. First, it tracks objects already
196 :     found so we don't get into a recursion loop. Second, it uses a
197 : parrello 1.4 [[StatsPm]] object to track the number of objects of each type already found.
198 :     This is used to generate pretty names for each object.
199 : parrello 1.3
200 :     The parameters are both optional.
201 :    
202 :     =over 4
203 :    
204 :     =item maxCols
205 :    
206 :     Maximum number of columns allowed in C<Table> displays.
207 :    
208 :     =item maxWidth
209 :    
210 :     Maximum character width of a table cell.
211 :    
212 :     =back
213 : parrello 1.1
214 : parrello 1.3 The fields in this object are as follows.
215 : parrello 1.1
216 :     =over 4
217 :    
218 : parrello 1.3 =item nameHash
219 : parrello 1.1
220 : parrello 1.3 Hash of reference strings to object names.
221 : parrello 1.1
222 : parrello 1.3 =item objectStats
223 : parrello 1.1
224 : parrello 1.3 Statistics object containing the number of objects found of each type.
225 : parrello 1.1
226 : parrello 1.3 =item maxCols
227 : parrello 1.1
228 : parrello 1.3 Maximum number of table columns allowed for the C<Table> display format.
229 :    
230 :     =item maxWidth
231 :    
232 :     Maximum permissible width of a table cell in characters.
233 : parrello 1.1
234 :     =back
235 :    
236 : parrello 1.3 =cut
237 :    
238 :     sub new {
239 :     # Get the parameters.
240 :     my ($class, $maxCols, $maxWidth) = @_;
241 :     # Set the defaults for the table limits.
242 :     $maxCols = 100 if ! $maxCols;
243 :     $maxWidth = 50 if ! $maxWidth;
244 :     # Create and bless the object.
245 :     my $retVal = { nameHash => {},
246 : parrello 1.9 path => [],
247 : parrello 1.3 objectStats => Stats->new(qw(ARRAY HASH SCALAR)),
248 :     maxCols => $maxCols,
249 :     maxWidth => $maxWidth};
250 :     bless $retVal, $class;
251 :     return $retVal;
252 :     }
253 :    
254 :     =head3 DisplayText
255 :    
256 :     my $html = $symbolMap->DisplayText($value);
257 :    
258 :     Display a multi-line string in a format that makes it easy to see how all
259 :     the pieces line up.
260 :    
261 :     =over 4
262 :    
263 :     =item value
264 :    
265 :     Value to display.
266 :    
267 :     =item RETURN
268 :    
269 :     HTML string that displays the value preformatted with line-end markings.
270 :    
271 :     =back
272 :    
273 :     =cut
274 :    
275 :     sub DisplayText {
276 :     # Get the parameters.
277 :     my ($self, $value) = @_;
278 :     # Declare the return variable.
279 :     my $retVal;
280 :     # Insure this is really a string.
281 :     if (ref $value) {
282 :     # It's the wrong type. Display using normal format, and prefix
283 :     # it with an error message.
284 :     $retVal = join("\n",
285 :     CGI::blockquote("Result is not a string. Normal display used."),
286 :     $self->DisplayNormal($value));
287 :     } else {
288 :     # HTML-escape the string.
289 :     $retVal = CGI::escapeHTML($value);
290 :     # Put in markers for the major control characters.
291 :     $retVal =~ s/\r/$Marks{CR}/g;
292 :     $retVal =~ s/\t/$Marks{TAB}/g;
293 :     # Mark each new-line character.
294 :     $retVal =~ s/\n/$Marks{EOL}/g;
295 :     # Put in markers for the other control characters.
296 :     $retVal =~ s/[\x00-\x1F]/$Marks{ICKY}/g;
297 :     # Denote we're preformatted.
298 :     $retVal = CGI::pre($retVal);
299 :     }
300 :     # Return the result.
301 :     return $retVal;
302 :     }
303 :    
304 :     =head3 DisplayNormal
305 :    
306 :     my $html = $symbolMap->DisplayNormal($value);
307 :    
308 :     Display the specified value in HTML. This method treats the value as a
309 :     single object.
310 : parrello 1.1
311 :     =over 4
312 :    
313 : parrello 1.3 =item value
314 : parrello 1.1
315 : parrello 1.3 Value to display.
316 : parrello 1.1
317 : parrello 1.3 =item RETURN
318 : parrello 1.1
319 : parrello 1.3 Returns a display of the value.
320 : parrello 1.1
321 : parrello 1.3 =back
322 : parrello 1.1
323 : parrello 1.3 =cut
324 :    
325 :     sub DisplayNormal {
326 :     # Get the parameters.
327 :     my ($self, $value) = @_;
328 :     # The value is displayed in a single-cell table.
329 :     my $retVal = CGI::table(CGI::Tr(CGI::th("Result")),
330 :     CGI::Tr($self->DisplayCell($value)));
331 :     return $retVal;
332 :     }
333 :    
334 :    
335 :     =head3 DisplayThing
336 :    
337 :     my $html = $symbolMap->DisplayThing($value);
338 :    
339 :     Display the specified value in HTML. The display is output as a recursive
340 :     numbered and/or definition list, with anchors and links for references that are
341 :     re-used.
342 :    
343 :     =over 4
344 :    
345 :     =item value
346 :    
347 :     Value to display.
348 :    
349 :     =item RETURN
350 :    
351 :     Returns a recursive list of the pieces of the value.
352 : parrello 1.1
353 :     =back
354 :    
355 :     =cut
356 :    
357 : parrello 1.3 sub DisplayThing {
358 : parrello 1.1 # Get the parameters.
359 : parrello 1.3 my ($self, $value) = @_;
360 :     # Declare the return variable.
361 :     my $retVal = "";
362 : parrello 1.7 # Check for a value. Note we quote the value for the string comparisons to
363 :     # prevent newer PERLs from attempting to use an overloaded equality operator
364 :     # should the value be a blessed object.
365 : parrello 1.3 if (! defined $value) {
366 :     # No value, so display an undef.
367 :     $retVal = UNDEF_HTML;
368 : parrello 1.7 } elsif ("$value" eq '') {
369 : parrello 1.6 # Empty string.
370 :     $retVal = EMPTY_HTML;
371 : parrello 1.7 } elsif ("$value" eq ' ') {
372 : parrello 1.6 # Single space.
373 :     $retVal = SPACE_HTML;
374 : parrello 1.11 } elsif ("$value" =~ /^\s+$/) {
375 :     # Pure white space. This needs to be converted to something un-spacelike or
376 :     # it really goofs up the display.
377 :     $retVal = CGI::span({class => "marker"}, length($value) . " white chars");
378 : parrello 1.3 } elsif (! ref $value) {
379 :     # Here we have a scalar.
380 :     $retVal = CGI::escapeHTML($value);
381 :     } else {
382 : parrello 1.9 # Here we have a structure. Get the name hash and the path.
383 : parrello 1.3 my $nameHash = $self->{nameHash};
384 : parrello 1.9 my $path = $self->{path};
385 :     # Have we seen it before?
386 : parrello 1.3 if (exists $nameHash->{$value}) {
387 : parrello 1.9 # Yes. Get its name.
388 : parrello 1.3 my $name = $nameHash->{$value};
389 : parrello 1.9 # Format it into a link to the original output location.
390 : parrello 1.10 $retVal = CGI::strong($name) . ARROW_HTML . CGI::a({href => "#$name"}, 'link');
391 : parrello 1.9 # Check to see if it's on the path.
392 :     if (grep { $_ eq $name } @$path) {
393 :     # Yes, so flag it as circular.
394 :     $retVal .= " " . CGI::span({class => "marker"}, "CIRCULAR!!");
395 :     }
396 : parrello 1.3 } else {
397 :     # Here it's new. We need to create a name for it.
398 :     my $type = ref $value;
399 :     my $name = $type . $self->{objectStats}->Add($type);
400 :     $nameHash->{$value} = $name;
401 : parrello 1.10 # Output the object name as an anchored string. We attach a click event
402 :     # to toggle the object value on and off.
403 :     $retVal = CGI::a({ name => "$name", onClick => "TUToggle('OBJ$name')" },
404 :     $name) . "\n";
405 : parrello 1.9 # Remember it in the path stack.
406 :     push @{$path}, $name;
407 : parrello 1.3 # Now we determine the underlying object type. This is
408 :     # either HASH or ARRAY. Note that the following trick
409 :     # will treat objects as either hashes or arrays depending
410 :     # on what's been blessed.
411 :     if ("$value" =~ /ARRAY/) {
412 : parrello 1.10 # Is this array empty?
413 :     if (scalar(@$value) == 0) {
414 :     # Yes. Add an empty tag.
415 :     $retVal .= ARROW_HTML . ' (no members)';
416 :     } else {
417 :     # An array is output as a numbered list. Here we use our first
418 :     # style class: "item".
419 :     $retVal .= CGI::ol({ start => 0, id => "OBJ$name" },
420 :     join("\n", map { CGI::li(CGI::span({class => "item"}, $self->DisplayThing($_))) } @{$value} ));
421 :     }
422 : parrello 1.3 } elsif ("$value" =~ /HASH/) {
423 : parrello 1.10 # Is this hash empty?
424 :     my @keys = sort keys %$value;
425 :     if (scalar(@keys) == 0) {
426 :     # Yes. Add an empty tag.
427 :     $retVal .= ARROW_HTML . ' (no members)';
428 :     } else {
429 :     # Here we have a hash. A hash is output as a definition list.
430 :     my @lines = ();
431 :     for my $key (@keys) {
432 :     my $element = $value->{$key};
433 :     push @lines, CGI::dt(CGI::escapeHTML($key)),
434 :     CGI::dd($self->DisplayThing($element));
435 :     }
436 :     $retVal .= CGI::dl({ id => "OBJ$name" }, join("\n", @lines));
437 : parrello 1.1 }
438 : parrello 1.3 } elsif ("$value" =~ /SCALAR/) {
439 :     # Here we have a scalar reference. We dereference it by one level and output
440 :     # it with a little arrow thing.
441 :     $retVal .= ARROW_HTML . CGI::escapeHTML(${$value});
442 :     } else {
443 :     # Here we have something goofy like a glob, so we just display
444 :     # its name. Note the paranoid trick of putting it in double
445 :     # quotes to insure it's evaluated as a string.
446 :     $retVal .= ARROW_HTML . CGI::escapeHTML("$value");
447 : parrello 1.1 }
448 : parrello 1.9 # Pop this name off the path stack.
449 :     pop @{$path};
450 :     # Add a trailing new-line to the return value.
451 : parrello 1.3 $retVal .= "\n";
452 :     }
453 :     }
454 :     # Return the result.
455 :     return $retVal;
456 :     }
457 :    
458 :    
459 :     =head3 DisplayMatrix
460 :    
461 :     my $html = $symbolMap->DisplayMatrix($value);
462 :    
463 :     Display a hash or list of lists as an HTML table. Each sub-list is displayed as a
464 :     table row, one element per cell, with the key or index of the row in the first
465 :     column.
466 :    
467 :     =over 4
468 :    
469 :     =item value
470 :    
471 :     Value to display, which should be a hash of lists or a list of lists.
472 :    
473 :     =item RETURN
474 :    
475 :     Returns the HTML text for a table indicating the contents of the specified
476 :     hash of lists.
477 :    
478 :     =back
479 :    
480 :     =cut
481 :    
482 :     sub DisplayMatrix {
483 :     # Get the parameters.
484 :     my ($self, $value) = @_;
485 :     # Declare the return variable.
486 :     my $retVal = "";
487 :     # Check the object type.
488 :     my $type = IsComplex($value);
489 :     if (! $type) {
490 :     # It's the wrong type. Display using normal format, and prefix
491 :     # it with an error message.
492 :     $retVal = join("\n",
493 :     CGI::blockquote("Result is not a HASH or ARRAY. Normal display used."),
494 :     $self->DisplayNormal($value));
495 :     } else {
496 :     # Here we have something we can work with. We'll build the table rows in
497 :     # here.
498 :     my @rows = ();
499 :     # Determine how to traverse the value elements.
500 :     if ($type eq 'ARRAY') {
501 :     $retVal = CGI::p("Array reference found.");
502 :     # Here we have an array. We believe it to be a list of lists. If any
503 :     # element is not a list, it will be displayed normally in a single cell. The
504 :     # whole thing is done as a table. Start with a header row.
505 :     push @rows, CGI::Tr(CGI::th(['Idx', 'Value']));
506 :     # Loop through the array elements.
507 :     my $count = scalar @{$value};
508 :     for (my $key = 0; $key < $count; $key++) {
509 :     # Get the value for this element.
510 :     my $element = $value->[$key];
511 :     # Write out the row.
512 :     push @rows, $self->MatrixRow($key, $element);
513 :     }
514 :     } else {
515 :     $retVal = CGI::p("Hash reference found.");
516 :     # Here we have a hash. We believe it to be a hash of lists. As before,
517 :     # if any element is not a list, it will be displayed normally in a single
518 :     # cell.
519 :     push @rows, CGI::Tr(CGI::th(['Key', 'Value']));
520 :     # Loop through the hash keys.
521 :     for my $key (sort keys %{$value}) {
522 :     # Get the value for this key.
523 :     my $element = $value->{$key};
524 :     # Write it out as a row.
525 :     push @rows, $self->MatrixRow($key, $element);
526 :     }
527 :     }
528 :     # Format the whole thing as a table.
529 :     $retVal .= CGI::table(@rows);
530 :     }
531 :     # Return the result.
532 :     return $retVal;
533 :     }
534 :    
535 :     =head3 MatrixRow
536 :    
537 :     my $row = $symbolMap->MatrixRow($key, $value);
538 :    
539 :     Return an HTML table row for the specified key and value. The value is
540 :     expected to be a list, and will be expanded one element per cell. The
541 :     first column will be formatted as a header and will contain the key. If
542 :     the key is a number it will be left-aligned; otherwise it will be
543 :     right-aligned.
544 :    
545 :     =over 4
546 :    
547 :     =item key
548 :    
549 :     Key to be put into the first column.
550 :    
551 :     =item value
552 :    
553 :     Value to be displayed in the remaining columns. If this value is not a list
554 :     reference, there will be a single column after the first containing the value.
555 :    
556 :     =item RETURN
557 :    
558 :     Returns an HTML table row for displaying the key and value.
559 :    
560 :     =back
561 :    
562 :     =cut
563 :    
564 :     sub MatrixRow {
565 :     # Get the parameters.
566 :     my ($self, $key, $value) = @_;
567 :     # We'll accumulate table cells in here.
568 :     my @cells = ();
569 :     # The first task is to process the key.
570 :     if ($key =~ /^\s*-?\d+\s*$/) {
571 :     # Here the key is a number.
572 :     push @cells, CGI::th({ align => 'right'}, $key);
573 :     } else {
574 :     # Here it's a string. We escape it for safety reasons.
575 :     push @cells, CGI::th(CGI::escapeHTML($key));
576 :     }
577 :     # Now we check the value.
578 :     my $type = IsComplex($value);
579 :     if ($type ne 'ARRAY') {
580 :     # We don't have an array here, so we treat the value as a single-element list.
581 :     push @cells, $self->DisplayCell($value);
582 :     } else {
583 :     # We have an array, so we put each array element in a table cell.
584 :     push @cells, map { $self->DisplayCell($_) } @{$value};
585 :     }
586 :     # Return the result.
587 :     my $retVal = CGI::Tr(@cells);
588 :     return $retVal;
589 :     }
590 :    
591 :    
592 :     =head3 DisplayTable
593 :    
594 :     my $html = $symbolMap->DisplayTable($value);
595 :    
596 :     Display a hash or list of hashes as an HTML table. Each sub-hash is
597 :     displayed as a table row, one element per cell, with the key in the
598 :     first column. It is assumed all of the sub-hashes have the same
599 :     structure, and each sub-hash key will be an output column.
600 :    
601 :     The maximum allowable number of columns is 100. At that point, this
602 :     rather severe formatting rule produces something seriously illegible.
603 :    
604 :     =over 4
605 :    
606 :     =item value
607 :    
608 :     Value to display, which should be a hash of hashes, all hashes having the
609 :     same structure.
610 :    
611 :     =item RETURN
612 :    
613 :     Returns the HTML for a table indicating the contents of the hash of hashes.
614 :    
615 :     =back
616 :    
617 :     =cut
618 :    
619 :     sub DisplayTable {
620 :     # Get the parameters.
621 :     my ($self, $value) = @_;
622 :     # Declare the return variable.
623 :     my $retVal = "";
624 :     # Check the object type.
625 :     my $type = IsComplex($value);
626 :     if (! $type) {
627 :     # It's the wrong type. Display using normal format, and prefix
628 :     # it with an error message.
629 :     $retVal = join("\n",
630 :     CGI::blockquote("Result is not a HASH or ARRAY. Normal display used."),
631 :     $self->DisplayNormal($value));
632 :     } else {
633 :     # Here we have something we can work with. Our first task is to look at the
634 :     # elements we'll be writing out. We're going to play a little trick here and
635 :     # convert everything to a hash with no undefined values. Removing empty
636 :     # entries in the hash or array makes the output more concise and increases
637 :     # the odds we'll be able to write output.
638 :     my ($keyType, %valueMap);
639 :     if ($type eq 'ARRAY') {
640 :     # Get the array length.
641 :     my $count = scalar @{$value};
642 :     # Map the array into a hash.
643 :     for (my $key = 0; $key < $count; $key++) {
644 :     my $element = $value->[$key];
645 :     if (defined $element) {
646 :     $valueMap{$key} = $value->[$key];
647 : parrello 1.1 }
648 :     }
649 : parrello 1.3 # Denote that the keys are array indices.
650 :     $keyType = "Idx";
651 :     } else {
652 :     # Extract the non-empty hash elements.
653 :     for my $key (keys %{$value}) {
654 :     my $element = $value->{$key};
655 :     if (defined $element) {
656 :     $valueMap{$key} = $value->{$key};
657 : parrello 1.1 }
658 :     }
659 : parrello 1.3 # Denote that the keys are hash keys.
660 :     $keyType = "Key";
661 :     }
662 :     # Now we make our second pass through the data, verifying that each value
663 :     # is a hash, and tracking the column names. If we find something that's not a hash,
664 :     # or if we're seeing too many columns, we set an error flag and give up.
665 :     my %columns = ();
666 :     my $columnsFound = 0;
667 :     my $okFlag = 1;
668 :     my @keys = sort { Tracer::Cmp($a, $b) } keys %valueMap;
669 :     my $n = scalar @keys;
670 :     for (my $i = 0; $i < $n && $okFlag; $i++) {
671 :     # Get the element with this key.
672 :     my $key = $keys[$i];
673 :     my $element = $valueMap{$key};
674 :     # Check the type.
675 :     if (IsComplex($value) ne 'HASH') {
676 :     # Not a hash, so we have an error.
677 :     $okFlag = 0;
678 :     $retVal = CGI::blockquote("Table output failed: item with key \"" .
679 :     CGI::escapeHTML($key) . "\" is not a Hash.");
680 : parrello 1.1 } else {
681 : parrello 1.3 # Here we have a hash, so we track its columns.
682 :     for my $subKey (keys %{$element}) {
683 :     if (! $columns{$subKey}) {
684 :     $columns{$subKey} = 1;
685 :     $columnsFound++;
686 : parrello 1.1 }
687 :     }
688 : parrello 1.3 # If there are too many columns, we have an error.
689 :     if ($columnsFound > $self->{maxCols}) {
690 :     $okFlag = 0;
691 :     $retVal = CGI::blockquote("Table output failed: $columnsFound columns were found, " .
692 :     " the maximum number allowed is " . $self->{maxCols} . ".");
693 :     }
694 :     }
695 :     }
696 :     # At this point, either $okFlag is FALSE, and there's an error message in $retVal,
697 :     # or we're good to go.
698 :     if (! $okFlag) {
699 :     # Display the results normally. The user deserves to see the outcome of the test.
700 :     $retVal .= $self->DisplayNormal($value);
701 :     } else {
702 :     # Finally, we can write output. Sort the column names.
703 :     my @cols = sort { Tracer::Cmp($a,$b) } keys %columns;
704 :     # Start the table with a header row.
705 :     my @rows = (CGI::Tr(CGI::th([ $keyType, map { CGI::escapeHTML($_) } @cols])));
706 :     # Loop through the row keys.
707 :     for my $rowKey (@keys) {
708 :     # Get this row's hash.
709 :     my $rowHash = $valueMap{$rowKey};
710 :     # Get a safe copy of the key.
711 :     my $safeKey = CGI::escapeHTML($rowKey);
712 :     # Generate table cells for each known column key.
713 :     my @cells = map { $self->DisplayCell($rowHash->{$_}) } @cols;
714 :     # Push the result onto the table list.
715 :     push @rows, CGI::Tr(CGI::th($safeKey), @cells);
716 : parrello 1.1 }
717 : parrello 1.3 # Form the rows into a table.
718 :     $retVal = CGI::table(@rows);
719 : parrello 1.1 }
720 : parrello 1.2 }
721 : parrello 1.3 # Return the result.
722 :     return $retVal;
723 : parrello 1.1 }
724 :    
725 : parrello 1.3 =head3 DisplayCell
726 : parrello 1.1
727 : parrello 1.3 my $cell = $symbolMap->DisplayCell($value);
728 : parrello 1.1
729 : parrello 1.3 Display the contents of a table cell. When we are displaying an object in
730 :     a table cell, the rules for formatting are slightly different. If the
731 :     value is undefined, we leave the cell blank. If the value is a number, we
732 :     align it to the right.
733 : parrello 1.1
734 :     =over 4
735 :    
736 : parrello 1.3 =item value
737 : parrello 1.1
738 : parrello 1.3 Value to display.
739 : parrello 1.1
740 : parrello 1.3 =item RETURN
741 : parrello 1.1
742 : parrello 1.3 Returns the HTML for a single table cell.
743 : parrello 1.1
744 :     =back
745 :    
746 :     =cut
747 :    
748 : parrello 1.3 sub DisplayCell {
749 : parrello 1.1 # Get the parameters.
750 : parrello 1.3 my ($self, $value) = @_;
751 :     # Declare the return variable.
752 :     my $retVal;
753 :     # Get the maximum character width of a table cell.
754 :     my $maxWidth = $self->{maxWidth};
755 :     # Check the incoming value.
756 : parrello 1.7 if (! defined $value || "$value" eq '') {
757 : parrello 1.3 # An undefined or empty value is a blank cell.
758 :     $retVal = CGI::td("&nbsp;");
759 :     } elsif ("$value" =~ /^\s*-?\d+$/) {
760 :     # Integers are right-aligned.
761 :     $retVal = CGI::td({ align => 'right'}, $value);
762 :     } elsif (ref $value) {
763 :     # Complex value: display normally.
764 :     $retVal = CGI::td($self->DisplayThing($value));
765 :     } elsif (length $value < $maxWidth) {
766 :     # Here we have an unvarnished, short string.
767 :     $retVal = CGI::td(CGI::escapeHTML($value));
768 :     } else {
769 :     # Here we have a long string. We need to bust it up to prevent
770 :     # the table cells from being too awful. First, we break on all
771 :     # the white characters.
772 :     my @pieces = split /\s+/, $value;
773 :     # Now we want to split up long pieces. We'll also use this opportunity to do
774 :     # Html-escaping. The output pieces will go in a list.
775 :     my @outputPieces = ();
776 :     for my $piece (@pieces) {
777 :     # Set up a variable to contain the chunks we pull off.
778 :     my $chunk;
779 :     # Loop until the piece is small enough.
780 :     while (length $piece > $maxWidth) {
781 :     # Break off a chunk. Note that we are guaranteed to get two
782 :     # nonempty strings here, thanks to the loop condition.
783 :     ($chunk, $piece) = ($piece =~ /(.{0,$maxWidth})(.*)/);
784 :     # Put this chunk in the output.
785 :     push @outputPieces, CGI::escapeHTML($chunk) . BREAK_HTML;
786 : parrello 1.1 }
787 : parrello 1.3 # Output the residual. It's the last one, so there's no little break
788 :     # indicator at the end.
789 :     push @outputPieces, CGI::escapeHTML($piece);
790 : parrello 1.1 }
791 : parrello 1.3 # Finally, we create the table cell.
792 :     $retVal = CGI::td(join(" ", @outputPieces));
793 : parrello 1.1 }
794 : parrello 1.3 # Return the result.
795 :     return $retVal;
796 : parrello 1.1 }
797 :    
798 : parrello 1.3
799 :    
800 : parrello 1.2 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3