File Coverage

blib/lib/HTML/GUI/widget.pm

Criterion	Covered	Total	%
statement	29	148	19.5
branch	0	42	0.0
condition	0	18	0.0
subroutine	10	29	34.4
pod			n/a
total	39	237	16.4

package HTML::GUI::widget;

use warnings;
use strict;

=head1 NAME

HTML::GUI::widget - Create and control GUI for web application

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.04';

use Locale::TextDomain qw (GUI::HTML);
use POSIX qw(strftime);
use Data::Compare;
use YAML::Syck;
use HTML::GUI::tag;
use HTML::GUI::log::eventList;

use Log::Log4perl qw(:easy);

our @ISA = qw(HTML::GUI::tag);

=head1 WIDGET

base class for HTML widgets

=cut

#the root directory to look after the screen definition
our $rootDirectory = '/' ;

# Define the default values for the new widget
my %GHW_defaultValue = (display =>1 , constraints => []);

# array of string : list of all public properties of the widget
my @publicPropList = qw/type value id display
						constraints label title class disabled/;


=head1 PUBLIC METHODS

=pod

=head3 new

   Parameters :
      params : hash ref : Contains the properties of the widget :
				-type : text, select, checkbox
				-value : the value of the widget
				-id : the id of the widget (mandatory)
				-display : if false, the fied has the propertie style="display:none"
				-constraints : array ref of contraints names
				-label : text associated with the fiel
				-title : title to display when the mouse cursor is over the widget
				-class : css class to associate with the widget
				-disabled : the widget is disabled or not

   Return :


   Description :
      create a new html widget.
      It can be feed with data manually or automatically with a hash.

=cut

sub new
{
  my($class,
     $params) = @_;
  my $this = $class->SUPER::new($params);

 foreach my $propName(@publicPropList){
   if (exists $params->{$propName}){
     $this->{$propName} = $params->{$propName};
		 #we don't like undef as property value
		 $this->{$propName} = '' unless defined $this->{$propName};
	 }else{
		 $this->{$propName} =
						$GHW_defaultValue{$propName} ||"";
	 }
 }
 $this->{alert} = [];
 $this->{debug} = [];

 $this->{style} = [];
 $this->{class} = [];

 $this->{parent} = undef; #a ref to the parent widget

 bless($this, $class);
}


=head1 FACTORY

 instantiante any widget previously serialized

=cut

=pod

=head3 instantiate

  Create widgets from the data structure $data
	This is a class method so it should be use like this :
				HTML::GUI::widget->instantiate($myString)

  Parameters :
	  -$data : the data structure which describe the widgets
		-$path : the path (used to name the screen objects)

	Return :
		a widget or undef if the $data is not correct

=cut

sub instantiate {
  my ($class,$data,$path) = @_;

	if (!$data || !exists $data->{type}){
		return undef;
	}
	my $wtype = $data->{type}.'::' ;
	if (!exists $HTML::GUI::{$wtype}){
		my $moduleFilename = $data->{type}.'.pm';
		if ($moduleFilename !~ '::'){
				#no namespace specified => this is a HTML::GUI native
				#widget
				$moduleFilename = 'HTML::GUI::'.$moduleFilename;
		}
		#convert module name to fileName
		$moduleFilename =~ s/::/\//g;

		require $moduleFilename;
  }

# Rastafarian code inside !!
# Automatic instantation of widgets
# We explore the available packages to instantiate
# 	the good objects (see perlmod and perlobj for more explanation
# 	about this particular notation).

		my $package = $HTML::GUI::{$wtype};
		my $constructor = $package->{new};
	  return &$constructor('HTML::GUI::'.$data->{type},$data,$path);

}

=pod

=head3 instantiateFromYAML

  Instantiante a widget from a yaml string
	This is a class method so it should be use like this :
				HTML::GUI::widget->instantiateFromYAML($myString)

	parameters :
	- $class : the className
	- $yamlString : the yaml string describing the widget
	- $path : the path (used to name the screen objects)

	returns :
	-the new widget or undef if the yaml does not describe a widget

=cut

