view release on metacpan or  search on metacpan

lib/Bio/Regexp.pm  view on Meta::CPAN

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;