lib/CXGN/Page/FormattingHelpers.pm

   1 package CXGN::Page::FormattingHelpers;
   2 use strict;
   3 use CXGN::Tools::List;
   4 use warnings;
   5 use Carp;
   6 use POSIX;
   7 use HTML::Entities;
   8 use Storable qw/dclone/;
   9 use Config::General;
  10
  11 use JSON::Any;
  12 my $json = JSON::Any->new;
  13
  14 use CXGN::Tools::List qw/max all/;
  15 use CXGN::Tools::Text qw/commify_number/;
  16
  17 use CXGN::MasonFactory;
  18 use CXGN::Scrap;
  19 use CXGN::Page::Widgets qw/collapser/;
  20
  21 =head1 NAME
  22
  23 CXGN::Page::FormattingHelpers - helper functions for formatting
  24 HTML in an attractive and uniform way across our many pages
  25
  26 =head1 SYNOPSIS
  27
  28     #somewhere in a mod_perl script on the SGN site....
  29     use CXGN::Page::FormattingHelpers qw/  page_title_html
  30                                            info_section_html  /;
  31
  32     print page_title_html('Making a Great SGN Page');
  33
  34     print blue_section_html('SGN Page Guidelines',<<EOH);
  35     <ol>
  36       <li>Always use the FormattingHelpers module!
  37       </li>
  38       <li>Using HTML helper functions is the easiest way to ensure
  39           that your page fits in with the look of the rest of the site.
  40       </li>
  41     </ol>
  42 EOH
  43
  44     print info_section_html( title => 'Search Again',
  45                              contents => my_search_form_html(),
  46                            );
  47
  48
  49 =head1 FUNCTIONS
  50
  51 All functions are EXPORT_OK.
  52
  53 =over 4
  54
  55 =cut
  56
  57
  58 BEGIN {
  59     our @ISA = qw/Exporter/;
  60     use Exporter;
  61     our $VERSION = sprintf "%d.%03d", q$Revision: 1.1 $ =~ /(\d+)/g;
  62     our @EXPORT_OK = qw/  blue_section_html                    html_optional_show
  63                           newlines_to_brs                      html_break_string
  64                           html_string_linebreak_and_highlight  page_title_html
  65                           tabset  modesel                      info_table_html
  66                           toolbar_html                         truncate_string
  67                           simple_selectbox_html                columnar_table_html
  68                           hierarchical_selectboxes_html        numerical_range_input_html
  69                           conditional_like_input_html          info_section_html
  70                           tooltipped_text                      html_alternate_show
  71                           multilevel_mode_selector_html        commify_number
  72                        /;
  73 }
  74 our @ISA;
  75 our @EXPORT_OK;
  76
  77
  78 =head2 blue_section_html
  79
  80     DEPRECATED DEPRECATED DEPRECIATED DEPRECATED DEFENESTRATED DEPRECATED
  81          This is now a special case of info_section_html().
  82
  83     Returns HTML for a page section with a standard SGN header
  84     and indented content.
  85     Args: HTML string containing the section title,
  86           (optional) HTML string containing the sections second title
  87           HTML string containing the section content
  88
  89     Returns: HTML for an SGN-style page section
  90
  91 =cut
  92
  93 sub blue_section_html  {
  94   if( @_ == 3 ) {
  95     info_section_html( title    => shift,
  96                        subtitle => shift,
  97                        contents  => shift,
  98                      )
  99   } else {
 100     info_section_html( title    => shift,
 101                        contents  => shift,
 102                      )
 103   }
 104 }
 105
 106 =head2 info_section_html
 107
 108   Usage: my $section_html =
 109            info_section_html( title         => 'Search Results',
 110                               subtitle      => '3 matches',
 111                               empty_message => 'No matching monkeys found',
 112                               is_subsection => 0,
 113                               contents      => <<EOHTML);
 114   <ul><li>chimpanzee</li><li>bonobo</li><li>rob</li></ul>
 115   EOHTML
 116   Desc : return a piece of html that formats the given
 117          content for display as a section of a detail page
 118   Ret  : string of html to make a pretty page section
 119   Args : named argument list, as:
 120       ( title         => 'main title of the section',
 121         contents      => 'HTML content this section will contain',
 122         subtitle      => (optional) 'secondary title of the section',
 123         empty_message => (optional) 'The message that should be displayed to the user when
 124                           the section is empty', default 'None'
 125         is_empty      => (optional) if true, forces this info_section to be drawn in the empty
 126                          state, content will not be shown.
 127         is_subsection => (optional) if true, renders this section with sub-section styles,
 128         id         => (optional) collapsible_id for the collbpsible javascript div. Default "sgnc" . int(rand(10000)
 129         collapsible => (optional) if true, this section is collapsible.  default false.
 130         collapsed   => (optional) if true, this section should be shown initially collapsed.  default false.
 131         align       =>
 132       )
 133   Side Effects: none
 134
 135 =cut
 136
 137 sub info_section_html {
 138   my %args = @_;
 139
 140   #check arguments.  i think this is better for everyone except beth
 141   my @valid_keys = qw/ title subtitle contents empty_message is_empty is_subsection collapsible collapsed id align/;
 142   foreach my $argname (keys %args) {
 143     grep {$_ eq $argname} @valid_keys
 144       or croak "Unknown argument name '$argname' to info_section_html";
 145   }
 146
 147   #$args{collapsible} = 1 unless defined $args{collapsible}; #collapsible defaults to on
 148
 149   #set anything we dont have to the empty string,
 150   #avoids 'undefined value in string or concatenation' warnings.
 151   $_ ||= '' foreach @args{qw/title subtitle contents/};
 152
 153   #if we have been given content, and we aren't told that this section
 154   #is supposed to be empty, print a full section
 155   my $sub = $args{is_subsection} ? 'sub_' : '';
 156   if ( $args{contents} && ! $args{is_empty} ) {
 157         my $title = $args{title};
 158                 my $contents = $args{contents} || '';
 159                 my $collapser_id = $args{id};
 160                 my $collapsed = $args{collapsed};
 161                 my $align = $args{align} ? qq| style="text-align: $args{align}"| : '';
 162                 $collapsed ||= 0;
 163                 $collapser_id ||= "sgnc" . int(rand(10000));
 164                 $contents = <<EOC;
 165 <div class="${sub}infosectioncontent" $align>
 166 $contents
 167 </div>
 168 EOC
 169                 if ($args{collapsible}) {
 170                         ($title, $contents) = collapser({
 171                                                                                                                                                          linktext => $title,
 172                                                                                                                                                          hide_state_linktext => $title,
 173                                                                                                                                                          content => $contents,
 174                                                                                                                                                          collapsed => $collapsed,
 175                                                                                                                                                          id => $collapser_id});
 176                 }
 177         my $title_bar = <<EOHTML;
 178 <table cellspacing="0" cellpadding="0" class="${sub}infosectionhead" summary=""><tr><td class="${sub}infosectiontitle">$title</td><td class="${sub}infosectionsubtitle">$args{subtitle}&nbsp;</td></tr></table>
 179 EOHTML
 180     return "$title_bar\n$contents\n";
 181   }
 182   #otherwise, if it's actually empty, just print a collapsed section
 183   #with the empty message
 184   else {
 185     my $maybe_subtitle = $args{subtitle}
 186       ? qq|<td class="${sub}infosectionsubtitle_empty" align="right">$args{subtitle}&nbsp;</td>|
 187                                 : '';
 188     $args{empty_message} ||= 'None';
 189     return <<EOT;
 190 <table cellspacing="0" cellpadding="0" class="${sub}infosectionhead_empty" summary=""><tr><td class="${sub}infosectiontitle_empty">$args{title}</td><td class="${sub}infosection_emptymessage">$args{empty_message}</td>$maybe_subtitle</tr></table>
 191 EOT
 192   }
 193 }
 194
 195
 196 =head2 page_title_html
 197
 198     Returns HTML for a standard SGN page title.
 199
 200     Args: text of the page title
 201     Returns: page title HTML
 202
 203 =cut
 204
 205 sub page_title_html {
 206     my ($title) = @_;
 207     return CXGN::MasonFactory->bare_render('/page/page_title.mas', title => $title);
 208 }
 209
 210 =head2 html_optional_show
 211
 212     given a unique item ID, an item title, and the HTML of the item,
 213     makes a "Show $itemtitle" link that turns the display of the item
 214     on as well as a 'Hide' link to hide it again
 215
 216     Args: unique identifier for the item on the page (no whitespace),
 217           title of the item to hide or show OR ['text to show when hidden','text to show when shown']
 218           html contents to be hidden or shown,
 219           (optional) boolean whether it should be shown by default,
 220           (optional) css class name for the <a> and <div> elements.  Both elements will
 221                      always be of class [class], but when the show is active (open),
 222                      the class [class]_active will be added to the <a> and <div>
 223                      Default 'optional_show'
 224    Returns: HTML
 225
 226 =cut
 227
 228 sub html_optional_show {
 229     my ($itemid,$itemtitle,$itemHTML,$default_show_item,$class_name) = @_;
 230     $class_name  ||= 'optional_show';
 231
 232     $default_show_item = $default_show_item ? ' hos_default_show' : '';
 233
 234     # NOTE: most of the action happens in FormattingHelpers.js
 235
 236     return <<END_HTML;
 237 <a name="$itemid" id="$itemid" class="html_optional_show $class_name$default_show_item ${class_name}_active">$itemtitle</a>
 238 <div id="${itemid}_optional_content" class="html_optional_show $class_name ${class_name}_active">
 239    $itemHTML
 240 </div>
 241 END_HTML
 242 }
 243
 244 =head2 html_alternate_show
 245
 246     given a unique item ID, an item title, and the HTML of two items,
 247     makes a "Show $itemtitle" link that turns the display of the second item
 248     on and the display of the first item off, as well as a 'Hide' link to hide it again
 249
 250     Args: unique identifier for the item on the page (no whitespace),
 251           title of the item to hide or show OR ['text to show when hidden','text to show when shown']
 252           html contents to be shown, html contents to replace the first one.
 253     Returns: HTML
 254
 255 =cut
 256
 257 sub html_alternate_show {
 258     my ($itemid1,$itemtitle1, $itemHTML1,$itemHTML2) = @_;
 259
 260     my ($click_style,$start_style) = 0 ? (' class="optional_show" style="display:none"',' class="optional_show"') :
 261                                          (' class="optional_show"',' class="optional_show" style="display:none"') ;
 262     my ($hiddentitle1,$showntitle1) = ref($itemtitle1) ? (@$itemtitle1) : ($itemtitle1,$itemtitle1);
 263
 264
 265  return <<END_HTMLD;
 266     <a name="$itemid1"></a>
 267     <div id="click$itemid1" $click_style>
 268     <a class="optional_show" onclick="document.getElementById('start$itemid1').style.display='block';document.getElementById('click$itemid1').style.display='none';">$hiddentitle1</a>
 269     $itemHTML1
 270     </div>
 271     <div id="start$itemid1" $start_style>
 272     <a class="optional_show_active" onclick="document.getElementById('click$itemid1').style.display='block';document.getElementById('start$itemid1').style.display='none';">$showntitle1</a>
 273     $itemHTML2
 274     </div>
 275 END_HTMLD
 276
 277 }
 278
 279
 280 =head2 newlines_to_brs
 281
 282     Given a string, replaces newlines with the given breaking string.
 283     Args: string, breaking string (default "<br />\n")
 284     Returns: broken HTML string
 285
 286 =cut
 287
 288 sub newlines_to_brs {
 289     my($string,$breaker)=@_;
 290     $breaker ||= "<br />\n";
 291     $string=~s/\n/$breaker/g;
 292     return $string;
 293 }
 294
 295 =head2 html_break_string
 296
 297     format a string with html line breaks at the specified width
 298
 299     Args:  string to break,
 300            optional break width (default 50),
 301            optional break string (default "<br />\n")
 302     Returns: formatted HTML
 303
 304 =cut
 305
 306 sub html_break_string {
 307   my $seq = shift;
 308   my $width = shift || 50;
 309   my $break = shift || "<br />\n";
 310   return '' unless $seq;
 311   return join ($break,($seq =~ /.{1,$width}/g))
 312 }
 313
 314
 315 =head2 html_string_linebreak_and_highlight
 316
 317   args:  - string to format and break up,
 318          - array ref to pairs of start and end highlight regions as
 319          - [[start, end], [start, end], [start, end]],
 320          - CSS class of highlighting <span> elements
 321            (optional, default ='badseq'),
 322          - width in characters at which to break the string
 323            (optional, default = 50)
 324   returns: the complete formatted HTML string
 325
 326 =cut
 327
 328 sub html_string_linebreak_and_highlight {
 329     my ($seq,$highlights_ar,$highlightclass,$breakwidth) = @_;
 330     $highlightclass ||= 'badseq';
 331     $breakwidth ||= 50;
 332
 333     my $hstart_string = qq/<span class="$highlightclass">/;
 334     my $hend_string = q|</span>|;
 335
 336     my %hstarts;
 337     my %hends;
 338
 339     #build highlight starts and ends hashes
 340     while (scalar(@$highlights_ar)) {
 341         my ($hs,$he) = @{shift @$highlights_ar};
 342         croak "Highlight indexes array must have an even number of elements.\n"
 343             unless defined($he);
 344
 345 #     my $hs = shift @$highlights_ar;
 346 #     my $he = shift @$highlights_ar;
 347         croak "Invalid highlight start index $hs.\n"
 348             unless $hs >= 0;
 349
 350         ($he >= 0 && $he >= $hs) || croak "Invalid highlight end index $he (highlight start was $hs).\n";
 351         $hstarts{$hs}++;
 352         $hends{$he}++;
 353     }
 354
 355     my @splitseq = split '',$seq;
 356     my $retstr = '';
 357
 358     my $linectr = 0;
 359     #get down wid da for loop
 360     for (my $i=0; $i<scalar(@splitseq); $i++) {
 361         $retstr .= $hstart_string x ($hstarts{$i} || 0);
 362         $retstr .= $splitseq[$i];
 363         $retstr .= $hend_string x ($hends{$i} || 0);
 364         if(++$linectr == $breakwidth) {
 365             $retstr .= "<br />\n";
 366             $linectr = 0;
 367         }
 368     }
 369     return $retstr;
 370 }
 371
 372 =head2 modesel
 373
 374   args:    ( [ [url, HTML contents],
 375                [url, HTML contents],
 376                [url, HTML contents],
 377              ],
 378              index of currently selected mode, or undef if none
 379            )
 380   returns: a string of HTML for a set of tabs, which is actually an HTML
 381            table of class 'modesel', containing images and text to make
 382            pretty tabs
 383
 384   You may find the CSS style a.modesel in sgn.css useful for formatting HTML
 385   links in mode selections.
 386
 387   Note: tabset() is now an alias for modesel()
 388
 389   Note II:  This thing now uses some javascript to change the button highlighting
 390             when the user clicks, rather than just when the next page loads.
 391             This turns out to make the interface feel way nicer and more responsive.
 392             If you mess with this function, make sure you check
 393             modesel_switch_highlight in documents/inc/sgn.js
 394
 395 =cut
 396
 397 sub tabset { modesel(@_) } #alias
 398
 399 sub modesel {
 400   my $ar = shift;
 401   my $numcols = @$ar*4+1;
 402   my $selected = shift;
 403
 404   my @buttons =
 405     map { { id       => 'mb'.our $_unique_modesel_button_counter++,
 406             contents => $_->[1],
 407             url      => $_->[0],
 408             onclick  => $_->[2] || '',
 409           }
 410         } @$ar;
 411
 412   my $highlighted_id = defined($selected) && $selected >=0 ? $buttons[$selected]{id} : '';
 413
 414   foreach my $button (@buttons) {
 415     my $bid = $button->{id};
 416     my $sel = $bid eq $highlighted_id ? '_hi' : '';
 417
 418     my $tablecell = sub {
 419       my ($leaf,$content) = @_;
 420       qq|    <td id="${bid}_${leaf}" class="modesel_$leaf$sel">$content</td>\n|;
 421     };
 422
 423     $button->{contents} = [
 424                             $tablecell->('tl',qq|<img src="/documents/img/modesel_tl$sel.gif" alt="" />|)
 425                            .$tablecell->('t', qq||)
 426                            .$tablecell->('tr',qq|<img src="/documents/img/modesel_tr$sel.gif" alt="" />|),
 427                             $tablecell->('l', qq|<img src="/documents/img/modesel_l$sel.gif" alt="" />|)
 428                            .$tablecell->('c', qq|<a class="modesel$sel" onclick="CXGN.Page.FormattingHelpers.modesel_switch_highlight('$highlighted_id','$bid'); $button->{onclick}" href="$button->{url}">$button->{contents}</a>|)
 429                            .$tablecell->('r', qq|<img src="/documents/img/modesel_r$sel.gif" alt="" />|),
 430                             $tablecell->('bl',qq|<img src="/documents/img/modesel_bl$sel.gif" alt="" />|)
 431                            .$tablecell->('b', qq||)
 432                            .$tablecell->('br',qq|<img src="/documents/img/modesel_br$sel.gif" alt="" />|),
 433                           ];
 434   }
 435
 436   my $spacer = qq{    <td class="modesel_spacer"></td>\n};
 437   my $tabs_html = join("\n",
 438                        (map {"  <tr>\n$_  </tr>"}
 439                         (join ($spacer,
 440                                (map {$_->{contents}[0]} @buttons)
 441                               ),
 442                          join ($spacer,
 443                                (map {$_->{contents}[1]} @buttons)
 444                               ),
 445                          join ($spacer,
 446                                (map {$_->{contents}[2]} @buttons)
 447                               ),
 448                         )
 449                        )
 450                       );
 451   return <<EOH;
 452 <center>
 453 <table class="modesel" summary="" cellspacing="0">
 454 $tabs_html
 455 </table>
 456 </center>
 457 <hr class="modesel" />
 458 EOH
 459
 460 }
 461
 462 =head2 simple_selectbox_html
 463
 464   args:    - hash-style list as:
 465                      name     => 'the name of the variable',
 466                      choices  => [array of choices],
 467                      selected => (optional) the selected value (from choices),
 468                      multiple => (optional) anything true here makes it a multiple-select
 469                                  box
 470                      id       => (optional) a specific HTML id to be given to this <select>
 471                      params   => (optional) any additional HTML parameters to be attached to the <select> tag,
 472                                      either as a hashref ( { onchange => "alert('foo')" } )
 473                                      or as a string ( 'onchange="alert('foo')" )
 474                      label    => (optional) html string to put inside a <label> </label> preceding the select box
 475   returns: a string of HTML for a select box input
 476
 477
 478   The choices can each either be a simple string, in which case the
 479   value returned and the visible text will be the same, or they can be
 480   an array ref as ['value','visible text'].  If you want grouped
 481   select options (with optgroup tags), pass strings prefixed with two
 482   underscores to for group names, like:
 483
 484   [  '__Group 1',
 485      choices,
 486      [choiceval, choicename],
 487      ...,
 488      '__Group 2',
 489      choices,
 490      ...
 491   ]
 492
 493 =cut
 494
 495 sub simple_selectbox_html {
 496   my %params = @_;
 497   my $retstring;
 498
 499   $params{choices} && ref($params{choices}) eq 'ARRAY'
 500       or confess "'choices' option must be an arrayref";
 501
 502   $params{multiple} = $params{multiple} ? 'multiple' : '';
 503
 504   $params{id} ||= "simple_selectbox_" . ++ our $__simple_selectbox_ctr;
 505   my $id = qq|id="$params{id}"|;
 506
 507   #print out the select box head
 508   if(ref $params{params}) {
 509     $params{params} = join ' ',map { qq|$_="$params{params}{$_}"| } keys %{$params{params}};
 510   }
 511   $params{params} ||= '';
 512   $params{name} ||= '';
 513   $retstring = qq!<select $id $params{multiple} $params{params} name="$params{name}">\n!;
 514   $retstring =~ s/ +/ /; #collapse spaces
 515   my $in_group = 0;
 516   foreach (@{$params{choices}}) {
 517     if(!ref && s/^__// ) {
 518       $retstring .= qq{</optgroup>} if $in_group;
 519       $in_group = 1;
 520       $retstring .= qq{<optgroup label="$_">};
 521     } else {
 522       my ($name,$text) = ref $_ ? @$_ : ($_,$_);
 523       my $selected = (defined $params{selected} && $params{selected} eq $name) ? ' selected="selected"' : '';
 524       $retstring .= qq{<option value="$name"$selected>$text</option>\n};
 525     }
 526   }
 527   $retstring .= qq{</optgroup>} if $in_group;
 528   $retstring .= "</select>\n";
 529
 530   if($params{label}) {
 531     $retstring = qq|<label for="$params{id}">$params{label}</label> $retstring|;
 532   }
 533   return $retstring;
 534 }
 535
 536
 537 =head2 info_table_html
 538
 539   Desc:
 540   Args: an ordered list of value names => values
 541   Ret : html to produce an attractive table laying out these values
 542   Used in:  clone_info.pl, clone_read_info.pl
 543   Example:
 544
 545     my $info_html = info_table_html( 'Clone name' => $clone->name ,
 546                                      'Clone type' => $clone->clone_type_object->name,
 547                                      '__title'    => 'Clone '.$clone->name,
 548                                    );
 549     print $info_html;
 550
 551   There are a few special value names that, if found in the list you pass,
 552   will modify the table this produces:
 553
 554 =over 12
 555
 556 =item __title
 557
 558   If found, will produce a title on the simple info table.
 559
 560 =item __caption
 561
 562   If found, will put the value of this field in the html caption of the table.
 563
 564 =item __tableattrs
 565
 566   A string of HTML attributes (like qq{width="100%" height="200"}) that will be directly imbedded
 567   in the beginning <table> tag.
 568
 569 =item __multicol
 570
 571   Maximum number of columns the data can appear in.  This function
 572   will attempt to fit the given data into the minimum number of rows
 573   while staying within the specified __multicol column limit.
 574
 575   Default is __multicol => 1.
 576
 577 =item __border
 578
 579   If true, draw a border around the table.  If false, do not.
 580   Default true.
 581
 582 =item __sub
 583
 584   If true, this info_table is a subtable of another info_table.  Implies __border => 0,
 585   and uses sub_info_table styles.
 586   Default false.
 587
 588 =back
 589
 590 =cut
 591
 592 sub info_table_html {
 593   croak 'Must pass an even-length argument list' if scalar(@_) % 2;
 594
 595   my %tabledata = @_;
 596   $tabledata{__multicol} ||= 1;
 597   $tabledata{__border} = 1 unless exists($tabledata{__border});
 598
 599   #list of reserved field names
 600   my @reserved = qw/__title __caption __tableattrs __multicol __border __sub/;
 601   my %reserved = map {$_=>1} @reserved; #hash them for quick lookup
 602
 603   #get every other element from args to remember the order of the
 604   #table row names
 605   my $last = 0;
 606   my @field_order = map {$last = !$last; $last ? ($_) : ()} @_;
 607   #take out the reserved field names from the field order list
 608   @field_order = grep { ! $reserved{$_} } @field_order;
 609
 610   #figure out the multi-column wrapping
 611   my @fields_layout; #2-D array of where in the table each field name
 612                      #will be
 613   my $numcols = 0;
 614   {
 615     my $numfields = @field_order;
 616     my $max_col_len = POSIX::ceil($numfields/$tabledata{__multicol});
 617
 618     #  split the fields array into chunks (these will be columns)
 619     push @fields_layout,[] foreach(1..$max_col_len);
 620     while (my @chunk = splice(@field_order,0,$max_col_len)) {
 621       #     my $chunksize = @chunk;
 622       #     push @chunk,undef while($chunksize++ != $max_col_len);
 623       # for each chunk, add one of its elements to each of the rows
 624       push @$_,(shift @chunk) foreach (@fields_layout);
 625       $numcols++;
 626     }
 627   }
 628
 629   my $tableattrs =
 630       $tabledata{__tableattrs}
 631         ? ' '.$tabledata{__tableattrs}
 632         : '';
 633
 634   my $sub = $tabledata{__sub} ? 'sub_' : '';
 635
 636   my $noborder = $tabledata{__border} ? '' : '_noborder';
 637   join("\n",
 638        (qq/<table summary="" class="${sub}info_table$noborder" $tableattrs>/,
 639
 640         $tabledata{__caption}
 641         ? (qq!<caption class="${sub}info_table">$tabledata{__caption}</caption>!)
 642         : (),
 643
 644         $tabledata{__title}
 645         ? (qq!<tr><th class="${sub}info_table" colspan="$numcols">$tabledata{__title}</th></tr>!)
 646         : (),
 647
 648         #turn each of the passed field=>value pairs into an html table row
 649         (map {'<tr>'.join('',map {$_ ? <<EOH : '<td>&nbsp;</td><td>&nbsp;</td>'} @$_).'</tr>'} @fields_layout),
 650   <td class="${sub}info_table_field">
 651     <span class="${sub}info_table_fieldname">$_</span>
 652     <div class="${sub}info_table_fieldval">
 653       $tabledata{$_}
 654     </div>
 655   </td>
 656 EOH
 657
 658 #       '<tr><td colspan="2" class="${sub}info_table_lastrow"></td></tr>',
 659         '</table>',
 660        )
 661       );
 662 }
 663
 664
 665
 666
 667 =head2 truncate_string
 668
 669   Desc: truncate a string that might be long so that it fits in a manageable
 670         length, adding an arbitrary string (default '&hellip;') to the end if
 671         necessary.  If the string is shorter than the given truncation
 672         length, simply returns the string unaltered.  If the truncated
 673         string would have whitespace between the end of the given
 674         string and the addon string, drops that whitespace.
 675   Args: string to truncate, optional truncation length (default 50),
 676         optional truncation addon (default '&hellip;')
 677   Ret : in scalar context:   truncated string
 678         in list context:     (truncated string,
 679                               boolean telling whether string was truncated)
 680
 681   Example:
 682     truncate_string('Honk if you love ducks',6);
 683     #would return
 684     'Honk i&hellip;'
 685
 686     truncate_string('Honk if you love cats',5);
 687     #would return
 688     'Honk&hellip;'
 689     #because this function drops trailing whitespace
 690
 691 =cut
 692
 693 sub truncate_string {
 694   my ($string,$length,$addon) = @_;
 695   $length ||= 50;
 696   $addon ||= '&hellip;';
 697
 698   return CXGN::Tools::Text::truncate_string( $string, $length, $addon );
 699 }
 700
 701
 702 =head2 columnar_table_html
 703
 704   Desc: generates a table of results arranged in columns,
 705         with column headings and pretty alternating-color rows
 706   Args: ( headings => [ col name, col name,...],
 707           data     => [ [html, html, ...],
 708                         [ html,
 709                           { onmouseover => "alert('ow!')",
 710                             content => some html
 711                           },
 712                           html,
 713                           ...
 714                         ],
 715                         ...
 716                       ],
 717           __align      => 'cccccc...',
 718           __tableattrs => 'summary="" cellspacing="0" width="100%"',
 719           __border     => 1,
 720
 721           __alt_freq   => 4,
 722           __alt_width  => 2,
 723           __alt_offset => 0,
 724         )
 725   Ret : string of HTML to prettily draw such a table
 726   Side Effects: none
 727
 728   If you want, you can add arbitrary HTML attributes to the <tds>
 729   by passing hashrefs instead of HTML strings in the
 730   table data, such as { colspan => 3, content=>"blabla" }.
 731
 732   Note about the use of colspan: If you are going to use colspan
 733   you need put after this element as many undef variables as colspan
 734   number. For example, if you want print:
 735
 736   +------------+------------+-----------+-----------+----------+
 737   |   head1    |  head2     |   head3   |  head4    | head5    |
 738   +------------+------------+-----------+-----------+----------+
 739   |   test1    |  test2     |   test3               |  test4   |
 740   +------------+------------+-----------------------+----------+
 741
 742   The code will be:
 743
 744   columnar_table_html( headings => ['head1' ,
 745                                     'head2' ,
 746                                     'head3' ,
 747                                     'head4' ,
 748                                     'head5'
 749                                    ],
 750                        data     => [ [ 'test1',
 751                                        'test2',
 752                                        { colspan => 2, content => 'test3'},
 753                                        undef,
 754                                        'test4'
 755                                    ] ]
 756                       );
 757
 758   Best used to display lists of query results and the like.
 759   __alt_width must be smaller than __alt_freq.
 760
 761   To produce a heading that spans multiple consecutive columns, succeed
 762   the heading with undefs.  For example ['foo', undef, undef, 'bar'] will
 763   cause the table heading 'foo' to have a colspan of 3.
 764
 765   There are a few special value names that, if found in the list you pass,
 766   will modify the table this produces:
 767
 768 =head3 __align
 769
 770 Specify the text alignments for each column.  Takes either
 771 a string containing the alignments, like 'lccr' or 'llll', or an array
 772 ref like ['l','c','c','r'].  Default is all columns centered.
 773
 774 =head2 __alt_freq
 775
 776 If specified, sets the frequency of color change for alternating the
 777 color of rows.  Setting this to 0 will disable alternate-row
 778 highlighting.  Defaults to 0 for tables with fewer than 3 rows, 2
 779 (every other row) for tables with 4-6 rows, and 4 (every 3rd row) for
 780 tables with more than 6 rows.
 781
 782 =head3 __tableattrs
 783
 784 If set, will add whatever html you put here to the HTML as <table $params{__tableattrs}>
 785
 786 =head3 __border
 787
 788 Defaults to false.  If true, draws a border around the table.
 789
 790 =head3 __alt_width
 791
 792 Set the width of the alternate row highlighting.  Defaults to 1 for tables with fewer than 6 rows, 2 otherwise.
 793
 794 =head3 __alt_offset
 795
 796 Set the offset of the row highlighting.  Shifts all the row
 797 highlighting up and down by the number placed here.  Defaults to 0.
 798 Play with this if you don't like the exact placement of the
 799 every-other-row highlighting.
 800
 801 =cut
 802
 803 sub columnar_table_html {
 804   my %params = @_;
 805
 806   croak "must provide 'data' parameter" unless $params{data};
 807
 808   my $noborder = $params{__border} ? '' : '_noborder';
 809
 810   my $html;
 811   #table beginning
 812   $params{__tableattrs} ||= qq{summary="" cellspacing="0" width="100%"};
 813   $html .= qq|<table class="columnar_table$noborder" $params{__tableattrs}>\n|;
 814
 815   unless( defined $params{__alt_freq} ) {
 816     $params{__alt_freq} = @{$params{data}} > 6 ? 4 :
 817                           @{$params{data}} > 3 ? 2 :
 818                                                  0;
 819   }
 820   unless( defined $params{__alt_width} ) {
 821     $params{__alt_width}  = @{$params{data}} > 6 ? 2 : 1;
 822   }
 823   unless( $params{__alt_width} < $params{__alt_freq} ) {
 824     $params{__alt_width} = $params{__alt_freq}/2;
 825   }
 826   unless( defined $params{__alt_offset} ) {
 827     $params{__alt_offset} = 0;
 828   }
 829
 830   #set the number of columns in our table.  rows will be padded
 831   #up to this with '&nbsp;' if they don't have that many columns
 832   my $cols = $params{headings} ?
 833         scalar(@{$params{headings}})
 834       : max(map {scalar(@$_)} @{$params{data}});
 835
 836   ###figure out text alignments of each column
 837   my @alignments = do {
 838     if(ref $params{__align}) {
 839       ref($params{__align}) eq 'ARRAY'
 840         or croak '__align parameter must be either a string or an arrayref';
 841       @{$params{__align}} #< just dereference it
 842     } elsif($params{__align}) {
 843       split '',$params{__align}; #< explode the string into an array
 844     } else {
 845       ('c')x$cols;
 846     }
 847   };
 848   my %lcr = ( l => 'align="left"', c => 'align="center"', r => 'align="right"' );
 849   foreach (@alignments) {
 850     if($_) {
 851       $_ = $lcr{$_} or croak "'$_' is not a valid column alignment";
 852     }
 853   }
 854
 855   #columns headings
 856   if( $params{headings} ) {
 857     # Turn headings like this:
 858     #  [ 'foo', undef, undef, 'bar' ]
 859     # into this:
 860     # <tr><th colspan="3">foo</th><th>bar</th></tr>
 861     # The first column heading may not be undef.
 862     unless (defined ($params{headings}->[0])) {
 863       croak ("First column heading is undefined");
 864     }
 865     $html .= '<thead><tr>';
 866     # The outer loop grabs the defined colheading; the
 867     # inner loop advances over any undefs.
 868     my $i = 0;
 869     while ($i<@{$params{headings}}) {
 870       my $colspan = 1;
 871       my $align = $alignments[$i] || '';
 872       my $heading = $params{headings}->[$i++] || '';
 873       while (($i<@{$params{headings}}) && (!defined($params{headings}->[$i]))) {
 874         $colspan++;
 875         $i++;
 876       }
 877       $html .= "<th $align class=\"columnar_table$noborder\" colspan=\"$colspan\">$heading</th>";
 878     }
 879     $html .= "</tr></thead>\n";
 880   }
 881
 882   $html .= "<tbody>\n";
 883   my $hctr = 0;
 884   my $rows_remaining_to_hilite = 0;
 885   foreach my $row ( @{$params{data}} ) {
 886     if( $params{__alt_freq} != 0
 887         && ($hctr++ - $params{__alt_offset})%$params{__alt_freq} == 0
 888       ) {
 889       $rows_remaining_to_hilite = $params{__alt_width};
 890     }
 891     my $hilite = do {
 892       if( $rows_remaining_to_hilite ) {
 893         $rows_remaining_to_hilite--;
 894         'class="columnar_table bgcoloralt2"'
 895       } else {
 896         'class="columnar_table bgcoloralt1"'
 897       }
 898     };
 899     #pad the row with &nbsp;s up to the length of the headings
 900     if(@$row < $cols) {
 901       $_ = '&nbsp;' foreach @{$row}[scalar(@$row)..($cols-1)];
 902     }
 903     $html .= "<tr>";
 904     for(my $i=0;$i<@$row;$i++) {
 905       my $a = $alignments[$i] || '';
 906       my $c = $row->[$i] || '';
 907       my $tdparams = '';
 908       if(ref $c) { #< process HTML attributes if this piece of data is a hashref
 909         my $d = $c;
 910         $c = delete $d->{content};
 911         if(my $moreclasses = delete $d->{class}) { #< add more classes if present
 912           $hilite =~ s/"$/ $moreclasses"/x;
 913         }
 914         if (exists $d->{'colspan'}) {    ### If exists a colspan it should not add more columns so, we increase
 915                                          ### the column count as many times as colspan
 916             $i = $i + $d->{'colspan'};
 917         }
 918         $tdparams = join ' ',map { qq|$_="$d->{$_}"| } grep {$_ ne 'content'} keys %$d;
 919       }
 920       $html .= "<td $hilite $tdparams $a>$c</td>"
 921     }
 922     $html .= "</tr>\n";
 923 #    $html .= join( '',('<tr>',(map {"<td $hilite>$_</td>"} @$row),'</tr>'),"\n" );
 924   }
 925   $html .= "</tbody></table>\n";
 926
 927   return $html;
 928 }
 929
 930 =head2 commify_number
 931
 932   Args: a number
 933   Ret : a string containing the commified version of it
 934
 935   Example: commify_number(230400) returns '230,400'
 936
 937 =cut
 938
 939 # just handled by the importation of CXGN::Tools::Text::commify_number above
 940
 941
 942
 943 =head2 hierarchical_selectboxes_html
 944
 945   Desc: make two select boxes, the contents of one of which is
 946         dependent on the selection in the first
 947   Args: hash-style list as:
 948         (  parentsel => ref to hash of args in format called for by
 949                         simple_selectbox_html(),
 950            childsel  => ref to hash of args in format called for by
 951                         simple_selectbox_html(),
 952            childchoices => [ [ option, option, option, ...],
 953                              [ option, option, option, ...],
 954                              [ option, option, option, ...],
 955                            ],
 956        )
 957   Ret : in scalar context: complete html of parent select box, child box, and javascript
 958         in list context:
 959           array of (parent select box, child select box, piece of
 960           javascript)
 961
 962   WARNING: currently, the javascript won't work if the parent and
 963            child boxes are in different <form>s.  So either don't do
 964            that or make it work yourself and remove this warning.
 965
 966 =cut
 967
 968 sub hierarchical_selectboxes_html {
 969   my %params = @_;
 970
 971   #assemble javascript datastructure holding the options for the contents of
 972   #our dependent select box
 973   our $sel_id;
 974   $sel_id++;
 975   my $seloptions = "seloptions$sel_id";
 976   $params{parentsel}{id} ||= "hsparent$sel_id";
 977 #  $params{childsel}{id} ||= "hschild$sel_id";
 978
 979   #since this routine knows nothing about the form it's going to be used in,
 980   #we can't just use javascript to initialize the dependent select box to
 981   #its proper state based on the initial state of the parent select box.  Thus,
 982   #we figure out the proper state and initialize it to that statically in HTML
 983   #make sure that the child select box has the proper options initially for
 984   #whatever is selected in the parent select box
 985   my $i = 0;
 986   #index in the options array of the initially selected value in the parent box
 987   my $parent_selected_index = 0;
 988   foreach my $option (@{$params{parentsel}{choices}}) {
 989     my $val = ref($option) ? $option->[0] : $option;
 990     if( $params{parentsel}{selected}
 991         && $val eq $params{parentsel}{selected}
 992       ) {
 993       $parent_selected_index = $i;
 994       last;
 995     } else {
 996       $i++;
 997     }
 998   }
 999
1000   $params{childsel}{choices} = $params{childchoices}[$parent_selected_index] || [];
1001
1002   #add an onChange event handler to the parent select box
1003   my $onchange = qq|CXGN.Page.FormattingHelpers.update_hierarchical_selectbox(document.getElementById('$params{parentsel}{id}').selectedIndex,$seloptions,document.getElementById('$params{parentsel}{id}').form.$params{childsel}{name})|;
1004
1005   if(ref $params{parentsel}{params}) {
1006     $params{parentsel}{params}{onchange} = $onchange.'; '.$params{parentsel}{params}{onchange};
1007   } else {
1008     $params{parentsel}{params} = qq|onchange="$onchange;" |.( $params{parentsel}{params} || '' );
1009   }
1010
1011   #now make the html for the parent select box
1012   my $parentselbox = simple_selectbox_html( %{$params{parentsel}} );
1013   #and for the child select box
1014   my $childselbox = simple_selectbox_html( %{$params{childsel}} );
1015
1016   #and the javascript enumerating the options and initializing the box
1017   my $options_js =
1018     #is an array
1019     "var $seloptions = [ "
1020     #of arrays
1021     .join(",",( map {"\n                            [ "
1022                        #of options
1023                        .join(', ',( map { #consisting of quoted names and values
1024                                           ref $_ ? "new Option('$_->[1]','$_->[0]')"
1025                                                  : "new Option('$_','$_')"
1026                                         } @$_
1027                                   )
1028                             )
1029                        ."]"
1030                       } @{$params{childchoices}}
1031                 )
1032          )
1033     ."\n                           ];\n$onchange";
1034   #NOTE: a lot of the seemingly useless spaces above are for nice indentation
1035   #      in the output
1036
1037
1038   if(wantarray) {
1039     return ($parentselbox,$childselbox,$options_js);
1040   } else {
1041   #and put them in context
1042     return <<EOH;
1043 $parentselbox
1044 $childselbox
1045 <script language="JavaScript" type="text/javascript">
1046 <!--
1047 $options_js
1048 -->
1049 </script>
1050 EOH
1051   }
1052 }
1053
1054 =head2 numerical_range_input_html
1055
1056   Args: hash-style list as:
1057      ( compare => [name, (optional) initial value],
1058        value1  => [name, (optional) initial value],
1059        value2  => [name, (optional) initial value],
1060        units   => html string describing the measurement units of these numbers,
1061      )
1062   Ret : html for a numerical range form input
1063
1064 =cut
1065
1066 my $numerical_range_input_unique_id = 0;
1067 sub numerical_range_input_html {
1068   my %params = @_;
1069
1070   3 == grep {$params{$_}[0]} qw/compare value1 value2/
1071     or croak 'Must provide names for each of the three form fields that make up a numerical range input';
1072
1073   if(defined($params{compare}[1])) {
1074     grep {$params{compare}[1] eq $_} qw/gt lt bet eq/
1075       or croak "Invalid initial value for comparison box, you passed '$params{compare}[1]'";
1076   }
1077
1078   my $id = 'rangeinput'.$numerical_range_input_unique_id++;
1079
1080   my $compare_select = simple_selectbox_html(name     => $params{compare}[0],
1081                                              choices  => [
1082                                                           ['gt' , 'greater than'],
1083                                                           ['lt' , 'less than' ],
1084                                                           ['bet', 'between' ],
1085                                                           ['eq' , 'exactly' ],
1086                                                          ],
1087                                              selected => $params{compare}[1],
1088                                              id       => $id.'_r',
1089                                              params   => qq|onchange="CXGN.Page.FormattingHelpers.update_numerical_range_input('$id','$params{units}')"|
1090                                             );
1091
1092   $params{value1}[1] = '' unless defined($params{value1}[1]);
1093   $params{value2}[1] = '' unless defined($params{value2}[1]);
1094
1095 return <<EOH;
1096 $compare_select&nbsp;<input type="text" size="8" name="$params{value1}[0]" value="$params{value1}[1]" />&nbsp;<span id="${id}_m">and</span>&nbsp;<span id="${id}_2" ><input size="8" type="text" name="$params{value2}[0]" value="$params{value2}[1]" />&nbsp;</span><span id="${id}_e">$params{units}</span>
1097 <script language="JavaScript" type="text/javascript">
1098   CXGN.Page.FormattingHelpers.update_numerical_range_input('$id','$params{units}');
1099 </script>
1100 EOH
1101
1102
1103 }
1104
1105 =head2 conditional_like_input_html
1106
1107   Usage: my $html = conditional_like_input_html('matchtype','matchstring');
1108   Desc : makes html for a select box and text input field for a sort of
1109          "conditional like", which is a select box with 'starts with','ends with',
1110          'contains', and 'exactly', followed by a regular text input box
1111   Ret  : a string of html
1112   Args : name of these two elements (select will be called $name.'_matchtype',
1113            text input will be called $name),
1114          (optional) initial value of the match type select box,
1115          (optional) initial value of the match string box
1116   Side Effects: none
1117   Example:
1118
1119     my $condselect = conditional_like_input_html('locus_name','starts_with','YabbaMonkeyTumor', '30');
1120     #will return a select box set to 'starts_with' (displaying 'starts with', with no underscore),
1121     #and a text input initialized to 'YabbaMonkeyTumor' size = 30
1122
1123 =cut
1124
1125 sub conditional_like_input_html {
1126   my ($name,$type_init,$string_init, $size) = @_;
1127
1128   #check arguments
1129   $name or croak 'must provide a name to conditional_like_input_html()';
1130   !$type_init
1131     or grep {$type_init eq $_} qw/starts_with ends_with contains exactly/
1132       or croak <<EOC;
1133 conditional_like_input_html: invalid initial match type $type_init, must be
1134 starts_with, ends_with, contains, or exactly
1135 EOC
1136   $string_init ||= '';
1137   $size ||= '30';
1138   #make the select box
1139   my $matchtype_select = simple_selectbox_html( name     => $name.'_matchtype',
1140                                                 selected => $type_init,
1141                                                 choices  => [ 'contains',
1142                                                               ['starts_with','starts with'],
1143                                                               ['ends_with','ends with'],
1144                                                               'exactly',
1145                                                             ],
1146                                               );
1147   chomp $matchtype_select; #remove newline, cause some browsers are idiotic.
1148   #return the html
1149   return <<EOHTML;
1150 $matchtype_select<input name="$name" value="$string_init" size="$size" type="text" />
1151 EOHTML
1152 }
1153
1154 =head2 tooltipped_text($text, $tooltip)
1155
1156   Usage: my $html = tooltipped_text('Mouse over here for help',
1157                                     'help is on the way!'
1158                                    );
1159   Desc : Returns html for a span containing a tooltip and styled
1160          according to the span.help rules in sgn.css . Typically this
1161          includes a dashed underline and a question-mark cursor.
1162   Ret  : said string of html
1163   Args : text of span, text of tooltip,
1164          optional class of the <span> (defaults to 'help')
1165   Side Effects: none
1166   Example:
1167
1168     my $html = tooltipped_text('Select a marker confidence','Marker confidences come from the MapMaker program and range from I to F(LOD3).');
1169
1170    # This produces the following html:
1171    <span class="help" onmouseover="return escape('Marker confidences come from the MapMaker program and range from I to F(LOD3).')">Select a marker confidence</span>
1172
1173   These tooltips require the wz_tooltip.js library, which is included in the SGN footer.
1174
1175 =cut
1176
1177
1178 sub tooltipped_text {
1179
1180   my ($text, $tooltip, $class) = @_;
1181
1182   $class||='help';
1183
1184   $tooltip =~ s/'/\\'/g;
1185   $tooltip =~ s!\n! !g;
1186   $tooltip = HTML::Entities::encode_entities($tooltip);
1187
1188   return qq{<span class="$class" onmouseover="return escape('$tooltip')">$text</span>};
1189
1190 }
1191
1192
1193 =head2 multilevel_mode_selector_html
1194
1195   Usage: my ($selector_html,@selected_levels) = multilevel_mode_selector_html($mode_config, $current_modename);
1196   Desc : function to do a multilevel mode selector
1197   Args : mode config string (in the Apache-like Config::General format, see below),
1198          full name of mode to draw as selected
1199   Ret  : list as ( selector html,
1200                    list of selected choices that have been selected in each of
1201                    the selection levels, based on the modename you passed,
1202                  )
1203   Side Effects: none
1204   Configuration format:
1205
1206     Takes config information as a parsable string (you would probably
1207     want to write it as a heredoc).  Format is
1208     <modename>
1209       desc "Something"
1210       <submodename>
1211          desc "Something green"
1212       </submodename>
1213       <submodename2>
1214          desc "Something blue"
1215       </submodename2>
1216     </modename>
1217
1218     Modes can be nested to arbitrary depth, but for depths greater
1219     than 3 the coloring might be rather difficult.
1220
1221   Example:
1222
1223      my $animal_selector_html = multilevel_mode_selector_html(<<EOC,$params{mode});
1224   <monkey>
1225      text "Monkey"
1226      <rhesus>
1227        text "Rhesus monkey"
1228        <from_madagascar>
1229          text "from Madagascar"
1230        </from_madagascar>
1231        <from_borneo>
1232          text "from Borneo"
1233        </from_borneo>
1234      </rhesus>
1235      <spider>
1236        text "Spider monkey"
1237        <malaysia>
1238          text "from Malaysia"
1239        </malaysia>
1240      </spider>
1241   </monkey>
1242   <dog>
1243     text "Dog"
1244     <wild>
1245       text "Wild dog"
1246       <dingo>
1247         text "a Dingo"
1248       </dingo>
1249       <coyote>
1250         text "coyote, sort of a wild dog"
1251       </coyote>
1252     </wild>
1253     <domesticated>
1254       text "In Your House"
1255       <mastiff>
1256         text "a huge Mastiff"
1257       </mastiff>
1258       <chihuahua>
1259         text "a little Chihuahua"
1260       </chihuahua>
1261     </domesticated>
1262   </dog>
1263   EOC
1264
1265   # and now, if mode were to be 'monkey_rhesus_from_borneo', it would return
1266   # an HTML selector with Monkey > Rhesus monkey > from Borneo selected,
1267   # along with the list 'monkey','rhesus','borneo'.  Notice that underscores
1268   # are allowed in mode names.  It's smart enough to handle them correctly.
1269
1270 =cut
1271
1272 # IMPLEMENTATION OVERVIEW: first we parse
1273
1274 sub multilevel_mode_selector_html {
1275   my ($config,$mode_name) = @_;
1276
1277   # parse our configuration if necessary
1278   my %conf = ref($config) ? %{dclone($config)} : Config::General->new(-String => $config)->getall;
1279
1280   ($mode_name) = %conf unless $mode_name;
1281   #warn "mode name is $mode_name\n";
1282
1283   my $url_pattern = delete($conf{url_pattern}) || '?mode=%m';
1284
1285   # these are the colors for the various mode selection levels
1286   my @colors = qw/ e6e6e6 c2c2ff 9797c7 333333 /;
1287
1288   #now use the above recursive function to find and set active => 1 appropriately for each mode level
1289   my @selected_modes;
1290   _ml_find_active('',\%conf,'',$mode_name,\@selected_modes);
1291 #   use Data::Dumper;
1292 #   warn Dumper(\@selected_modes);
1293
1294 #   use Data::Dumper;
1295 #   print  Dumper(\%conf);
1296
1297   #TODO: transform the conf into a more standard tree structure, which is easier to work with
1298   #      and rewrite render code for it
1299   sub _xform_tree {
1300     my ($def,$stem_name) = @_;
1301     my @child_keys = _ml_child_keys($def);
1302     my @children;
1303     foreach (@child_keys) {
1304       my $mn = $def->{$_}->{ml_modename} = $stem_name ? $stem_name.'_'.$_ : $_;
1305       push @{$def->{ml_children}}, $def->{$_};
1306       _xform_tree(delete $def->{$_}, $mn);
1307     }
1308   }
1309   _xform_tree(\%conf,'');
1310
1311 #   use Data::Dumper;
1312 #   die Dumper($categories);
1313
1314   #now call the rendering function to recursively render each level
1315   #use Data::Dumper;
1316   #print Dumper(\%conf);
1317   return ( _ml_render( $url_pattern, 1, \%conf ),
1318            @selected_modes
1319          );
1320 }
1321
1322 sub _ml_max_stratum_size {
1323   my ($tree) = @_;
1324   my @q = ($tree->{ml_children});
1325   my $max = 0;
1326   while(@q) {
1327     my $set = shift @q;
1328     $max = @$set if $max < @$set;
1329     push @q,$_->{ml_children} foreach @$set;
1330   }
1331   return $max;
1332 }
1333
1334 # multilevel helper function:
1335 # recursion to figure out which category is active in each level
1336 sub _ml_find_active {
1337   my ($curr_name,$curr_entry,$stem,$selected_mode_name,$active_levels) = @_;
1338   #warn join(',',($curr_name,$curr_entry,$stem,$selected_mode_name,$active_levels))."\n";
1339   my $level_name = $stem ? $stem.'_'.$curr_name : $curr_name;
1340   #warn "lev name is $level_name\n";
1341   my @child_keys = _ml_child_keys($curr_entry);
1342   if ($selected_mode_name eq $level_name ) {
1343     $curr_entry->{ml_active} = 1;
1344     unshift @$active_levels,$curr_name;
1345     return 1;
1346   } elsif ( $selected_mode_name =~ /^$level_name/ ) {
1347     # might match one of our children
1348     #warn "hmm, check children\n";
1349     foreach my $child_name (@child_keys) {
1350       if ( _ml_find_active( $child_name, $curr_entry->{$child_name}, $level_name, $selected_mode_name, $active_levels ) ) {
1351         #this returns true, one of my children must match
1352         unshift @$active_levels,$curr_name if $curr_name;
1353         $curr_entry->{ml_active} = 1;
1354         return 1;
1355       }
1356     }
1357   }
1358   #warn "that's all\n";
1359   return 0;
1360 }
1361
1362 # check whether a given hash key is reserved
1363 our %ml_reserved = map { $_=>1 } qw/ ml_active ml_modename ml_children text sort_index ml_parent_id ml_container_id ml_id tooltip/;
1364 sub _ml_is_reserved_key {
1365   return  $ml_reserved{+shift};
1366 }
1367 # return a list of unreserved keys in the given hash
1368 sub _ml_child_keys {
1369   return grep !_ml_is_reserved_key($_), keys %{+shift};
1370 }
1371
1372 # multilevel helper function, recursively renders the HTML for the widget
1373
1374 our $ml_id_ctr = 0;
1375 sub _ml_render {
1376   #my ($inactive_color,$active_colors,$level_count, %defs) = @_;
1377   my ($url_pattern, $active, $tree) = @_;
1378   #use Data::Dumper;
1379   #print Dumper($defs);
1380
1381   #make a global id ctr for this whole multilevel widget
1382   $ml_id_ctr = 0;
1383   my $thisml = $ml_id_ctr++;
1384
1385   #sorts a single set of children by sort_index, if present
1386   sub _sort_nodes {
1387     no warnings 'uninitialized';
1388     my ($nodelist) = @_;
1389     sort {$a->{sort_index} <=> $b->{sort_index}} @$nodelist
1390   }
1391
1392   # go through all the nodes and assign them an id, building an index
1393   # of the parent and children for each ID
1394   #use Data::Dumper;
1395 #  print Dumper($tree);
1396   my %id_based_index;
1397   sub _assign_ids_and_build_idx {
1398     my ($self,$parent_id,$idx) = @_;
1399     my $id = "ml_".$ml_id_ctr++;
1400     $self->{ml_id} = $id;
1401     $idx->{$id} = $self;
1402     $self->{ml_parent_id} = $parent_id if $parent_id;
1403     _assign_ids_and_build_idx($_,$id,$idx) foreach @{$self->{ml_children}};
1404   }
1405   _assign_ids_and_build_idx($_,'',\%id_based_index) foreach @{$tree->{ml_children}};
1406   #warn Dumper($tree);
1407   #warn Dumper(\%id_based_index);
1408
1409   my $button_html = '';
1410
1411   my @active_button_ids; #< one per depth, indexed by depth
1412   my @active_group_ids; #< one per depth, indexed by depth
1413   my @traverse_queue = ( [0,_sort_nodes($tree->{ml_children})] ); #< queue used for breadth-first traversal of the tree structure of the mode definitions
1414   my $max_stratum_size = _ml_max_stratum_size($tree);
1415   while( @traverse_queue ) {
1416     my ($depth,@node_set) = @{shift @traverse_queue};
1417
1418     my $group_html = '';
1419     my $group_is_active = 0;
1420
1421     my $group_id = 'ml_'.$ml_id_ctr++;
1422
1423     my $width_rel = sprintf('%0.0f%%',92/$max_stratum_size*@node_set);
1424     foreach my $node_def (@node_set) {
1425       my $name = $node_def->{ml_modename};
1426       my @subnodes = _sort_nodes($node_def->{ml_children});
1427       my $id = $node_def->{ml_id};
1428
1429       #record the depth in the node_def
1430       $node_def->{ml_depth} = $depth;
1431
1432       my $title = $node_def->{tooltip} ? qq| title="$node_def->{tooltip}"| : '';
1433       my $link_class = "multilevel_modesel";
1434       if(@subnodes) {
1435         $link_class .= '_parent';
1436       }
1437       if( $node_def->{ml_active} ) {
1438         $link_class .= '_active';
1439         $active_button_ids[$depth] = $id;
1440         $active_group_ids[$depth] = $group_id;
1441         die 'assertion failed' if $group_is_active;
1442         $group_is_active = 1;
1443       }
1444
1445       my $width = sprintf('%0.0f%%',92/$max_stratum_size);
1446       my $href = qq| href="$url_pattern"|;
1447       $href =~ s/\%m/$name/;
1448       $group_html .= qq|<td style="width: $width"><a id="$id" class="$link_class" onclick="ml_choose_$thisml(this.id); return false"$href$title>$node_def->{text}</a></td>|;
1449
1450       #schedule children for this breadth-first traversal
1451       push @traverse_queue,[$depth+1,@subnodes] if @subnodes;
1452     }
1453
1454     my $active = $group_is_active ? '_active' : '';
1455     $button_html .= qq|<div id="$group_id" class="multilevel_modesel_level_$depth multilevel_modesel$active"> <table style="width: $width_rel"><tr>$group_html</tr></table></div>\n|;
1456   }
1457
1458   my $js_idx = $json->to_json(\%id_based_index);
1459
1460 #   my $js_parents = objToJson(\%parent_ids);
1461 #   my $js_children = objToJson(do {
1462 #     my @rev_parents = reverse %parent_ids;
1463 #     my $children = {};
1464 #     while( my ($c,$p) = splice @rev_parents,0,2 ) {
1465 #       push @{$children->{$c}},$p;
1466 #     }
1467 #     $children
1468 #   });
1469   my $js_active_buttons = $json->to_json( \@active_button_ids );
1470   my $js_active_groups  = $json->to_json( \@active_group_ids  );
1471
1472   return <<EOH;
1473 <script>
1474   var ml_idx_$thisml = $js_idx;
1475   var ml_active_buttons_$thisml = $js_active_buttons;
1476   var ml_active_groups_$thisml = $js_active_groups;
1477
1478   //sets the link with the given id as highlighted and adds it to the ml_active_$thisml list
1479   function ml_apply_upward( tree, id, func ) {
1480     if( id ) {
1481       var el = document.getElementById(id);
1482       if( ! el ) {
1483         alert('id '+id+' not found');
1484       }
1485       ml_apply_upward(tree,tree[id].ml_parent_id,func)
1486       func(el);
1487     } else {
1488       return null;
1489     }
1490   }
1491
1492   function ml_unset_active(depth,activelist) {
1493     var old_active = document.getElementById(activelist[depth]);
1494     if( old_active ) {
1495       //alert('unset '+old_active.id+', set '+el.id);
1496       old_active.className = old_active.className.replace(/_active\$/,'');
1497     }
1498   }
1499
1500   function ml_set_active(el,depth,activelist) {
1501     for( var d=depth; d<activelist.length; d++) {
1502       //console.log('unset at depth '+d)
1503       ml_unset_active(d,activelist);
1504     }
1505     activelist[depth] = el.id;
1506     el.className += '_active';
1507   }
1508
1509   var ml_choose_$thisml = function( clicked_id ) {
1510     // set all the parent buttons and parent groups to active
1511     ml_apply_upward( ml_idx_$thisml, clicked_id,
1512      function(el) {
1513        var depth = ml_idx_${thisml}[el.id].ml_depth;
1514        ml_set_active(el.parentNode.parentNode.parentNode.parentNode.parentNode,depth,ml_active_groups_$thisml);
1515        ml_set_active(el,depth,ml_active_buttons_$thisml);
1516      });
1517
1518     var mydepth = ml_idx_${thisml}[clicked_id].ml_depth;
1519
1520     //now set this button's child group to active, if any
1521     var firstchild_rec = ml_idx_${thisml}[clicked_id].ml_children[0];
1522     if( firstchild_rec ) {
1523       //console.log('setting child div active');
1524       var child_elem = document.getElementById(firstchild_rec.ml_id);
1525       ml_set_active(child_elem.parentNode.parentNode.parentNode.parentNode.parentNode,mydepth+1,ml_active_groups_$thisml);
1526     }
1527   };
1528 </script>
1529
1530 $button_html
1531 EOH
1532 }
1533
1534
1535 ###
1536 1;# do not remove
1537 ###
1538
1539
1540 =head1 AUTHOR
1541
1542 Robert Buels and friends
1543
1544 =cut