/[Frey]/trunk/lib/Frey/Action.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Annotation of /trunk/lib/Frey/Action.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1101 - (hide annotations)
Sun Jun 28 23:08:02 2009 UTC (14 years, 9 months ago) by dpavlin
File size: 9445 byte(s)
implemented fieldset for attributes which begin with same prefix
1 dpavlin 369 package Frey::Action;
2     use Moose;
3     extends 'Frey::PPI';
4     with 'Frey::Web';
5     with 'Frey::Config';
6    
7 dpavlin 386 use Clone qw/clone/;
8 dpavlin 369 use Data::Dump qw/dump/;
9    
10     =head1 DESCRIPTION
11    
12     Invoke any L<Frey> object creating html for with various default parameters
13     if not supplied at invocation.
14    
15 dpavlin 940 You can force rendering of fields if you define C<render_attribute> sub with
16     desired rendering as in:
17    
18     sub render_pipe { 'radio' }
19    
20 dpavlin 369 =cut
21    
22     has 'class' => (
23     is => 'rw',
24     isa => 'Str',
25     required => 1,
26     );
27    
28     has 'params' => (
29     is => 'rw',
30     isa => 'HashRef',
31     default => sub { {} },
32     );
33    
34 dpavlin 782 has 'input_step_size' => (
35 dpavlin 780 documentation => 'Resize input fields by this step',
36     is => 'rw',
37     isa => 'Int',
38     # required => 1,
39     default => 20,
40     );
41    
42 dpavlin 369 =head2 required
43    
44     my @required_attributes = $self->required;
45     my $required_attributes = $self->required;
46 dpavlin 975 my $required_hash = $self->required('as_hash');
47 dpavlin 369
48     =cut
49    
50     sub required {
51 dpavlin 975 my ($self,$param) = @_;
52 dpavlin 369 $self->load_class( $self->class );
53 dpavlin 731
54 dpavlin 369 my @required =
55 dpavlin 435 grep {
56 dpavlin 469 defined $_ && $_->can('name') &&
57     ! defined( $self->params->{ $_->name } ) &&
58     ! $_->is_lazy
59 dpavlin 435 }
60 dpavlin 430 map {
61 dpavlin 435 my $attr = $self->class->meta->get_attribute($_);
62 dpavlin 440 blessed $attr && $attr->is_required && $attr;
63 dpavlin 369 } $self->class->meta->get_attribute_list;
64    
65 dpavlin 975 @required = map { $_->name } @required;
66     warn "## required = ",dump( @required ), " for ", $self->class if @required && $self->debug;
67    
68     if ( $param eq 'as_hash' ) {
69     my $hash;
70     map { $hash->{$_}++ } @required;
71     return $hash;
72     }
73 dpavlin 369 return @required if wantarray;
74     return \@required;
75     }
76    
77     =head2 attributes
78    
79     Generated from attributes specified in code (extracted using L<Frey::PPI>)
80     and required atributes
81    
82     my @class_attributes = $self->attributes;
83     my @class_attributes = $self->attributes;
84    
85     =cut
86    
87     sub attributes {
88     my ( $self ) = @_;
89     my $a;
90     my @attrs = @{ $self->attribute_order };
91     @attrs = map { $a->{$_}++; $_ } @attrs;
92 dpavlin 975 push @attrs, $_ foreach grep { ! $a->{$_} } @{ $self->required };
93 dpavlin 386 warn "# attributes = ",dump( @attrs ) if $self->debug;
94 dpavlin 369 return @attrs if wantarray;
95     return \@attrs;
96     }
97    
98     =head2 params_form
99    
100 dpavlin 386 my $html = $self->params_form;
101     my ($html,$default_params) = $self->params_form;
102 dpavlin 369
103     =cut
104    
105     sub params_form {
106     my ( $self ) = @_;
107 dpavlin 978
108     foreach my $checkbox ( split(/\s+/, $self->params->{'frey-checkboxes'} ) ) {
109     next if defined $self->params->{ $checkbox };
110    
111     $self->params->{ $checkbox } = 0;
112     warn "# checkbox $checkbox not ticked";
113     }
114    
115 dpavlin 975 my $required = $self->required('as_hash');
116     if ( $required ) {
117     warn $self->class, " required params ", dump( keys %$required ) if $self->debug;
118     } else {
119 dpavlin 414 warn "all params available ", dump( $self->params ), " not creating form" if $self->debug;
120 dpavlin 386 return (undef,$self->params) if wantarray;
121 dpavlin 369 return;
122     }
123    
124     my $class = $self->class;
125    
126     $self->load_class( $class );
127    
128 dpavlin 386 my $default = clone $self->params; # XXX we really don't want to modify params!
129 dpavlin 369
130 dpavlin 731 my $params_config = {};
131     $params_config = $self->config($class);
132     warn "# $class config = ",dump( $params_config ) if $self->debug;
133 dpavlin 369
134 dpavlin 386 my $form;
135 dpavlin 950 my $form_id = $class;
136     $form_id =~ s{\W+}{_}g;
137 dpavlin 386
138 dpavlin 504 sub select_values {
139     my ( $name, $attr_type, $values ) = @_;
140 dpavlin 734
141 dpavlin 950 $attr_type ||= '?' and warn "$name doesn't have attr_type";
142    
143 dpavlin 782 my $max_value_len = 0;
144     my @values;
145 dpavlin 1079 my $display;
146 dpavlin 782 my $html = '';
147    
148     foreach ( @$values ) {
149     my $v = ref($_) eq 'HASH' ? $_->{$name} : $_;
150 dpavlin 1079 if ( $v =~ s/\t+(.+)$// ) {
151     $display->{$v} = $1;
152     }
153 dpavlin 782 warn "## value '$v'";
154     push @values, $v;
155     $max_value_len = length($v) if length($v) > $max_value_len;
156     }
157    
158     warn "# max_value_len: $max_value_len";
159 dpavlin 940 my $render = eval $class . '->render_' . $name;
160     warn "## render $@";
161 dpavlin 782
162 dpavlin 940 if ( $#values > 3 && $render !~ m{radio} ) {
163 dpavlin 734 my $options = join("\n",
164     map {
165 dpavlin 1079 my $d = $display->{$_} || $_;
166     qq|<option value="$_">$d</option>|;
167 dpavlin 782 } @values
168 dpavlin 734 );
169 dpavlin 782 # onchange="alert(this.options[this.selectedIndex].value);"
170     $html = qq|
171     <select title="$attr_type" name="$name">
172     $options
173     </select>
174     | if $options;
175 dpavlin 734 } else {
176 dpavlin 782 my $delimiter = $max_value_len > $self->input_step_size ? qq|<br>| : '';
177     my $radio =
178     # $delimiter .
179     join("\n",
180     map { strip(qq|
181     <span title="$attr_type">
182     <input type="radio" name="$name" value="$_">
183     $_
184     </span>
185     $delimiter
186     |) } @values
187 dpavlin 734 );
188 dpavlin 950 if ( $radio ) {
189    
190     my $size = int( $max_value_len / $self->input_step_size ) + 1;
191     $size = 5 if $size > 5;
192     $size *= $self->input_step_size;
193     $radio .= qq|
194     <span>
195     <input type="radio" name="$name" value=" " onclick="document.getElementById('new-$name').focus();" >
196     <input type="text" name="new-$name" id="new-$name" onchange="clear_radio('$form_id','$name'); this.disable = false;" onblur="this.disable = true;" title="enter new value" size="$size">
197     </span>
198     |;
199     }
200 dpavlin 782 $html = qq|<div style="display: block;">$radio</div>|;
201 dpavlin 734 }
202 dpavlin 782
203     return
204     # qq|<input type="text" name="$name">| .
205     $html
206 dpavlin 504 }
207    
208 dpavlin 950
209 dpavlin 645 my @checkboxes;
210    
211 dpavlin 731 my $label_width = 1; # minimum
212    
213 dpavlin 1101 my @fields =
214 dpavlin 645 grep {
215 dpavlin 940 die "$_ doesn't have meta" unless $class->can('meta');
216 dpavlin 645 ! $class->meta->get_attribute($_)->is_lazy
217     && ! defined $default->{$_}
218 dpavlin 715 && ! m{^_} # skip _private
219 dpavlin 1101 } $self->attributes;
220    
221     my $fieldset;
222    
223     my $last;
224     foreach my $name ( @fields ) {
225     my $set = $name;
226     $set =~ s{_[^_]+$}{};
227     push @{ $fieldset->{$set} }, $name;
228     }
229    
230     delete( $fieldset->{$_} )
231     foreach ( grep { $#{ $fieldset->{$_} } == 0 } keys %$fieldset );
232    
233     warn "XXX fields = ",dump( @fields );
234     warn "XXX set = ",dump( $fieldset );
235    
236     foreach my $name ( @fields ) {
237 dpavlin 414 my $attr_type = '';
238 dpavlin 369 my $type = $name =~ m/^pass/ ? 'password' : 'text';
239 dpavlin 372 my $label = $name;
240     my $label_title = '';
241 dpavlin 369 my $value_html = '';
242 dpavlin 504
243     my $attr = $class->meta->get_attribute( $name );
244     $attr_type = $attr->type_constraint->name if $attr->has_type_constraint;
245    
246 dpavlin 645 my $value =
247     defined $default->{$name} ? $default->{$name} :
248     $attr->has_default ? $attr->default( $name ) :
249 dpavlin 978 undef;
250 dpavlin 510
251 dpavlin 783 if ( ref($params_config) eq 'HASH' && defined $params_config->{$name} ) {
252 dpavlin 731 $value = $params_config->{$name};
253     } elsif ( ref($params_config) eq 'ARRAY' ) {
254     $value_html = select_values( $name, $attr_type, $params_config );
255     $default->{$name} = $params_config->[0]->{$name};
256 dpavlin 504 } elsif ( $attr->has_type_constraint && $attr->type_constraint->can('values') ) {
257 dpavlin 731 $value_html = select_values( $name, $attr_type, $attr->type_constraint->values );
258 dpavlin 1079 } elsif ( $class->can( $name . '_available' ) ) {
259     my $available = eval $class . '->' . $name . '_available';
260     confess $@ if $@;
261     $available =~ s/^\s+//gs;
262     $available =~ s/\s+$//gs;
263     $value_html = select_values( $name, $attr_type, [ split(/\n/,$available) ]);
264 dpavlin 640 } elsif ( $attr_type =~ m{^Bool} ) {
265 dpavlin 731 my $suffix = '';
266 dpavlin 978 $suffix = ' checked=1' if $value;
267     $value_html = qq|<input type="checkbox" name="$name" title="$attr_type" value=1$suffix>|;
268 dpavlin 731 push @checkboxes, $name;
269 dpavlin 1085 } elsif ( ! defined $value && ! $required->{$name} ) {
270 dpavlin 731 $value_html = qq|<tt id="$name">undef</tt><!-- $name = undef -->|; # FIXME if $self->debug
271 dpavlin 832 } elsif ( $attr_type !~ m{^(Str|Int)$} || $value =~ $Frey::Web::re_html || $name =~ m{text} ) {
272 dpavlin 731 $value_html = qq|<textarea name="$name" title="$attr_type">$value</textarea>|;
273 dpavlin 369 }
274 dpavlin 731
275 dpavlin 504 $label_title = qq| title="| . $attr->documentation . qq|"| if $attr->has_documentation;
276 dpavlin 372
277 dpavlin 469 $default->{$name} = $value unless defined $default->{$name};
278    
279 dpavlin 782 my $size = ( int( length($value) / $self->input_step_size ) + 1 ) * $self->input_step_size;
280 dpavlin 780 $value_html = qq|<input type="$type" name="$name" title="$attr_type" value="$value" size="$size">| unless $value_html;
281 dpavlin 372
282 dpavlin 369 # warn "# required $name ", $class->meta->get_attribute( $name )->dump( 2 );
283 dpavlin 975
284     $label_title .= qq| class="required"| if $required->{$name};
285     $label =~ s/_/ /g;
286    
287 dpavlin 1101 my $set = $name;
288     $set =~ s{_[^_]+$}{};
289    
290     my ( $before, $after ) = ( '', '<br>' );
291    
292     if ( my $s = $fieldset->{$set} ) {
293     if ($s->[0] eq $name) {
294     $before = qq|
295     <fieldset>
296     <legend>$set</legend>
297     |;
298     } elsif ( $s->[ -1 ] eq $name ) {
299     $after = qq|
300     </fieldset>
301     |;
302     }
303     $label =~ s{^\Q$set\E\s+}{};
304     }
305    
306     $form .= qq|$before<label for="$name"$label_title>$label</label>$value_html $after|;
307 dpavlin 731 my $ll = length($label);
308     $label_width = $ll if $ll > $label_width;
309 dpavlin 369 }
310 dpavlin 645 $form .= qq|<input type="hidden" name="frey-checkboxes" value="| . join(' ', @checkboxes) . qq|">| if @checkboxes;
311    
312 dpavlin 975 $label_width += 2; # XXX padding left+right em
313    
314 dpavlin 950 $self->add_js('static/Frey/Action.js');
315    
316 dpavlin 731 $self->add_css(qq|
317     label,input {
318     display: block;
319     float: left;
320     margin-bottom: 10px;
321     }
322    
323 dpavlin 950 input:focus {
324     border-color: #cc0;
325 dpavlin 975 background: #ffc;
326 dpavlin 950 }
327    
328 dpavlin 731 label {
329     text-align: right;
330     width: ${label_width}ex;
331 dpavlin 975 padding-right: 1ex;
332     white-space: nowrap;
333 dpavlin 731 }
334    
335 dpavlin 975 label.required {
336     font-weight: bold;
337     }
338    
339 dpavlin 731 br {
340     clear: left;
341     }
342 dpavlin 1101
343     fieldset {
344     margin: 0;
345     padding: 0;
346     }
347 dpavlin 731 |);
348    
349 dpavlin 645 my $html;
350    
351 dpavlin 734 # http://www.quirksmode.org/oddsandends/forms.html
352     # $form =~ s{<([^>]+)(name=")([^"]+)(")([^>]*)>}{<$1$2$3$4 id="$3" $5}gs;
353 dpavlin 731
354 dpavlin 645 $html = qq|
355     <h1>$class params</h1>
356 dpavlin 950 <form name="$form_id" id="$form_id" method="post">
357 dpavlin 645 $form
358     <input type="submit" value="Run $class">
359     </form>
360     | if $form;
361    
362 dpavlin 507 $self->add_status({
363 dpavlin 595 $self->class => {
364 dpavlin 469 params => $self->params,
365 dpavlin 731 params_config => $params_config,
366     default => $default,
367 dpavlin 390 },
368 dpavlin 507 });
369 dpavlin 369
370 dpavlin 386 return ($html,$default) if wantarray;
371 dpavlin 369 return $html;
372     }
373    
374 dpavlin 731 =head1 SEE ALSO
375    
376     L<http://www.quirksmode.org/css/forms.html> for info on CSS2 forms
377    
378     =cut
379    
380 dpavlin 369 1;

  ViewVC Help
Powered by ViewVC 1.1.26