RTF::Tokenizer - Tokenize RTF

 use RTF::Tokenizer;

 # Create a tokenizer object
	my $tokenizer = RTF::Tokenizer->new();

	my $tokenizer = RTF::Tokenizer->new( string => '{\rtf1}'  );
	my $tokenizer = RTF::Tokenizer->new( string => '{\rtf1}', note_escapes => 1 );

	my $tokenizer = RTF::Tokenizer->new( file   => \*STDIN    );
	my $tokenizer = RTF::Tokenizer->new( file   => 'lala.rtf' );
	my $tokenizer = RTF::Tokenizer->new( file   => 'lala.rtf', sloppy => 1 );

 # Populate it from a file
	$tokenizer->read_file('filename.txt');

 # Or a file handle
	$tokenizer->read_file( \*STDIN );

 # Or a string
	$tokenizer->read_string( '{\*\some rtf}' );

 # Get the first token
	my ( $token_type, $argument, $parameter ) = $tokenizer->get_token();

 # Ooops, that was wrong...
	$tokenizer->put_token( 'control', 'b', 1 );

 \control1Plaintext

#!perl
# RTF::Tokenizer - Peter Sergeant <pete@clueball.com>

require 5;

package RTF::Tokenizer;
BEGIN {
  $RTF::Tokenizer::VERSION = '1.13';
}
use vars qw($VERSION);

use strict;
use warnings;
use Carp;
use IO::File;

sub new {
	# Get the real class name in the highly unlikely event we've been
	# called from an object itself.
	my $proto = shift;
	my $class = ref($proto) || $proto;

	# Read in the named parameters
	my %config = @_;

	my $self = {
		_BUFFER       => '',    # Stores read but unparsed RTF
		_BINARY_DATA  => '',    # Temporary data store if we're reading a \bin
		_FILEHANDLE   => '',    # Stores the active filehandle
		_INITIAL_READ => 512,   # How many characters to read by default. 512 recommended by RTF spec
		_UC           => 1,    # Default number of characters to count for \uc
	};

	bless $self, $class;

	# Call the data-reading convenience methods if required
	if ( $config{'file'} ) {
		$self->read_file( $config{'file'} )
	} elsif ( $config{'string'} ) {
		$self->read_string( $config{'string'} )
	}

	# Set up final config stuff
	$self->{_NOTE_ESCAPES} = $config{'note_escapes'};
	$self->{_SLOPPY}       = $config{'sloppy'};

	return $self;

}

sub read_string {
	my $self = shift;
	$self->{_BUFFER} .= shift;
}

sub read_file {

	my $self = shift;
	my $file = shift;

	# Accept a filehandle referenced via a GLOB
	if ( ref $file eq 'GLOB' ) {
		$self->{_FILEHANDLE} = IO::File->new_from_fd( $file, '<' );
		croak
			"Couldn't create an IO::File object from the reference you specified"
			unless $self->{_FILEHANDLE};

	# Accept IO::File and subclassed objects
	} elsif ( eval { $file->isa('IO::File') } ) {
		$self->{_FILEHANDLE} = $file;

	# This is undocumented, because you shouldn't use it. Don't rely on it.
	} elsif ( ref $file eq 'IO::Scalar' ) {
		$self->{_FILEHANDLE} = $file;

	# If it's not a reference, assume it's a filename
	} elsif ( !ref $file ) {
		$self->{_FILEHANDLE} = IO::File->new("< $file");
		croak "Couldn't open '$file' for reading" unless $self->{_FILEHANDLE};

	# Complain if we get anything else
	} else {
		croak "You passed a reference to read_file of type " . ref($file) .
			" which isn't an allowed type";
	}

	# Check what our line-endings seem to be, then set $self->{_IRS} accordingly.
	# This also reads in the first few lines as a side effect.
	$self->_line_endings;
}

# Reads a line from an IO:File'ish object
sub _get_line {
	my $self = shift();

	# Turn off warnings for the rest of this sub (at some point I'll upgrade
	# to 'no warnings "uninitialized"', but don't want to force a Perl version
	# on people yet)
	local ($^W);

	# Localize the input record separator before changing it so
	# we don't mess up any other part of the application running
	# us that relies on it
	local $/ = $self->{_IRS};

	# Read the line itself
	$self->{_BUFFER} .= $self->{_FILEHANDLE}->getline();
}

# Determine what kind of line-endings the file uses

