# RTF::Tokenizer - Peter Sergeant =head1 NAME RTF::Tokenizer - Tokenize RTF =head1 DESCRIPTION Tokenizes RTF =head1 SYNOPSIS 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 ); =head1 INTRODUCTION This documentation assumes some basic knowledge of RTF. If you lack that, go read The_RTF_Cookbook: L =cut require 5; package RTF::Tokenizer; use vars qw($VERSION); use strict; use Carp; use IO::File; $VERSION = '1.10'; =head1 METHODS =head2 new() Instantiates an RTF::Tokenizer object. B: C - calls the C method with the value provided after instantiation C - calls the C method with the value provided after instantiation C - boolean - whether to give RTF Escapes a token type of C (true) or C (false) C - boolean - whether or not to allow some illegal but common RTF sequences found 'in the wild'. As of C<1.08>, this currently only allows control words with a numeric argument to have a text field right after with no delimiter, like: \control1Plaintext but this may change in future releases. =cut 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; } =head2 read_string( STRING ) Appends the string to the tokenizer-object's buffer (earlier versions would over-write the buffer - this version does not). =cut sub read_string { my $self = shift; $self->{_BUFFER} .= shift; } =head2 read_file( \*FILEHANDLE ) =head2 read_file( $IO_File_object ) =head2 read_file( 'filename' ) Appends a chunk of data from the filehandle to the buffer, and remembers the filehandle, so if you ask for a token, and the buffer is empty, it'll try and read the next line from the file (earlier versions would over-write the buffer - this version does not). This chunk is 500 characters, and then whatever is left until the next occurrence of the IRS (a newline character in this case). If for whatever reason, you want to change that number to something else, use C. =cut 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; } =head2 get_token() Returns the next token as a three-item list: 'type', 'argument', 'parameter'. Token is one of: C, C, C, C or C. =over =item C 'type' is set to 'text'. 'argument' is set to the text itself. 'parameter' is left blank. NOTE: C<\{>, C<\}>, and C<\\> are all returned as control words, rather than rendered as text for you, as are C<\_>, C<\-> and friends. =item C 'type' is 'control'. 'argument' is the control word or control symbol. 'parameter' is the control word's parameter if it has one - this will be numeric, EXCEPT when 'argument' is a literal ', in which case it will be a two-letter hex string. =item C 'type' is 'group'. If it's the beginning of an RTF group, then 'argument' is 1, else if it's the end, argument is 0. 'parameter' is not set. =item C End of file reached. 'type' is 'eof'. 'argument' is 1. 'parameter' is 0. =item C If you specifically turn on this functionality, you'll get an C type, which is identical to C, only, it's only returned for escapes. =back =cut 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 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}; } } } =head2 put_token( type, token, argument ) Adds an item to the token cache, so that the next time you call get_token, the arguments you passed here will be returned. We don't check any of the values, so use this carefully. This is on a first in last out basis. =cut 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; } =head2 sloppy( [bool] ) Decides whether we allow some types of broken RTF. See C's docs for a little more explanation about this. Pass it 1 to turn it on, 0 to turn it off. This will always return undef. =cut sub sloppy { my $self = shift; my $bool = shift; # $bool ? $self->{_SLOPPY} = 1 : $self->{_SLOPPY} = 0; if ( $bool ) { $self->{_SLOPPY} = 1 } else { $self->{_SLOPPY} = 0 } return undef; } =head2 initial_read( [number] ) Don't call this unless you actually have a good reason. When the Tokenizer reads from a file, it first attempts to work out what the correct input record-seperator should be, by reading some characters from the file handle. This value starts off as 512, which is twice the amount of characters that version 1.7 of the RTF specification says you should go before including a line feed if you're writing RTF. Called with no argument, this returns the current value of the number of characters we're going to read. Called with a numeric argument, it sets the number of characters we'll read. You really don't need to use this method. =cut sub initial_read { my $self = shift; if (@_) { $self->{_INITIAL_READ} = shift } return $self->{_INITIAL_READ}; } =head2 debug( [number] ) Returns (non-destructively) the next 50 characters from the buffer, OR, the number of characters you specify. Printing these to STDERR, causing fatal errors, and the like, are left as an exercise to the programmer. Note the part about 'from the buffer'. It really means that, which means if there's nothing in the buffer, but still stuff we're reading from a file it won't be shown. Chances are, if you're using this function, you're debugging. There's an internal method called C<_get_line>, which is called without arguments (C<$self->_get_line()>) that's how we get more stuff into the buffer when we're reading from filehandles. There's no guarentee that'll stay, or will always work that way, but, if you're debugging, that shouldn't matter. =cut 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, '' ); } =head1 NOTES To avoid intrusively deep parsing, if an alternative ASCII representation is available for a Unicode entity, and that ASCII representation contains C<{>, or C<\>, by themselves, things will go B. But I'm not convinced either of those is allowed by the spec. =head1 AUTHOR Pete Sergeant -- C =head1 LICENSE Copyright B. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1;