--- google/lib/CWMP/Request.pm	2007/06/18 23:52:41	32
+++ google/trunk/lib/CWMP/Request.pm	2007/11/18 17:49:51	214
@@ -4,58 +4,26 @@
 use strict;
 
 use XML::Rules;
+use CWMP::Tree;
 use Data::Dump qw/dump/;
 use Carp qw/confess cluck/;
+use Class::Trigger;
 
 =head1 NAME
 
-CWMP::Request - parse SOAP request
+CWMP::Request - parse SOAP request metods
 
-=head1 METHODS
-
-=head2 _tag
-
-Get value of tag. Tag name is case insensitive (don't ask why),
-we ignore namespaces and can take optional C<sub_key>
-(usually C<_content>).
+=head1 CPE metods
 
-  _tag( $tag_hash, $name, $sub_key )
+All methods described below call triggers with same name
 
 =cut
 
-sub _tag {
-	my ( $tag_hash, $name, $sub_key ) = @_;
-	confess "need hash as first argument" unless ( ref $tag_hash eq 'HASH' );
-	$name = (grep { m/^(?:\w+:)*$name$/i } keys %$tag_hash )[0];
-#	$name =~ s/^\w+://;
-	if ( defined $tag_hash->{$name} ) {
-		if ( ! defined $sub_key ) {
-			return $tag_hash->{$name};
-		} elsif ( defined $tag_hash->{$name}->{$sub_key} ) {
-			return $tag_hash->{$name}->{$sub_key};
-		} else {
-			return if ( $name =~ m/^value$/i );
-			warn "can't find '$name/$sub_key' in ", dump( $tag_hash );
-			return;
-		}
-	} else {
-		warn "can't find '$name' in ", dump( $tag_hash );
-		return;
-	}
-}
+my $tree = CWMP::Tree->new({ debug => 0 });
 
-my $state;
+our $state;	# FIXME check this!
 
-my $parser = XML::Rules->new(
-#	start_rules => [
-#		'^division_name,fax' => 'skip',
-#	],
-	namespaces => {
-#		'http://schemas.xmlsoap.org/soap/envelope/' => 'soapenv',
-#		'http://schemas.xmlsoap.org/soap/encoding/' => 'soap',
-		'urn:dslforum-org:cwmp-1-0' => '',
-	},
-	rules => [
+my $rules =  [
 		#_default => 'content trim',
 		x_default => sub {
 			my ($tag_name, $tag_hash, $context, $parent_data) = @_;
@@ -65,10 +33,8 @@
 			my ($tag_name, $tag_hash, $context, $parent_data) = @_;
 			$state->{ID} = $tag_hash->{_content};
 		},
-		#
-		# Inform
-		#
-		qr/DeviceId/ => sub {
+
+		'DeviceId' => sub {
 			my ($tag_name, $tag_hash, $context, $parent_data) = @_;
 			foreach my $name ( keys %$tag_hash ) {
 				next if $name eq '_content';
@@ -77,7 +43,7 @@
 				$state->{DeviceID}->{ $key } = _tag( $tag_hash, $name, '_content' );
 			}
 		},
-		qr/EventStruct/ => sub {
+		'EventStruct' => sub {
 			my ($tag_name, $tag_hash, $context, $parent_data) = @_;
 			push @{ $state->{EventStruct} }, $tag_hash->{EventCode}->{_content};
 		},
@@ -85,23 +51,99 @@
 			my ($tag_name, $tag_hash, $context, $parent_data) = @_;
 			$state->{$tag_name} = $tag_hash->{_content};
 		},
-		qr/ParameterValueStruct/ => sub {
+		'ParameterValueStruct' => sub {
 			my ($tag_name, $tag_hash, $context, $parent_data) = @_;
 			# Name/Value tags must be case insnesitive
 			my $value = (grep( /value/i, keys %$tag_hash ))[0];
 			$state->{Parameter}->{ _tag($tag_hash, 'Name', '_content') } = _tag($tag_hash, 'Value', '_content' );
+			$state->{_trigger} = 'ParameterValue';
 		},
-		#
-		# GetRPCMethodsResponse
-		#
+
+];
+
+=head2 Inform
+
+Generate InformResponse to CPE
+
+=cut
+
+push @$rules,
+	'Inform' => sub {
+		$state->{_dispatch} = 'InformResponse';		# what reponse to call
+		$state->{_trigger} = 'Inform';
+	};
+
+=head2 GetRPCMethodsResponse
+
+=cut
+
+push @$rules,
 		qr/^(?:^\w+:)*string$/ => 'content array',
-		qr/MethodList/ => sub {
+		'MethodList' => sub {
 			my ($tag_name, $tag_hash, $context, $parent_data) = @_;
 			$state->{MethodList} = _tag( $tag_hash, 'string' );
-		},	
-	]
+			$state->{_trigger} = 'GetRPCMethodsResponse';
+		};
+
+=head2 GetParameterNamesResponse
+
+=cut
+
+push @$rules,
+		'ParameterInfoStruct' => sub {
+			my ($tag_name, $tag_hash, $context, $parent_data) = @_;
+			my $name = _tag($tag_hash, 'Name', '_content');
+			my $writable = _tag($tag_hash, 'Writable', '_content' );
+
+			confess "need state" unless ( $state );	# don't remove!
+
+=for obsolete
+
+			# XXX dragons ahead: convert name to tree rewriting it into perl
+			my $s = '$state->{ParameterInfo}->' . $tree->name2perl( $name ) . "->{writable} = $writable;";
+			eval "$s";
+			confess "can't eval $s : $@" if ($@);
+
+=cut
+
+			$state->{ParameterInfo}->{$name} = $writable;
+
+			#warn "## state = dump( $state ), "\n";
+
+			$state->{_trigger} = 'GetParameterNamesResponse';
+		};
+	
+=head2 Fault
+
+=cut
+
+push @$rules,
+		'Fault' => sub {
+			my ($tag_name, $tag_hash, $context, $parent_data) = @_;
+			$state->{Fault} = {
+				FaultCode => _tag( $tag_hash, 'FaultCode', '_content' ),
+				FaultString => _tag( $tag_hash, 'FaultString', '_content' ),
+			};
+			warn "FAULT: ", $state->{Fault}->{FaultCode}, " ", $state->{Fault}->{FaultString}, "\n";
+			$state->{_trigger} = 'Fault';
+		};
+
+my $parser = XML::Rules->new(
+#	start_rules => [
+#		'^division_name,fax' => 'skip',
+#	],
+	namespaces => {
+		'http://schemas.xmlsoap.org/soap/envelope/' => 'soapenv',
+		'http://schemas.xmlsoap.org/soap/encoding/' => 'soap',
+		'http://www.w3.org/2001/XMLSchema' => 'xsd',
+		'http://www.w3.org/2001/XMLSchema-instance' => 'xsi',
+		'urn:dslforum-org:cwmp-1-0' => '',
+	},
+	rules => $rules,
 );
 
+=head1 METHODS
+
 =head2 parse
 
   my $state = CWMP::Request->parse( "<soap>request</soap>" );
@@ -115,7 +157,44 @@
 
 	$state = {};
 	$parser->parsestring( $xml );
+	if ( my $trigger = $state->{_trigger} ) {
+		warn "### call_trigger( $trigger )\n";
+		$self->call_trigger( $trigger, $state );
+	}
+	# XXX don't propagate _trigger (useful?)
+	delete( $state->{_trigger} );
 	return $state;
 }
 
+=head2 _tag
+
+Get value of tag. Tag name is case insensitive (don't ask why),
+we ignore namespaces and can take optional C<sub_key>
+(usually C<_content>).
+
+  _tag( $tag_hash, $name, $sub_key )
+
+=cut
+
+sub _tag {
+	my ( $tag_hash, $name, $sub_key ) = @_;
+	confess "need hash as first argument" unless ( ref $tag_hash eq 'HASH' );
+	$name = (grep { m/^(?:\w+:)*$name$/i } keys %$tag_hash )[0];
+#	$name =~ s/^\w+://;
+	if ( defined $tag_hash->{$name} ) {
+		if ( ! defined $sub_key ) {
+			return $tag_hash->{$name};
+		} elsif ( defined $tag_hash->{$name}->{$sub_key} ) {
+			return $tag_hash->{$name}->{$sub_key};
+		} else {
+			return if ( $name =~ m/^value$/i );
+			warn "can't find '$name/$sub_key' in ", dump( $tag_hash );
+			return;
+		}
+	} else {
+		warn "can't find '$name' in ", dump( $tag_hash );
+		return;
+	}
+}
+
 1;