view release on metacpan or  search on metacpan

lib/Bio/Das/Lite.pm  view on Meta::CPAN

  # recursive child-node handling, usually for <group>s
  #
  for my $subpart (@subparts) {
    my $subpart_ref  = [];

    my $pat = qr{(<$subpart[^>]*/>|<$subpart[^>]*?(?!/)>.*?/$subpart>)}smix;
    while($blk =~ s/$pat//smx) {
      $self->_parse_branch({
			    request    => $dsn,
			    seginfo    => $subpart_ref,
			    attr       => $attr->{$subpart},
			    blk        => $1,
			    addseginfo => 0,
			    depth      => $depth+1,
			   });
    }

    if(scalar @{$subpart_ref}) {
      $ref->{$subpart} = $subpart_ref;
    }

    #########
    # To-do: normalise group data across features here - mostly for 'group' tags in feature responses
    # i.e. merge links, use cached hashrefs (keyed on group id) describing groups to reduce the parsed tree footprint
    # NOTE: groups are now deprecated
    #
  }

  #########
  # Attribute processing for tags in blocks
  #
  my $tmp;
  for my $tag (@parts) {
    my $opts = $attr->{$tag}||[];

    for my $a (@{$opts}) {
      ($tmp)              = $blk =~ m{<$tag[^>]*\s+$a="([^"]+?)"}smix;
      if(defined $tmp) {
	$ref->{"${tag}_$a"} = $tmp;
      }
    }

    ($tmp) = $blk =~ m{<$tag[^>]*>([^<]+)</$tag>}smix;
    if(defined $tmp) {
      $tmp         =~ s/^\s+$//smgx;
      if(length $tmp) {
	$ref->{$tag} = $tmp;
      }
    }
    if($tmp && $DEBUG) {
      print {*STDERR} q( )x($depth*2), qq(  $tag = $tmp\n); ## no critic (InputOutput::RequireCheckedSyscalls)
    }
  }

  $self->_parse_twig($dsn, $blk, $ref, $addseginfo);

  push @{$ar_ref}, $ref;
  $DEBUG and print {*STDERR} q( )x($depth*2), qq(leaving _parse_branch\n);

  #########
  # only perform callbacks if we're at recursion depth zero
  #
  if($depth == 0 && $self->{'callback'}) {
    $DEBUG and print {*STDERR} q( )x($depth*2), qq(executing callback at depth $depth\n);
    $ref->{'dsn'} = $dsn;
    my $callback  = $self->{'callback'};
    &{$callback}($ref);
  }

  return q();
}

sub _parse_twig {
  my ($self, $dsn, $blk, $ref, $addseginfo) = @_;

  #########
  # handle multiples of twig elements here
  #
  $blk =~ s/$LINKRE/{
                     $ref->{'link'} ||= [];
                     push @{$ref->{'link'}}, {
                                              'href' => $1 || $3,
                                              'txt'  => $2,
                                             };
                     q()
                    }/smegix;
  $blk =~ s/$NOTERE/{
                     $ref->{'note'} ||= [];
                     push @{$ref->{'note'}}, $1;
                     q()
                    }/smegix;

  if($addseginfo && $self->{'currentsegs'}->{$dsn}) {
    while(my ($k, $v) = each %{$self->{'currentsegs'}->{$dsn}}) {
      $ref->{$k} = $v;
    }
  }
  return;
}

sub registry {
  my ($self, @reg) = @_;

  if((scalar @reg == 1) &&
     (ref $reg[0])      &&
     (ref$reg[0] eq 'ARRAY')) {
    push @{$self->{'registry'}}, @{$reg[0]};
  } else {
    push @{$self->{'registry'}}, @reg;
  }
  return $self->{'registry'};
}

sub registry_sources {
  my ($self, $filters, $flush) = @_;

  $filters       ||= {};
  my $category     = $filters->{'category'}   || [];
  my $capability   = $filters->{'capability'} || $filters->{'capabilities'} || [];

  if(!ref $category) {

lib/Bio/Das/Lite.pm  view on Meta::CPAN

  my $sources = $das->source;  

=head2 sequence : Retrieve sequence data for a segment (probably dna or protein)

  my $sequence      = $das->sequence('2:1,1000'); # segment:start,stop (e.g. chromosome 2, bases 1 to 1000)

=head2 stylesheet : Retrieve stylesheet data

  my $style_data    = $das->stylesheet();
  my $style_data2   = $das->stylesheet($callback);

=head2 statuscodes : Retrieve HTTP status codes for request URLs

  my $code         = $das->statuscodes($url);
  my $code_hashref = $das->statuscodes();

=head2 specversions : Retrieve a server's DAS specification version for a request URL

  my $version         = $das->specversions($url);  # e.g. 1.53, 1.6, 1.6E
  my $version_hashref = $das->specversions();

=head2 max_hosts set number of running concurrent host connections

  THIS METHOD IS NOW DEPRECATED AND HAS NO EFFECT

  $das->max_hosts(7);
  print $das->max_hosts();

=head2 max_req set number of running concurrent requests per host

  THIS METHOD IS NOW DEPRECATED AND HAS NO EFFECT

  $das->max_req(5);
  print $das->max_req();

=head2 registry : Get/Set accessor for DAS-Registry service URLs

  $biodaslite->registry('http://www.dasregistry.org/das');

  my $registry_arrayref = $biodaslite->registry();

=head2 registry_sources : Arrayref of dassource objects from the configured registry services

  my $sources_ref = $biodaslite->registry_sources();

  my $sources_ref = $biodaslite->registry_sources({
    'capability' => ['features','stylesheet'],
  });

  my $sources_ref = $biodaslite->registry_sources({
    'category' => ['Protein Sequence'],
  });

=head2 build_queries

Constructs an arrayref of DAS requests including parameters for each call

=head2 build_requests

Constructs the WWW::Curl callbacks

=head2 postprocess

Applies processing to the result set, e.g. removal of whitespace from sequence responses.

=head1 DESCRIPTION

This module is an implementation of a client for the DAS protocol (XML over HTTP primarily for biological-data).

=head1 DEPENDENCIES

=over

=item strict

=item warnings

=item WWW::Curl

=item HTTP::Response

=item Carp

=item English

=item Readonly

=back

=head1 DIAGNOSTICS

  Set $Bio::Das::Lite::DEBUG = 1;

=head1 CONFIGURATION AND ENVIRONMENT


=head1 INCOMPATIBILITIES

=head1 BUGS AND LIMITATIONS

  The max_req and max_hosts methods are now deprecated and have no effect.

=head1 SEE ALSO

DAS Specifications at: http://biodas.org/documents/spec.html

ProServer (A DAS Server implementation also by the author) at:
   http://www.sanger.ac.uk/proserver/

The venerable Bio::Das suite (CPAN and http://www.biodas.org/download/Bio::Das/).

The DAS Registry at:
   http://das.sanger.ac.uk/registry/

=head1 AUTHOR

Roger Pettett, E<lt>rpettett@cpan.orgE<gt>

=head1 LICENSE AND COPYRIGHT