File Coverage

blib/lib/Bio/Regexp.pm

Criterion	Covered	Total	%
statement	95	103	92.2
branch	24	36	66.6
condition	7	12	58.3
subroutine	16	22	72.7
pod	0	14	0.0
total	142	187	75.9

package Bio::Regexp;

our $VERSION = '0.101';

use v5.10;
use common::sense;

use Data::Alias;
use Regexp::Exhaustive;

use Bio::Regexp::AST;




sub dna { _arg($_[0], 'type', 'dna') }
sub rna { _arg($_[0], 'type', 'rna') }
sub protein { _arg($_[0], 'type', 'protein') }

sub circular { _arg($_[0], 'circular', 1) }
sub linear { _arg($_[0], 'circular', 0) }

sub single_stranded { _arg($_[0], 'strands', 1) }
sub double_stranded { _arg($_[0], 'strands', 2) }

sub strict_thymine_uracil { _arg($_[0], 'strict_thymine_uracil', 1) }
sub strict_case { _arg($_[0], 'strict_case', 1) }

sub no_substr { _arg($_[0], 'no_substr', 1) }


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

  $self->{type} //= 'dna';

  if ($self->{type} eq 'dna') {
    $self->{arg}->{strands} //= 2;
  } elsif ($self->{type} eq 'rna') {
    $self->{arg}->{strands} //= 1;
  } elsif ($self->{type} eq 'protein') {
    die "protein search not implemented";
  }
}





sub new {
  my ($class, @args) = @_;

  my $self = {};
  bless $self, $class;

  return $self;
}



sub add {
  my ($self, $regexp) = @_;

  die "Can't add new regexp because regexp has already been compiled" if $self->{compiled_regexp};

  push @{ $self->{regexps} }, $regexp;

  return $self;
}



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

  return if $self->{compiled_regexp};

  $self->_arg_defaults;

  my $regexp_index = 0;
  my @regexp_fragments;

  foreach my $regexp (@{ $self->{regexps} }) {
    ## Parse

    my $ast = Bio::Regexp::AST->new($regexp, $self->{type}, $self->{arg});

    ## Compute meta data

    my ($min, $max) = $ast->compute_min_max;

    $self->{min} = $min if !defined $self->{min} || $min < $self->{min};
    $self->{max} = $max if !defined $self->{max} || $max > $self->{max};

    ## Main "sense" strand

    my $rendered = $ast->render;

    push @regexp_fragments, "$rendered(?{ $regexp_index })";
    $regexp_index++;

    my $component = { regexp => $regexp, };

    $component->{strand} = 1 if $self->{arg}->{strands} == 2;

    push @{ $self->{components} }, $component;

    ## Reverse complement strand

    if ($self->{arg}->{strands} == 2) {
      $ast->reverse_complement;
      $rendered = $ast->render;

      push @regexp_fragments, "$rendered(?{ $regexp_index })";
      $regexp_index++;

      my $component = { regexp => $regexp, strand => 2, };

      push @{ $self->{components} }, $component;
    }
  }

  my $compiled_regexp = ($self->{arg}->{strict_case} ? '' : '(?i)') .
                        '(' .
                        ($self->{arg}->{no_substr} ? '?:' : '') .
                        join('|', @regexp_fragments) .
                        ')';

  {
    use re 'eval';
    $self->{compiled_regexp} = qr{$compiled_regexp};
  }

  return $self;
}



sub match {
  alias my ($self, $input, $callback) = @_;

  $self->compile;

  my @output;

  my @matches = Regexp::Exhaustive::exhaustive($input => $self->{compiled_regexp},
                                               qw[ $1 @- @+ $^R ]);

  foreach my $match (@matches) {
    my $element = {
                    match => $match->[0],
                    start => $match->[1]->[0],
                    end => $match->[2]->[0],
                    %{ $self->{components}->[$match->[3]] },
                  };

    push @output, $element;
  }


  ## Check circular overlap

  if ($self->{arg}->{circular}) {
    my $start = length($input) - $self->{max} + 1;
    $start = 1 if $start < 1;

    my $end = $self->{max} - 1;
    $end = 0 if $end < 0;

    my $input_overlap = substr($input, $start) . substr($input, 0, $end);

    my @matches_overlap = Regexp::Exhaustive::exhaustive($input_overlap => $self->{compiled_regexp},
                                                         qw[ $1 @- @+ $^R ]);

    foreach my $match (@matches_overlap) {
      my $element = {
                      match => $match->[0],
                      start => $match->[1]->[0],
                      end => $match->[2]->[0],
                      %{ $self->{components}->[$match->[3]] },
                    };

      $element->{start} += $start;
      $element->{end} += $start;

      push @output, $element;
    }
  }


  ## Re-order reverse complement start/end

  if ($self->{arg}->{strands} == 2) {
    foreach my $match (@output) {
      ($match->{start}, $match->{end}) = ($match->{end}, $match->{start})
        if $match->{strand} == 2;
    }
  }

  return @output;
}






sub _arg {
  my ($self, $arg, $val) = @_;

  die "Can't set $arg to $val because it was already set to $val" if exists $self->{$arg};
  die "Can't set $arg to $val because regexp has already been compiled" if $self->{compiled_regexp};

  $self->{arg}->{$arg} = $val;

  return $self;
}


1;



__END__