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