sub _line_endings {
	my $self = shift();

	my $temp_buffer;
	$self->{_FILEHANDLE}->read( $temp_buffer, $self->{_INITIAL_READ} );

	# This catches all allowed cases
	if ( $temp_buffer =~ m/(\cM\cJ|\cM|\cJ)/ ) {
		$self->{_IRS} = $1;
	}

	# Warnings will happen here if there wasn't a line ending,
	# so switch them off for this part...
	{
		local ($^W);

		$self->{_RS} = "Macintosh" if $self->{_IRS} eq "\cM";
		$self->{_RS} = "Windows"   if $self->{_IRS} eq "\cM\cJ";
		$self->{_RS} = "UNIX"      if $self->{_IRS} eq "\cJ";
	}

	# Add back to main buffer
	$self->{_BUFFER} .= $temp_buffer;

	# Call C<_get_line> again so we're sure we're not only
	# reading half a line
	$self->_get_line;

}

sub get_token {
	my $self = shift;

	# If the last token we returned was \bin, we'll now have a
	# big chunk of binary data waiting for the user, so send that
	# back
	if ( $self->{_BINARY_DATA} ) {
		my $data = $self->{_BINARY_DATA};
		$self->{_BINARY_DATA} = '';
		return ( 'text', $data, '' );
	}

	# We might have a cached token, and if we do, we'll want to
	# return that first
	if ( $self->{_PUT_TOKEN_CACHE_FLAG} ) {
		# Take the value from the cache
		my @return_values = @{ pop( @{ $self->{_PUT_TOKEN_CACHE} } ) };

		# Update the flag
		$self->{_PUT_TOKEN_CACHE_FLAG} = @{ $self->{_PUT_TOKEN_CACHE} };

		# Give the user the token back
		return @return_values;
	}

	# Our main parsing loop
	while (1) {

		my $start_character = substr( $self->{_BUFFER}, 0, 1, '' );

		# Most likely to be text, so we check for that first
		if ( $start_character =~ /[^\\{}\r\n]/ ) {
			local ($^W);    # Turn off warnings here ('uninitialized')

			# We want to return text fields that have newlines in as one
			# token, which requires a bit of work, as we read in one line
			# at a time from out files...
			my $temp_text = '';

		READTEXT:

			# Grab all the next 'text' characters
			$self->{_BUFFER} =~ s/^([^\\{}]+)//s;
			$temp_text .= $1 if defined $1;

			# If the buffer is empty, try reading in some more, and
			# then go back to READTEXT to keep going. Now, the clever
			# thing would be to assume that if the buffer *IS* empty
			# then there MUST be more to read, which is true if we
			# have well-formed input. We're going to assume that the
			# input could well be a little broken.
			if ( ( !$self->{_BUFFER} ) && ( $self->{_FILEHANDLE} ) ) {
				$self->_get_line;
				goto READTEXT if $self->{_BUFFER};
			}

			# Make sure we're not including newlines in our output,
			# as RTF spec says they're to be ignored...
			$temp_text =~ s/(\cM\cJ|\cM|\cJ)//g;

			# Give the user a shiny token back
			return ( 'text', $start_character . $temp_text, '' );

		# Second most likely to be a control character
		} elsif ( $start_character eq "\\" ) {
			my @args = $self->_grab_control();

			# If the control word was an escape, and the user
			# asked to be told separately about those, this
			# will be set, so return an 'escape'. Otherwise,
			# return the control word as a 'control'
			if ( $self->{_TEMP_ESCAPE_FLAG} ) {
				$self->{_TEMP_ESCAPE_FLAG} = 0;
				return ( 'escape', @args );
			} else {
				return ( 'control', @args );
			}

		# Probably a group then
		} elsif ( $start_character eq '{' ) {
			return ( 'group', 1, '' );
		} elsif ( $start_character eq '}' ) {
			return ( 'group', 0, '' );

		# No start character? Either we're at the end of our input,
		# or we need some new input
		} elsif ( !$start_character ) {
			# If we were read from a string, we're all done
			return ( 'eof', 1, 0 ) unless $self->{_FILEHANDLE};

			# If we were read from a file, try and get some more stuff
			# in to the buffer, or return the 'eof' character
			$self->_get_line;
			return ( 'eof', 1, 0 ) unless $self->{_BUFFER};
		}
	}
}

sub put_token {

	my $self = shift;
	my ( $type, $token, $argument ) = ( shift, shift, shift );

	push( @{ $self->{_PUT_TOKEN_CACHE} }, [ $type, $token, $argument ] );

	# No need to set this to the real value of the token cache, as
	# it'll get set properly when we try and read a cached token.
	$self->{_PUT_TOKEN_CACHE_FLAG} = 1;
}

