• 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

strip c-style comments from beginning of query (23/10/2017)

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};
    my $re = qr{/\*}; # eg /* some comment */
    return $str =~ /^$re/ # affects stdout format so only apply IF c-style comments
        ? strip_comments($str) : $str;
#-------------------------------------------------------------------------------
}

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%
sub strip_comments {
    my $str = shift; # p $str;
    $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;
    return $str;
}
1;