sub instantiateFromYAML{
  my ($class,$yamlString,$path) = @_;

	$YAML::Syck::ImplicitTyping =1 ;
	$YAML::Syck::ImplicitUnicode=1; #try to get correct utf8 handling
	my $descriptionData  = YAML::Syck::Load($yamlString);
  return HTML::GUI::widget->instantiate($descriptionData,$path);

}
=pod

=head3 setParent

   Return :
				nothing

   Description :
				set the reference to the parent of the widget in the widget tree

=cut

sub setParent
{
  my($self,$parent) = @_;
	$self->{parent} = $parent;

}

=pod

=head3 top

   Return :
     the root of the widget tree or itself if the widget doesn't belong to
		 any container

=cut
sub top {
  my($self) = @_;
	if (defined $self->{parent}){
		return $self->{parent}->top();
	}else{
		return $self;
	}
}


=pod

=head3 setRootDirectory

   Description :
				Define the root Directory of the screen definitions

=cut

sub setRootDirectory
{
  my ($class,$rootDir)=@_;
	$HTML::GUI::widget::rootDirectory = $rootDir;
}

=pod

=head3 getRootAncestor

   Description :
      search the root of the current widget tree.

   Return :
      The root object of the current tree

=cut
sub getRootAncestor
{
  my($self) = @_;
	if (defined $self->{parent}){
		return $self->{parent}->getRootAncestor();
	}else{
		return $self;
	}
}

=pod

=head3 getHtml

   Parameters :

   Return :
      string

   Description :
      Return the html of the widget.

=cut

sub getHtml
{
  my($self    ) = @_;
#UML_MODELER_BEGIN_PERSONAL_CODE_getHtml
#UML_MODELER_END_PERSONAL_CODE_getHtml
}


=pod

=head3 getId

   Return :
				string

   Description :
      return the id of the widget.

=cut

sub getId
{
  my($self) = @_;
	return $self->{id};
}

=pod

=head3 getIds

   Return :
				array

   Description :
      return an array of the ids of the widget.
			For simple widget, it's the same thing as getId
			but it's different for container which can have many widgets.

=cut

sub getIds
{
  my($self) = @_;
	return ($self->{id});
}

=pod

=head3 getTempId

  Return a new widget id who is unique for the current screen.

=cut
my $idCounter = 0;
sub getTempId{
  my($self) = @_;
	$idCounter++;
	return 'GHW::tmpId::'.$idCounter;
}

=pod

=head3 getElementById

   Parameters :
      id : string : id of the object to find.

   Description :
				return the widget whose id is $id or undef if no object has this id


=cut

sub getElementById
{

  my($self,$id) = @_;

	return undef unless ($id eq $self->getId());

	return $self;
}


=pod


=head3 getStyleContent

   Description :
     return the content of the html 'style' attribute
   Parameters :
      style : hashref : reference to a hash containing all styles attributs ; if not defined, the function use $self->style to generate a html content

=cut
sub getStyleContent($$){
		my ($self,$style)=@_;
		my @styleList = ();
		my $styleData = $style;
		my @propNames = ();
		@propNames = keys %$styleData;
		@propNames = sort {$a cmp $b} @propNames; #always the same order

		foreach my $styleProp (@propNames){
				push @styleList, $styleProp.":".$style->{$styleProp};
		}

		return join ";",@styleList;
}



=pod

=head3 setProp

   Parameters :
      params : hash ref : defines params value

   Return :


   Description :


=cut

sub setProp
{
  my($self,
     $params, # hash ref : defines params value
    ) = @_;
  my $pubPropHash = $self->getPubPropHash();
 foreach my $propName(keys %$params){
		if (!$pubPropHash->{$propName}){
				$self->alert( __x("Propertie [{propName}] doesn't exists !!"
										."Can't set value [{value}] ",
										propName		=> $propName,
										value				=> $params->{$propName}));
		}else{
				$self->{$propName} = $params->{$propName} || "";
		}
 }
}


=pod

=head3 getProp

   Parameters :
      $propName : the name of the property we want to read

   Return :
		   - the value of the property if it exists
			 - undef if the property doesn't exists

=cut

sub getProp
{
  my($self,
     $propName,
    ) = @_;
  my $pubPropHash = $self->getPubPropHash();
		if (!$pubPropHash->{$propName}){
				$self->alert( __x("Propertie [{propName}] doesn't exists !!"
										."Can't get the value !!",
										propName		=> $propName,));
				return undef;
		}else{
				return $self->{$propName};
		}
}