sub sloppy {
	my $self = shift;
	my $bool = shift;

	if ($bool) {
		$self->{_SLOPPY} = 1;
	} else {
		$self->{_SLOPPY} = 0;
	}

	return;
}

sub initial_read {
	my $self = shift;
	if (@_) { $self->{_INITIAL_READ} = shift }
	return $self->{_INITIAL_READ};
}

sub debug {
	my $self = shift;
	my $number = shift || 50;

	return substr( $self->{_BUFFER}, 0, $number );
}

# Work with control characters

sub _grab_control {
	my $self = shift;

	# Check for a star here, as it simplifies our regex below,
	# and it occurs pretty often
	if ( $self->{_BUFFER} =~ s/^\*// ) {
		return ( '*', '' );

	# A standard control word:
	} elsif (
		$self->{_BUFFER} =~ s/

						^([a-z]{1,32})          # Lowercase word
						(-?\d+)?                # Optional signed number
						(
								?:\s                  # Either whitespace, which we gobble
						|
								(?=[^a-z0-9]))        # or a non alpha-numeric, which we leave

						//ix
	) {
		# Return the control word, unless it's a \bin
		my $param = '';
		$param = $2 if defined($2);
		return ( $1, $param ) unless $1 eq 'bin';

		# Pre-grab the binary data, and return the control word
		$self->_grab_bin($2);
		return ( 'bin', $2 );

	# hex-dec character (escape)
	} elsif ( $self->{_BUFFER} =~ s/^'([0-9a-f]{2})//i ) {
		$self->{_TEMP_ESCAPE_FLAG}++ if $self->{_NOTE_ESCAPES};
		return ( "'", $1 );

	# Control symbol (escape)
	} elsif ( $self->{_BUFFER} =~ s/^([-_~:|{}'\\])// ) {
		$self->{_TEMP_ESCAPE_FLAG}++ if $self->{_NOTE_ESCAPES};
		return ( $1, '' );

	# Escaped whitespace (ew, but allowed)
	} elsif ( $self->{_BUFFER} =~ s/^[\r\n]// ) {
		return ( 'par', '' );

	# Escaped tab (ew, but allowed)
	} elsif ( $self->{_BUFFER} =~ s/^\t// ) {
		return ( 'tab', '' );

	# Escaped semi-colon - this is WRONG
	} elsif ( $self->{_BUFFER} =~ s/^\;// ) {
		carp( "Your RTF contains an escaped semi-colon. This isn't allowed, but we'll let you have it back as a literal for now. See the RTF spec." );
		return ( ';', '' );

	# Unicode characters
	} elsif ( $self->{_BUFFER} =~ s/^u(\d+)// ) {
		return ( 'u', $1 );

	# Allow incorrect control words
	} elsif ( ( $self->{_SLOPPY} ) &&
		( $self->{_BUFFER} =~ s/^([a-z]{1,32})(-?\d+)//i ) )
	{
		my $param = '';
		$param = $2 if defined($2);

		return ( $1, $param )
	}

	# If we get here, something has gone wrong. First we'll create
	# a human readable section of RTF to show the user.
	my $die_string = substr( $self->{_BUFFER}, 0, 50 );
	$die_string =~ s/\r/[R]/g;

	# Get angry with the user
	carp
		"Your RTF is broken, trying to recover to nearest group from '\\$die_string'\n";
	carp
		"Chances are you have some RTF like \\control1plaintext. Which is illegal. But you can allow that by passing the 'sloppy' attribute to new() or using the sloppy() method. Please also write to and abuse the developer of the software which wrote your RTF :-)\n";

	# Kill everything until the next group
	$self->{_BUFFER} =~ s/^.+?([}{])/$1/;
	return ( '', '' );
}

# A first stab at grabbing binary data
sub _grab_bin {
	my $self  = shift;
	my $bytes = shift;

	# If the buffer is too small, attempt to read in some more data...
	while ( length( $self->{_BUFFER} ) < $bytes ) {

		# If there's no filehandle, or the one we have is eof, complain
		if ( !$self->{_FILEHANDLE} || $self->{_FILEHANDLE}->eof ) {
			croak "\\bin is asking for $bytes characters, but there are only " .
				length( $self->{_BUFFER} ) . " left.";
		}

		# Try and read in more data
		$self->_get_line;
	}

	# Return the right number of characters
	$self->{_BINARY_DATA} = substr( $self->{_BUFFER}, 0, $bytes, '' );
}

1;