# HG changeset patch # User wizard # Date 1268092245 -10800 # Node ID 0f3e369553bdfa164ce89a283b34d87da610eab8 # Parent a35b60b16a99c6bd2033f7baacd1636a97eec61e Rewritten property implementation (probably become slower but more flexible) Configuration infrastructure in progress (in the aspect of the lazy activation) Initial concept for the code generator diff -r a35b60b16a99 -r 0f3e369553bd Lib/DOM/Providers/Headlines.pm --- a/Lib/DOM/Providers/Headlines.pm Fri Mar 05 20:14:45 2010 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,128 +0,0 @@ -package DOM::Providers::Headlines::Headline; -use Common; -use Time::Local; -our @ISA = qw(Object); - -BEGIN { - DeclareProperty(Id => ACCESS_READ); - DeclareProperty(DateModify => ACCESS_READ); - DeclareProperty(DateExpire => ACCESS_READ); - DeclareProperty(URL => ACCESS_READ); - DeclareProperty(Text => ACCESS_READ); - DeclareProperty(Channel => ACCESS_READ); -} - -sub str2time { - my $str = shift; - - if ($str =~ /^(\d{4})-(\d{2})-(\d{2})(?:\s(\d{2}):(\d{2}):(\d{2}))?$/) { - my ($year,$month,$day,$hh,$mm,$ss) = ($1,$2-1,$3,(defined $4 ? $4 : 0),(defined $5 ? $5 : 0),(defined $6 ? $6 : 0)); - return timelocal($ss,$mm,$hh,$day,$month,$year); - } else { - die new Exception("A string '$str' isn't an ISO standard time"); - } -} - -sub IsActive { - my ($this) = @_; - my $timeExpire = str2time($this->{$DateExpire}); - - return ($timeExpire > time()); -} - -package DOM::Providers::Headlines::Collection; -use Common; -our @ISA = qw (Object); - -BEGIN { - DeclareProperty(Items => ACCESS_READ); -} - -sub CTOR { - my ($this,%args) = @_; - - foreach my $headline (@{$args{'Items'}}) { - $this->{$Items}->{$headline->Id()} = $headline if ($headline->IsActive) - } -} - -sub as_list { - my $this = shift; - - return [ map { $this->{$Items}->{$_} } sort keys %{$this->{$Items}} ]; -} - -sub GenerateRandomSequence { - my ($count,$max) = @_; - - my %hash; - $hash{rand()} = $_ foreach (0 .. $max - 1); - my @sequence = map { $hash{$_} } sort keys %hash; - return splice @sequence,0,$count; -} - -sub Random { - my ($this,$count) = @_; - - my $list = $this->as_list(); - - return [map { $list->[$_] } GenerateRandomSequence($count,scalar(@$list))]; -} - -sub Recent { - my ($this,$count) = @_; - - my @result = sort { $b->DateModify() cmp $a->DateModify() } values %{$this->{$Items}}; - splice @result,$count; - - return \@result; -} - -sub AddItem { - my ($this,$newItem) = @_; - - $this->{$Items}->{$newItem->Id()} = $newItem; -} - -package DOM::Providers::Headlines; -use Common; -use ObjectStore::Headlines; - -our $DBPath; -our $Encoding; - -my %Channels; - -eval { - LoadHeadlines(); -}; - -if ($@) { - my $err = $@; - if (ref $err eq 'Exception') { - die $err->ToString(); - } else { - die $err; - } -} - - -sub GetProviderInfo { - return { - Name => 'Headlines', - Host => 'DOM::Site', - Objects => \%Channels - } -} - -sub LoadHeadlines { - my $dsHeadlines = new ObjectStore::Headlines(DBPath => $DBPath, HeadlineClass => 'DOM::Providers::Headlines::Headline', Encoding => $Encoding); - - foreach my $headline (@{$dsHeadlines->Search(Filter => sub { return $_[0]->IsActive(); } )}) { - my $channel = $headline->Channel() || 'main'; - $Channels{$channel} = new DOM::Providers::Headlines::Collection() if not exists $Channels{$channel}; - $Channels{$channel}->AddItem($headline); - } -} - -1; diff -r a35b60b16a99 -r 0f3e369553bd Lib/IMPL/Class/MemberInfo.pm --- a/Lib/IMPL/Class/MemberInfo.pm Fri Mar 05 20:14:45 2010 +0300 +++ b/Lib/IMPL/Class/MemberInfo.pm Tue Mar 09 02:50:45 2010 +0300 @@ -24,6 +24,7 @@ die new IMPL::Exception('The name is required for the member') unless $this->Name; die new IMPL::Exception('The class is required for the member') unless $this->Class; + $this->Attributes({}) unless defined $this->Attributes; $this->Frozen(0); $this->Virtual(0) unless defined $this->Virtual; $this->Access(3) unless $this->Access; @@ -40,7 +41,7 @@ sub set { my $this = shift; if ($this->Frozen) { - die new IMPL::Exception('The member information can\'t be modified', $this->Name); + die new IMPL::Exception('The member information is frozen', $this->Name); } $this->SUPER::set(@_); } diff -r a35b60b16a99 -r 0f3e369553bd Lib/IMPL/Class/Property.pm --- a/Lib/IMPL/Class/Property.pm Fri Mar 05 20:14:45 2010 +0300 +++ b/Lib/IMPL/Class/Property.pm Tue Mar 09 02:50:45 2010 +0300 @@ -15,7 +15,7 @@ sub prop_get { 1 }; sub prop_set { 2 }; -sub owner_set { 2 }; +sub owner_set { 10 }; sub prop_none { 0 }; sub prop_all { 3 }; sub prop_list { 4 }; diff -r a35b60b16a99 -r 0f3e369553bd Lib/IMPL/Class/Property/Base.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Class/Property/Base.pm Tue Mar 09 02:50:45 2010 +0300 @@ -0,0 +1,190 @@ +package IMPL::Class::Property::Base; +use strict; + +use IMPL::Class::Property; + +require IMPL::Class::Member; + +our @factoryParams = qw($class $name $set $get $validator); + +my %factoryCache; + +my $accessor_get_no = 'die new IMPL::Exception(\'The property is write only\',$name,$class) unless $get;'; +my $accessor_set_no = 'die new IMPL::Exception(\'The property is read only\',$name,$class) unless $set;'; + +my $custom_accessor_get = 'unshift @_, $this and goto &$get;'; +my $custom_accessor_set = 'unshift @_, $this and goto &$set;'; + +my $validator_code = '$this->$validator(@_);'; + +my %access_code = ( + IMPL::Class::Member::MOD_PUBLIC , "", + IMPL::Class::Member::MOD_PROTECTED, "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless UNIVERSAL::isa(scalar caller,\$class);", + IMPL::Class::Member::MOD_PRIVATE, "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;" +); + +my $virtual_call = q( + my $method = $this->can($name); + return $this->$method(@_) unless $method == $accessor or caller->isa($class); +); + +my $owner_check = "die new IMPL::Exception('Set accessor is restricted to the owner',\$name,\$class,scalar caller) unless caller eq \$class;"; + +sub GenerateAccessors { + my ($self,$param,@params) = @_; + + my %accessors; + + if (not ref $param) { + if ($param & prop_list) { + $accessors{get} = ($param & prop_get) ? $self->GenerateGetList(@params) : $accessor_get_no; + $accessors{set} = ($param & prop_set) ? $self->GenerateSetList(@params) : $accessor_set_no; + } else { + $accessors{get} = ($param & prop_get) ? $self->GenerateGet(@params) : $accessor_get_no; + $accessors{set} = ($param & prop_set) ? $self->GenerateSet(@params) : $accessor_set_no; + } + $accessors{owner} = (($param & owner_set) == owner_set) ? $owner_check : ""; + } elsif (UNIVERSAL::isa($param,'HASH')) { + $accessors{get} = $param->{get} ? $custom_accessor_get : $accessor_get_no; + $accessors{set} = $param->{set} ? $custom_accessor_set : $accessor_set_no; + $accessors{owner} = ""; + } else { + die new IMPL::Exception('The unsupported accessor/mutators supplied',$param); + } + + return \%accessors; +} + +sub GenerateSet { + die new IMPL::Exception("Standard accessors not supported"); +} + +sub GenerateGet { + die new IMPL::Exception("Standard accessors not supported"); +} + +sub GenerateGetList { + die new IMPL::Exception("Standard accessors not supported"); +} + +sub GenerateSetList { + my ($self) = @_; + die new IMPL::Exception("Standard accessors not supported"); +} + +sub Make { + my ($self,$propInfo) = @_; + + my $key = $self->MakeFactoryKey($propInfo); + + my $factory = $factoryCache{$key}; + + unless ($factory) { + my $mutators = $self->GenerateAccessors($propInfo->Mutators); + $factory = $self->CreateFactory( + $access_code{ $propInfo->Access }, + $propInfo->Attributes->{validator} ? $validator_code : "", + $mutators->{owner}, + $mutators->{get}, + $mutators->{set} + ); + $factoryCache{$key} = $factory; + } + + { + no strict 'refs'; + *{ $propInfo->Class.'::'.$propInfo->Name } = &$factory($self->RemapFactoryParams($propInfo)); + } + + my $mutators = $propInfo->Mutators; + + if (ref $mutators) { + $propInfo->canGet( $mutators->{get} ? 1 : 0 ); + $propInfo->canSet( $mutators->{set} ? 1 : 0 ); + } else { + $propInfo->canGet( $mutators & prop_get ); + $propInfo->canSet( $mutators & prop_set ); + } +} + +# extract from property info: class, name, get_accessor, set_accessor, validator +sub RemapFactoryParams { + my ($self,$propInfo) = @_; + + my $mutators = $propInfo->Mutators; + my $class = $propInfo->Class; + my $validator = $propInfo->Attributes->{validator}; + + die new IMPL::Exception('Can\'t find the specified validator',$class,$validator) if $validator and ref $validator ne 'CODE' and not $class->can($validator); + + return ( + $propInfo->get(qw(Class Name)), + (ref $mutators? + ($mutators->{set},$mutators->{get}) + : + (undef,undef) + ), + $validator + ); +} + +sub MakeFactoryKey { + my ($self,$propInfo) = @_; + + my ($access,$mutators,$validator) = ($propInfo->get(qw(Access Mutators)),$propInfo->Attributes->{validator}); + + return join ('', + $access, + $validator ? 'v' : 'n', + ref $mutators ? + ('c' , $mutators->{get} ? 1 : 0, $mutators->{set} ? 1 : 0) + : + (($mutators & prop_list) ? 'l' : 's' , ($mutators & prop_get) ? 1 : 0, ($mutators & prop_set) ? ((($mutators & owner_set) == owner_set) ? 2 : 1 ) : 0 ) + ); +} + +sub CreateFactory { + my ($self,$codeAccessCheck,$codeValidator,$codeOwnerCheck,$codeGet,$codeSet) = @_; + + my $strParams = join(',',@factoryParams); + + my $factory = <mk_accessors qw(ExportField); +push @IMPL::Class::Property::Base::factoryParams, qw($field); + sub _direct($) { my ($prop_info) = @_; $prop_info->Implementor( IMPL::Class::Property::Direct->new({ExportField => 1}) ); return $prop_info; } -my $access_private = "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;"; -my $access_protected = "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless caller eq \$class;"; -my $accessor_get_no = 'die new IMPL::Exception(\'The property is write only\',$name,$class) unless $get;'; -my $accessor_set_no = 'die new IMPL::Exception(\'The property is read only\',$name,$class) unless $set;'; -my $accessor_set = 'return( $this->{$field} = @_ == 1 ? $_[0] : [@_] );'; -my $accessor_get = 'return( $this->{$field} );'; -my $list_accessor_set = 'return( - wantarray ? - @{ $this->{$field} = IMPL::Object::List->new( - (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_] - )} : - ($this->{$field} = IMPL::Object::List->new( - (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_] - )) -);'; -my $list_accessor_get = 'return( - wantarray ? - @{ $this->{$field} ? - $this->{$field} : - ( $this->{$field} = IMPL::Object::List->new() ) - } : - ( $this->{$field} ? - $this->{$field} : - ( $this->{$field} = IMPL::Object::List->new() ) - ) -);'; -my $custom_accessor_get = 'unshift @_, $this and goto &$get;'; -my $custom_accessor_set = 'unshift @_, $this and goto &$set;'; +sub GenerateGet { + 'return ($this->{$field});'; +} + +sub GenerateSet { + 'return ($this->{$field} = $_[0])'; +} -my %accessor_cache; -sub mk_acessor { - my ($virtual,$access,$class,$name,$mutators,$field,$validator) = @_; - - my ($get,$set) = ref $mutators ? ( $mutators->{get}, $mutators->{set}) : ($mutators & prop_get, $mutators & prop_set); - my $key = join '',$virtual,$access,$get ? 1 : 0,$set ? 1 : 0, (ref $mutators ? 'c' : ($mutators & prop_list() ? 'l' : 's')), $validator ? 1 : 0 ; - my $factory = $accessor_cache{$key}; - if (not $factory) { - my $code = -<can(\$name); - return \$this->\$method(\@_) unless \$method == \$accessor or caller->isa(\$class); -VCALL - $code .= ' 'x8 . "$access_private\n" if $access == IMPL::Class::Member::MOD_PRIVATE; - $code .= ' 'x8 . "$access_protected\n" if $access == IMPL::Class::Member::MOD_PROTECTED; - $code .= ' 'x8 . '$this->$validator(@_);'."\n" if $validator; - - my ($codeGet,$codeSet); - if (ref $mutators) { - $codeGet = $get ? $custom_accessor_get : $accessor_get_no; - $codeSet = $set ? $custom_accessor_set : $accessor_set_no; - } else { - if ($mutators & prop_list) { - $codeGet = $get ? $list_accessor_get : $accessor_get_no; - $codeSet = $set ? $list_accessor_set : $accessor_set_no; - } else { - $codeGet = $get ? $accessor_get : $accessor_get_no; - $codeSet = $set ? $accessor_set : $accessor_set_no; - } - } - $code .= -<{$field} = IMPL::Object::List->new( + (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_] + )} : + ($this->{$field} = IMPL::Object::List->new( + (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_] + )) + );'; } -END - warn $code; - $factory = eval $code; - if (not $factory) { - my $err = $@; - die new IMPL::Exception('Failed to generate the accessor factory',$err); - } - $accessor_cache{$key} = $factory; - } - - die new IMPL::Exception('Can\'t find the specified validator',$class,$validator) if $validator and ref $validator ne 'CODE' and not $class->can($validator); - - return $factory->($class,$name,$set,$get, $field, $validator); + +sub GenerateGetList { + 'return( + wantarray ? + @{ $this->{$field} ? + $this->{$field} : + ( $this->{$field} = IMPL::Object::List->new() ) + } : + ( $this->{$field} ? + $this->{$field} : + ( $this->{$field} = IMPL::Object::List->new() ) + ) + );'; +} + +sub RemapFactoryParams { + my ($self,$propInfo) = @_; + + return $self->SUPER::RemapFactoryParams($propInfo),$self->FieldName($propInfo); } sub Make { - my ($self,$propInfo) = @_; - - my $isExportField = ref $self ? ($self->ExportField || 0) : 0; - my ($class,$name,$virt,$access,$mutators,$attr) = $propInfo->get qw(Class Name Virtual Access Mutators Attributes); - (my $field = "${class}_$name") =~ s/::/_/g; - - my $propGlob = $class.'::'.$name; - - no strict 'refs'; - *$propGlob = mk_acessor($virt,$access,$class,$name,$mutators,$field,$attr->{validator}); - *$propGlob = \$field if $isExportField; - - if (ref $mutators) { - $propInfo->canGet( $mutators->{get} ? 1 : 0); - $propInfo->canSet( $mutators->{set} ? 1 : 0); - } else { - $propInfo->canGet( ($mutators & prop_get) ? 1 : 0); - $propInfo->canSet( ($mutators & prop_set) ? 1 : 0); - } + my ($self,$propInfo) = @_; + + $self->SUPER::Make($propInfo); + + { + no strict 'refs'; + if (ref $self and $self->ExportField) { + my $field = $self->FieldName($propInfo); + *{$propInfo->Class.'::'.$propInfo->Name} = \$field; + } + } } sub FieldName { diff -r a35b60b16a99 -r 0f3e369553bd Lib/IMPL/Code/Generator.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Code/Generator.pm Tue Mar 09 02:50:45 2010 +0300 @@ -0,0 +1,4 @@ +package IMPL::Code::Generator; +use strict; + +1; \ No newline at end of file diff -r a35b60b16a99 -r 0f3e369553bd Lib/IMPL/Code/MethodFactory.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Code/MethodFactory.pm Tue Mar 09 02:50:45 2010 +0300 @@ -0,0 +1,4 @@ +package IMPL::Code::MethodFactory; +use strict; + +1; \ No newline at end of file diff -r a35b60b16a99 -r 0f3e369553bd Lib/IMPL/Config/Activator.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Config/Activator.pm Tue Mar 09 02:50:45 2010 +0300 @@ -0,0 +1,43 @@ +package IMPL::Config::Activator; +use strict; + +use base qw(IMPL::Object IMPL::Object::Autofill); +use IMPL::Class::Property; + +BEGIN { + public property factory => prop_all; + public property args => prop_all; + private property _object => prop_all; +} + +__PACKAGE__->PassThroughArgs; + +sub CTOR { + my $this = shift; + + die new IMPL::Exception("A Type parameter is required") unless $this->Type; + +} + +sub _is_class { + no strict 'refs'; + scalar keys %{"$_[0]::"} ? 1 : 0; +} + +sub instance { + my $this = shift; + + my $factory = $this->fatory; + + if (my $obj = $this->_object) { + return $obj; + } else { + my %args = (%{$this->args || {}},@_); + eval "require $factory" unless not ref $factory and _is_class($factory); + my $inst = $factory->new(%args); + $this->_object($inst); + return $inst; + } +} + +1; \ No newline at end of file diff -r a35b60b16a99 -r 0f3e369553bd Lib/IMPL/Config/Container.pm --- a/Lib/IMPL/Config/Container.pm Fri Mar 05 20:14:45 2010 +0300 +++ b/Lib/IMPL/Config/Container.pm Tue Mar 09 02:50:45 2010 +0300 @@ -30,7 +30,7 @@ (my $prop = $AUTOLOAD) =~ s/.*?(\w+)$/$1/; my $child = $this->Chidren->{$prop}; - if (ref $child and $child->isa('IMPL::Config::Class')) { + if (UNIVERSAL::isa($child,'IMPL::Config::Class')) { return $child->instance(@_); } else { return $child; diff -r a35b60b16a99 -r 0f3e369553bd Lib/IMPL/Config/Link.pm --- a/Lib/IMPL/Config/Link.pm Fri Mar 05 20:14:45 2010 +0300 +++ b/Lib/IMPL/Config/Link.pm Tue Mar 09 02:50:45 2010 +0300 @@ -11,12 +11,17 @@ return ${$_[0]} = ${$_[0]}->instance() if UNIVERSAL::isa(${$_[0]},'IMPL::Config::Activator'); } +sub surrogate { + die new IMPL::Exception("You can't create a forward declarations of the link"); +} + sub restore { my ($self,$data,$surrogate) = @_; - + my %args = @$data; die new IMPL::Exception('A target is required for the link') unless exists $args{target}; - - return $self->new($args{target}); + my $val; + tie $val, $self, $args{target}; + return $val; } \ No newline at end of file diff -r a35b60b16a99 -r 0f3e369553bd Lib/IMPL/Web/Application.pm --- a/Lib/IMPL/Web/Application.pm Fri Mar 05 20:14:45 2010 +0300 +++ b/Lib/IMPL/Web/Application.pm Tue Mar 09 02:50:45 2010 +0300 @@ -13,7 +13,7 @@ BEGIN { public property handlerError => prop_all; public property factoryAction => prop_all; - public property handlersQuery => prop_all; + public property handlersQuery => prop_all | prop_list; } # custom factory @@ -60,7 +60,7 @@ =head1 SYNOPSIS require MyApp; -MyApp->instance('app.config')->Run(); +MyApp->spawn('app.config')->Run(); =head1 DESCRIPTION diff -r a35b60b16a99 -r 0f3e369553bd Lib/IMPL/Web/Application/Response.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Web/Application/Response.pm Tue Mar 09 02:50:45 2010 +0300 @@ -0,0 +1,230 @@ +package IMPL::Web::Application::Response; +use strict; + +use base qw(IMPL::Object IMPL::Object::Autofill); + +require IMPL::Exception; +require CGI; +require CGI::Cookie; + +use Carp; +use IMPL::Class::Property; + +BEGIN { + public property query => prop_get | owner_set; # cgi query + public property status => prop_all, { validator => \&_checkHeaderPrinted }; + public property contentType => prop_all, { validator => \&_checkHeaderPrinted }; # String + public property charset => { get => \&_charset, set => \&_charset }, { validator => \&_checkHeaderPrinted }; + public property expires => prop_all, { validator => \&_checkHeaderPrinted }; + public property cookies => prop_all, { validator => \&_checkHeaderPrinted }; # Hash + + public property buffered => prop_all, { validator => \&_canChangeBuffer }; # Boolean + public property streamOut => prop_get | owner_set; # stream + public property streamBody => {get => \&getStreamBody }; # stream + public property isHeaderPrinted => prop_get | owner_set; # Boolean + + private property _bufferBody => prop_all; + private property _streamBody => prop_all; +} + +__PACKAGE__->PassThroughArgs; + +sub CTOR { + my ($this,%args) = @_; + + $this->query(CGI->new($this->query() | {})) unless $this->query; + $this->charset($this->query->charset) unless $this->charset; + + $this->streamOut(*STDOUT) unless $this->streamOut; +} + +sub _checkHeaderPrinted { + my ($this,$value) = @_; + + die new IMPL::InvalidOperationException() if $this->isHeaderPrinted; +} + +sub _canChangeBuffer { + my ($this,$value) = @_; + + die new IMPL::InvalidOperationException() if $this->isHeaderPrinted or $this->_streamBody; +} + +sub _charset { + my $this = shift; + + return $this->query->charset(@_); +} + +sub _PrintHeader { + my ($this) = @_; + + unless ($this->isHeaderPrinted) { + $this->isHeaderPrinted(1); + + my %opt; + + $opt{-type} = $this->contentType if $this->contentType; + $opt{-status} = $this->status if $this->status; + $opt{-expires} = $this->expires if $this->expires; + + my $refCookies = $this->cookies; + $opt{-cookie} = [map CGI::Cookie->new(-name => $_, $refCookies->{$_} ), keys %$refCookies] if $refCookies; + + my $hOut = $this->streamOut; + + print $hOut $this->query->header( + %opt + ); + } +} + +sub getStreamBody { + my ($this) = @_; + + return undef unless $this->streamOut; + + unless ($this->_streamBody) { + if ($this->buffered) { + my $buffer = ""; + $this->_bufferBody(\$buffer); + + open my $hBody, ">", \$buffer or die new IMPL::Exception("Failed to create buffer",$!); + + $this->_streamBody($hBody); + } else { + $this->_PrintHeader(); + $this->_streamBody($this->streamOut); + } + } + + return $this->_streamBody; +} + +sub Complete { + my ($this) = @_; + + return 0 unless $this->streamOut; + + my $hOut = $this->streamOut; + + $this->_PrintHeader(); + + if ($this->buffered) { + print $hOut ${$this->_bufferBody}; + } + + $this->_streamBody(undef); + $this->_bufferBody(undef); + $this->streamOut(undef); + + return 1; +} + +sub Discard { + my ($this) = @_; + + carp "Discarding sent response" if $this->isHeaderPrinted; + + $this->_streamBody(undef); + $this->_bufferBody(undef); + $this->streamOut(undef); +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + +Ответ сервера на CGI запрос, позволяет сформировать основные свойства заголовка и тело запроса. + +Объект позволяет буфферизировать вывод в тело ответа, что позволяет отменить или изменить +ответ в последний момент. + +Свойство C< isHeaderPrinted > можно использовать для определения были ли отправлены какие-нибудь +данные клиенту. + +=head1 PROPERTIES + +=head2 HTTP Header + +Свойства отвечающие за заголовок HTTP ответа. Эти своства могут быть изменены до тех пор пока +не будет отправлен заголовок. В противном случае выдается исключение C< IMPL::InvalidOperationException >. + +=over + +=item C< query > + +CGI запрос, который используется для вывода данных, заголовка и пр. Существует всегда. + +=item C< status > + +Код ошибки HTTP. Например, '200 OK'. По умолчанию не установлен, при отправке клиенту бедт отправлен '200 ОК'. + +=item C< contentType > + +Тип MIME. По умолчанию не установлен, подразумивается 'text/html'. + +=item C< charset > + +Кодировка, синоним свойства query->charset. + +=item C< expires > + +Определяет время жизни контента, например '+10m'. По умолчанию не задано и не передается. + +=item C< cookies > + +Хеш массив с cookies, например C< { cart => ['foo','bar'], display => 'list' } >. + +=back + +=head2 Response behaviour + +Свойства отвечающие за поведение ответа. + +=over + +=item C< buffered > + +C< True > - то тело ответа пишется в буффер и будет отправлено при вызове метода C< Complete >, +заголовок также будет отправлен после вызова метода C< Complete >. + +C< False > - тело ответа пишется непосредственно в поток к клиенту, при этом заголовок +будет отправлен при первом обращении к свойству C< streamBody > + +Это свойство можно менять до первого обращения к потоку для записи в тело ответа. + +=item C< streamOut > + +Стандартный вывод CGI приложения. + +=item C< streamBody > + +Поток для записи в тело ответа. + +=item C< isHeadPrinted > + +Признак того, что заголовок уже был отправлен клиенту. + +=back + +=head1 METHODS + +=over + +=item C< Complete > + +Завершает отправку ответа. + +=item C< Discard > + +Отменяет отправку ответа, при этом если часть данных (например, заголовок) +уже была отправлена, выдает предупреждение в STDERR. + +=back + +=cut \ No newline at end of file diff -r a35b60b16a99 -r 0f3e369553bd Lib/IMPL/Web/Response.pm --- a/Lib/IMPL/Web/Response.pm Fri Mar 05 20:14:45 2010 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,230 +0,0 @@ -package IMPL::Web::Response; -use strict; - -use base qw(IMPL::Object IMPL::Object::Autofill); - -require IMPL::Exception; -require CGI; -require CGI::Cookie; - -use Carp; -use IMPL::Class::Property; - -BEGIN { - public property query => prop_get | owner_set; # cgi query - public property status => prop_all, { validator => \&_checkHeaderPrinted }; - public property contentType => prop_all, { validator => \&_checkHeaderPrinted }; # String - public property charset => { get => \&_charset, set => \&_charset }, { validator => \&_checkHeaderPrinted }; - public property expires => prop_all, { validator => \&_checkHeaderPrinted }; - public property cookies => prop_all, { validator => \&_checkHeaderPrinted }; # Hash - - public property buffered => prop_all, { validator => \&_canChangeBuffer }; # Boolean - public property streamOut => prop_get | owner_set; # stream - public property streamBody => {get => \&getStreamBody }; # stream - public property isHeaderPrinted => prop_get | owner_set; # Boolean - - private property _bufferBody => prop_all; - private property _streamBody => prop_all; -} - -__PACKAGE__->PassThroughArgs; - -sub CTOR { - my ($this,%args) = @_; - - $this->query(CGI->new($this->query() | {})) unless $this->query; - $this->charset($this->query->charset) unless $this->charset; - - $this->streamOut(*STDOUT) unless $this->streamOut; -} - -sub _checkHeaderPrinted { - my ($this,$value) = @_; - - die new IMPL::InvalidOperationException() if $this->isHeaderPrinted; -} - -sub _canChangeBuffer { - my ($this,$value) = @_; - - die new IMPL::InvalidOperationException() if $this->isHeaderPrinted or $this->_streamBody; -} - -sub _charset { - my $this = shift; - - return $this->query->charset(@_); -} - -sub _PrintHeader { - my ($this) = @_; - - unless ($this->isHeaderPrinted) { - $this->isHeaderPrinted(1); - - my %opt; - - $opt{-type} = $this->contentType if $this->contentType; - $opt{-status} = $this->status if $this->status; - $opt{-expires} = $this->expires if $this->expires; - - my $refCookies = $this->cookies; - $opt{-cookie} = [map CGI::Cookie->new(-name => $_, $refCookies->{$_} ), keys %$refCookies] if $refCookies; - - my $hOut = $this->streamOut; - - print $hOut $this->query->header( - %opt - ); - } -} - -sub getStreamBody { - my ($this) = @_; - - return undef unless $this->streamOut; - - unless ($this->_streamBody) { - if ($this->buffered) { - my $buffer = ""; - $this->_bufferBody(\$buffer); - - open my $hBody, ">", \$buffer or die new IMPL::Exception("Failed to create buffer",$!); - - $this->_streamBody($hBody); - } else { - $this->_PrintHeader(); - $this->_streamBody($this->streamOut); - } - } - - return $this->_streamBody; -} - -sub Complete { - my ($this) = @_; - - return 0 unless $this->streamOut; - - my $hOut = $this->streamOut; - - $this->_PrintHeader(); - - if ($this->buffered) { - print $hOut ${$this->_bufferBody}; - } - - $this->_streamBody(undef); - $this->_bufferBody(undef); - $this->streamOut(undef); - - return 1; -} - -sub Discard { - my ($this) = @_; - - carp "Discarding sent response" if $this->isHeaderPrinted; - - $this->_streamBody(undef); - $this->_bufferBody(undef); - $this->streamOut(undef); -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Ответ сервера на CGI запрос, позволяет сформировать основные свойства заголовка и тело запроса. - -Объект позволяет буфферизировать вывод в тело ответа, что позволяет отменить или изменить -ответ в последний момент. - -Свойство C< isHeaderPrinted > можно использовать для определения были ли отправлены какие-нибудь -данные клиенту. - -=head1 PROPERTIES - -=head2 HTTP Header - -Свойства отвечающие за заголовок HTTP ответа. Эти своства могут быть изменены до тех пор пока -не будет отправлен заголовок. В противном случае выдается исключение C< IMPL::InvalidOperationException >. - -=over - -=item C< query > - -CGI запрос, который используется для вывода данных, заголовка и пр. Существует всегда. - -=item C< status > - -Код ошибки HTTP. Например, '200 OK'. По умолчанию не установлен, при отправке клиенту бедт отправлен '200 ОК'. - -=item C< contentType > - -Тип MIME. По умолчанию не установлен, подразумивается 'text/html'. - -=item C< charset > - -Кодировка, синоним свойства query->charset. - -=item C< expires > - -Определяет время жизни контента, например '+10m'. По умолчанию не задано и не передается. - -=item C< cookies > - -Хеш массив с cookies, например C< { cart => ['foo','bar'], display => 'list' } >. - -=back - -=head2 Response behaviour - -Свойства отвечающие за поведение ответа. - -=over - -=item C< buffered > - -C< True > - то тело ответа пишется в буффер и будет отправлено при вызове метода C< Complete >, -заголовок также будет отправлен после вызова метода C< Complete >. - -C< False > - тело ответа пишется непосредственно в поток к клиенту, при этом заголовок -будет отправлен при первом обращении к свойству C< streamBody > - -Это свойство можно менять до первого обращения к потоку для записи в тело ответа. - -=item C< streamOut > - -Стандартный вывод CGI приложения. - -=item C< streamBody > - -Поток для записи в тело ответа. - -=item C< isHeadPrinted > - -Признак того, что заголовок уже был отправлен клиенту. - -=back - -=head1 METHODS - -=over - -=item C< Complete > - -Завершает отправку ответа. - -=item C< Discard > - -Отменяет отправку ответа, при этом если часть данных (например, заголовок) -уже была отправлена, выдает предупреждение в STDERR. - -=back - -=cut \ No newline at end of file diff -r a35b60b16a99 -r 0f3e369553bd _test/wmi.pl --- a/_test/wmi.pl Fri Mar 05 20:14:45 2010 +0300 +++ b/_test/wmi.pl Tue Mar 09 02:50:45 2010 +0300 @@ -1,7 +1,8 @@ #!/usr/bin/perl -w use strict; -use Win32::OLE; + +eval "use Win32::OLE; 1;" if $^ =~ /win/; my $wmi = Win32::OLE->GetObject("winmgmts:{impersonationLevel=impersonate}!\\\\.\\root\\cimv2");