SL/Presenter/Tag.pm

   1 package SL::Presenter::Tag;
   2
   3 use strict;
   4
   5 use parent qw(Exporter);
   6
   7 use Exporter qw(import);
   8 our @EXPORT = qw(html_tag input_tag name_to_id select_tag stringify_attributes);
   9
  10 use Carp;
  11
  12 my %_valueless_attributes = map { $_ => 1 } qw(
  13   checked compact declare defer disabled ismap multiple noresize noshade nowrap
  14   readonly selected
  15 );
  16
  17 sub stringify_attributes {
  18   my ($self, %params) = @_;
  19
  20   my @result = ();
  21   while (my ($name, $value) = each %params) {
  22     next unless $name;
  23     next if $_valueless_attributes{$name} && !$value;
  24     $value = '' if !defined($value);
  25     push @result, $_valueless_attributes{$name} ? $self->escape($name) : $self->escape($name) . '="' . $self->escape($value) . '"';
  26   }
  27
  28   return @result ? ' ' . join(' ', @result) : '';
  29 }
  30
  31 sub html_tag {
  32   my ($self, $tag, $content, %params) = @_;
  33   my $attributes = $self->stringify_attributes(%params);
  34
  35   return "<${tag}${attributes}>" unless defined($content);
  36   return "<${tag}${attributes}>${content}</${tag}>";
  37 }
  38
  39 sub input_tag {
  40   my ($self, $name, $value, %attributes) = @_;
  41
  42   $attributes{id}   ||= $self->name_to_id($name);
  43   $attributes{type} ||= 'text';
  44
  45   return $self->html_tag('input', undef, %attributes, name => $name, value => $value);
  46 }
  47
  48 sub name_to_id {
  49   my ($self, $name) = @_;
  50
  51   $name =~ s/[^\w_]/_/g;
  52   $name =~ s/_+/_/g;
  53
  54   return $name;
  55 }
  56
  57 sub select_tag {
  58   my ($self, $name, $collection, %attributes) = @_;
  59
  60   $attributes{id}   ||= $self->name_to_id($name);
  61
  62   my $value_key       = delete($attributes{value_key})   || 'id';
  63   my $title_key       = delete($attributes{title_key})   || $value_key;
  64   my $default_key     = delete($attributes{default_key}) || 'selected';
  65
  66
  67   my $value_title_sub = delete($attributes{value_title_sub});
  68
  69   my $value_sub       = delete($attributes{value_sub});
  70   my $title_sub       = delete($attributes{title_sub});
  71   my $default_sub     = delete($attributes{default_sub});
  72
  73   my $with_empty      = delete($attributes{with_empty});
  74   my $empty_title     = delete($attributes{empty_title});
  75
  76   my $with_optgroups  = delete($attributes{with_optgroups});
  77
  78   my %selected;
  79
  80   if ( ref($attributes{default}) eq 'ARRAY' ) {
  81
  82     foreach my $entry (@{$attributes{default}}) {
  83       $selected{$entry} = 1;
  84     }
  85   } elsif ( defined($attributes{default}) ) {
  86     $selected{$attributes{default}} = 1;
  87   }
  88
  89   delete($attributes{default});
  90
  91
  92   my @all_options;
  93   push @all_options, [undef, $empty_title || ''] if $with_empty;
  94
  95   my $normalize_entry = sub {
  96     my ($type, $entry, $sub, $key) = @_;
  97
  98     return $sub->($entry) if $sub;
  99
 100     my $ref = ref($entry);
 101
 102     if ( !$ref ) {
 103       return $entry if $type eq 'value' || $type eq 'title';
 104       return 0;
 105     }
 106
 107     if ( $ref eq 'ARRAY' ) {
 108       return $entry->[ $type eq 'value' ? 0 : $type eq 'title' ? 1 : 2 ];
 109     }
 110
 111     return $entry->{$key} if $ref  eq 'HASH';
 112     return $entry->$key   if $type ne 'default' || $entry->can($key);
 113     return undef;
 114   };
 115
 116   my $list_to_code = sub {
 117     my ($sub_collection) = @_;
 118
 119     my @options;
 120     foreach my $entry ( @{ $sub_collection } ) {
 121       my $value;
 122       my $title;
 123
 124       if ( $value_title_sub ) {
 125         ($value, $title) = @{ $value_title_sub->($entry) };
 126       } else {
 127
 128         $value = $normalize_entry->('value', $entry, $value_sub, $value_key);
 129         $title = $normalize_entry->('title', $entry, $title_sub, $title_key);
 130       }
 131
 132       my $default = $normalize_entry->('default', $entry, $default_sub, $default_key);
 133
 134       push(@options, [$value, $title, $default]);
 135     }
 136
 137     foreach my $entry (@options) {
 138       $entry->[2] = 1 if $selected{$entry->[0]};
 139     }
 140
 141     return join '', map { $self->html_tag('option', $self->escape($_->[1]), value => $_->[0], selected => $_->[2]) } @options;
 142   };
 143
 144   my $code;
 145
 146   if (!$with_optgroups) {
 147     $code = $list_to_code->($collection);
 148
 149   } else {
 150     $code = join '', map {
 151       my ($optgroup_title, $sub_collection) = @{ $_ };
 152       $self->html_tag('optgroup', $list_to_code->($sub_collection), label => $optgroup_title)
 153     } @{ $collection };
 154   }
 155
 156   return $self->html_tag('select', $code, %attributes, name => $name);
 157 }
 158
 159 1;
 160 __END__
 161
 162 =pod
 163
 164 =encoding utf8
 165
 166 =head1 NAME
 167
 168 SL::Presenter::Tag - Layouting / tag generation
 169
 170 =head1 SYNOPSIS
 171
 172 Usage from a template:
 173
 174   [% USE P %]
 175
 176   [% P.select_tag('direction', [ [ 'left', 'To the left' ], [ 'right', 'To the right', 1 ] ]) %]
 177
 178   [% P.select_tag('direction', [ { direction => 'left',  display => 'To the left'  },
 179                                  { direction => 'right', display => 'To the right' } ],
 180                                value_key => 'direction', title_key => 'display', default => 'right')) %]
 181
 182   [% P.select_tag('direction', [ { direction => 'left',  display => 'To the left'  },
 183                                  { direction => 'right', display => 'To the right', selected => 1 } ],
 184                                value_key => 'direction', title_key => 'display')) %]
 185
 186 =head1 DESCRIPTION
 187
 188 A module modeled a bit after Rails' ActionView helpers. Several small
 189 functions that create HTML tags from various kinds of data sources.
 190
 191 =head1 FUNCTIONS
 192
 193 =head2 LOW-LEVEL FUNCTIONS
 194
 195 =over 4
 196
 197 =item C<html_tag $tag_name, $content_string, %attributes>
 198
 199 Creates an opening and closing HTML tag for C<$tag_name> and puts
 200 C<$content_string> between the two. If C<$content_string> is undefined
 201 or empty then only a E<lt>tag/E<gt> tag will be created. Attributes
 202 are key/value pairs added to the opening tag.
 203
 204 C<$content_string> is not HTML escaped.
 205
 206 =item C<name_to_id $name>
 207
 208 Converts a name to a HTML id by replacing various characters.
 209
 210 =item C<stringify_attributes %items>
 211
 212 Creates a string from all elements in C<%items> suitable for usage as
 213 HTML tag attributes. Keys and values are HTML escaped even though keys
 214 must not contain non-ASCII characters for browsers to accept them.
 215
 216 =back
 217
 218 =head2 HIGH-LEVEL FUNCTIONS
 219
 220 =over 4
 221
 222 =item C<input_tag $name, $value, %attributes>
 223
 224 Creates a HTML 'input type=text' tag named C<$name> with the value
 225 C<$value> and with arbitrary HTML attributes from C<%attributes>. The
 226 tag's C<id> defaults to C<name_to_id($name)>.
 227
 228 =item C<select_tag $name, \@collection, %attributes>
 229
 230 Creates a HTML 'select' tag named C<$name> with the contents of one
 231 'E<lt>optionE<gt>' tag for each element in C<\@collection> and with arbitrary
 232 HTML attributes from C<%attributes>. The value
 233 to use and the title to display are extracted from the elements in
 234 C<\@collection>. Each element can be one of four things:
 235
 236 =over 12
 237
 238 =item 1. An array reference with at least two elements. The first element is
 239 the value, the second element is its title. The third element is optional and and should contain a boolean.
 240 If it is true, than the element will be used as default.
 241
 242 =item 2. A scalar. The scalar is both the value and the title.
 243
 244 =item 3. A hash reference. In this case C<%attributes> must contain
 245 I<value_key>, I<title_key> and may contain I<default_key> keys that name the keys in the element to use
 246 for the value, title and default respectively.
 247
 248 =item 4. A blessed reference. In this case C<%attributes> must contain
 249 I<value_key>, I<title_key> and may contain I<default_key> keys that name functions called on the blessed
 250 reference whose return values are used as the value, title and default
 251 respectively.
 252
 253 =back
 254
 255 For cases 3 and 4 C<$attributes{value_key}> defaults to C<id>,
 256 C<$attributes{title_key}> defaults to C<$attributes{value_key}>
 257 and C<$attributes{default_key}> defaults to C<selected>.
 258
 259 In addition to pure keys/method you can also provide coderefs as I<value_sub>
 260 and/or I<title_sub> and/or I<default_sub>. If present, these take precedence over keys or methods,
 261 and are called with the element as first argument. It must return the value, title or default.
 262
 263 Lastly a joint coderef I<value_title_sub> may be provided, which in turn takes
 264 precedence over the C<value_sub> and C<title_sub> subs. It will only be called once for each
 265 element and must return a list of value and title.
 266
 267 If the option C<with_empty> is set then an empty element (value
 268 C<undef>) will be used as the first element. The title to display for
 269 this element can be set with the option C<empty_title> and defaults to
 270 an empty string.
 271
 272 The option C<default> can be either a scalar or an array reference
 273 containing the values of the options which should be set to be
 274 selected.
 275
 276 The tag's C<id> defaults to C<name_to_id($name)>.
 277
 278 If the option C<with_optgroups> is set then this function expects
 279 C<\@collection> to be one level deeper. The upper-most level is
 280 translated into a HTML C<optgroup> tag. So the structure becomes:
 281
 282 =over 4
 283
 284 =item 1. Array of array references. Each element in the
 285 C<\@collection> is converted into an optgroup.
 286
 287 =item 2. The optgroup's C<label> attribute will be set to the the
 288 first element in the array element. The second array element is then
 289 converted to a list of C<option> tags like it is described above.
 290
 291 =back
 292
 293 Example for use of optgroups:
 294
 295   # First in a controller:
 296   my @collection = (
 297     [ t8("First optgroup with two items"),
 298       [ { id => 42, name => "item one" },
 299         { id => 54, name => "second item" },
 300         { id => 23, name => "and the third one" },
 301       ] ],
 302     [ t8("Another optgroup, with a lot of items from Rose"),
 303       SL::DB::Manager::Customer->get_all_sorted ],
 304   );
 305
 306   # Later in the template:
 307   [% L.select_tag('the_selection', COLLECTION, with_optgroups=1, title_key='name') %]
 308
 309 =back
 310
 311 =head1 BUGS
 312
 313 Nothing here yet.
 314
 315 =head1 AUTHOR
 316
 317 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
 318 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 319
 320 =cut