• Files
• Commits
• Log
• Graph
• Stats

package LIMS::Local::QueryLibrary;

use strict;
use warnings;

use Data::Dumper;
# use Data::Printer;
our $VERSION = 0.0.3; # CPAN version has not been updated since 2004

=head1 NAME

SQL::Library - A module for managing simple SQL libraries
stored in INI-like files.

=head1 VERSION

This document refers to version 0.0.3 of SQL::Library.

=head1 SYNOPSIS

Modification of CPAN SQL::Library - uses its new() and retr() methods and adds
a new function in new() to ensure unique entity_name entries. Original
SQL::Library silently ignored duplicate entries eg [find_stuff] .... [find_stuff]
and appended content of duplicate entry to content of initial entry:
$self->{'contents'}->{$curr_name} .= $_; # $curr_name = entity_name of SQL query

23/10/2017:
strip c-style comments from beginning of query; appends new-line so needs to be
removed

only includes retr() & elements(), not other methods such as set(), drop(), etc
=cut

sub new
{
    my $proto = shift;
    my $options = shift;
    my $self = {
                 'options'  => $options,
                 'contents' => undef
               };

    my $curr_name = '';

    my @lib_arr = ();
    if ( ref $self->{'options'}->{'lib'} eq 'ARRAY' )
    {
        # Could be a filehandle or a string.
        if ( @{ $self->{'options'}->{'lib'} } == 1 )
        {
            @lib_arr = split /(?<=\n)/, $self->{'options'}->{'lib'}->[0];
        }
        else
        {
            @lib_arr = @{ $self->{'options'}->{'lib'} };
        }
    }
    else
    {
        open LIB, $self->{'options'}->{'lib'}
          or die "Cannot open $self->{'options'}->{'lib'}: $!";
        @lib_arr = <LIB>;
        close LIB;
    }
#-------------------------------------------------------------------------------
	my %seen = (); # new code to check for duplicate entries - see below
#-------------------------------------------------------------------------------
    foreach ( @lib_arr ) # each line of library(s) content
    {
        next if m{^\s*$};
        next if m{^\s*#};
        next if m{^\s*//};
        if ( m{^\[([^\]]+)\]} ) # gets entity_name of entry eg [find_stuff]
        {
            $curr_name = $1; # warn Dumper $curr_name;
#-------------------------------------------------------------------------------
			die 'already have entry for ' . $curr_name if $seen{$curr_name}++;
#-------------------------------------------------------------------------------
            next;
        }
        if ( $curr_name )
        {
            $self->{'contents'}->{$curr_name} .= $_;
        }
    }

    bless $self, $proto;
    return $self;
}

=item $OBJ-E<gt>retr( NAME )

Returns the library entry referenced by NAME.

=cut

sub retr
{
    my ( $self, $entity_name ) = @_;
#-------------------------------------------------------------------------------
    # return $self->{'contents'}->{$entity_name}; # strip c-style comments:
    my $str = $self->{contents}->{$entity_name};
    return strip_comments($str); # ignores queries without /* c-style comments */
#-------------------------------------------------------------------------------
}

sub elements
{
    my $self = shift;
    return sort keys %{$self->{'contents'}};
}

# http://perldoc.perl.org/perlfaq6.html#How-do-I-use-a-regular-expression-to-strip-C-style-comments-from-a-file%3f
sub strip_comments {
    my $str = shift; # my $pre = $str; p $pre;
    # short one-line version to remove /* comments */ only, need to remove
    # remaining new-line marker or QueryLog dumps query to error.log
    my $n = $str =~ s{/\*[^*]*\*+([^/*][^*]*\*+)*/}{defined $2 ? $2 : ""}gse; # p $n;
    # remove any leading white-spaces before SELECT/UPDATE, etc (breaks QueryLog)
    $str =~ s/^\s+//; # p $pre if $str ne $pre;
    return $str;
=begin # long version:
    $str =~ s{
        /\*         ##  Start of /* ... */ comment
        [^*]*\*+    ##  Non-* followed by 1-or-more *'s
        (
           [^/*][^*]*\*+
        )*      ##  0-or-more things which don't start with / but do end with *
        /       ##  End of /* ... */ comment
      |         ##     OR  various things which aren't comments:
        (
            "   ##  Start of " ... " string
                (
                    \\.           ##  Escaped char
                    |             ##    OR
                    [^"\\]        ##  Non "\
                )*
            "   ##  End of " ... " string
            |   ##     OR
            '   ##  Start of ' ... ' string
                (
                    \\.     ##  Escaped char
                    |       ##    OR
                    [^'\\]  ##  Non '\
                )*
            '   ##  End of ' ... ' string
            |   ##     OR
            .   ##  Anything other char
            [^/"'\\]*   ##  Chars which doesn't start a comment, string or escape
        )
      }{defined $2 ? $2 : ""}gxse; # p $pre if $str ne $pre;
    # remove leading new-line left over from /* comment */ removal:
    $str =~ s/^\s+//; # or breaks QueryLog and all queries go to Apache error log
    return $str;
=cut
}

1;