=pod

=head3 getDefinitionData

  This method is the miror of the "new" method it generate a data structure that defines the widget, calling the "new" function with this hash ref will create the same widget. It is usefull for serialing a widget.
  With no parameters it works for a generic widget, but it is possible to specify paramters in order to specialise the behavior for a particular class.
	The expression "definition data" means the data that are specified when calling the 'new' function. Exemple :

my $definitionData = {id	=> "textObject",
          				value=> '2'};

my $textInputWidget = HTML::GUI::text->new($definitionData);

  Parameters :
		- $paramPublicProp : the hash to feed with the public properties, if undef a new hash is created
		- $paramDefaultValue : an ARRAY ref containing a list of the default values (if a propertie is set to a default value, il is not specified as a "definition data"), if undef the default values of generic widgets is used
		- $paramPublicPropList : the list of properties that can be "definition data", if undef the list of public properties of a generic widget is used

  Return :
		- a ref to the hash that define the public properties of the widget

=cut
sub getDefinitionData($;$$$)
{
  my ($self,$paramPublicProp,$paramDefaultValue, $paramPublicPropList) = @_;

  my $publicProp = $paramPublicProp || {};
	my $defaultValues = $paramDefaultValue ?
						$paramDefaultValue : \%GHW_defaultValue;
  my $publicPropList = $paramPublicPropList ?
						$paramPublicPropList :\@publicPropList;

	foreach my $propName(@{$publicPropList}){
   if (exists $self->{$propName} ){
		 my $defaultValue = $defaultValues->{$propName};
		 if (defined $defaultValue
				&& Data::Compare::Compare($self->{$propName}, $defaultValue)){
			  next;
		 }elsif(!ref $self->{$propName}
						&& $self->{$propName} eq ''){
				next;
		 }elsif('ARRAY' eq ref $self->{$propName}
						&& ! scalar @{$self->{$propName}}){
				next;
		 }
		$publicProp->{$propName} = $self->{$propName};
	 }
	}
	return $publicProp;
}

=pod

=head3 serializeToYAML

		return a string describing the current widget in YAML format

=cut

sub serializeToYAML
{
  my ($self)=@_;
	$YAML::Syck::ImplicitTyping =1 ;
	$YAML::Syck::ImplicitUnicode=1; #try to get correct utf8 handling
  my $dataString =YAML::Syck::Dump($self->getDefinitionData());
	#we want a utf-8 encoded string
	#so we convert the escape sequences (\x09...)
	$dataString =~ s/\\x([0-9A-Fa-f]{2})/chr(hex($1))/eg;
	return $dataString;
}


=pod

=head3 writeToFile

  write the seralization of the current objet into the file $fileName.
	Currently, only the YAML is available, so $fileName MUST be like "*.yaml"
	Parameters :
	 - $fileName : the name of the file to write into
  returns :
	 - 1 if the operation terminates normally
	 - 0 if a problem occurs

=cut

sub writeToFile
{
  my ($self,$fileName)=@_;
	if ($fileName !~ /\.yaml$/){
		#TODO : rise an error here
		return 0;
	}
	my $dataString = $self->serializeToYAML ();
	open(FH,'>:utf8',"$fileName") or return 0 ;

  print FH  $dataString;
  close FH;
	return 1;
}

=pod

=head3 instantiateFromFile

  Instantiate widgets from a file
	Currently, only the YAML format is available, so $fileName MUST be like "*.yaml"
	Parameters :
	 - $fileName : the name of the file to read
	 - $baseDir (optional) : the base Directory (this path is added befaor $fileName
														to effectively locate the file on the filesystem)
  returns :
	 - the widgets object newly created if the operation terminates normally
	 - undef if a problem occurs

=cut
sub instantiateFromFile
{
  my ($class,$fileName,$baseDir)=@_;
	my $wholeName = '';


	if (defined $baseDir){
		$wholeName = $baseDir.$fileName;
	}else{
		$wholeName = $rootDirectory.$fileName;
  }

	if (!-e $wholeName){
		die "the file $wholeName doesn't exists";
	}
  undef $/; #we want to read the whole flie at once
	open DATAFILE ,'<:encoding(utf8)', $wholeName;
  my $whole_file = ;
	close DATAFILE;
	if ($fileName =~ /\.yaml$/){
	  return HTML::GUI::widget->instantiateFromYAML($whole_file,$fileName);
	}
	return undef;
}

