File Coverage

blib/lib/Data/Stag/SxprParser.pm

Criterion	Covered	Total	%
statement	81	94	86.1
branch	37	54	68.5
condition			n/a
subroutine	8	9	88.8
pod	0	2	0.0
total	126	159	79.2

# $Id: SxprParser.pm,v 1.22 2008/06/03 17:31:15 cmungall Exp $
#
# Copyright (C) 2002 Chris Mungall
#
# See also - http://stag.sourceforge.net
#
# This module is free software.
# You may distribute this module under the same terms as perl itself

package Data::Stag::SxprParser;

=head1 NAME

  SxprParser.pm     - parses Stag S-expression format

=head1 SYNOPSIS

=cut

=head1 DESCRIPTION


=head1 AUTHOR

=cut

use Exporter;
use Carp;
use FileHandle;
use strict;
use Data::Stag qw(:all);
use base qw(Data::Stag::BaseGenerator Exporter);

use vars qw($VERSION);
$VERSION="0.14";

sub fmtstr {
    return 'sxpr';
}

sub parse_fh {
    my $self = shift;
    my $fh = shift;
    my $line_no = 0;
    my $state = "init";
    my $txt = '';

    # c: comment ;
    # q: quote (double quote only)
    # o: opening tag - after round bracket, before whitespace or ()
    # 0: body, or awaiting open or close
    while (my $line = <$fh>) {
        $line_no++;

        while (length($line)) {
            my $c = substr($line,0,1,'');
            if ($state eq 'init') {
                if ($c eq '(') {
                    # at start - do nothing
                    $state = 0;
                }
                elsif ($c eq "'") {
                    # leading quote is allowed [list constructor in lisp]
                    # (good for editing in emacs)
                    next;
                    $state = 0;
                }
                elsif ($c =~ /\s/) {
                    next;
                }
                elsif ($c eq ';') {
                    $state = 'c';
                }
                else {
                    $self->throw("Line: $line_no\n$line\nExpected \"(\" at start of file");
                }
            }
            $state ne 'init' || $self->throw("assertion error: state=$state");

            if ($state eq 'c') { # comment
                # newline is the only char that can break out of comments
                if ($c eq "\n") {
                    $state = 0;
                }
                next;
            }
            $state ne 'c' || $self->throw("assertion error: state=$state");

            if ($state eq 'q') {
                if ($c eq '"') {
                    $state = 0;
                }
                else {
                    $txt .= $c;
                }
                next;
            }
            $state ne 'q' || $self->throw("assertion error: state=$state");

            if ($c eq '"') {
                $state = 'q';
                next;
            }
            $state ne 'q' || $self->throw("assertion error: state=$state");

            if ($c eq ';') {
                # can only open comments when NOT in quotes
                $state = 'c';
                next;
            }

            if ($c eq '(') {
                if ($state eq 'o') {
                    if (!$txt) {
                        $self->throw("Line: $line_no\b$line\ndouble open brackets (( not allowed!");
                    }
                    $self->start_event($txt);
                    $txt = '';
                }
                $state = 'o';
                next;
            }
            if ($c eq ')') {
                if ($state eq 'o') {
                    if (!$txt) {
                        $self->throw("Line: $line_no\b$line\n () not allowed!");
                    }
                    $self->start_event($txt);
                    $txt = '';
                    $self->end_event;
                }
                else {
                    if ($txt) {
                        $self->evbody($txt);
                    }
                    $txt = '';
                    $self->end_event;
                }
                $state=0;
                next;
            }
            if ($state eq 'o') {
                if ($c =~ /\s/) {
                    # reached last char of start event name
                    $self->start_event($txt);
                    $txt = '';
                    $state = 0;
                    next;
                }
                else {
                    $txt .= $c;
                    next;
                }
            }
            $state == 0 || $self->throw("assertion error: state=$state");
            if ($c =~ /\s/) {
                next;
            }
            $txt .= $c;
            next;
        }
    }
    if ($txt =~ /\S/) {
        $self->throw("text at end: $txt");
    }
}

1;