view release on metacpan or  search on metacpan

lib/Jabber/Lite.pm  view on Meta::CPAN

		}
	}

}

=head2 toStr

Returns the object in a single string.  Takes an optional hash consisting
of 'FH', being a filehandle reference to send output to instead (useful if
you aren't wanting to copy the object into a local variable), and 
'GenClose', which defaults to 1 and ensures that the first tag has the
proper '/' character when closing the tag.  

If set to '0', '<stream>' will be output instead of '<stream/>', a highly
important distinction when first connecting to Jabber servers (remember that
a Jabber connection is really one long '<stream>' tag ).

=cut

# Note - since this is a recursive call, there are probably too many
# tests to see whether we have a filehandle.  A slight performance
# increase could probably be gained by duplicating the code in 
# a seperate function, but that means that two locations for output
# need to be maintained.

sub toStr {
	my $self = shift;
	my %args = ( FH => undef,
			GenClose => 1,
			@_, );
	my $fh = $args{"FH"};
	my $doend = 0;

	my $dval = $self->_check_val( '_debug' );
	if( $dval ){
		$dval = $self->{'_debug'};
	}

	if( ! $args{"GenClose"} ){
		$doend = 1;
	}

	# Return a string representation of this object.
	my $retstr = "";
	my $usefh = 0;
	my $mustend = 0;
	if( defined( $fh ) ){
		$usefh = 1;
	}

	# $self->debug( "toStr starting\n") if( $dval );
	if( ! $usefh ){
		$retstr = "<" . $self->name();
	}else{
		print $fh "<" . $self->name();
	}

	# See if this is actually processing instructions etc.
	if( $self->name() =~ /^\[CDATA\[/ ){
		if( ! $usefh ){
			$retstr .= $self->{'_cdata'} . "]]";
		}else{
			print $fh $self->{'_cdata'} . "]]";
		}
		$doend = 1;
	}elsif( $self->name() =~ /^\!/ ){
		$mustend = 1;

		# doctype stuff is special.  When we see the
		# pattern '\[\s*\]' within, that means that we
		# insert, at that point, the 'next' subtag object,
		# and so forth.  Annoying stuff.
		my $tstr = "";
		my $tloop = -1;
		my $tstrlength = -1;
		my $stillgoing = 0;
		if( defined( $self->{'_doctype'} ) ){
			$tstrlength = length( $self->{'_doctype'} );
			$stillgoing = 1;
		}

		my $nexttag = 0;
		my $foundopen = -5;
		while( $tloop < $tstrlength && $stillgoing ){
			$tloop++;
			my $thischar = substr( $self->{'_doctype'}, $tloop, 1 );
			if( $thischar eq '[' ){
				$tstr .= $thischar;
				$foundopen = $tloop;
				# Find the next subtag offset.
				if( defined( $self->{'_curobjs'} ) ){
					if( defined( ${$self->{'_curobjs'}}[$nexttag] ) ){
						$tstr .= ${$self->{'_curobjs'}}[$nexttag]->toStr();
						$nexttag++;
					}
				}
			}elsif( $foundopen >= 0 && $thischar !~ /^(\s*|\])$/ ){
				$tstr .= "]";
				$foundopen = -5;
				$tstr .= $thischar;
			}elsif( $foundopen >= 0 && $thischar eq ']' ){
				$foundopen = -5;
				$tstr .= $thischar;
			}elsif( $foundopen < 0 ){
				$tstr .= $thischar;
			}
		}

		if( ! $usefh ){
			$retstr .= $tstr;
		}else{
			print $fh $tstr;
		}
		$doend = 1;
	}elsif( $self->name() =~ /^\?/ ){
		if( defined( $self->{'_processinginstructions'} ) ){
			if( ! $usefh ){
				$retstr .= " " . $self->{'_processinginstructions'};
			}else{
				print $fh " " . $self->{'_processinginstructions'};
			}
		}
		$mustend = 1;

lib/Jabber/Lite.pm  view on Meta::CPAN

	# Keep looping until we run out of text.
	my $pmloop = 5;

	while( $pmloop > 0 && length( $str ) > 0 ){
		$pmloop--;

		$self->debug( " $pmloop status of $curstatus\n" ) if( $dval );

		# First possible - adding to the name.  The text received
		# is a continuation of the name.
		if( $curstatus eq "name" ){
			if( $str =~ /^(\S+)(\s+.*)?$/s ){
				my $namefurther = $1;
				$str = $2;

				# Deal with 'dfgdg><dljgdlgj>', which could be
				# read as a continuation of the name.
				if( $namefurther =~ /^([^\/]*\/>)(.*)$/s ){
					$namefurther = $1;

					# This juggling is to avoid a warning.
					my $r2 = $2;
					my $ostr = $str;
					$str = "";
					if( defined( $r2 ) ){
						$str = $r2;
					}
					if( defined( $ostr ) ){
						$str .= $ostr;
					}
				}elsif( $namefurther =~ /^([^>]*>)(.*)$/s ){
					$namefurther = $1;

					# This juggling is to avoid a warning.
					my $r2 = $2;
					my $ostr = $str;
					$str = "";
					if( defined( $r2 ) ){
						$str = $r2;
					}
					if( defined( $ostr ) ){
						$str .= $ostr;
					}
				}
		
				# Add it to the current name.	
				$self->{'_name'} .= $namefurther;

				# See if we've incorporated a possible end tag into
				# this.  We do the test on the completed name instead
				# of the string received in case we received the
				# '/' during the previous call.
				# We send it back if we did.
				if( $self->{'_name'} =~ /^\!\-\-(.*)$/s ){
					# Start processing a comment.
					$curstatus = "comment";
					$self->{'_name'} = '!--';
					$str = $1 . $str;

				}elsif( $self->{'_name'} =~ /^(\!\[CDATA\[)(.*)$/ ){
					$curstatus = "cdata";
					$self->{'_name'} = $1;
					$str = $2 . $str;

				}elsif( $self->{'_name'} =~ /\/$/s ){
					# Possible start of '/>' .  Send it back.
					# If its actually 'sdlfk//sdf', it'll be
					# properly parsed next time.
					chop( $self->{'_name'} );
					$str = '/' . $str;
					$curstatus = "name";

				}elsif( $self->{'_name'} =~ /\/>$/s ){
					# Definitely bad.  Chop off the last 
					# two characters.
					chop( $self->{'_name'} );
					chop( $self->{'_name'} );

					# Then mark ourselves as being complete.
					$self->{'_is_complete'} = 1;
					$retval = 1;
					$curstatus = "complete";

				}elsif( $self->{'_name'} =~ /\?>$/s && $self->{'_name'} =~ /^\?/ ){
					# This is 'processing instructions'.
					chop( $self->{'_name'} );
					chop( $self->{'_name'} );
					$curstatus = "complete";

				}elsif( $self->{'_name'} =~ />$/s ){
					# name is 'sdfj>'.  Means that we've reached
					# the end of the tag name, but not the end
					# of the tag.  Remove the '>', and indicate
					# what we've got.
					chop( $self->{'_name'} );
					$curstatus = "subtag";

					if( $self->{'_name'} =~ /^\!/ ){
						$curstatus = "complete";
					}

					# This point is good for checking
					# whether this name matches the
					# one specified as 'expect-incomplete'.
					if( defined( $self->{'_expect-incomplete'} ) ){
						if( defined( $self->{'_expect-incomplete'}{$self->{'_name'}} ) ){
							$curstatus = "complete";
						}
					}

				}elsif( defined( $str ) ){
					# We've got a space.  The name has been 
					# completed.
					$curstatus = "attribs";

					# See if this is special stuff.
					if( $self->{'_name'} =~ /^\!/ ){
						$curstatus = "doctype";
					}elsif( $self->{'_name'} =~ /^\?/s ){
						$curstatus = "processinginstructions";
					}elsif( $self->{'_name'} =~ /^(\!\[CDATA\[)(.*)$/ ){
						$curstatus = "cdata";
						$self->{'_name'} = $1;
						$str = $2 . $str;
					}

				}elsif( ! defined( $str ) ){
					$str = "";
				}

				$self->debug( " ($curstatus) Remaining is $str X\n" ) if( $dval );


			# A space, indicating the end of the name tag, and onto the
			# attributes.
			}elsif( $str =~ /^\s+(\S+.*)$/s ){
				$str = $1;
				$curstatus = "attribs";
			}

			# Check for comments.  Second check in case we missed 
			# something.
			if( $curstatus eq "attribs" ){
				if( $self->{'_name'} =~ /^\!\-\-(.*)$/s ){
					# Start processing a comment.
					$curstatus = "comment";
					$str = $1 . $str;
				}elsif( $self->{'_name'} =~ /^\!/ ){
					$curstatus = "doctype";
				}elsif( $self->{'_name'} =~ /^\?/s ){
					$curstatus = "processinginstructions";
				}elsif( $self->{'_name'} =~ /^(\!\[CDATA\[)(.*)$/ ){
					$curstatus = "cdata";
					$self->{'_name'} = $1;
					$str = $2 . $str;
				}
			}

			# Finally, check for a valid name.
			if( $curstatus ne "name" ){
				if( $self->{'_name'} !~ /^[A-Za-z][A-Za-z0-9\-\_\:\.]*$/ ){
					if( $self->{'_name'} !~ /^(\?|\!)(\S+)/ ){
						# Invalid XML!
						$retval = -2;
						$retstr = $str;
						return( $retval, $retstr );
					}
				}
			}
		}

		# The string is (or is now) text that is stuff with the doctype
		# declaration.
		if( $curstatus =~ /^(doctype|processinginstructions|cdata)/ ){
			my $strlength = ( length( $str ) - 1 );

			my $loop = -1;
			my $stillgoing = 1;
			my $prevquery = -5;

			while( $loop < $strlength && $stillgoing ){
				$loop++;
				my $thischar = substr( $str, $loop, 1 );
				if( $curstatus eq "doctype" ){
					if( $thischar eq '[' ){
						$curstatus = "subtag";
						$stillgoing = 0;
						$self->{'_doctype'} .= $thischar;
						next;
					}elsif( $thischar eq '>' ){
						$curstatus = "complete";
						$stillgoing = 0;
						next;
					}else{
						$self->{'_doctype'} .= $thischar;
						next;
					}
				}elsif( $curstatus eq "processinginstructions" ){
					if( $thischar eq '>' ){
						$self->{'_processinginstructions'} .= $thischar;
						# See if this is the end pattern?
						if( $self->{'_processinginstructions'} =~ /\?>$/s ){
							$self->{'_processinginstructions'} =~ s/\?>$//sg;
							# chomp( $self->{'_processinginstructions'} );
							$self->debug( " PI is " . $self->{'_processinginstructions'} . " X " . $str . " X\n" ) if( $dval );
							# $loop++;
							$curstatus = "complete";
							$stillgoing = 0;
						}
						next;
					}elsif( $thischar eq '?' ){
						$prevquery = '?';
						$self->{'_processinginstructions'} .= $thischar;
					}else{
						$self->{'_processinginstructions'} .= $thischar;
					}
				}elsif( $curstatus eq "cdata" ){
					if( $thischar eq '>' ){
						$self->{'_cdata'} .= $thischar;
						# See if this is the end pattern?
						if( $self->{'_cdata'} =~ /\]\]>$/s ){
							chomp( $self->{'_processinginstructions'} );
							chomp( $self->{'_processinginstructions'} );
							chomp( $self->{'_processinginstructions'} );
							$curstatus = "complete";
							$stillgoing = 0;
						}
					}else{
						$self->{'_cdata'} .= $thischar;
					}
				}
			}

			# Supply the remaining text to return.
			if( $loop < $strlength ){
				# Remember that $loop is the character that we
				# have read, and $strlength has been decremented
				# already.  So adding 1 to $loop is ok.
				$str = substr( $str, ( $loop + 1 ) );
			}else{
				$str = "";
			}
		}

		# The string is (or is now) text that is possibly attribute text.
		# It gets split up based on spaces.
		if( $curstatus =~ /^attrib/ ){

			# The attribute text looks like 'dsfkl="dfg dg" dlgkj="dg"',
			# with a possible end character as well.  At first glance,
			# we can split between seperate attribute name=value pairs
			# by using whitespace, however whitespace within the 
			# attribute value is possibly significant.  We _must_ keep
			# it in place.  The next method of doing this is character
			# by character, which is a royal pain in the ass to do.
			# Since we don't know how big the string is, using 
			# split( // ) simply duplicates the string.  Ugg.
			# So we continually use substr to peek at each character 
			# in turn.
			my $strlength = ( length( $str ) - 1 );

			my $loop = -1;

			my $stillgoing = 1;
			my $prevforslash = -5;	# Need for a numeric comparison.
			my $prevbacslash = -5;	# Need for a numeric comparison.
			my $whitestart = -5;	# Need for a numeric comparison.
			my $prevquery = -5;	# Need for a numeric comparison.

			while( $loop < $strlength && $stillgoing ){
				$loop++;

				# What are we currently doing?  Adding to a current
				# attribute or just waiting for a new attribute?
				# $curstatus is one of:
				#	attribs	- toss out whitespace, wait for
				#		  next attribute or end marker.
				#	attrib-n - Finishing up a name, stored in
				#		   '_cur_attrib_name'.  Look for '='.
				#	attrib-s-fooble - Looking for a seperator
				#			  character to save in 
				#			  '_cur_attrib_end'
				#	attrib-v-fooble - Adding data to an attribute,
				#			  saving everything except for
				#			  the value in '_cur_attrib_end'
				#
				my $thischar = substr( $str, $loop, 1 );

				if( $curstatus eq "attribs" ){