=pod

=head3 clone

   Parameters :
      params : hash ref : params to overload the params of the current objet (changing the id is a good idea)

   Return :
      widget

   Description :


=cut

sub clone
{
  my($self,
     $params, # hash ref : params to overload the params of the current objet (changing the id is a good idea)
    ) = @_;
#UML_MODELER_BEGIN_PERSONAL_CODE_clone
#UML_MODELER_END_PERSONAL_CODE_clone
}


=pod

=head3 error

   Parameters :
      type : string : Visibility of the error (pub/priv)
      params :  hashref : params of the error
   Description :
                 record one error in the current objet

=cut

sub error
{
		my($self,
				$params, # hashref : params of the error
		) = @_;
		my $eventList = HTML::GUI::log::eventList::getCurrentEventList();
		my %errorParams = ( visibility => 'pub',
                      	'error-type' => 'internal',);
		foreach my $paramName qw/visibility error-type constraint-info message/{
				if (exists $params->{$paramName}){
						$errorParams{$paramName} = $params->{$paramName};
				}
		}
		$errorParams{widgetSrc} = $self;
		my $errorEvent =  HTML::GUI::log::error->new(\%errorParams);
		DEBUG "ERREUR :".$errorEvent->getMessage();
		$eventList->addEvent($errorEvent);
}



=head3 printTime

   Parameters :
      $time : string : a value returned by the function time
   Description :
		  return a human readable string of the date $time

=cut
sub printTime($$)
{
  my ($self,$time)=@_;
  return  strftime "%a %b %e %H:%M:%S %Y", localtime($time);
}

=head3 dumpStack

   Parameters :
      stackName : string : name of the stack to convert to string
   Description :
		  return a human readable string of the stack $stackName

=cut
sub dumpStack
{
  my ($self,$stackName)=@_;
	my $dumpString="";
  my %stackNames = (
				error => 'error',
				debug => 'debug',
				alert => 'alert',
		);
  if (!exists $stackNames{$stackName}){
		return "bad stack name [".$stackName."]\n";
	}
  foreach my $event (@{$self->{$stackName}}){
		$dumpString .= "[".$self->printTime($event->{time})."]";
		$dumpString .= $event->{message}."\n";
		foreach my $frame (@{$event->{stack}}){
				$dumpString .= "  ->".$frame->{subroutine}
										." line:".$frame->{line}
										." in:".$frame->{filename}."\n";
		}
		$dumpString .="\n";
	}
	return $dumpString;
}


=pod

=head3 getCurrentStack

   Description :
		  return a array of the current stack

=cut
sub getCurrentStack
{
  my ($self) = @_;
	my @stack  ;
	my $i=0;
  my ($package, $filename, $line,$subroutine) ;
	while ($i==0 || $filename){
	($package, $filename, $line,$subroutine) = caller($i);
			push @stack, {
					'package' => $package,
					filename => $filename,
					line			=> $line,
					subroutine=> $subroutine,
			} unless (!defined $filename);
			$i++;
	}
	return \@stack;
}

=head3 alert

   Description :
		  store an alert message in the current objet

=cut
sub alert($$)
{
  my($self,
     $message, # string : alert message
    ) = @_;
		push @{$self->{alert}},{
				'time'=>time,
				message => $message,
				stack		=> $self->getCurrentStack(),
				};
}

=head3 debug

   Parameters :
      message : string : message to debug
   Description :
		  record one debug in the current objet


=cut

sub debug($)
{
  my ($self,$message)=@_;
		push @{$self->{debug}},{
				'time'=>time,
				message => $message,
				};
}


=head3 getLabel

   Description :
		  return the label of the current obj


=cut
sub getLabel()
{
  my ($self) = @_;
	return $self->{label};
}

=head3 getLabelHtml

   Description :
		  return the html of the label of the current obj
			If the label is a void string, return ''


=cut

