HTML-TurboForm-0.634/0000755000175000017500000000000011473014547014513 5ustar thorstenthorstenHTML-TurboForm-0.634/lib/0000755000175000017500000000000011473014547015261 5ustar thorstenthorstenHTML-TurboForm-0.634/lib/HTML/0000755000175000017500000000000011473014547016025 5ustar thorstenthorstenHTML-TurboForm-0.634/lib/HTML/TurboForm.pm0000644000175000017500000005336711473007273020316 0ustar thorstenthorstenpackage HTML::TurboForm; use strict; use warnings; use UNIVERSAL::require; use YAML::Syck; our $VERSION='0.635'; use File::Copy; sub new{ my ($class, $r,$prefix)=@_; my $self = {}; $self->{request}= $r; $self->{submitted} = 0; $self->{after_upload}=''; $self->{submit_value} = ''; $self->{count}=0; $self->{submit_id} = -1; $self->{addition_modules}=''; $self->{prefix}=''; $self->{row_wrapper}=''; $self->{prefix}=$prefix if ($prefix); bless( $self, $class ); return $self; } sub set_row_wrapper{ my ($self, $wrapper) = @_; $self->{row_wrapper}=$wrapper; } sub add_modules{ my ($self, $mods) = @_; $self->{addition_modules}=$mods; } sub add_constraint{ my ($self, $params) = @_; my $name= $self->{prefix}.$params->{name}; $params->{request}=$self->{request}; my $class_name = "HTML::TurboForm::Constraint::" . $params->{ type }; $class_name->require() or die "Constraint Class '" . $class_name . "' does not exist: $@"; push(@ { $self->{constraints} }, $class_name->new($params)); } sub add_uploads{ my ($self, $uploads) = @_; $self->{uploads} = $uploads; } sub build_form{ my ($self, $data, $resultsource, $options)=@_; my @columns=$resultsource->columns; foreach (@columns){ my $forbidden=0; my $info=$resultsource->column_info($_); my $label=$_; $label=$info->{label} if $info->{label}; my $type='Text'; $type=$info->{fieldtype} if $info->{fieldtype}; my $args={ type=>$type, name=> $_, label=> $label }; if ($data->{$_}) { while(my($key, $value) = each(%{$data->{$_}})){ $args->{$key}=$value if ($key ne 'name'); } } my $k=$_; if ($options->{definedonly}){ if ($options->{definedonly} eq '1'){ } else{ my $number = keys %$info; $forbidden=1 if ($number==0); } } else{ my $number = keys %$info; $forbidden=1 if ($number==0); } if (($data->{forbidden})&&($forbidden==0)){ #if ($data->{forbidden}){ foreach (@{$data->{forbidden}}){ $forbidden=1 if ($_ eq $k); } } $self->add_element($args) if $forbidden == 0; } } sub load{ my ($self,$fn)=@_; my $data = LoadFile($fn); foreach my $item( @{ $data->{elements} }) { $self->add_element($item); } foreach my $item( @{ $data->{constraints} }) { if ($item->{params}->{compvalue}){ my $tmp=$item->{params}->{compvalue}; $item->{params}->{comp}=$self->get_value($tmp); } $self->add_constraint($item); } } sub unignore_all{ my ($self ) = @_; my $k; my $v; foreach $k(keys %{ $self->{element_index} } ){ $self->{element_index}->{$k}->{ignore}='false'; } } sub ignore_all{ my ($self ) = @_; my $k; my $v; foreach $k(keys %{ $self->{element_index} } ){ $self->{element_index}->{$k}->{ignore}='true'; } } sub remove_all{ my ($self ) = @_; $self->{element_index}={}; $self->{element}=(); } sub ignore_element{ my ($self, $name ) = @_; $name=$self->{prefix}.$name; $self->{element_index}->{$name}->{ignore}='true'; } sub unignore_element{ my ($self, $name ) = @_; $name=$self->{prefix}.$name; $self->{element_index}->{$name}->{ignore}='false'; } sub add_element{ my( $self, $params ) = @_; my $class=''; my $options=''; if (!$params->{name}){ $params->{name}='html'.$self->{count}; $self->{count}++; } $params->{request}=$self->{request}; my $namew= $params->{name}; my $name= $self->{prefix}.$params->{name}; $params->{name}=$name; #print $name."\n"; my $class_name = "HTML::TurboForm::Element::" . $params->{ type }; $class_name->require() or die "Class '" . $class_name . "' does not exist: $@"; if (!$params->{wrapper}){ $params->{wrapper}=$self->{row_wrapper} if ($self->{row_wrapper} ne ''); } my $element= $class_name->new($params,$self->{uploads}->{$name.'_upload'}); my $new_len = push(@ { $self->{element} }, $element); $self->{element_index}->{$name}->{index}=$new_len-1; $self->{element_index}->{$name}->{frozen}=0; $self->{element_index}->{$name}->{ignore}='false'; $self->{element_index}->{$name}->{error_message}=''; if ($params->{type} eq 'Imageupload') { if ( exists $self->{uploads}->{$name."_upload"} ){ $self->{after_upload}=$name; $element->do_img(); } } if ($params->{type} eq 'Submit') { if (( exists $self->{request}->{$name.".x"} )or(exists $self->{request}->{$name})){ $self->{submitted}=1 ; $self->{submit_value} = $namew; } } if ($params->{submit}){ if ( $self->{request}->{$name} ){ $self->{submitted}=1 ; $self->{submit_value} = $namew; } } if (($params->{type} eq 'Image')||($params->{type} eq 'Upload')) { if ( exists $self->{request}->{$name.'_submit' } ){ $self->{submitted}=1 ; $self->{submit_value} = $namew.'_uploaded'; } } if ($params->{type} eq 'Imagegalerie') { my $f=''; $f = $self->find_action($name.'_delete_'); $self->{submit_value} = $namew.'_delete' if ($f ne ''); if ($f eq ''){ $f = $self->find_action($name.'_next_'); $self->{submit_value} = $namew.'_next' if ($f ne ''); } if ($f eq ''){ $f = $self->find_action($name.'_prev_'); $self->{submit_value} = $namew.'_prev' if ($f ne ''); } if ($f ne ''){ $self->{submitted}=1 ; $self->{submit_id} = $f; } } if ($params->{type} eq 'Imageslider') { my $f=''; $f = $self->find_action($name.'_delete_'); if ($f ne ''){ $self->{submitted}=1 ; $self->{submit_value} = $name.'_delete'; $self->{submit_id} = $f; } } if ($params->{type} eq 'Captcha') { my $tlabel=$params->{label1}; my $tlabel2=$params->{label2}; my $tname=$name."_input"; my $tname2=$name."_input2"; $self->add_element({ type => 'Text', name => $tname, label=> $tlabel } ); $self->add_element({ type => 'Text', name => $tname2, class=>"form_input2", label=> $tlabel2 } ); my $c_val = $self->get_value($tname2); #use Data::Dumper; #print STDERR Dumper($params); $self->add_constraint({ type=> 'Equation', operator=>'eq', name=>$tname, comp=>$c_val, text=>$params->{message} }); #$self->add_constraint({ type=> 'Equation', operator=>'eq', name=>$tname2, comp=>'', text=>$params->{message} }); $self->add_constraint({ type=> 'Mintime', name=>$tname, keyname=> $params->{keyname}."2", keyphrase=>$params->{keyphrase} ,session=> $params->{session} , text=>'Error, please wait 5 Seconds and resubmit the form.' }); } } sub find_action{ my ($self, $action_part)=@_; foreach (%{$self->{request}}){ if (length($_)>length($action_part)){ if (index($_,$action_part) > -1){ my $tmp = substr($_,length($action_part)); return $tmp if (length($tmp)>0); } } } return ''; } sub do{ my ($self, $name, $fn,@args)=@_; $self->{element}[$self->{element_index}->{$self->{prefix}.$name}->{index}]->$fn(@args); } sub get_javascript{ my ($self, $url)=@_; my $js=''; my $result=''; my $usejquery = 0; foreach my $item(@{$self->{element}}) { if ($item->{js}){ $usejquery = 1; $js.=$item->{js}."\n"; } } if ($usejquery==1){ $js=''; } return $js; } sub get_jquery_modules{ my ($self, $url)=@_; my @modules; my @stylefiles; my $js=''; my $result=''; my $css_r = ''; my $usejquery = 0; foreach my $item(@{$self->{element}}) { if ($item->{modules}){ foreach (@{ $item->{modules} }){ my $f = 0; foreach my $t(@modules){ if ($t eq $_) { $f = 1; }} push(@modules, $_) if ($f==0) ; } } if ($item->{stylefiles}){ foreach (@{ $item->{stylefiles} }){ my $f = 0; foreach my $t(@stylefiles){ if ($t eq $_) { $f = 1; }} push(@stylefiles, $_) if ($f==0) ; } } if ($item->{js}){ $usejquery = 1; $js.=$item->{js}."\n"; } } if ($usejquery==1){ $js=''; } foreach (@modules){ $result .=''."\n"; } foreach (@stylefiles){ $css_r.=''."\n"; } return $css_r.$result.$js.$self->{addition_modules}; } sub set_table_class{ my ($self, $classname)=@_; $self->{table_class}=$classname; } sub set_table_attributes{ my ($self, $attributes)=@_; my $attr=''; while ( my ($key, $value) = each(%$attributes) ) { $attr.=$key.'="'.$value.'" '; } $self->{table_attibutes}=$attr; } sub render{ my ($self, $view, $action)=@_; my $table=-1; my $count=0; $view='' if (!$view); $action=' action="'.$action.'" ' if ($action); $action='' if (!$action); my $table_class='class="form_table"'; $table_class= 'class="'.$self->{table_class}.'"' if ($self->{table_class}); $table_class=$self->{table_attibutes} if ($self->{table_attibutes}); my $result='
'; if ($view eq 'table'){ $result.=''; } foreach my $item(@{$self->{element}}) { my $name = $item->name; if ($self->{element_index}->{$name}->{ignore} ne 'true'){ $item->{table}=-1; if ($view eq 'flat'){ if ($item->type ne 'Submit'){ my $label = $item->get_label(); my $value = $item->get_value(); $result.=''.$label.": ".$value."
"; } } else { if ($item->type eq "TableEnd") { $item->{table}=-1; $table=-1; } if ($item->type eq "Table") { $item->{table}=$item->columns; $item->{colcount}=-1; $count=-1; $table=$item->columns; } if ($table>-1) { $count++; $count=1 if ($count>$table); $item->{colcount}=$count; $item->{table}=$table; } $result .= $item->render($self->{element_index}->{$name}, $view); } } else { $result.=""; } } if ($view eq 'table'){ $result.='
'; } #if ($view eq 'clean'){ } return $result.'
'; } sub uploaded{ my ($self) = @_; return $self->{after_upload} if ($self->{after_upload} ne ''); return ''; } sub submit{ my ($self) = @_; my $result=''; if ($self->{submit_value} ne '') { $result=$self->{submit_value}; } return $result; } sub submitted{ my ($self) = @_; my $result=''; my $set=0; if ($self->{submit_value} ne '') { $result=$self->{submit_value}; #$result=substr($result,length($self->{prefix})) if ($self->{prefix} ne''); foreach my $item(@{$self->{constraints}}) { my $name=$item->{name}; if ($item->check() == 0){ $self->{element_index}->{$name}->{error_message}= $item->message(); $set=1; } } $result='' if ($set==1); } return $result; } sub get_single_dbix{ my ($self,$name)=@_; my $result = $self->{element}[$self->{element_index}->{$self->{prefix}.$name}->{index}]->get_dbix(); return $result; } sub get_dbix{ my ($self)=@_; my $result; foreach (@{$self->{element}}) { my $tmp = $_->get_dbix(); if ($tmp){ while ( my ($key, $value) = each(%$tmp) ) { $result->{$key} = $value; } } } return $result; } sub add_options{ my ($self,$name,$options)=@_; $self->{element}[$self->{element_index}->{$self->{prefix}.$name}->{index}]->add_options($options); } sub reset_options{ my ($self,$name,$options,$label,$id)=@_; $self->{element}[$self->{element_index}->{$self->{prefix}.$name}->{index}]->reset_options($options,$label,$id); } sub freeze{ my ($self, $name)=@_; $self->{element_index}->{$self->{prefix}.$name}->{frozen}=1; $self->{element}[$self->{element_index}->{$self->{prefix}.$name}->{index}]->freeze(); } sub get_r{ my ($self, $name)=@_; $self->{element}[$self->{element_index}->{$self->{prefix}.$name}->{index}]->pure(1) if (!$self->{element}[$self->{element_index}->{$self->{prefix}.$name}->{index}]->pure); return $self->{element}[$self->{element_index}->{$self->{prefix}.$name}->{index}]->render(); } sub get_e{ my ($self, $name)=@_; return '' if (!$self->{element_index}->{$self->{prefix}.$name}->{error_message}); return $self->{element_index}->{$self->{prefix}.$name}->{error_message}; } sub get_errors{ my ($self)=@_; my $k; my $result=''; foreach $k(keys %{ $self->{element_index} } ){ $result.=$self->{element_index}->{$k}->{error_message}.'
' if ( $self->{element_index}->{$k}->{error_message}); } return $result; } sub freeze_all{ my ($self)=@_; my $k; my $v; foreach $k(keys %{ $self->{element_index} } ){ $self->{element_index}->{$k}->{frozen}=1; } } sub unfreeze{ my ($self, $name)=@_; $self->{element_index}->{$self->{prefix}.$name}->{frozen}=0; } sub get_value{ my ($self, $name)=@_; my $result=''; if (!$self->{request}->{$self->{prefix}.$name}){ } else { $result=$self->{element}[$self->{element_index}->{$self->{prefix}.$name}->{index}]->get_value(); } return $result; } sub populate{ my ($self, $data, $anyway)=@_; $self->{submit_value}='' unless ($self->{submit_value}); if (($self->{submit_value} eq '') or ($anyway ne '')) { if (ref($data) eq 'HASH') { while (my ($key, $value) = each %{ $data }){ $self->{request}->{$self->{prefix}.$key}=$value; } } else { my @columns= $data->result_source->columns; foreach my $item(keys %{$self->{element_index}}) { $item=substr($item,length($self->{prefix})) if ($self->{prefix} ne''); if ( grep { $item eq $_ } @columns ) { if (!$self->{request}->{$self->{prefix}.$item}) { $self->{request}->{$self->{prefix}.$item}=$data->get_column($item); } } } } } } sub serial_populate{ my ($self, $data)=@_; my $result = {}; my @arr_data = split('&',$data); foreach (@arr_data) { my @tmp = split('=',$_); $self->{request}->{$self->{prefix}.$tmp[0]} = $tmp[1] if ($tmp[1]); } } sub map_value{ my ($self, @columns)=@_; my $result; foreach my $item(keys %{$self->{element_index}}) { $item=substr($item,length($self->{prefix})) if ($self->{prefix} ne''); my $type=$self->{element}[$self->{element_index}->{$self->{prefix}.$item}->{index}]->type; if (($type ne 'Upload')&&($type ne 'Image')){ if ( grep { $item eq $_ } @columns ) { $result->{$item}=$self->get_value($item); } } } return $result; } sub get_values{ my ($self)=@_; my $result; foreach my $item(keys %{$self->{element_index}}) { $item=substr($item,length($self->{prefix})) if ($self->{prefix} ne''); $result->{$item}=$self->get_value($item); } return $result; } 1; __END__ =head1 HTML::TurboForm HTML::TurboForm - fast and compact HTML Form Class =head1 SYNOPSIS to start with, two simple examples of how to use turboform. I am still working on both the classes and the docs so please be patient. =head2 Usage variant 1 : via objects and methods my $options; $options->{ 'label1' }='1'; $options->{ 'label2' }='2'; $options->{ 'label3' }='3'; $form->add_element({ type => 'Html', text =>'
' }); $form->add_element({ type => 'Text', name => 'texttest', label => 'element1' } ); $form->add_element({ type => 'Text', name => 'texttest2', label => 'vergleichselement' } ); $form->add_element({ type => 'Textarea', name => 'textareatest', label => 'Areahalt:' } ); $form->add_element({ type => 'Submit', name => 'freeze', label => ' ', value=>'einfrieren' } ); $form->add_element({ type => 'Submit', name => 'unfreeze', label => ' ', value=>'normal' } ); $form->add_element({ type => 'Checkbox', name => 'boxtest', label => 'auswählen', options => $options, params =>{ 'listmode'=>'' } } ); $form->add_element({ type => 'Html', text =>'
' }); $form->add_element({ type => 'Select', name => 'selecttest', label => 'selectieren', options => $options } ); $form->add_element({ type => 'Select', name => 'selecttest2', label => 'selectieren', options => $options, attributes => { 'multiple'=>'' , 'size'=>'3' } } ); $form->add_element({ type => 'Text', name => 'mailtest', label => 'E-Mail' } ); $form->add_element({ type => 'Radio', name => 'tadiotest', label => 'radioteile', options => $options, params =>{ 'listmode', 'norow'} } ); $form->add_element({ type => 'Date', name => 'datetest', label => 'Datum', params=>{ startyear=> '2000' , endyear => '2020' } } ); $form->add_element({ type => 'Image', name => 'imagetest', label => 'Bild', width=>'400', height=>'300', thumbnail => { width => '60', height=>'80' }, savedir=>'/home/whocares/catalyst/formproject/root/static/images/temp', loadurl=>'/static/images/temp' } ); $form->add_constraint({ type=> 'Equation', name=> 'texttest', text=> 'kein Vergleich', params=>{ operator => 'eq', comp=>$form->get_value('texttest2') } }); $form->add_constraint({ type=> 'Required', name=> 'boxtest', text=> 'du musst schon was auswählen' }); $form->add_constraint({ type=> 'Date', name=> 'datetest', text=> 'das ist doch kein datum' }); $form->add_constraint({ type=> 'Email', name=> 'mailtest', text=> 'ungültige Mailadresse' }); $form->add_element({ type => 'Html', text =>'
' }); $form->freeze_all() if ($form->submitted() eq 'freeze'); $c->stash->{form} = $form->render(); $c->stash->{template}='formtest/formtest.tt'; if ($form->submitted() eq 'freeze') { my @cols= ('txt1','date','txt2','checkboxtest'); my $data=$form->map_value(@cols); } =head2 Usage Variant 2 : via yml file: my $form= new HTML::TurboForm($c->req->params); $form->load('test.yml'); my $text=$form->render(); if ($form->submitted eq 'freeze') {} Sample yml-file: --- languages: - de elements: - type: Html text:
- type: Text name: messageausyml label: ausyml - type: Text name: txt1 label: sampleinput - type: Text name: txt2 label: whatever to compare - type: Checkbox label: chooser name: checkboxtest options: label1: 1 label2: 2 - type: Html text:

- type: Radio label: radiochooser options: radio1: 1 radio2: 2 - type: Submit name: freeze value: einfrieren - type: Submit name: defreeze value: normal - type: Date label: Datum name: date params: startyear: 2000 endyear: 2010 - type: Html text:
constraints: - type: Required name: messageausyml text: mandatory field - type: Date name: date text: must be a correct date - type: Equation name: txt1 text: must be higher params: operator: < compvalue: txt2 =head1 DESCRIPTION HTML::TurboForm was designed as a small, fast and compact Form Class to use with catalyst in order to easily create any needed Form. I know there a quite a lot of classes out there which do the same but i wasn't quite content with what i found. They were either too slow or complicated or both. =head1 METHODS =head2 new Arguments: $request Creates new Form Object, needs Request Arguments to fill out Form Elements. To do so it's very important that the form elements have the same names as the request parameters. =head2 add_constraint Arguments: $params Adds a new Contraint to the Form. Constraints can be date, required or any other constraint class object. Only if they successfully match the given constraint rule the form will return valid. =head2 load Arguments: $fn Loads a form from a given YML File. =head2 unignore_element Arguments: $name will unIgnore an element so it will be rendered normally =head2 ignore_element Arguments: $name will Ignore an element so it won't be rendered and in effect invisible, it's value will be given to the form as hidden value =head2 add_element Arguments: $params Will add a new Form Element, for example a new text element or select box or whatever. =head2 render Arguments: none Renders the form. Will retrun the HTML Code for the form including error messages. =head2 submitted Arguments: none Will be true if the form is correctly filled out by user, otherwise it returns false and shows the corresponding error message(s). =head2 add_options Arguments: $name, $option Adds option to HTML elements that needs them, for example select boxes. =head2 freeze Arguments: $name Will disable the HTML Element identified by name for viewing purposes only. =head2 freeze_all Arguments: none Freezes the whole form. =head2 unfreeze Arguments: $name Unfreezes certain Element. =head2 get_value Arguments: $name Returns Value of Eelement by name =head2 populate Arguments: $data fills form with values form hash. =head2 map_value Arguments: @columns Expects an array with column names. This method is used to map the request and form elements to the columns of a database table. =head1 AUTHOR Thorsten Drobnik, camelcase@hotmail.com =head1 LICENSE This library is free software, you can redistribute it and/or modify it under the same terms as Perl itself. =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/0000755000175000017500000000000011473014547017744 5ustar thorstenthorstenHTML-TurboForm-0.634/lib/HTML/TurboForm/Constraint.pm0000644000175000017500000000113711455433374022433 0ustar thorstenthorstenpackage HTML::TurboForm::Constraint; use warnings; use strict; use base qw/ Class::Accessor /; __PACKAGE__->mk_accessors( qw/ params request type name text / ); sub message{ my ($self)=@_; return $self->text; } 1; __END__ =head1 HTML::TurboForm::Constraint Base Class for formconstraints =head1 SYNOPSIS $form->addconstraint(...); =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 message Arguments: none returns error message of constraint =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element.pm0000644000175000017500000001442711473007143021675 0ustar thorstenthorstenpackage HTML::TurboForm::Element; use warnings; use strict; use base qw/ Class::Accessor /; __PACKAGE__->mk_accessors( qw/ params submit wrapper errorclass pure default dbsearchfield dbdata optionstext dbop dbid dblabel ignore_dbix type id name label text value request options optionsnum class left_class limit right_class row_class attributes table submit columns / ); sub new{ my ($class, $request) = @_; my $self = $class->SUPER::new( $request ); $self->{view} =''; $self->{submitted} = 0; $self->{submitted} = 1 if ($request->{ $self->name }); if ($self->dbdata and $self->dbid and $self->dblabel){ my @t = @{ $self->dbdata }; foreach (@t){ my $label_method = $self->dblabel; my $value_method = $self->dbid; my $l=$_->$label_method; my $v=$_->$value_method; $self->options->{$l}=$v; } } if ($self->submit){ @{$self->{modules}} = ('jquery/jquery'); $self->{js} = ' $("#'.$self->name.'").'.$self->submit.'(function(){$("form")[0].submit(); }); '; } if ($self->dbdata and $self->dbid and not $self->dblabel){ my @t = @{ $self->dbdata }; my @tmp; foreach (@t){ my $value_method = $self->dbid; my $v=$_->$value_method; push(@tmp,$v); } @{$self->{options}} = @tmp; } $self->init(); return $self; } sub init{ my ($self) = @_; } sub add_options{ my ($self, $opt) = @_; $self->{options} = $opt; } sub reset_options{ my ($self, $opt) = @_; $self->{dbdata}=[]; $self->{options}=[]; $self->{options} = $opt; } sub freeze{ my($self) =@_; } sub populate{ my($self) =@_; } sub get_attr{ my ($self) =@_; my $result=""; while ( my( $key,$value) = each %{$self->{attributes}}){ if ($value) { $result.=' '.$key.'="'.$value.'"'; } else { $result.=' '.$key; } } return $result.' '; } sub check_param{ my ($self, $name)=@_; my $result=0; if ( exists($self->{params}->{ $name })) { $result=1; } return $result; } sub get_dbix{ my ($self)=@_; if (!$self->ignore_dbix) { my $dbname=$self->name if ($self->name); $dbname =$self->dbsearchfield if ($self->dbsearchfield); if ($self->type eq 'Select'){ return 0 if ($self->get_value() eq '-1'); } if($self->get_value() ne '') { return { $dbname => $self->get_value()}; } else { return 0; } } else {return 0;} } sub vor{ my ($self,$options)=@_; return "" if ( $self->pure ); my $error=''; $error=$options->{error_message} if $options->{error_message}; my $result=''; my $table=''; my $rwc=''; my $rtc=''; my $ltc=''; my $class='class="form_row"'; my $errorclass=" ".$self->errorclass if ($self->errorclass); if ($self->{class}) { $class='class="'.$self->{class}.'"'; } if ($self->{row_class}) { $rwc = " class='".$self->{row_class}."' "; } if ($self->{right_class}) { $rtc = " class='".$self->{right_class}."' "; } if ($self->{left_class}) { $ltc = " class='".$self->{left_class}."' "; } if ($self->{view} eq '') { $error="
$error
" if ($error ne ''); $self->label('') if (!$self->label); $errorclass='' if (!$errorclass); $result=$table."
".$error. "
".$self->label."
". "
"; #$result=$table."
".$error. # "
".$self->label."
". # "
"; $result=$table."
" if ($self->type eq "Html"); } if ($self->{view} eq 'table') { $error=''.$error.'' if ($error ne ''); $table='' if (!$table); $error='' if (!$error); $class=''; $rwc='' if (!$rwc); $rtc='' if (!$rtc); $self->label('') if (!$self->label); $result = $table. $error. "". "".$self->label."". ""; $result=$table.'' if ($self->type eq "Html"); } if ($self->{view} eq 'column') { $self->label('') if (!$self->label); $result=''.$self->label.''; $result.=$error.'
' if ($error ne ''); } if ($self->wrapper){ my $wrap=$self->wrapper; my $s=''; $s=$self->label if (!$s); $wrap=~s/
"; my $table=''; $result='' if ($self->wrapper); $result="
" if ($self->type eq "Html"); $result="" if ($self->{view} eq 'table'); $result="" if ($self->{view} eq 'column'); if ($self->wrapper){ $result=$self->{after_wrap} if ($self->{after_wrap}); } $result.="\n"; return $result; } sub get_label{ my ($self) = @_; my $result=''; $result=$self->label if $self->label; return $result; } sub get_value{ my ($self) = @_; my $result=''; $result=$self->{request}->{$self->name} if exists($self->{request}->{$self->name}); return $result; } 1; __END__ =head1 HTML::TurboForm::Element Base Class for HTML elements =head1 SYNOPSIS $form->addelement(...); =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 add_options Arguments: $options adds option tags to a html element =head2 get_value Arguments: none returns value of the element =head2 get_attr Arguments: none Return List of attributes of HTML Tag =head2 check_param Arguments: $name checks if param with given name does exist =head2 nach Arguments: none returns given prehtml =head2 vor Arguments: none return given posthtml =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/0000755000175000017500000000000011473014547021335 5ustar thorstenthorstenHTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Slider.pm0000644000175000017500000000625511455433374023130 0ustar thorstenthorstenpackage HTML::TurboForm::Element::Slider; use warnings; use strict; use base qw(HTML::TurboForm::Element); __PACKAGE__->mk_accessors( qw/ min max steps label_addon start modules zerovalue / ); sub init{ my ($self)=@_; my $min = 0; my $max = 100; my $step = 10; my $start = $self->start; $min=$self->min; $min-- if($self->zerovalue); $step=$self->steps; $max=$self->max; my $js_min=''; $js_min ='if (ui.value == '.$min.') label="'.$self->zerovalue.'";' if($self->zerovalue); @{$self->{modules}} = ('jquery/jquery','jquery/ui.core.min','jquery/ui.slider.min'); my $labelchange=''; $labelchange = 'if (label != "'.$self->zerovalue.'") label+="'.$self->label_addon.'";' if ($self->label_addon); $self->{js} = ' $("#'.$self->name.'_slider").slider({ "steps": '.$step.', "min": '.$min.', "max": '.$max.', "startValue": '.$start.', "slide": function(e, ui){ var label = ui.value; '.$js_min.' $("#'.$self->name.'").val(ui.value); '.$labelchange.' $("#'.$self->name.'_label").html(label); } }); '; $self->{value}=$self->request->{ $self->name }; if ($self->{value}){ $self->{js} .= '$("#'.$self->name.'_slider").slider("moveTo",'.$self->{value}.');'; } } sub get_dbix{ my ($self)=@_; my $dbname=$self->name if ($self->name); $dbname =$self->dbsearchfield if ($self->dbsearchfield); my $val = $self->get_value(); if($val ne '') { if ($val < $self->min) { return 0; } else { if (!$self->dbop){ return { $dbname => $val } ; } else { return { $dbname => { $self->dbop => $val }} ; } } } else { return 0; } } sub get_value{ my ($self)=@_; return 0 if (($self->zerovalue) && ( $self->{value} == ($self->{min}-1))); return $self->{value}; } sub freeze{ my ($self)=@_; $self->{js} .= '$("#'.$self->name.'_slider").slider("disable");'; } sub render { my ($self, $options, $view)=@_; if ($view) { $self->{view}=$view; } my $request=$self->request; my $result=''; my $disabled=''; my $class='form_text'; $class = $self->class if ($self->class); my $name=$self->name; my $minlabel = $self->min; my $maxlabel = $self->max; $minlabel = $self->zerovalue if ($self->zerovalue); $result='
'.$minlabel.'
 
'; return $self->vor($options).$result.$self->nach; } 1; __END__ =head1 HTML::TurboForm::Element::Slider Representation class for HTML SLider input element. This Element uses the jquery Javascript library ! =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 render Arguments: $options returns HTML Code for element. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Text.pm0000644000175000017500000000250211455433374022621 0ustar thorstenthorstenpackage HTML::TurboForm::Element::Text; use warnings; use strict; use base qw(HTML::TurboForm::Element); sub render { my ($self, $options, $view)=@_; if ($view) { $self->{view}=$view; } my $id=''; $id=' id="'.$self->id.'" ' if ($self->id); my $request=$self->request; my $result=''; my $disabled=''; my $class='form_text'; $class = $self->class if ($self->class); $class = 'class="'.$class.'"'; my $name=' name="'.$self->name.'" '; my $value=''; $value=' value="'.$request->{ $self->name }.'" ' if ($request->{ $self->name }); if ($options->{frozen}) { if ($options->{frozen} eq 1) { my $text= $value; $disabled=' disabled '; $result=''; } } my $limit=''; $limit=' maxlength="'.$self->limit.'"' if ($self->limit); $result .='' ; return $self->vor($options).$result.$self->nach; } 1; __END__ =head1 HTML::TurboForm::Element::Text Representation class for HTML Text input element. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 render Arguments: $options returns HTML Code for element. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Imagegalerie.pm0000644000175000017500000000462611455433374024261 0ustar thorstenthorstenpackage HTML::TurboForm::Element::Imagegalerie; use warnings; use strict; use base qw(HTML::TurboForm::Element); __PACKAGE__->mk_accessors( qw/ del_link all_link max dir noimgs / ); sub render{ my ($self, $options, $view)=@_; if ($view) { $self->{view}=$view; } my $result=''; my $disabled=''; my $class='form_imagegalerie'; my $request=$self->request; $self->label(' ') if ($self->label eq ''); $class=$self->{class} if exists($self->{class}); my $aha=$self->options; my $name=$self->name; my $nr_obj = scalar(@{ $self->{options} }); $disabled=' disabled ' if ($options->{frozen} == 1); my $dir=''; $dir = $self->dir if ($self->dir); $result.='
'."\n"; $result.=''; foreach (@{$self->{options}}){ my $col_fn = $self->dbid; my $col_label = $self->dblabel; my $fn =''; $fn = $_->$col_fn if ($_->$col_fn); if (!$self->noimgs){ if ($self->all_link){ my $label = ''; $label = '
'.$_->$col_label.'' if($self->dblabel); $result.=''."\n"; }else{ $result.=''."\n"; } } if ($self->noimgs){ $result.=''."\n";} } $result.='

'.$label.'
'.$fn.'
'; $result='' if ($nr_obj ==0); $result= $self->vor($options).$result.$self->nach if ($self->check_param('norow')==0); return $result; } sub init{ my ($self)=@_; my $name=$self->name; } sub get_dbix{ my ($self)=@_; return 0; } 1; __END__ =head1 HTML::TurboForm::Element::Imageslider Representation class for Imageslider element. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 render Arguments: $options returns HTML Code for checkbox element. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Submit.pm0000644000175000017500000000316611455433374023147 0ustar thorstenthorstenpackage HTML::TurboForm::Element::Submit; use warnings; use strict; use base qw(HTML::TurboForm::Element); __PACKAGE__->mk_accessors( qw/ image pure ajaxcall / ); sub render{ my ($self, $options, $view)=@_; if ($view) { $self->{view}=$view; } my $result=''; my $disabled=''; if ($self->label and ($self->label eq '')) { $self->label(' '); } my $class= "form_std"; $class=$self->class if ($self->class); my $id=''; $id=" id='$self->{name}' "; my $value=$self->value; $value= ' value="'.$value.'" '; if ($options->{frozen}){ if ($options->{frozen} == 1) { my $text= $value; } } my $js_tag_text = ''; if ($self->ajaxcall) { $result= ''; $result= $result.'ajaxcall."'".');" value="'.$self->{value}.'"> '; } else { my $t = 'type="Submit"'; $t = 'type="image" src="'.$self->image.'"' if ($self->image); $result =$result.'' ; } return $result if ($self->{pure}); return $self->vor($options).$result.$self->nach; } sub get_dbix{ my ($self)=@_; return 0; } 1; __END__ =head1 HTML::TurboForm::Element::Submit Representation class for HTML Submit element. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 render Arguments: $options returns HTML Code for Submit element. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Hidden.pm0000644000175000017500000000170711455433374023076 0ustar thorstenthorstenpackage HTML::TurboForm::Element::Hidden; use warnings; use strict; use base qw(HTML::TurboForm::Element); sub render { my ($self, $options, $view)=@_; if ($view) { $self->{view}=$view; } my $request=$self->request; my $result=''; my $disabled=''; my $id=''; $id=" id='".$self->name."' "; my $name=' name="'.$self->name.'" '; my $value=''; $value=' value="'.$self->value.'" ' if ($self->value); $value=' value="'.$request->{ $self->name }.'" ' if ($request->{ $self->name }); $result .='' ; return $result; } 1; __END__ =head1 HTML::TurboForm::Element::Hidden Representation class for HTML Hidden input element. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 render Arguments: $options returns HTML Code for element. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Checkbox.pm0000644000175000017500000000453711455433374023435 0ustar thorstenthorstenpackage HTML::TurboForm::Element::Checkbox; use warnings; use strict; use base qw(HTML::TurboForm::Element); __PACKAGE__->mk_accessors( qw/ tablelayout listmode/ ); sub render{ my ($self, $options, $view)=@_; if ($view) { $self->{view}=$view; } my $result=''; my $disabled=''; my $class=''; my $request=$self->request; if (!$self->label){ $self->label(''); } $self->label(' ') if ($self->label eq ''); $class=' class="'.$self->{class}.'" ' if exists($self->{class}); my $name=' name="'.$self->name.'" '; my $checked=''; if ($options->{frozen}){ $disabled=' disabled ' if ($options->{frozen} == 1) ; } my $pre=''; my $post=''; my $after=''; $self->listmode('') if (!$self->listmode); if ( $self->listmode ne '' ){ $result.=''; } my $counter=0; my $max=0; if ($self->tablelayout) { $result.=''; $max = $self->tablelayout ; } while ( my( $key,$value) = each %{$self->options}){ $counter++; if (($counter == $max) && ($self->tablelayout)) { $result.="\n"; $counter = 0; } my $values = $request->{ $self->name }; $values = [ $values ] unless ref( $values ) =~ /ARRAY/; $checked=''; if ([ $values]){ $checked=' checked ' if ( grep { $_ eq $value if ($_) } @{ $values } ); } $result.=$pre.''.$key.$post; $result.='' if (($disabled ne '')&& ( $checked ne '')); $result.='
' if($self->tablelayout); } $result.=$after; $result.='' if ($self->tablelayout); return $result if ($self->tablelayout); $result= $self->vor($options).$result.$self->nach if ($self->check_param('norow')==0); return $result; } 1; __END__ =head1 HTML::TurboForm::Element::Checkbox Representation class for HTML Checkbox element. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 render Arguments: $options returns HTML Code for checkbox element. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Imageupload.pm0000644000175000017500000002106511455433374024131 0ustar thorstenthorstenpackage HTML::TurboForm::Element::Imageupload; use warnings; use strict; use base qw(HTML::TurboForm::Element); use Imager; use File::Finder; __PACKAGE__->mk_accessors( qw/ prev upload keeporiginal scaletype filename width height savedir thumbnail loadurl caption maxsize errormessage / ); sub new{ my ($class, $request, $upload) = @_; my $self = $class->SUPER::new( $request ); $self->upload( $upload ); $self->do_img(); return $self; } sub ren{ my ($self, $newfilename)=@_; my $file=''; my $request=$self->request; $file=$self->{pic}; if (!$self->{pic}){ $file=$request->{$self->name} if ($request->{$self->name}); } rename($self->savedir.'/med_'.$file, $self->savedir.'/'.$newfilename.'.jpg'); } sub ren_thumb{ my ($self, $newfilename)=@_; my $file=''; my $request=$self->request; $file=$self->{pic}; if (!$self->{pic}){ $file=$request->{$self->name} if ($request->{$self->name}); } rename($self->thumbnail->{savedir}.'/thumb_'.$file, $self->thumbnail->{savedir}.'/'.$newfilename.'.jpg'); } sub do_img{ my ($self)=@_; my $request=$self->request; my $pic=''; $pic = $self->request->{$self->name} if ($self->request->{$self->name} ); if ($request->{ $self->name.'_upload' }) { if( $self->upload->type !~ /^image\/(jpeg|jpg|gif|png|pjpeg)$/ ) { #$c->stash->{ 'error' } = 'Filetype not supported!'; } else { # read image my $image = Imager->new; $self->{sizeerror}=0; if ($self->maxsize) { if (($self->upload->size/1024) > $self->maxsize){ $self->{sizeerror}=1; } } if (!$self->{sizeerror}){ if( $image->read( file => $self->upload->tempname ) ) { # remove alpha channels because jpg does not support it # and its not used anyways $image = $image->convert( preset => 'noalpha' ); #attribute keeporignal isparams local path for storing orig sized images my $tmp = File::Temp->new( DIR => $self->savedir.'', UNLINK => 0, SUFFIX => '.jpg' ); $pic = substr( $tmp, length( $self->savedir )+1 ); $self->{pic}=$pic; if ($self->keeporiginal){ $self->upload->copy_to($self->keeporiginal.'/orig_'.$pic); } # if there is a save dir, resize. depending if width and/or height is given, scale to dimensions if ($self->savedir){ my $continueflag=1; if ($self->scaletype eq 'smart'){ if ($self->width && $self->height){ $continueflag = 0; my $container_dir='v'; if ($self->width > $self->height){ my $container_dir='h'; } my $dir='v'; if ($image->getwidth() > $image->getheight()){ $dir='h'; } if ($container_dir ne $dir ){ my $tmp=$self->width; $self->width=$self->height; $self->height=$tmp; } $image = $image->scale(ypixels=>$self->height,xpixels=>$self->width); } } if ($continueflag==1){ if (($self->width) and ($self->height) and ($self->scaletype)) { # Resize height, scale width $image = $image->scale(ypixels=>$self->height,xpixels=>$self->width,type=>$self->scaletype); } elsif (($self->width) and ($self->height)) { # No scale. Resize to given dimensions $image = $image->scaleX(pixels=>$self->width)->scaleY(pixels=>$self->height); } elsif ($self->width) { # Resize width, scale height $image = $image->scale(xpixels=>$self->width); } elsif ($self->height) { # Resize height, scale width $image = $image->scale(ypixels=>$self->height); } } $image->write( file => $self->savedir.'/med_'.$pic, type => 'jpeg', jpegquality => 90 ); unlink($self->upload->tempname); if ($self->thumbnail) { if ($self->thumbnail->{width} || $self->thumbnail->{height} ) { if (($self->thumbnail->{width}) and ($self->thumbnail->{height})) { # No scale. Resize to given dimensions $image = $image->scaleX(pixels=>$self->thumbnail->{width})->scaleY(pixels=>$self->thumbnail->{height}); } elsif ($self->thumbnail->{width}) { # Resize width, scale height $image = $image->scale(xpixels=>$self->thumbnail->{width}); } elsif ($self->thumbnail->{height}) { # Resize height, scale width $image = $image->scale(ypixels=>$self->thumbnail->{height}); } my $thmb_fn = $self->savedir.'/thumb_'.$pic; $thmb_fn = $self->thumbnail->{savedir}.'/thumb_'.$pic if ($self->thumbnail->{savedir}); $image->write( file => $thmb_fn, type => 'jpeg', jpegquality => 90 ); } } unlink($self->savedir.'/'.$pic); } } } } }#end of if upload and submit } sub get_value{ my ($self) = @_; my $result=''; my $request=$self->request; $result=$self->{pic}; if (!$self->{pic}){ $result=$request->{$self->name} if ($request->{$self->name}); } return $result; } sub render{ my ($self, $options, $view)=@_; if ($view) { $self->{view}=$view; } my $request=$self->request; my $result=''; my $disabled=''; my $class='form_image_select'; $self->label(' ') if ($self->label eq ''); $class=$self->{class} if exists($self->{class}); my $name=' name="'.$self->name.'_upload" '; my $checked=''; my $pic=''; $pic= $self->{pic} if ($self->{pic}); $pic=$request->{$self->name} if ($request->{$self->name}); if ($options->{frozen}) { $disabled=' disabled ' if ($options->{frozen} == 1); } my $tmpres=''; $tmpres.= $self->errormessage if ($self->{sizeerror} && $self->errormessage); $tmpres.='get_attr().$disabled.$name.'>'; if ($options->{frozen}) { $result .= $tmpres unless ($options->{frozen} == 1 ); } else { $result .= $tmpres; } $result.=''; if ($pic ne ''){ $result.="

"; $result.="" if ($self->loadurl); } return $self->vor($options).$result.$self->nach; } 1; __END__ =head1 HTML::TurboForm::Element::Imageupload Representation class for HTMl SelectBox element. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 render Arguments: $options returns HTML Code for select element. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Upload.pm0000644000175000017500000000537611473004657023133 0ustar thorstenthorstenpackage HTML::TurboForm::Element::Upload; use warnings; use strict; use base qw(HTML::TurboForm::Element); use File::Copy "mv"; use File::Path; __PACKAGE__->mk_accessors( qw/ prev upload maxsize keeporiginal savedir loadurl filedir caption overwrite errormessage / ); sub new{ my ($class, $request, $upload) = @_; my $self = $class->SUPER::new( $request ); $self->upload( $upload ); my $pic=''; $pic = $self->request->{$self->name} if ($self->request->{$self->name} ); if (!$self->filedir){ $self->filedir(''); } else { mkpath($self->savedir.'/'.$self->filedir); $self->filedir($self->filedir.'/') if ($self->filedir!~/(.*)\/$/); } if ($self->request->{ $self->name.'_upload' }) { if ((-e $self->savedir.'/'.$self->filedir.$self->upload->basename)&&(!$self->overwrite)){ $pic='ERROR'; } else { mv($self->upload->tempname,$self->savedir.'/'.$self->filedir.$self->upload->basename); $pic = $self->savedir.'/'.$self->upload->basename; } } $self->{pic}=$pic; return $self; } sub get_value{ my ($self) = @_; my $result=''; my $request=$self->request; $result=$self->{pic} if ($self->{pic}); if (!$self->{pic}){ $result=$request->{$self->name} if ($request->{$self->name}); } return $result; } sub render{ my ($self, $options, $view)=@_; if ($view) { $self->{view}=$view; } my $request=$self->request; my $result=''; my $disabled=''; my $class='form_upload_select'; $self->label(' ') if ($self->label eq ''); $class=$self->{class} if exists($self->{class}); my $name=' name="'.$self->name.'_upload" '; my $checked=''; $disabled=' disabled ' if ($options->{frozen} == 1); if ($options->{frozen} != 1 ){ $result.= $self->errormessage if ($self->{sizeerror} && $self->errormessage); $result.='get_attr().$disabled.$name.'>'; $result.=''; } if ($self->get_value() ne ''){ my @parts=split('/',$self->get_value()); my $f= pop(@parts); $result.='File: '.$f; } return $self->vor($options).$result.$self->nach; } 1; __END__ =head1 HTML::TurboForm::Element::Upload Representation class for HTMl SelectBox element. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 render Arguments: $options returns HTML Code for select element. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Select.pm0000644000175000017500000001022211473011707023102 0ustar thorstenthorstenpackage HTML::TurboForm::Element::Select; use warnings; use strict; use base qw(HTML::TurboForm::Element); __PACKAGE__->mk_accessors( qw/ default first optionstext/ ); sub render{ my ($self, $options, $view)=@_; if ($view) { $self->{view}=$view; } my $request=$self->request; my $result=''; my $disabled=''; my $class='form_select'; $self->label(' ') if (!$self->label); $class=$self->{class} if exists($self->{class}); my $name=' name="'.$self->name.'" '; my $id=' id="'.$self->name.'" '; my $checked=''; $self->{submitted} = 1 if ($request->{ $self->name }); if ($self->{submitted} == 0){ $request->{ $self->name } = $self->default if($self->default); } if ($options->{frozen}){ $disabled=' disabled ' if ($options->{frozen} == 1); } if ($self->dbdata and $self->dbid and $self->dblabel){ my @t = @{ $self->dbdata }; foreach (@t){ my $label_method = $self->dblabel; my $value_method = $self->dbid; my $l=$_->$label_method; my $v=$_->$value_method; $self->options->{$l}=$v; } } $result.='' if (($disabled ne '')&& ( $checked ne '')); } if ($self->optionsnum){ foreach (@{$self->optionsnum}){ while( my ($key, $value) = each %$_ ) { my $values = $request->{ $self->name }; $values = [ $values ] unless ref( $values ) =~ /ARRAY/; $checked=''; if ( @{ $values } && $value) { if ( grep { $_ eq $value if ($_) } @{ $values } ){ $checked=' selected '; } } if ($self->first) { if ($value ne $self->first){ $optiontags.=''; } else { $first = ''; } } else { $optiontags.=''; } $result2.='' if (($disabled ne '')&& ( $checked ne '')); } } } if ($self->options){ foreach my $key(sort keys %{$self->options}){ my $value = $self->options->{$key}; $value="" if (!$value); my $values = $request->{ $self->name }; $values = [ $values ] unless ref( $values ) =~ /ARRAY/; $checked=''; if (@{ $values } && $value) { foreach (@{$values}){ #if ( grep { $_ eq $value } @{ $values } ){ if ($_){ $checked=' selected ' if $_ eq $value; } } } $self->first('') if (!$self->first); if ($value ne $self->first){ $optiontags.=''; } else { $first = ''; } $result2.='' if (($disabled ne '')&& ( $checked ne '')); } } $result .= $first.$optiontags; } $result.=''; return $self->vor($options).$result.$result2.$self->nach if ($self->{pure}); return $self->vor($options).$result.$result2.$self->nach; } sub get_value{ my ($self) = @_; my $result=''; $result=$self->{request}->{$self->name} if exists($self->{request}->{$self->name}); $result='' if ($result eq '-1'); return $result; } 1; __END__ =head1 HTML::TurboForm::Element::Select Representation class for HTMl SelectBox element. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 render Arguments: $options returns HTML Code for select element. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Html.pm0000644000175000017500000000146311455433374022606 0ustar thorstenthorstenpackage HTML::TurboForm::Element::Html; use warnings; use strict; use base qw(HTML::TurboForm::Element); __PACKAGE__->mk_accessors( qw/ pure / ); sub render { my ($self, $options, $view)=@_; if ($view) { $self->{view}=$view; } return $self->{text} if ($self->{pure}); return $self->vor($options).$self->{text}.$self->nach; } sub get_dbix{ my ($self)=@_; return 0; } 1; __END__ =head1 HTML::TurboForm::Element::Html Representation class for Html element . =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 render Arguments: $options returns HTML Code. This element is needed if you want to insert plain HTML Code in a certain Position in a form. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Date.pm0000644000175000017500000001406711455433374022563 0ustar thorstenthorstenpackage HTML::TurboForm::Element::Date; use warnings; use strict; use DateTime::Format::MySQL; use base qw(HTML::TurboForm::Element); __PACKAGE__->mk_accessors( qw/ showdate language /); sub render{ my ($self, $options, $view)=@_; if ($view) { $self->{view}=$view; } my $request=$self->request; my $result=''; my $disabled=''; my $class='form_date'; $self->label(' ') if ($self->label eq ''); $class=$self->{class} if exists($self->{class}); my $name=' name="'.$self->name; my $checked=''; my $startyear=1977; my $endyear=2010; $startyear=$self->{params}->{startyear}; $endyear=$self->{params}->{endyear}; if (!$self->{request}->{$self->name}.'_day' ) { if ($self->{request}->{$self->name}){ my $dt = DateTime::Format::MySQL->parse_datetime($self->{request}->{$self->name}); if ($self->showdate ne 'no'){ $self->{request}->{$self->name.'_year'} = $dt->year; $self->{request}->{$self->name.'_month'} = $dt->month; $self->{request}->{$self->name.'_day'} = $dt->day; } if ($self->{params}->{showtime} eq '24'){ $self->{request}->{$self->name.'_hour'} = $dt->hour; $self->{request}->{$self->name.'_minute'} = $dt->minute; } } } if ($options->{frozen} == 1){ $disabled=' disabled '; $result.=''; $result.=''; $result.=''; } if ($self->showdate ne 'no'){ $result.=''; $result.=''; $result.=''; } else { $result.=''; $result.=''; $result.=''; } if ($self->{params}->{showtime} eq '24'){ $result.=' '; $result.=''; } return $self->vor($options).$result.$self->nach; } sub get_value{ my ($self) = @_; my $result=''; if ($self->{request}->{$self->name.'_day'}) { $result=$self->{request}->{$self->name.'_year'}.'-'. $self->{request}->{$self->name.'_month'}.'-'. $self->{request}->{$self->name.'_day'}; if ($self->{params}->{showtime} eq '24'){ $result.=' '.$self->{request}->{$self->name.'_hour'}.'-'. $self->{request}->{$self->name.'_minute'}; } } else { if ($self->{request}->{$self->name}){ my $dt = DateTime::Format::MySQL->parse_datetime($self->{request}->{$self->name}); $self->{request}->{$self->name.'_year'} = $dt->year; $self->{request}->{$self->name.'_month'} = $dt->month; $self->{request}->{$self->name.'_day'} = $dt->day; if ($self->{params}->{showtime} eq '24'){ $self->{request}->{$self->name.'_hour'} = $dt->hour; $self->{request}->{$self->name.'_minute'} = $dt->minute; } } } return $result; } 1; __END__ =head1 HTML::TurboForm::Element::Date Representation class for Date element consisting out of three seperate select boxes. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 render Arguments: $options returns HTML Code for date element. =head2 get_value Arguments: none returns selected Date as MySQL compatible String. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Imageslider.pm0000644000175000017500000000616711455433374024135 0ustar thorstenthorstenpackage HTML::TurboForm::Element::Imageslider; use warnings; use strict; use base qw(HTML::TurboForm::Element); __PACKAGE__->mk_accessors( qw/ del_link max dir noimgs / ); sub reset_js{ my ($self)=@_; my $name=$self->name; $self->{options}=[] if (!$self->{options}); my $nr_obj = scalar(@{ $self->{options} }); #$nr_obj=1 if (($nr_obj == 0) and ($self->{options})); my $max = $self->max; $max = $nr_obj if($nr_obj < $max); if ($nr_obj > 1){ $self->{js} = ' $(function() { $("#'.$name.'").jCarouselLite({ btnNext: "#next_'.$name.'", btnPrev: "#prev_'.$name.'", visible: '.$max.' }); }); '; } } sub render{ my ($self, $options, $view)=@_; if ($view) { $self->{view}=$view; } my $result=''; my $disabled=''; my $class='form_slider'; my $request=$self->request; $self->label(' ') if ($self->label eq ''); $class=$self->{class} if exists($self->{class}); my $aha=$self->options; my $name=$self->name; my $nr_obj = scalar(@{ $self->{options} }); $disabled=' disabled ' if ($options->{frozen} == 1); my $dir=''; $dir = $self->dir if ($self->dir); if ($nr_obj>1){ $result='
<-
'; $result.='
->
'."\n"; #$result.='
    '."\n"; $result.='
      '."\n"; my $result2=''; foreach (@{$self->{options}}){ if (!$self->noimgs){ if ($self->del_link){ # $result2.=''; $result.='

    • '."\n"; }else{ $result.='
    • '."\n"; } }; if ($self->noimgs){ $result.='
    • '.$_.'
    • '."\n";} } $result.="
    "; } if ($nr_obj==1){ foreach (@{$self->{options}}){ $result.='
    '."\n"; } } if ($nr_obj==0){ $result = '';} $result= $self->vor($options).$result.$self->nach if ($self->check_param('norow')==0); #$result= '' if ($self->{options}); return $result; } sub init{ my ($self)=@_; @{$self->{modules}} = ('jquery/jquery','jquery/jcarousellite_1.0.1.min', 'jquery/easing'); $self->{max} = 3; my $name=$self->name; $self->reset_js(); } sub get_dbix{ my ($self)=@_; return 0; } 1; __END__ =head1 HTML::TurboForm::Element::Imageslider Representation class for Imageslider element. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 render Arguments: $options returns HTML Code for checkbox element. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Textarea.pm0000644000175000017500000000307611455433374023461 0ustar thorstenthorstenpackage HTML::TurboForm::Element::Textarea; use warnings; use strict; use base qw(HTML::TurboForm::Element); __PACKAGE__->mk_accessors( qw/ id tinymce / ); sub init{ my ($self)=@_; @{$self->{modules}} = ('tinymce/tiny_mce') if ($self->tinymce); } sub render { my ($self, $options, $view)=@_; if ($view) { $self->{view}=$view; } my $request=$self->request; my $result=''; my $disabled=''; my $class='form_textarea'; $class = $self->class if ($self->class); my $id=''; $id = ' id="'.$self->id.'" ' if ($self->id); $class = 'class="'.$class.'"'; my $name=' name="'.$self->name.'" '; my $value=$request->{ $self->name }; if ($options->{frozen}) { if ($options->{frozen} == 1) { my $text= $value; $disabled=' disabled '; $result=''; } } my $tinytext=''; if ($self->tinymce){ $tinytext = ' '; } $value='' if (!$value); $result =$result.$tinytext.'' ; return $self->vor($options).$result.$self->nach; } 1; __END__ =head1 HTML::TurboForm::Element::Textarea Representation class for HTML Textarea input element. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 render Arguments: $options returns HTML Code for element. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Range.pm0000644000175000017500000001216411455433374022736 0ustar thorstenthorstenpackage HTML::TurboForm::Element::Range; use warnings; use strict; use base qw(HTML::TurboForm::Element); __PACKAGE__->mk_accessors( qw/ min max round rangetext zerovalue dbtype steps start1 start2 modules / ); sub init{ my ($self)=@_; my $step = 10; if ($self->min) { $self->{min}=int($self->min); }; if ($self->max) { $self->{max}= int( $self->max ); }; if ($self->start1) { $self->{start1}=$self->start1; }; if ($self->start2) { $self->{start2}=$self->start2; }; $self->{value}=''; my $js_min=''; my $js_max=''; if($self->zerovalue){ $self->{start1}=$self->{min}; $self->{start2}=$self->{max}; $js_min ='if (value1 == '.$self->{min}.') $("#'.$self->name.'_label1").html("'.$self->zerovalue.'");'; $js_max ='if (value2 == '.$self->{max}.') $("#'.$self->name.'_label2").html("'.$self->zerovalue.'");'; } if ($self->steps) { $step=$self->steps; } else { $step = $self->{max} - $self->{min}; }; if ($self->request->{ $self->name }) { $self->{value} = $self->request->{ $self->name }; my @vals = split(/,/, $self->request->{ $self->name }); $self->{start1}= $vals[0]; $self->{start2}= $vals[1]; } @{$self->{modules}} = ('jquery/jquery','jquery/ui.core.min','jquery/ui.slider.min'); $self->{js} = ' $("#'.$self->name.'_slider").slider({ "steps": '.$step.',range:true, "min": '.$self->{min}.', "max": '.$self->{max}.', "slide": function(e, ui){ var value1 = $("#'.$self->name.'_slider").slider("value",0); var value2 = $("#'.$self->name.'_slider").slider("value",1); var field = value1+","+value2; $("#'.$self->name.'_label1").html(value1.toFixed(0),0); $("#'.$self->name.'_label2").html(value2.toFixed(0),1); $("#'.$self->name.'").val(field); '.$js_min.' '.$js_max.' } }); '; if ($self->{start2}){ $self->{js} .= '$("#'.$self->name.'_slider").slider("moveTo",'.$self->{start2}.',1);'; } if ($self->{start1}){ $self->{js} .= '$("#'.$self->name.'_slider").slider("moveTo",'.$self->{start1}.',0);'; } } sub get_value{ my ($self)=@_; return 0 if (($self->zerovalue) && ( $self->{value} == ($self->{min}-1))); return 0 if (($self->zerovalue) && ( $self->{value} == ($self->{max}+1))); return $self->{value}; } sub freeze{ my ($self)=@_; $self->{js} .= '$("#'.$self->name.'_slider").slider("disable");'; } sub get_dbix{ my ($self)=@_; my $dbname=$self->name if ($self->name); $dbname =$self->dbsearchfield if ($self->dbsearchfield); my @vals = split(/,/, $self->get_value()); my $low = $vals[0]; my $high = $vals[1]; my $result = 0; if ($self->zerovalue) { $low='' if ($low == $self->{min}); $high='' if ($high == $self->{max}); } if($self->get_value() ne '') { $result={}; if ($self->dbtype) { $result->{'CAST('.$dbname.' AS '.$self->dbtype.')'}->{'>='}=[$low] if ($low ne ''); $result->{'CAST('.$dbname.' AS '.$self->dbtype.')'}->{'<='}=[$high] if ($high ne ''); } else { $result->{$dbname}->{'>='}=$low if ($low ne ''); $result->{$dbname}->{'<='}=$high if ($high ne ''); } } return $result; } sub render { my ($self, $options, $view)=@_; if ($view) { $self->{view}=$view; } my $request=$self->request; my $result=''; my $disabled=''; my $class='form_text'; $class = $self->class if ($self->class); my $name=$self->name; my $minlabel = $self->{min}; my $maxlabel = $self->{max}; $minlabel = $self->zerovalue if ($self->zerovalue); $maxlabel = $self->zerovalue if ($self->zerovalue); #print STDERR $self->{min}." bis ".$self->{max}."\n"; #$self->{min} =~ s/^(.*?)\..*$/$1/ ; #$self->{max} =~ s/^(.*?)\..*$/$1/ ; my $rt=''; $rt = ' '.$self->{rangetext}.' ' if ($self->rangetext); $result='
    '.$minlabel.' '.$rt.' '.$maxlabel.'

     
     
    '; return $self->vor($options).$result.$self->nach; } 1; __END__ =head1 HTML::TurboForm::Element::Range Representation class for HTML SLider input element with two Sliders. This Element uses the jquery Javascript library ! =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 render Arguments: $options returns HTML Code for element. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Radio.pm0000644000175000017500000001051611455713641022735 0ustar thorstenthorstenpackage HTML::TurboForm::Element::Radio; use warnings; use strict; use Tie::IxHash; use base qw(HTML::TurboForm::Element); __PACKAGE__->mk_accessors( qw/ class special listmode pre post position labelclass/); sub render{ my ($self, $options, $view)=@_; if ($view) { $self->{view}=$view; } my $request=$self->request; my $result=''; my $disabled=''; my $class='form_radio'; if ($self->label) { $self->label(' ') if ($self->label eq ''); } else { $self->label(' '); } $class=$self->{class} if exists($self->{class}); $class=' class="'.$class.'" '; my $aha=$self->options; my $name=' name="'.$self->name.'" '; my $checked=''; if ($options->{frozen}){ $disabled=' disabled ' if ($options->{frozen} == 1) ; } my $pre=''; my $post=''; my $after=''; if ( $self->listmode ){ $result.='
      '; $pre='
    • '; $post='
    • '; $after='
    '; } $pre.=$self->pre if ($self->pre); $post.=$self->post if ($self->post); my $norm_hash=1; if ($self->options){ foreach (%{$self->options}){ $norm_hash=2 if (ref($_) eq 'HASH'); } if ($norm_hash==2){ for my $k2 ( sort{ $a <=> $b} keys %{$self->options} ) { while ( my( $key,$value) = each %{$self->options->{$k2}}){ my $values = $request->{ $self->name }; if (! $values){ $values = $self->default; } $values = [ $values ] unless ref( $values ) =~ /ARRAY/; $checked=''; if ([ $values ]) { $checked=' checked="true" ' if ( grep { $_ eq $value } @{ $values } ); } my $special=''; #$special='' if ($self->special==$k2); $result.=$pre.''.$key.$special.$post; $result.='' if (($disabled ne '')&& ( $checked ne '')); } } } else { while ( my( $key,$value) = each %{$self->options}){ # if (ref($value) eq 'HASH'){ print "wkfndfkhvbkh";} my $values = $request->{ $self->name }; if (! $values){ $values = $self->default; } $values = [ $values ] unless ref( $values ) =~ /ARRAY/; $checked=''; if ([ $values ]) { $checked=' checked ' if ( grep { $_ eq $value } @{ $values } ); } $result.=$pre.''.$key.$post; $result.='' if (($disabled ne '')&& ( $checked ne '')); } } } if ($self->optionsnum){ foreach (@{$self->optionsnum}){ while( my ($key, $value) = each %$_ ) { my $values = $request->{ $self->name }; if (! $values){ $values = $self->default; } if($self->labelclass){ $key='
    '.$key.'
    '; } my $keyr=$key; my $keyl=''; if ($self->position){ if ($self->position eq 'left') { $keyl=$key; $keyr=''; } } $values = [ $values ] unless ref( $values ) =~ /ARRAY/; $checked=''; if ([ $values ]) { $checked=' checked ' if ( grep { $_ eq $value if ($_) } @{ $values } ); } $result.=$pre.$keyl.''.$keyr.$post; $result.='' if (($disabled ne '')&& ( $checked ne '')); } } } $result.=$after; $result= $self->vor($options).$result.$self->nach if ($self->check_param('norow')==0); return $result; } 1; __END__ =head1 HTML::TurboForm::Element::Radio Representation class for HTML Radiobox element. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 render Arguments: $options returns HTML Code for Radiobox. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Captcha.pm0000644000175000017500000000657211455433374023253 0ustar thorstenthorstenpackage HTML::TurboForm::Element::Captcha; use warnings; use strict; use Crypt::Lite; use base qw(HTML::TurboForm::Element); __PACKAGE__->mk_accessors( qw/ session length keyname keyphrase/ ); sub render { my ($self, $options, $view)=@_; if ($view) { $self->{view}=$view; } my $request=$self->request; my $result=''; my $disabled=''; my $class='form_text'; $class = $self->class if ($self->class); $self->length(4) if (!$self->length); my $name=' name="'.$self->name.'_input" '; my $value=''; $value=' value="'.$request->{ $self->name }.'" ' if ($request->{ $self->name }); if ($options->{frozen} == 1) { my $text= $value; $disabled=' disabled '; $result=''; } my @numbers = (0,1,2,3,4,5,6,7,8,9); my $random = ''; for (my $i=0; $i < $self->length;$i++){ my $x = int(rand(scalar(@numbers))); $random .= $x; } my $k='_captcha'; $k=$self->keyname if ($self->keyname); $result=$self->print_number($random); my $crypt = Crypt::Lite->new( debug => 0, encoding => 'hex8' ); if ($self->keyphrase){ $random=$crypt->encrypt($random,$self->keyphrase); } my $tstamp=time(); $tstamp=$crypt->encrypt($tstamp,$self->keyphrase); if ($self->session && $self->name){ $self->session->{ $self->name.$k}=$random; $self->session->{ $self->name.$k.'2'}=$tstamp; } $self->{value}=$random; # $result .='' ; return $self->vor($options).$result.$self->nach; } sub get_value{ my ($self)=@_; my $k='_captcha'; $k=$self->keyname if ($self->keyname); my $val=$self->session->{ $self->name.$k }; if ($self->keyphrase){ my $crypt = Crypt::Lite->new( debug => 0, encoding => 'hex8' ); $val=$crypt->decrypt($val,$self->keyphrase); } return $val; } sub get_digit_matrix{ my ($self, $number)=@_; my @bitmasks = (31599, 18742, 29607, 31143, 18921, 31183, 31695, 18855, 31727, 31215); my @bits = (1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384); my @matrix=(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0); my $mask = $bitmasks[$number]; for (my $i=14;$i>0;$i--){ if (($mask / $bits[$i])>1) { $mask = $mask - $bits[$i]; $matrix[$i]=1; } } if ($mask == 1) { $matrix[0]=1; } return @matrix ; } sub print_matrix{ my ($self, @matrix)=@_; my $output =''; my $size = @matrix; for (my $i=0;$i<5;$i++) { for (my $k=0;$k < $size ;$k++){ for (my $j=0;$j<3;$j++) { if ( $matrix[$k][($j+(3*$i))] == 1 ){ $output.='  '; } else { $output.='  '; } } $output.='  '; } $output.='
    '; } return $output; } sub print_number{ my ($self, $number)=@_; my @matrix; for(my $i=0; $iget_digit_matrix($digit) ]; } return $self->print_matrix(@matrix); } 1; __END__ =head1 HTML::TurboForm::Element::Captcha Representation class for Captcha element. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 render Arguments: $options returns HTML Code for element. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Image.pm0000644000175000017500000001423311455433374022723 0ustar thorstenthorstenpackage HTML::TurboForm::Element::Image; use warnings; use strict; use base qw(HTML::TurboForm::Element); use Imager; __PACKAGE__->mk_accessors( qw/ prev upload keeporiginal width height savedir thumbnail loadurl caption maxsize errormessage / ); sub new{ my ($class, $request, $upload) = @_; my $self = $class->SUPER::new( $request ); $self->upload( $upload ); $self->do_img(); return $self; } sub do_img{ my ($self)=@_; my $request=$self->request; my $pic=''; $pic = $self->request->{$self->name} if ($self->request->{$self->name} ); if ($request->{ $self->name.'_upload' } && $request->{$self->name.'_submit'} ) { if( $self->upload->type !~ /^image\/(jpeg|jpg|gif|png|pjpeg)$/ ) { #$c->stash->{ 'error' } = 'Filetype not supported!'; } else { # read image my $image = Imager->new; $self->{sizeerror}=0; if ($self->maxsize) { if (($self->upload->size/1024) > $self->maxsize){ $self->{sizeerror}=1; } } if (!$self->{sizeerror}){ if( $image->read( file => $self->upload->tempname ) ) { # remove alpha channels because jpg does not support it # and its not used anyways $image = $image->convert( preset => 'noalpha' ); #attribute keeporignal isparams local path for storing orig sized images my $tmp = File::Temp->new( DIR => $self->savedir.'', UNLINK => 0, SUFFIX => '.jpg' ); $pic = substr( $tmp, length( $self->savedir )+1 ); $self->{pic}=$pic; if ($self->keeporiginal){ $self->upload->copy_to($self->keeporiginal.'/orig_'.$pic); } # if there is a save dir, resize. depending if width and/or height is given, scale to dimensions if ($self->savedir){ if (($self->width) and ($self->height)) { # No scale. Resize to given dimensions $image = $image->scaleX(pixels=>$self->width)->scaleY(pixels=>$self->height); } elsif ($self->width) { # Resize width, scale height $image = $image->scale(xpixels=>$self->width); } elsif ($self->height) { # Resize height, scale width $image = $image->scale(ypixels=>$self->height); } $image->write( file => $self->savedir.'/med_'.$pic, type => 'jpeg', jpegquality => 90 ); if ($self->thumbnail) { if ($self->thumbnail->{width} || $self->thumbnail->{height} ) { if (($self->thumbnail->{width}) and ($self->thumbnail->{height})) { # No scale. Resize to given dimensions $image = $image->scaleX(pixels=>$self->thumbnail->{width})->scaleY(pixels=>$self->thumbnail->{height}); } elsif ($self->thumbnail->{width}) { # Resize width, scale height $image = $image->scale(xpixels=>$self->thumbnail->{width}); } elsif ($self->thumbnail->{height}) { # Resize height, scale width $image = $image->scale(ypixels=>$self->thumbnail->{height}); } my $thmb_fn = $self->savedir.'/thumb_'.$pic; $thmb_fn = $self->thumbnail->{savedir}.'/thumb_'.$pic if ($self->thumbnail->{savedir}); $image->write( file => $thmb_fn, type => 'jpeg', jpegquality => 90 ); } } unlink($self->savedir.'/'.$pic); } } } } }#end of if upload and submit } sub get_value{ my ($self) = @_; my $result=''; my $request=$self->request; $result=$self->{pic}; if (!$self->{pic}){ $result=$request->{$self->name} if ($request->{$self->name}); } return $result; } sub render{ my ($self, $options, $view)=@_; if ($view) { $self->{view}=$view; } my $request=$self->request; my $result=''; my $disabled=''; my $class='form_image_select'; $self->label(' ') if ($self->label eq ''); $class=$self->{class} if exists($self->{class}); my $name=' name="'.$self->name.'_upload" '; my $checked=''; my $pic=''; $pic= $self->{pic} if ($self->{pic}); $pic=$request->{$self->name} if ($request->{$self->name}); $disabled=' disabled ' if ($options->{frozen} == 1); if ($options->{frozen} != 1 ){ $result.= $self->errormessage if ($self->{sizeerror} && $self->errormessage); $result.='get_attr().$disabled.$name.'>'; $result.=''; } $result.=''; if ($pic ne ''){ $result.="

    "; $result.="" if (($self->thumbnail) && ($self->prev)); } return $self->vor($options).$result.$self->nach; } 1; __END__ =head1 HTML::TurboForm::Element::Image Representation class for HTMl SelectBox element. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 render Arguments: $options returns HTML Code for select element. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Password.pm0000644000175000017500000000311111455433374023474 0ustar thorstenthorstenpackage HTML::TurboForm::Element::Password; use warnings; use strict; use base qw(HTML::TurboForm::Element); use Digest::SHA1 qw(sha1 sha1_hex); sub render { my ($self, $options, $view)=@_; if ($view) { $self->{view}=$view; } my $id=''; $id=' id="'.$self->id.'" ' if ($self->id); my $request=$self->request; my $result=''; my $disabled=''; my $class='form_text'; $class = $self->class if ($self->class); $class = 'class="'.$class.'"'; my $name=' name="'.$self->name.'" '; my $value=''; $value=' value="'.$request->{ $self->name }.'" ' if ($request->{ $self->name }); if ($options->{frozen}) { if ($options->{frozen} eq 1) { my $text= $value; $disabled=' disabled '; # $result=''; } } my $limit=''; $limit=' maxlength="'.$self->limit.'"' if ($self->limit); $result .='' ; return $self->vor($options).$result.$self->nach; } sub get_value{ my ($self) = @_; my $result=''; $result=$self->{request}->{$self->name} if exists($self->{request}->{$self->name}); return sha1_hex($result) if ($result); return '' if (!$result); } 1; __END__ =head1 HTML::TurboForm::Element::Password Representation class for HTML Password input element. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 render Arguments: $options returns HTML Code for element. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/.project0000644000175000017500000000055611455433374021424 0ustar thorstenthorsten formclass org.epic.perleditor.perlbuilder org.epic.perleditor.perlnature HTML-TurboForm-0.634/lib/HTML/TurboForm/Constraint/0000755000175000017500000000000011473014547022070 5ustar thorstenthorstenHTML-TurboForm-0.634/lib/HTML/TurboForm/Constraint/Email.pm0000644000175000017500000000143311455433374023461 0ustar thorstenthorstenpackage HTML::TurboForm::Constraint::Email; use warnings; use strict; use Email::Valid; use base qw(HTML::TurboForm::Constraint); sub check{ my ($self)=@_; my $request=$self->request; return 1 if Email::Valid->address( -address => $request->{$self->name} ); return 0; } sub message{ my ($self)=@_; return $self->{text}; } 1; __END__ =head1 HTML::TurboForm::Constraint::Email Representation class for Email constraint. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 check Arguments: none returns 1 if valid, otherwise 0. =head2 message Arguments: none returns Errormessage of Element which is connected to constraint. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Constraint/Required.pm0000644000175000017500000000166411455433374024220 0ustar thorstenthorstenpackage HTML::TurboForm::Constraint::Required; use warnings; use strict; use base qw(HTML::TurboForm::Constraint); __PACKAGE__->mk_accessors( qw/ emptyval / ); sub check{ my ($self)=@_; my $request=$self->request; my $result=0; my $empty = ''; $empty=$self->emptyval if ($self->emptyval); if (exists($request->{$self->{name}})) { $result=1 if ($request->{$self->{name}} ne $empty ); } return $result; } sub message{ my ($self)=@_; return $self->{text}; } 1; __END__ =head1 HTML::TurboForm::Constraint::Required Representation class for Required constraint. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 check Arguments: none returns 1 if valid, otherwise 0. =head2 message Arguments: none returns Errormessage of Element which is connected to constraint. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Constraint/Length.pm0000644000175000017500000000144411455433374023655 0ustar thorstenthorstenpackage HTML::TurboForm::Constraint::Length; use warnings; use strict; use base qw(HTML::TurboForm::Constraint); __PACKAGE__->mk_accessors( qw/ maxlength / ); sub check{ my ($self)=@_; my $result=0; my $request=$self->request; my $max = $self->maxlength; if ($max){ my $value=$request->{$self->{name}}; return 1 if( length($value) <= $max ); } return 0; } sub message{ my ($self)=@_; return $self->{text}; } 1; __END__ =head1 HTML::TurboForm::Constraint::Length Representation class for Length constraint. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 check Arguments: none returns 1 if valid, otherwise 0. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cutHTML-TurboForm-0.634/lib/HTML/TurboForm/Constraint/Equation.pm0000644000175000017500000000252311455433374024220 0ustar thorstenthorstenpackage HTML::TurboForm::Constraint::Equation; use warnings; use strict; use base qw(HTML::TurboForm::Constraint); __PACKAGE__->mk_accessors( qw/ operator comp / ); sub check{ my ($self)=@_; my $result=0; my $request=$self->request; my $op=''; my $comp_val; my $val=$request->{ $self->name }; $op= $self->operator; $comp_val = $self->comp ; if (($op eq "eq") or ($op eq "ne")) { if (($val)&&($comp_val)){ $val="'$val'"; $comp_val="'$comp_val'"; } } if ($val and $op and $comp_val ){ my $equation=$val." ".$op." ".$comp_val ; return 1 if( eval($equation) ); } return 0; } sub message{ my ($self)=@_; return $self->text; } 1; __END__ =head1 HTML::TurboForm::Constraint::Equation Representation class for Equation constraint. =head1 DESCRIPTION The equation constraint is supposed to be used whenever two values are to be compared. You have to give it the perl operator (ne, eq, <,>, whatever) and the two values to be compared via the params hash. Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 check Arguments: none returns 1 if valid, otherwise 0. =head2 message Arguments: none returns Errormessage of Element which is connected to constraint. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Constraint/Date.pm0000644000175000017500000000177011455433374023313 0ustar thorstenthorstenpackage HTML::TurboForm::Constraint::Date; use warnings; use strict; use Date::Calc qw/check_date/; use base qw(HTML::TurboForm::Constraint); sub check{ my ($self)=@_; my $result=0; my $day=''; my $month=''; my $year=''; my $request=$self->request; $day=$request->{$self->{name}.'_day'};# if (exists($request->{$self->{name}.'_day'})); $month=$request->{$self->{name}.'_month'};# if (exists($request->{$self->{name}.'_month'})); $year=$request->{$self->{name}.'_year'};# if (exists($request->{$self->{name}.'year'})) ; return 1 if( check_date( $year,$month,$day ) ); return 0; } sub message{ my ($self)=@_; return $self->{text}; } 1; __END__ =head1 HTML::TurboForm::Constraint::Date Representation class for Date constraint. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 check Arguments: none returns 1 if valid, otherwise 0. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Constraint/Mintime.pm0000644000175000017500000000226611455433374024041 0ustar thorstenthorstenpackage HTML::TurboForm::Constraint::Mintime; use warnings; use strict; use base qw(HTML::TurboForm::Constraint); use Crypt::Lite; __PACKAGE__->mk_accessors( qw/ mintime session keyphrase keyname / ); sub check{ my ($self)=@_; my $request=$self->request; my $result=0; my $mintime = 5; $mintime=$self->mintime if ($self->mintime); my $time=time(); my $id=$self->name; $id=$self->name.$self->keyname if ($self->keyname); my $t=$self->session->{$id}; my $crypt = Crypt::Lite->new( debug => 0, encoding => 'hex8' ); if ($self->keyphrase) { $t=$crypt->decrypt($t,$self->keyphrase); } $result=1 if (($time-$mintime) > $t); return $result; } sub message{ my ($self)=@_; return $self->{text}; } 1; __END__ =head1 HTML::TurboForm::Constraint::Required Representation class for Required constraint. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 check Arguments: none returns 1 if valid, otherwise 0. =head2 message Arguments: none returns Errormessage of Element which is connected to constraint. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Constraint/Regex.pm0000644000175000017500000000145111455433374023504 0ustar thorstenthorstenpackage HTML::TurboForm::Constraint::Regex; use warnings; use strict; use base qw(HTML::TurboForm::Constraint); __PACKAGE__->mk_accessors( qw/ regex / ); sub check{ my ($self)=@_; my $result=0; my $request=$self->request; my $regex = $self->regex; my $value=$request->{$self->{name}}; return 1 if (!$value); if ($regex){ return 1 if( $value =~ qr/$regex/ ); } return 0; } sub message{ my ($self)=@_; return $self->{text}; } 1; __END__ =head1 HTML::TurboForm::Constraint::Regex Representation class for Regex constraint. =head1 DESCRIPTION Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details. =head1 METHODS =head2 check Arguments: none returns 1 if valid, otherwise 0. =head1 AUTHOR Thorsten Domsch, tdomsch@gmx.de =cutHTML-TurboForm-0.634/lib/HTML/.project0000644000175000017500000000055611455433374017505 0ustar thorstenthorsten formclass org.epic.perleditor.perlbuilder org.epic.perleditor.perlnature HTML-TurboForm-0.634/lib/.project0000644000175000017500000000056011455433374016734 0ustar thorstenthorsten html formfu org.epic.perleditor.perlbuilder org.epic.perleditor.perlnature HTML-TurboForm-0.634/inc/0000755000175000017500000000000011473014547015264 5ustar thorstenthorstenHTML-TurboForm-0.634/inc/Module/0000755000175000017500000000000011473014547016511 5ustar thorstenthorstenHTML-TurboForm-0.634/inc/Module/AutoInstall.pm0000644000175000017500000005330611455433374021320 0ustar thorstenthorsten#line 1 package Module::AutoInstall; use strict; use Cwd (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.03'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps ); my ( $PostambleActions, $PostambleUsed ); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::cwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. my $cur = _load($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { if (not defined $cur) # indeed missing { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; } else { # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above print "too old. ($cur < $arg)\n"; } push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) { require Config; print "*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n"; # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89') { if ($cpan_env) { return _running_under('CPAN'); } return; # CPAN.pm new enough, don't need to check further } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed ); while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) { # grep out those already installed if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { push @installed, $pkg; } else { push @modules, $pkg, $ver; } } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^force$/; # pseudo-option $CPAN::Config->{$opt} = $arg; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $args{force} ? CPAN::Shell->force( install => $pkg ) : CPAN::Shell->install($pkg); $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::cwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # class/instance doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; if ( $CPAN::HandleConfig::VERSION ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison # return values same as <=> sub _version_cmp { my ( $cur, $min ) = @_; return -1 unless defined $cur; # if 0 keep comparing return 1 unless $min; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return version->new($cur) <=> version->new($min); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return Sort::Versions::versioncmp( $cur, $min ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return $cur <=> $min; } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; return <<"END_MAKE"; config :: installdeps \t\$(NOECHO) \$(NOOP) checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions END_MAKE } 1; __END__ #line 1056 HTML-TurboForm-0.634/inc/Module/Install/0000755000175000017500000000000011473014547020117 5ustar thorstenthorstenHTML-TurboForm-0.634/inc/Module/Install/Fetch.pm0000644000175000017500000000462711455433374021522 0ustar thorstenthorsten#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; HTML-TurboForm-0.634/inc/Module/Install/Win32.pm0000644000175000017500000000340311455433374021362 0ustar thorstenthorsten#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; HTML-TurboForm-0.634/inc/Module/Install/Can.pm0000644000175000017500000000333311455433374021163 0ustar thorstenthorsten#line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 HTML-TurboForm-0.634/inc/Module/Install/AutoInstall.pm0000644000175000017500000000227311455433374022723 0ustar thorstenthorsten#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub AutoInstall { $_[0] } sub run { my $self = shift; $self->auto_install_now(@_); } sub write { my $self = shift; $self->auto_install(@_); } sub auto_install { my $self = shift; return if $self->{done}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; my @config = @_; # We'll need Module::AutoInstall $self->include('Module::AutoInstall'); require Module::AutoInstall; Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); $self->makemaker_args( Module::AutoInstall::_make_args() ); my $class = ref($self); $self->postamble( "# --- $class section:\n" . Module::AutoInstall::postamble() ); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; HTML-TurboForm-0.634/inc/Module/Install/Base.pm0000644000175000017500000000176611455433374021344 0ustar thorstenthorsten#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '0.91'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { $_[0]->admin->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 154 HTML-TurboForm-0.634/inc/Module/Install/Makefile.pm0000644000175000017500000001600311455433374022175 0ustar thorstenthorsten#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing, always use defaults if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } sub makemaker_args { my $self = shift; my $args = ( $self->{makemaker_args} ||= {} ); %$args = ( %$args, @_ ); return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = sShift; my $name = shift; my $args = $self->makemaker_args; $args->{name} = defined $args->{$name} ? join( ' ', $args->{name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } my %test_dir = (); sub _wanted_t { /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; } sub tests_recursive { my $self = shift; if ( $self->tests ) { die "tests_recursive will not work if tests are already defined"; } my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } %test_dir = (); require File::Find; File::Find::find( \&_wanted_t, $dir ); $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{VERSION} = $self->version; $args->{NAME} =~ s/-/::/g; if ( $self->tests ) { $args->{test} = { TESTS => $self->tests }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = $self->author; } if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { $args->{NO_META} = 1; } if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } # Merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, ($self->configure_requires, $self->build_requires, $self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # merge both kinds of requires into prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $prereq->{$file}; } } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } $args->{INSTALLDIRS} = $self->installdirs; my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if (my $preop = $self->admin->preop($user_preop)) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 394 HTML-TurboForm-0.634/inc/Module/Install/Include.pm0000644000175000017500000000101511455433374022040 0ustar thorstenthorsten#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; HTML-TurboForm-0.634/inc/Module/Install/WriteAll.pm0000644000175000017500000000222211455433374022201 0ustar thorstenthorsten#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91';; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { $self->makemaker_args( PL_FILES => {} ); } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; HTML-TurboForm-0.634/inc/Module/Install/Metadata.pm0000644000175000017500000003530411455433374022205 0ustar thorstenthorsten#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract author version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords }; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless $self->author; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub perl_version_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ^ (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; $author =~ s{E}{<}g; $author =~ s{E}{>}g; $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } sub license_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ( =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b .*? ) (=head\\d.*|=cut.*|) \z /ixms ) { my $license_text = $1; my @phrases = ( 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s{\s+}{\\s+}g; if ( $license_text =~ /\b$pattern\b/i ) { $self->license($license); return 1; } } } warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } sub _extract_bugtracker { my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than on rt.cpan.org link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; HTML-TurboForm-0.634/inc/Module/Install/Scripts.pm0000644000175000017500000000101111455433374022100 0ustar thorstenthorsten#line 1 package Module::Install::Scripts; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub install_script { my $self = shift; my $args = $self->makemaker_args; my $exe = $args->{EXE_FILES} ||= []; foreach ( @_ ) { if ( -f $_ ) { push @$exe, $_; } elsif ( -d 'script' and -f "script/$_" ) { push @$exe, "script/$_"; } else { die("Cannot find script '$_'"); } } } 1; HTML-TurboForm-0.634/inc/Module/Install.pm0000644000175000017500000002411411455433374020462 0ustar thorstenthorsten#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '0.91'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); use Cwd (); use File::Find (); use File::Path (); use FindBin; sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; unless ( -f $self->{file} ) { require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{"$self->{file}"}; delete $INC{"$self->{path}.pm"}; # Save to the singleton $MAIN = $self; return 1; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } sub _read { local *FH; if ( $] >= 5.006 ) { open( FH, '<', $_[0] ) or die "open($_[0]): $!"; } else { open( FH, "< $_[0]" ) or die "open($_[0]): $!"; } my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } sub _write { local *FH; if ( $] >= 5.006 ) { open( FH, '>', $_[0] ) or die "open($_[0]): $!"; } else { open( FH, "> $_[0]" ) or die "open($_[0]): $!"; } foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2009 Adam Kennedy. HTML-TurboForm-0.634/MANIFEST0000644000175000017500000000274611455433374015660 0ustar thorstenthorsten.project inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Scripts.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/.project lib/HTML/.project lib/HTML/TurboForm.pm lib/HTML/TurboForm/.project lib/HTML/TurboForm/Constraint.pm lib/HTML/TurboForm/Constraint/Date.pm lib/HTML/TurboForm/Constraint/Email.pm lib/HTML/TurboForm/Constraint/Equation.pm lib/HTML/TurboForm/Constraint/Length.pm lib/HTML/TurboForm/Constraint/Regex.pm lib/HTML/TurboForm/Constraint/Mintime.pm lib/HTML/TurboForm/Constraint/Required.pm lib/HTML/TurboForm/Element.pm lib/HTML/TurboForm/Element/Captcha.pm lib/HTML/TurboForm/Element/Checkbox.pm lib/HTML/TurboForm/Element/Date.pm lib/HTML/TurboForm/Element/Hidden.pm lib/HTML/TurboForm/Element/Html.pm lib/HTML/TurboForm/Element/Image.pm lib/HTML/TurboForm/Element/Imageupload.pm lib/HTML/TurboForm/Element/Imagegalerie.pm lib/HTML/TurboForm/Element/Imageslider.pm lib/HTML/TurboForm/Element/Radio.pm lib/HTML/TurboForm/Element/Range.pm lib/HTML/TurboForm/Element/Select.pm lib/HTML/TurboForm/Element/Password.pm lib/HTML/TurboForm/Element/Slider.pm lib/HTML/TurboForm/Element/Submit.pm lib/HTML/TurboForm/Element/Text.pm lib/HTML/TurboForm/Element/Textarea.pm lib/HTML/TurboForm/Element/Upload.pm Makefile.PL MANIFEST This list of files META.yml HTML-TurboForm-0.634/.project0000644000175000017500000000055611455433374016173 0ustar thorstenthorsten TurboForm org.epic.perleditor.perlbuilder org.epic.perleditor.perlnature HTML-TurboForm-0.634/META.yml0000644000175000017500000000111211455433374015762 0ustar thorstenthorsten--- abstract: 'fast and compact HTML Form Class' author: - 'Thorsten Drobnik, camelcase@hotmail.com' build_requires: ExtUtils::MakeMaker: 6.42 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 0.91' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: HTML-TurboForm no_index: directory: - inc requires: Date::Calc: 0 Email::Valid: 0 Imager: 0 UNIVERSAL::require: 0 YAML::Syck: 0 resources: license: http://dev.perl.org/licenses/ version: 0.628 HTML-TurboForm-0.634/Makefile.PL0000644000175000017500000000041311455433374016466 0ustar thorstenthorstenuse inc::Module::Install; name 'HTML-TurboForm'; all_from 'lib/HTML/TurboForm.pm'; requires 'YAML::Syck'; requires 'Email::Valid'; requires 'UNIVERSAL::require'; requires 'Date::Calc'; requires 'Imager'; install_script glob('script/*.pl'); auto_install; WriteAll;