SL/Presenter/Tag.pm

   1 package SL::Presenter::Tag;
   2
   3 use strict;
   4
   5 use SL::HTML::Restrict;
   6 use SL::Presenter::EscapedText qw(escape);
   7
   8 use Exporter qw(import);
   9 our @EXPORT_OK = qw(
  10   html_tag input_tag hidden_tag javascript man_days_tag name_to_id select_tag
  11   checkbox_tag button_tag submit_tag ajax_submit_tag input_number_tag
  12   stringify_attributes restricted_html textarea_tag link
  13 );
  14 our %EXPORT_TAGS = (ALL => \@EXPORT_OK);
  15
  16 use Carp;
  17
  18 my %_valueless_attributes = map { $_ => 1 } qw(
  19   checked compact declare defer disabled ismap multiple noresize noshade nowrap
  20   readonly selected hidden
  21 );
  22
  23 my %_singleton_tags = map { $_ => 1 } qw(
  24   area base br col command embed hr img input keygen link meta param source
  25   track wbr
  26 );
  27
  28 sub _call_on {
  29   my ($object, $method, @params) = @_;
  30   return $object->$method(@params);
  31 }
  32
  33 { # This will give you an id for identifying html tags and such.
  34   # It's guaranteed to be unique unless you exceed 10 mio calls per request.
  35   # Do not use these id's to store information across requests.
  36 my $_id_sequence = int rand 1e7;
  37 sub _id {
  38   return ( $_id_sequence = ($_id_sequence + 1) % 1e7 );
  39 }
  40 }
  41
  42 sub _J {
  43   my $string = shift;
  44   $string    =~ s/(\"|\'|\\)/\\$1/g;
  45   return $string;
  46 }
  47
  48 sub stringify_attributes {
  49   my (%params) = @_;
  50
  51   my @result = ();
  52   while (my ($name, $value) = each %params) {
  53     next unless $name;
  54     next if $_valueless_attributes{$name} && !$value;
  55     $value = '' if !defined($value);
  56     push @result, $_valueless_attributes{$name} ? escape($name) : escape($name) . '="' . escape($value) . '"';
  57   }
  58
  59   return @result ? ' ' . join(' ', @result) : '';
  60 }
  61
  62 sub html_tag {
  63   my ($tag, $content, %params) = @_;
  64   my $attributes = stringify_attributes(%params);
  65
  66   return "<${tag}${attributes}>" if !defined($content) && $_singleton_tags{$tag};
  67   return "<${tag}${attributes}>${content}</${tag}>";
  68 }
  69
  70 sub input_tag {
  71   my ($name, $value, %attributes) = @_;
  72
  73   _set_id_attribute(\%attributes, $name);
  74   $attributes{type} ||= 'text';
  75
  76   html_tag('input', undef, %attributes, name => $name, value => $value);
  77 }
  78
  79 sub hidden_tag {
  80   my ($name, $value, %attributes) = @_;
  81   input_tag($name, $value, %attributes, type => 'hidden');
  82 }
  83
  84 sub man_days_tag {
  85   my ($name, $object, %attributes) = @_;
  86
  87   my $size           =  delete($attributes{size})   || 5;
  88   my $method         =  $name;
  89   $method            =~ s/^.*\.//;
  90
  91   my $time_selection = input_tag("${name}_as_man_days_string", _call_on($object, "${method}_as_man_days_string"), %attributes, size => $size);
  92   my $unit_selection = select_tag("${name}_as_man_days_unit",   [[ 'h', $::locale->text('h') ], [ 'man_day', $::locale->text('MD') ]],
  93                                           %attributes, default => _call_on($object, "${method}_as_man_days_unit"));
  94
  95   return $time_selection . $unit_selection;
  96 }
  97
  98 sub name_to_id {
  99   my ($name) = @_;
 100
 101   $name =~ s/\[\+?\]/ _id() /ge; # give constructs with [] or [+] unique ids
 102   $name =~ s/[^\w_]/_/g;
 103   $name =~ s/_+/_/g;
 104
 105   return $name;
 106 }
 107
 108 sub select_tag {
 109   my ($name, $collection, %attributes) = @_;
 110
 111   _set_id_attribute(\%attributes, $name);
 112
 113   my $value_key       = delete($attributes{value_key})   || 'id';
 114   my $title_key       = delete($attributes{title_key})   || $value_key;
 115   my $default_key     = delete($attributes{default_key}) || 'selected';
 116   my $default_val_key = delete($attributes{default_value_key});
 117   my $default_coll    = delete($attributes{default});
 118
 119   my $value_title_sub = delete($attributes{value_title_sub});
 120
 121   my $value_sub       = delete($attributes{value_sub});
 122   my $title_sub       = delete($attributes{title_sub});
 123   my $default_sub     = delete($attributes{default_sub});
 124
 125   my $with_empty      = delete($attributes{with_empty});
 126   my $empty_title     = delete($attributes{empty_title});
 127
 128   my $with_optgroups  = delete($attributes{with_optgroups});
 129
 130   undef $default_key if $default_sub || $default_val_key;
 131
 132   my $normalize_entry = sub {
 133     my ($type, $entry, $sub, $key) = @_;
 134
 135     return $sub->($entry) if $sub;
 136
 137     my $ref = ref($entry);
 138
 139     if ( !$ref ) {
 140       return $entry if $type eq 'value' || $type eq 'title';
 141       return 0;
 142     }
 143
 144     if ( $ref eq 'ARRAY' ) {
 145       return $entry->[ $type eq 'value' ? 0 : $type eq 'title' ? 1 : 2 ];
 146     }
 147
 148     return $entry->{$key} if $ref  eq 'HASH';
 149     return $entry->$key   if $type ne 'default' || $entry->can($key);
 150     return undef;
 151   };
 152
 153   my %selected;
 154   if (defined($default_coll) && !ref $default_coll) {
 155     %selected = ($default_coll => 1);
 156
 157   } elsif (ref($default_coll) eq 'HASH') {
 158     %selected = %{ $default_coll };
 159
 160   } elsif ($default_coll) {
 161     $default_coll = [ $default_coll ] unless 'ARRAY' eq ref $default_coll;
 162
 163     %selected = $default_val_key ? map({ ($normalize_entry->('value', $_, undef, $default_val_key) => 1) } @{ $default_coll })
 164               :                    map({ ($_                                                       => 1) } @{ $default_coll });
 165   }
 166
 167   my $list_to_code = sub {
 168     my ($sub_collection) = @_;
 169
 170     if ('ARRAY' ne ref $sub_collection) {
 171       $sub_collection = [ $sub_collection ];
 172     }
 173
 174     my @options;
 175     foreach my $entry ( @{ $sub_collection } ) {
 176       my $value;
 177       my $title;
 178
 179       if ( $value_title_sub ) {
 180         ($value, $title) = @{ $value_title_sub->($entry) };
 181       } else {
 182
 183         $value = $normalize_entry->('value', $entry, $value_sub, $value_key);
 184         $title = $normalize_entry->('title', $entry, $title_sub, $title_key);
 185       }
 186
 187       my $default = $default_key ? $normalize_entry->('default', $entry, $default_sub, $default_key) : 0;
 188
 189       push(@options, [$value, $title, $selected{$value} || $default]);
 190     }
 191
 192     return join '', map { html_tag('option', escape($_->[1]), value => $_->[0], selected => $_->[2]) } @options;
 193   };
 194
 195   my $code  = '';
 196   $code    .= html_tag('option', escape($empty_title || ''), value => '') if $with_empty;
 197
 198   if (!$with_optgroups) {
 199     $code .= $list_to_code->($collection);
 200
 201   } else {
 202     $code .= join '', map {
 203       my ($optgroup_title, $sub_collection) = @{ $_ };
 204       html_tag('optgroup', $list_to_code->($sub_collection), label => $optgroup_title)
 205     } @{ $collection };
 206   }
 207
 208   html_tag('select', $code, %attributes, name => $name);
 209 }
 210
 211 sub checkbox_tag {
 212   my ($name, %attributes) = @_;
 213
 214   _set_id_attribute(\%attributes, $name);
 215
 216   $attributes{value}   = 1 unless defined $attributes{value};
 217   my $label            = delete $attributes{label};
 218   my $checkall         = delete $attributes{checkall};
 219   my $for_submit       = delete $attributes{for_submit};
 220
 221   if ($attributes{checked}) {
 222     $attributes{checked} = 'checked';
 223   } else {
 224     delete $attributes{checked};
 225   }
 226
 227   my $code  = '';
 228   $code    .= hidden_tag($name, 0, %attributes, id => $attributes{id} . '_hidden') if $for_submit;
 229   $code    .= html_tag('input', undef,  %attributes, name => $name, type => 'checkbox');
 230   $code    .= html_tag('label', $label, for => $attributes{id}) if $label;
 231   $code    .= javascript(qq|\$('#$attributes{id}').checkall('$checkall');|) if $checkall;
 232
 233   return $code;
 234 }
 235
 236 sub button_tag {
 237   my ($onclick, $value, %attributes) = @_;
 238
 239   _set_id_attribute(\%attributes, $attributes{name}) if $attributes{name};
 240   $attributes{type} ||= 'button';
 241
 242   $onclick = 'if (!confirm("'. _J(delete($attributes{confirm})) .'")) return false; ' . $onclick if $attributes{confirm};
 243
 244   html_tag('input', undef, %attributes, value => $value, onclick => $onclick);
 245 }
 246
 247 sub submit_tag {
 248   my ($name, $value, %attributes) = @_;
 249
 250   _set_id_attribute(\%attributes, $attributes{name}) if $attributes{name};
 251
 252   if ( $attributes{confirm} ) {
 253     $attributes{onclick} = 'return confirm("'. _J(delete($attributes{confirm})) .'");';
 254   }
 255
 256   input_tag($name, $value, %attributes, type => 'submit', class => 'submit');
 257 }
 258
 259 sub ajax_submit_tag {
 260   my ($url, $form_selector, $text, %attributes) = @_;
 261
 262   $url           = _J($url);
 263   $form_selector = _J($form_selector);
 264   my $onclick    = qq|kivi.submit_ajax_form('${url}', '${form_selector}')|;
 265
 266   button_tag($onclick, $text, %attributes);
 267 }
 268
 269 sub input_number_tag {
 270   my ($name, $value, %params) = @_;
 271
 272   _set_id_attribute(\%params, $name);
 273   my @onchange = $params{onchange} ? (onChange => delete $params{onchange}) : ();
 274   my @classes  = ('numeric');
 275   push @classes, delete($params{class}) if $params{class};
 276   my %class    = @classes ? (class => join(' ', @classes)) : ();
 277
 278   $::request->layout->add_javascripts('kivi.Validator.js');
 279   $::request->presenter->need_reinit_widgets($params{id});
 280
 281   input_tag(
 282     $name, $::form->format_amount(\%::myconfig, $value, $params{precision}),
 283     "data-validate" => "number",
 284     %params,
 285     %class, @onchange,
 286   );
 287 }
 288
 289
 290 sub javascript {
 291   my ($data) = @_;
 292   html_tag('script', $data, type => 'text/javascript');
 293 }
 294
 295 sub _set_id_attribute {
 296   my ($attributes, $name, $unique) = @_;
 297
 298   if (!delete($attributes->{no_id}) && !$attributes->{id}) {
 299     $attributes->{id}  = name_to_id($name);
 300     $attributes->{id} .= '_' . $attributes->{value} if $unique;
 301   }
 302
 303   %{ $attributes };
 304 }
 305
 306 my $html_restricter;
 307
 308 sub restricted_html {
 309   my ($value) = @_;
 310
 311   $html_restricter ||= SL::HTML::Restrict->create;
 312   return $html_restricter->process($value);
 313 }
 314
 315 sub textarea_tag {
 316   my ($name, $content, %attributes) = @_;
 317
 318   _set_id_attribute(\%attributes, $name);
 319   $attributes{rows}  *= 1; # required by standard
 320   $attributes{cols}  *= 1; # required by standard
 321
 322   html_tag('textarea', $content, %attributes, name => $name);
 323 }
 324
 325 sub link {
 326   my ($href, $content, %params) = @_;
 327
 328   $href ||= '#';
 329
 330   html_tag('a', $content, %params, href => $href);
 331 }
 332
 333 1;
 334 __END__
 335
 336 =pod
 337
 338 =encoding utf8
 339
 340 =head1 NAME
 341
 342 SL::Presenter::Tag - Layouting / tag generation
 343
 344 =head1 SYNOPSIS
 345
 346 Usage in a template:
 347
 348   [% USE P %]
 349
 350   [% P.select_tag('direction', [ [ 'left', 'To the left' ], [ 'right', 'To the right', 1 ] ]) %]
 351
 352   [% P.select_tag('direction', [ { direction => 'left',  display => 'To the left'  },
 353                                  { direction => 'right', display => 'To the right' } ],
 354                                value_key => 'direction', title_key => 'display', default => 'right') %]
 355
 356   [% P.select_tag('direction', [ { direction => 'left',  display => 'To the left'  },
 357                                  { direction => 'right', display => 'To the right', selected => 1 } ],
 358                                value_key => 'direction', title_key => 'display') %]
 359
 360   # Use an RDBO object and its n:m relationship as the default
 361   # values. For example, a user can be a member of many groups. "All
 362   # groups" is therefore the full collection and "$user->groups" is a
 363   # list of RDBO AuthGroup objects whose IDs must match the ones in
 364   # "All groups". This could look like the following:
 365   [% P.select_tag('user.groups[]', SELF.all_groups, multiple=1,
 366                   default=SELF.user.groups, default_value_key='id' ) %]
 367
 368 =head1 DESCRIPTION
 369
 370 A module modeled a bit after Rails' ActionView helpers. Several small
 371 functions that create HTML tags from various kinds of data sources.
 372
 373 The C<id> attribute is usually calculated automatically. This can be
 374 overridden by either specifying an C<id> attribute or by setting
 375 C<no_id> to trueish.
 376
 377 =head1 FUNCTIONS
 378
 379 =head2 LOW-LEVEL FUNCTIONS
 380
 381 =over 4
 382
 383 =item C<html_tag $tag_name, $content_string, %attributes>
 384
 385 Creates an opening and closing HTML tag for C<$tag_name> and puts
 386 C<$content_string> between the two. If C<$content_string> is undefined
 387 or empty then only a E<lt>tag/E<gt> tag will be created. Attributes
 388 are key/value pairs added to the opening tag.
 389
 390 C<$content_string> is not HTML escaped.
 391
 392 =item C<name_to_id $name>
 393
 394 Converts a name to a HTML id by replacing various characters.
 395
 396 =item C<stringify_attributes %items>
 397
 398 Creates a string from all elements in C<%items> suitable for usage as
 399 HTML tag attributes. Keys and values are HTML escaped even though keys
 400 must not contain non-ASCII characters for browsers to accept them.
 401
 402 =item C<restricted_html $html>
 403
 404 Returns HTML stripped of unknown tags. See L<SL::HTML::Restrict>.
 405
 406 =back
 407
 408 =head2 HIGH-LEVEL FUNCTIONS
 409
 410 =over 4
 411
 412 =item C<input_tag $name, $value, %attributes>
 413
 414 Creates a HTML 'input type=text' tag named C<$name> with the value
 415 C<$value> and with arbitrary HTML attributes from C<%attributes>. The
 416 tag's C<id> defaults to C<name_to_id($name)>.
 417
 418 =item C<submit_tag $name, $value, %attributes>
 419
 420 Creates a HTML 'input type=submit class=submit' tag named C<$name> with the
 421 value C<$value> and with arbitrary HTML attributes from C<%attributes>. The
 422 tag's C<id> defaults to C<name_to_id($name)>.
 423
 424 If C<$attributes{confirm}> is set then a JavaScript popup dialog will
 425 be added via the C<onclick> handler asking the question given with
 426 C<$attributes{confirm}>. The request is only submitted if the user
 427 clicks the dialog's ok/yes button.
 428
 429 =item C<ajax_submit_tag $url, $form_selector, $text, %attributes>
 430
 431 Creates a HTML 'input type="button"' tag with a very specific onclick
 432 handler that submits the form given by the jQuery selector
 433 C<$form_selector> to the URL C<$url> (the actual JavaScript function
 434 called for that is C<kivi.submit_ajax_form()> in
 435 C<js/client_js.js>). The button's label will be C<$text>.
 436
 437 =item C<button_tag $onclick, $text, %attributes>
 438
 439 Creates a HTML 'input type="button"' tag with an onclick handler
 440 C<$onclick> and a value of C<$text>. The button does not have a name
 441 nor an ID by default.
 442
 443 If C<$attributes{confirm}> is set then a JavaScript popup dialog will
 444 be prepended to the C<$onclick> handler asking the question given with
 445 C<$attributes{confirm}>. The request is only submitted if the user
 446 clicks the dialog's "ok/yes" button.
 447
 448 =item C<man_days_tag $name, $object, %attributes>
 449
 450 Creates two HTML inputs: a text input for entering a number and a drop
 451 down box for chosing the unit (either 'man days' or 'hours').
 452
 453 C<$object> must be a L<Rose::DB::Object> instance using the
 454 L<SL::DB::Helper::AttrDuration> helper.
 455
 456 C<$name> is supposed to be the name of the underlying column,
 457 e.g. C<time_estimation> for an instance of
 458 C<SL::DB::RequirementSpecItem>. If C<$name> has the form
 459 C<prefix.method> then the full C<$name> is used for the input's base
 460 names while the methods called on C<$object> are only the suffix. This
 461 makes it possible to write statements like e.g.
 462
 463   [% P.man_days_tag("requirement_spec_item.time_estimation", SELF.item) %]
 464
 465 The attribute C<size> can be used to set the text input's size. It
 466 defaults to 5.
 467
 468 =item C<hidden_tag $name, $value, %attributes>
 469
 470 Creates a HTML 'input type=hidden' tag named C<$name> with the value
 471 C<$value> and with arbitrary HTML attributes from C<%attributes>. The
 472 tag's C<id> defaults to C<name_to_id($name)>.
 473
 474 =item C<checkbox_tag $name, %attributes>
 475
 476 Creates a HTML 'input type=checkbox' tag named C<$name> with arbitrary
 477 HTML attributes from C<%attributes>. The tag's C<id> defaults to
 478 C<name_to_id($name)>. The tag's C<value> defaults to C<1>.
 479
 480 If C<%attributes> contains a key C<label> then a HTML 'label' tag is
 481 created with said C<label>. No attribute named C<label> is created in
 482 that case.
 483
 484 If C<%attributes> contains a key C<checkall> then the value is taken as a
 485 JQuery selector and clicking this checkbox will also toggle all checkboxes
 486 matching the selector.
 487
 488 =item C<select_tag $name, \@collection, %attributes>
 489
 490 Creates an HTML 'select' tag named C<$name> with the contents of one
 491 'E<lt>optionE<gt>' tag for each element in C<\@collection> and with arbitrary
 492 HTML attributes from C<%attributes>. The value
 493 to use and the title to display are extracted from the elements in
 494 C<\@collection>. Each element can be one of four things:
 495
 496 =over 12
 497
 498 =item 1. An array reference with at least two elements. The first element is
 499 the value, the second element is its title. The third element is optional and and should contain a boolean.
 500 If it is true, than the element will be used as default.
 501
 502 =item 2. A scalar. The scalar is both the value and the title.
 503
 504 =item 3. A hash reference. In this case C<%attributes> must contain
 505 I<value_key>, I<title_key> and may contain I<default_key> keys that name the keys in the element to use
 506 for the value, title and default respectively.
 507
 508 =item 4. A blessed reference. In this case C<%attributes> must contain
 509 I<value_key>, I<title_key> and may contain I<default_key> keys that name functions called on the blessed
 510 reference whose return values are used as the value, title and default
 511 respectively.
 512
 513 =back
 514
 515 For cases 3 and 4 C<$attributes{value_key}> defaults to C<id>,
 516 C<$attributes{title_key}> defaults to C<$attributes{value_key}> and
 517 C<$attributes{default_key}> defaults to C<selected>. Note that
 518 C<$attributes{default_key}> is set to C<undef> if
 519 C<$attributes{default_value_key}> is used as well (see below).
 520
 521 In addition to pure keys/method you can also provide coderefs as I<value_sub>
 522 and/or I<title_sub> and/or I<default_sub>. If present, these take precedence over keys or methods,
 523 and are called with the element as first argument. It must return the value, title or default.
 524
 525 Lastly a joint coderef I<value_title_sub> may be provided, which in turn takes
 526 precedence over the C<value_sub> and C<title_sub> subs. It will only be called once for each
 527 element and must return a list of value and title.
 528
 529 If the option C<with_empty> is set then an empty element (value
 530 C<undef>) will be used as the first element. The title to display for
 531 this element can be set with the option C<empty_title> and defaults to
 532 an empty string.
 533
 534 The tag's C<id> defaults to C<name_to_id($name)>.
 535
 536 The option C<default> can be quite a lot of things:
 537
 538 =over 4
 539
 540 =item 1. A scalar value. This is the value of the entry that's
 541 selected by default.
 542
 543 =item 2. A hash reference for C<multiple=1>. Whether or not an entry
 544 is selected by default is looked up in this hash.
 545
 546 =item 3. An array reference containing scalar values. Same as 1., just
 547 for the case of C<multiple=1>.
 548
 549 =item 4. If C<default_value_key> is given: an array reference of hash
 550 references. For each hash reference the value belonging to the key
 551 C<default_value_key> is treated as one value to select by
 552 default. Constructs a hash that's treated like 3.
 553
 554 =item 5. If C<default_value_key> is given: an array reference of
 555 blessed objects. For each object the value returne from calling the
 556 function named C<default_value_key> on the object is treated as one
 557 value to select by default. Constructs a hash that's treated like 3.
 558
 559 =back
 560
 561 5. also applies to single RDBO instances (due to 'wantarray'
 562 shenanigans assigning RDBO's relationships to a hash key will result
 563 in a single RDBO object being assigned instead of an array reference
 564 containing that single RDBO object).
 565
 566 If the option C<with_optgroups> is set then this function expects
 567 C<\@collection> to be one level deeper. The upper-most level is
 568 translated into an HTML C<optgroup> tag. So the structure becomes:
 569
 570 =over 4
 571
 572 =item 1. Array of array references. Each element in the
 573 C<\@collection> is converted into an optgroup.
 574
 575 =item 2. The optgroup's C<label> attribute will be set to the
 576 first element in the array element. The second array element is then
 577 converted to a list of C<option> tags as described above.
 578
 579 =back
 580
 581 Example for use of optgroups:
 582
 583   # First in a controller:
 584   my @collection = (
 585     [ t8("First optgroup with three items"),
 586       [ { id => 42, name => "item one" },
 587         { id => 54, name => "second item" },
 588         { id => 23, name => "and the third one" },
 589       ] ],
 590     [ t8("Another optgroup, with a lot of items from Rose"),
 591       SL::DB::Manager::Customer->get_all_sorted ],
 592   );
 593
 594   # Later in the template:
 595   [% L.select_tag('the_selection', COLLECTION, with_optgroups=1, title_key='name') %]
 596
 597 =back
 598
 599 =head1 BUGS
 600
 601 Nothing here yet.
 602
 603 =head1 AUTHOR
 604
 605 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
 606 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 607
 608 =cut