sub getLabelHtml
{
  my ($self)=@_;
  my %tagProp =();
	my $label = $self->{label};

	if ($label eq ''){
  	return '';
	}
	$tagProp{for} = $self->{id};

	return $self->getHtmlTag("label",\%tagProp, $self->escapeHtml($label));
}


=head1 METHODS FOR SUBCLASSING



=cut


=head1 PRIVATE METHODS



=cut



=head3 getPubPropHash

   Returns :
      propHash : hash : a hash containing the value '1' pour each public propertie


=cut

my $pubPropHash = undef;
sub getPubPropHash{
 my($self    ) = @_;

 return $pubPropHash if (defined $pubPropHash);
 foreach my $propName(@publicPropList){
			$pubPropHash->{$propName} = 1;
 }
 return $pubPropHash;
}

=head3 getPath

   Return :
      a string containing the actual path of the module

=cut

sub getPath
{
  my($self    ) = @_;

  my $path = $INC{'HTML/GUI/container.pm'};
	$path =~ s/container.pm$//;
	return $path;
}


=pod

=head3 validate

   Description :
		  All widgets are OK by default. The input widgets have custom
			validate function to implements constraints.

   Return :
      always 1

=cut

sub validate
{
  my($self    ) = @_;
	return 1;
}


=pod

=head3 getValueHash

		Description :
				Default method for all non-input and non-container widgets
		Return :
			undef

=cut

sub getValueHash
{
  my($self) = @_;
	return undef;
}


=head3 fired

	 Parameters :
		 $params : the hash ref containing the POST key-value pairs.

   Decription :
		this function aims to be specialized for buttons.

   Returns :
      - true if the current object was fired
			- false otherwise

=cut
sub fired
{
  my($self,$params) = @_;

	return 0;
}

=head3 getNodeSession

   Decription :
		 return a hash ref to the session. This is a low level API to
		 manage multiple user session in multiple windows.
		 This function MUST be refined by the choosen engine.

   Returns :
      - a hash ref to the session corresponding to the user agent cookie
			- a void hash ref if no session can be found

=cut
sub getNodeSession
{
  return {};
}

=head3 getSession

   Decription :
		 return a hash ref to the session corresponding to one window of the browser. If a user opens two windows of the same brower, he will need to connect two times, getSession will return two different sessions.
		 This method MUST be implemented by the engine

   Returns :
      - a hash ref to the session corresponding to the user agent cookie
			- a void hash ref if no session can be found

=cut
sub getSession
{
  return {};
}

=pod

=head3 getFunctionFromName

		Description :
				Find the function whose name is $functionName
				If the module of the function not loaded, it will be loaded automatically.

		Returns :
				- a ref to the function whose name is $functionName if it exists
				- undef if no function of this name exists

=cut
sub getFunctionFromName{
 my ($self,$functionName) = @_;
 if (!$functionName){
		return undef; #nothing to do
 }
 my @funcPath = split '::',$functionName;
 my $funcName = pop @funcPath;
 my $moduleName = join '::',@funcPath;
 #for testing purpose
 $moduleName ||= 'main';
 $functionName = $moduleName.'::'.$funcName;
 if (!defined &{$functionName}){
		 my $status = undef;
			my $evalError = '';
		if ($moduleName ne ''){
			$status = eval "require $moduleName";
			$evalError = $@;
		}
	 if (!defined $status  && $moduleName ne ''){
			 my $msg = '['.$moduleName."] is not a valid module name : ".$evalError;
			 ERROR($msg);
			 $self->error({
						'message' =>$msg,
						});
				return undef;
	 }elsif(!defined &{$functionName}){
			 my $msg = '['.$moduleName.'] is not a valid module name';
			 ERROR($msg);
		 	 $self->error({
						'message' => $msg,
						});
				return undef
	 }
 }
 return \&{$functionName};
}
=head1 AUTHOR

Jean-Christian Hassler, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to
C, or through the web interface at
L.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.


=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc HTML::GUI::widget

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * RT: CPAN's request tracker

L

=item * Search CPAN

L

=back

=head1 ACKNOWLEDGEMENTS

=head1 COPYRIGHT & LICENSE

Copyright 2007 Jean-Christian Hassler, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of HTML::GUI::widget