File Coverage

blib/lib/DBIx/POS.pm

Criterion	Covered	Total	%
statement	13	53	24.5
branch	0	18	0.0
condition	0	5	0.0
subroutine	5	15	33.3
pod			n/a
total	18	91	19.7

package DBIx::POS::Statement;

use overload '""' => sub { shift->{sql} };

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $self = shift;
    bless ($self, $class);
    return $self;
}

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

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

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

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

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

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

package DBIx::POS;
# arch-tag: 2f764256-6fc0-415e-865d-767d9f202f02

use strict;
use warnings;
use base qw{Pod::Parser};

# Set our version
our $VERSION = '0.03';

# Hold data for our pending statement
my $info = {};

# Hold our SQL
my %sql;

# What command we're looking at
my $state;

# Does the work of creating a new instance
sub _new_instance {
    my $class = shift;
    my $file = shift;
    $class->new->parse_from_file ($file);
    bless \%sql, $class;
}

# Handle =whatever commands
sub command {
    my ($self, $command, $paragraph, $line) = @_;

    # Get rid of all trailing whitespace
    $paragraph =~ s/\s+$//ms;

    # There may be a short description right after the command
    if ($command eq 'desc') {
        $info->{short} = $paragraph || "";
    }

    # The name comes right after the command
    if ($command eq 'name') {
        $self->end_input;
        $info->{name} = $paragraph;
    }

    # The noreturn comes right after the command
    if ($command eq 'noreturn') {
        $info->{noreturn} = 1;
    }

    # Remember what command we're in
    $state = $command;
}

sub end_input {
    my ($self) = @_;

    # If there's stuff to try and construct from
    if (%{$info}) {

        # If we have the necessary bits
        if (scalar (grep {m/^(?:name|short|desc|sql)$/} keys %{$info}) == 3) {

            # Grab the entire content for the %sql hash
            $sql{$info->{name}} = DBIx::POS::Statement->new ($info);

            # Start with a new empty hashref
            $info = {};
        }

        # Something's missing
        else {

            # A nice format for dumping
            use YAML qw{Dump};

            die "Malformed entry\n" . Dump (\%sql, $info);
        }
    }
}

# Taken directly from Class::Singleton---we were already overriding
# _new_instance, and it seemed silly to have an additional dependency
# for four statements.

sub instance {
    my $class = shift;

    # get a reference to the _instance variable in the $class package
    no strict 'refs';
    my $instance = \${ "$class\::_instance" };

    defined $$instance
        ? $$instance
        : ($$instance = $class->_new_instance(@_));
}

# Handle the blocks of text between commands
sub textblock {
    my ($parser, $paragraph, $line) = @_;

    # Collapse trailing whitespace to a \n
    $paragraph =~ s/\s+$/\n/ms;

    if ($state eq 'desc') {
        $info->{desc} .= $paragraph;
    }

    elsif ($state eq 'param') {
        $info->{param} .= $paragraph;
    }

    elsif ($state eq 'sql') {
        $info->{sql} .= $paragraph;
    }
}

# We handle verbatim sections the same way
sub verbatim {
    my ($parser, $paragraph, $line) = @_;

    # Collapse trailing whitespace to a \n
    $paragraph =~ s/\s+$/\n/ms;

    if ($state eq 'desc') {
        $info->{desc} .= $paragraph;
    }

    elsif ($state eq 'param') {
        $info->{param} .= $paragraph;
    }

    elsif ($state eq 'sql') {
        $info->{sql} .= $paragraph;
    }
}

1;

__END__