File Coverage

blib/lib/Bio/GFF3/LowLevel.pm

Criterion	Covered	Total	%
statement	82	86	95.3
branch	30	34	88.2
condition	10	15	66.6
subroutine	15	15	100.0
pod	6	6	100.0
total	143	156	91.6

package Bio::GFF3::LowLevel;
BEGIN {
  $Bio::GFF3::LowLevel::AUTHORITY = 'cpan:RBUELS';
}
{
  $Bio::GFF3::LowLevel::VERSION = '2.0';
}
# ABSTRACT: fast, low-level functions for parsing and formatting GFF3

use strict;

use Scalar::Util ();
use URI::Escape ();


require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
  gff3_parse_feature
  gff3_parse_attributes
  gff3_parse_directive
  gff3_format_feature
  gff3_format_attributes
  gff3_escape
  gff3_unescape
);

my @gff3_field_names = qw(
    seq_id
    source
    type
    start
    end
    score
    strand
    phase
    attributes
);


sub gff3_parse_feature {
  my ( $line ) = @_;
  no warnings 'uninitialized';

  my @f = split /\t/, $line;
  for( @f ) {
      if( $_ eq '.' ) {
          $_ = undef;
      }
  }

  # unescape only the ref and source columns
  $f[0] =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
  $f[1] =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;

  $f[8] = gff3_parse_attributes( $f[8] );
  my %parsed;
  @parsed{@gff3_field_names} = @f;
  return \%parsed;
}


sub gff3_parse_attributes {
    my ( $attr_string ) = @_;

    return {} if !defined $attr_string || $attr_string eq '.';

    $attr_string =~ s/\r?\n$//;

    my %attrs;
    for my $a ( split ';', $attr_string ) {
        no warnings 'uninitialized';
        my ( $name, $values ) = split '=', $a, 2;
        next unless defined $values;
        push @{$attrs{$name}}, map { s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; $_ } split ',', $values;
    }

    return \%attrs;
}


sub gff3_parse_directive {
    my ( $line ) = @_;

    my ( $name, $contents ) = $line =~ /^ \s* \#\# \s* (\S+) \s* (.*) $/x
        or return;

    my $parsed = { directive => $name };
    if( length $contents ) {
        $contents =~ s/\r?\n$//;
        $parsed->{value} = $contents;
    }

    # do a little additional parsing for sequence-region and genome-build directives
    if( $name eq 'sequence-region' ) {
        my ( $seqid, $start, $end ) = split /\s+/, $contents, 3;
        s/\D//g for $start, $end;
        @{$parsed}{qw( seq_id start end )} = ( $seqid, $start, $end );
    }
    elsif( $name eq 'genome-build' ) {
        my ( $source, $buildname ) = split /\s+/, $contents, 2;
        @{$parsed}{qw(source buildname)} = ( $source, $buildname );
    }

    return $parsed;
}


sub gff3_format_feature {
    my ( $f ) = @_;

    my $attr_string = $f->{attributes};
    $attr_string = '.' unless defined $attr_string;

    $attr_string = gff3_format_attributes( $attr_string )
        if    ref( $attr_string ) eq 'HASH'
           && ! Scalar::Util::blessed( $attr_string );

    return join( "\t",
                 ( map { defined $_ ? gff3_escape($_) : '.' }
                   @{$f}{@gff3_field_names[0..7]}
                 ),
                 $attr_string
               )."\n";
}


my %force_attr_first = (
    ID     => 1,
    Name   => 2,
    Alias  => 3,
    Parent => 4,
);
sub _cmp_attr_names {
    no warnings 'uninitialized';
    my ( $fa, $fb ) = @force_attr_first{ $a, $b };
    return $fa <=> $fb if $fa && $fb;

    return -1 if  $fa && !$fb;
    return  1 if !$fa &&  $fb;

    return $a cmp $b;
}

sub gff3_format_attributes {
  my ( $attr ) = @_;

  return '.' unless defined $attr;

  my $astring = join ';' => (
    map {
      my $key = $_;
      my $val = $attr->{$key};
      no warnings 'uninitialized';
      $val = join( ',', map gff3_escape($_), ref $val eq 'ARRAY' ? @$val : $val );
      if( length $val ) {
          "$key=$val"
      } else {
          ()
      }
    }
    sort _cmp_attr_names
    keys %$attr
 );

  return length $astring ? $astring : '.';
}


sub gff3_escape {
    URI::Escape::uri_escape( $_[0], '\n\r\t;=%&,\x00-\x1f\x7f-\xff' )
}


*gff3_unescape = \&URI::Escape::uri_unescape;

__END__