LRG LRG
Other packages in the module: LRG LRG::LRG
Package variablesGeneral documentationMethods
Toolbar
WebCvsRaw content
Package variables
No package variables defined.
Synopsis
No synopsis!
Description
No description!
Methods
addEmptyNode
No description
Code
addExisting()
No description
Code
addNode
No description
Code
addNodeMulti()
No description
Code
content()
No description
Code
countNodes()
No description
Code
data
No description
Code
date()
No description
Code
empty
No description
Code
findNode
No description
Code
findNodeMulti
No description
Code
findOrAdd()
No description
Code
moveTo()
No description
Code
name
No description
Code
new
No description
Code
newFromFile
No description
Code
parent
No description
Code
pfetch()
No description
Code
position()
No description
Code
printAll
No description
Code
printNode
No description
Code
requestContent()
No description
Code
xml()
No description
Code
Methods description
None available.
Methods code
addEmptyNodedescriptionprevnextTop
sub addEmptyNode {
    my $self = shift;

    my $name = shift;
    
    # look for an additional arg containing
# data to be written in the tag itself
my $data = shift if @_; # check that the data sent is a hash
if(scalar keys %{$data}) { push @{$self->{'nodes'}}, LRG::Node::newEmpty($name, $self->{'xml'}, $data); } # otherwise assume no data
else { push @{$self->{'nodes'}}, LRG::Node::newEmpty($name, $self->{'xml'}); } (@{$self->{'nodes'}})[-1]->{'parent'} = $self; # return the last node added (i.e. this one)
return (@{$self->{'nodes'}})[-1]; } # add a ready-created node to this node
}
addExisting()descriptionprevnextTop
sub addExisting() {
	my $self = shift;
	
	my $new_node = shift;
	
	$new_node->{'parent'} = $self;
	
	#if(!defined $new_node->xml) {
$new_node->xml($self->xml) if defined $self->xml; #}
push @{$self->{'nodes'}}, $new_node; } # add multiple embedded nodes
}
addNodedescriptionprevnextTop
sub addNode {
    my $self = shift;

    my $name = shift;
    
    if($name =~ /\//) {
    	return $self->addNodeMulti($name);
    }
    
    # look for an additional arg containing
# data to be written in the tag itself
my $data = shift if @_; # check that the data sent is a hash
if(scalar keys %{$data}) { push @{$self->{'nodes'}}, LRG::Node::new($name, $self->{'xml'}, $data); } # otherwise assume no data
else { push @{$self->{'nodes'}}, LRG::Node::new($name, $self->{'xml'}); } (@{$self->{'nodes'}})[-1]->{'parent'} = $self; # return the last node added (i.e. this one)
return (@{$self->{'nodes'}})[-1];
}
addNodeMulti()descriptionprevnextTop
sub addNodeMulti() {
	my $self = shift;
	my $name = shift;

    my @levels = split /\s*\/\s*/, $name;

    # if only one level given, do a normal addNode
if(scalar @levels == 1) { return $self->addNode($name); } else { my $current = $self; while(@levels) { my $level = shift @levels; if(scalar @levels >= 1) { $current = $current->addNode($level); } else { return $current->addNode($level); } } } } # find node
}
content()descriptionprevnextTop
sub content() {
    my $self = shift;
    
    $self->{'content'} = shift if @_;

    return $self->{'content'};
}

# getter/setter for this node's position in the array order
}
countNodes()descriptionprevnextTop
sub countNodes() {
    my $self = shift @_;

    return scalar @{$self->parent->{'nodes'}};
}

# get content from STDIN given a list of fields
}
datadescriptionprevnextTop
sub data {
    my $self = shift;

    $self->{'data'} = shift if @_;

    return $self->{'data'};
}

# getter/setter for empty status
}
date()descriptionprevnextTop
sub date() {
    my @time = localtime(time());
    
    $time[4]++;

    # add leading zeroes as required
for my $i(0..4) { $time[$i] = "0".$time[$i] if $time[$i] < 10; } my $time = ($time[5] + 1900)."-".$time[4]."-".$time[3]; return $time; } # getter/recursive setter for the XML object
}
emptydescriptionprevnextTop
sub empty {
    my $self = shift;

    $self->{'empty'} = shift if @_;

    return $self->{'empty'};
}

# getter/setter for content
}
findNodedescriptionprevnextTop
sub findNode {
    my $self = shift;
    my $name = shift;
    my $data = shift if @_;

    # do a multi find if the name is delimited with "/"s
return $self->findNodeMulti($name, $data) if $name =~ /\//; my $found; my $match; # look through the nodes
foreach my $node(@{$self->{'nodes'}}) { # if the name matches
if(defined $node->name && defined $name && $node->name eq $name) { $match = 1; # if we are comparing data too
if(scalar keys %$data && scalar keys %{$node->data}) { $match = 0; my $needed = scalar keys %$data; foreach my $key(keys %$data) { next unless defined $node->data->{$key}; $match++ if $node->data->{$key} eq $data->{$key}; } $match = ($match == $needed ? 1 : 0); } if($match) { $found = $node; last; } } last if defined $found; # look recursively in any sub-nodes if not found
$found = $node->findNode($name, $data); } return $found; } # find node given multiple levels
}
findNodeMultidescriptionprevnextTop
sub findNodeMulti {
    my $self = shift;
    my $name = shift;
    my $data = shift if @_;

    my @levels = split /\s*\/\s*/, $name;

    # if only one level given, do a normal findNode
if(scalar @levels == 1) { return $self->findNode($name, $data); } else { my $current = $self; while(@levels) { my $level = shift @levels; if(scalar @levels >= 1) { $current = $current->findNode($level); } else { $current = $current->findNode($level, $data); } } return $current; } } # find or create a node if it doesn't exist
}
findOrAdd()descriptionprevnextTop
sub findOrAdd() {
	my $self = shift;
	my $name = shift;
	
	my $find = $self->findNode($name);
	
	if(defined $find) {
		return $find;
	}
	
	else {
		return $self->addNode($name);
	}
}

# compare a node with another
#sub compare {
# my $self = shift;
# my $comp = shift;
#
# my $match;
#
# # if the name matches
# if(defined $node->name && defined $name && $node->name eq $name) {
#
# $match = 1;
#
# # if we are comparing data too
# if(scalar keys %$data && scalar keys %{$node->data}) {
# $match = 0;
#
# my $needed = scalar keys %$data;
#
# foreach my $key(keys %$data) {
# next unless defined $node->data->{$key};
#
# $match++ if $node->data->{$key} eq $data->{$key};
# }
#
# $match = ($match == $needed ? 1 : 0);
# }
#
# if($match) {
# $found = $node;
# last;
# }
# }
#}
# print node
}
moveTo()descriptionprevnextTop
sub moveTo() {
    my $self = shift;
    my $num = (@_ ? shift : 1);
    #$num--;
my $pos = $self->position(); # copy the nodes array to @nodes
my @nodes = @{$self->parent->{'nodes'}}; # find out the highest index of the array
my $last_index = $#nodes; # if num is out of range
#$num = $last_index + 1 if $num > $last_index + 1;
# get the before and after arrays:
# (..@before..)*(..@after..)
# --------------------------
# where * is self
my @before = ($pos - 1 >= 0 ? @nodes[0..($pos-1)] : ()); my @after = ($pos + 1 <= $last_index ? @nodes[($pos+1)..$last_index] : ()); # put them back together and recalc the last index
@nodes = (@before, @after); $last_index = $#nodes; # chop into two again, only this time get all
# since this array doesn't include self:
# (..@before..)(..@after..)
# -------------------------
@before = ($num - 1 >= 0 ? @nodes[0..($num-1)] : ()); @after = ($num <= $last_index ? @nodes[$num..$last_index] : ()); # create a new array with self inserted in its new position
@nodes = (@before, $self, @after); # copy the new array into the parent's structure
$self->parent->{'nodes'} =\@ nodes; } # count the number of nodes
}
namedescriptionprevnextTop
sub name {
    my $self = shift;

    $self->{'name'} = shift if @_;

    return $self->{'name'};
}

# get parent node
}
newdescriptionprevnextTop
sub new {
    my $file = shift if @_;

    my $lrg;
    
    if(defined $file) {
		
		# get an IO object for the file
my $output = new IO::File(">$file") or die "Could not write to file $file\n"; # initialise the XML::Writer object
# the last two parameters ensure pretty formatting when the file is written
$lrg->{'xml'} = new XML::Writer(OUTPUT => $output, DATA_INDENT => 2, DATA_MODE => 1); } else { $lrg->{'xml'} = new XML::Writer(DATA_INDENT => 2, DATA_MODE => 1); } # initialise the nodes array
$lrg->{'nodes'} = (); # give this root node a name for completeness' sake
$lrg->{'name'} = 'LRG_ROOT_NODE'; # bless and return
bless $lrg, 'LRG::LRG'; return $lrg; } # constructor reads XML from file
}
newFromFiledescriptionprevnextTop
sub newFromFile {
    my $file = shift;

    my $outfile = shift if @_;

    # create a new LRG root - this can be a specific file
# or just a temporary file if one is not specified
my $lrg = LRG::LRG::new(defined $outfile ? $outfile : undef); # set the current node to the root
my $current = $lrg; my $name; # open the file
open IN, $file or die("Could not read from file $file\n"); # initiate a blank string to hold the XML
my $xml_string = ''; # read in the file
while(<IN>) { chomp; # lose leading/trailing whitespace
s/^\s+//g; s/\s+$//g; # ignore comment lines
next if /^\<\?/; $xml_string .= $_; } close IN; # get rid of newline and carriage return characters
$xml_string =~ s/\r+//g; $xml_string =~ s/\n+//g; my $prev_end = 0; # loop through XML tags sequentially
while($xml_string =~ m/<.+?>/g) {

# get the matched string and details about it
my
$string = $&;
my $length = length($string); my $pos = pos($xml_string); my $start = $pos - $length; my $end = $pos; # this code searches for content between tags
if($prev_end >= 1 && $start - $prev_end > 1) { # get substring from the XML string
my $temp = substr($xml_string, $prev_end, ($start - $prev_end)); # check that it contains word characters
if($temp =~ /\w+/) { # add content to the current node
$current->content($temp); } } # reset the prev_end variable
$prev_end = $end; # get rid of tag open/close characters
$string =~ s/\<|\>//g; # if this is a closing tag, point current to this node's parent
if($string =~ /^\//) { $current = $current->parent; } # otherwise this is an opening or empty tag
else { # split by whitespace
my @split = split /\s+/, $string; # the name of the tag is the first element
$name = shift @split; # if there are more elements, assume these are additional
# key/value pairs to be added
if(scalar @split) { # join
$string = join " ", @split; # change " = " to "="
$string =~ s/\s*\=\s*/\=/; # re-split by space or =
@split = split /\s+|\=/, $string; # create a new hash
my %data = (); # iterate through remaining elements
while(@split) { # get key/value pair
my $key = shift @split; my $val = shift @split; # remove "s and 's as these are converted to HTML form
# by XML::Writer
$val =~ s/\"|\'//g; # remove trailing / if it's an empty tag
$val =~ s/\/$//g; # add the data to the hash
$data{$key} = $val; } # if this is an empty tag (ends with a "/")
if($string =~ /\/$/) { $current = $current->addEmptyNode($name,\% data); # reset current to this node's parents
$current = $current->parent; } # if this is a normal opening tag
else { $current = $current->addNode($name,\% data); } } # no extra data elements to add
else { # if this is an empty tag (ends with a "/")
if($string =~ /\/$/) { $current = $current->addEmptyNode($name); # reset current node to this node's parents
$current = $current->parent; } # if this is a normal opening tag
else { $current = $current->addNode($name); } } } } # return
return $lrg; } # add node
}
parentdescriptionprevnextTop
sub parent {
    my $self = shift;

    return $self->{'parent'} if defined $self->{'parent'};
}

# getter/setter for data
}
pfetch()descriptionprevnextTop
sub pfetch() {
    my $self = shift;
    my $id = shift;
    my $sequence;

    open IN, "pfetch $id |";
    while(<IN>) {
		next if /^\>/;
		chomp;
		$sequence .= $_;
    }
    close IN;

    return $sequence;
}



# NODE
######
package LRG::Node; # inherit some functions from root LRG
our @ISA = "LRG::LRG";
}
position()descriptionprevnextTop
sub position() {
    my $self = shift;
    my $to = shift if @_;

    # if a new position specified, use the moveTo() subroutine
$self->moveTo($to) if defined $to; my $pos; for my $i(0..(scalar @{$self->parent->{'nodes'}} - 1)) { if($self eq $self->parent->{'nodes'}->[$i]) { $pos = $i; last; } } return $pos; } # move a node to a specific position in the array
# NB shunts all others down one so any pos need
# to be recalculated
}
printAlldescriptionprevnextTop
sub printAll {
    my $self = shift;
    
    # required to open the XML doc
$self->{'xml'}->xmlDecl('UTF-8'); $self->{'xml'}->pi('xml-stylesheet', 'type="text/xsl href="lrg2html.xsl"'); # iterate through the nodes recursively
foreach my $node(@{$self->{'nodes'}}) { $node->printNode(); } # finish and write the file
$self->{'xml'}->end(); } # getter/setter for name
}
printNodedescriptionprevnextTop
sub printNode {
    my $self = shift;
    
    # if this is an empty tag
# e.g. <mytag data1="value" />
if($self->empty) { if(scalar keys %{$self->data}) { $self->{'xml'}->emptyTag($self->name, %{$self->data}); } else { $self->{'xml'}->emptyTag($self->name); } } # if there is data for this node print like
# e.g. <mytag data1="value">
elsif(scalar keys %{$self->data}) { $self->{'xml'}->startTag($self->name, %{$self->data}); } # otherwise just open the bare tag
# e.g. <mytag>
else { $self->{'xml'}->startTag($self->name); } if(defined $self->{'content'}) { #foreach my $item(@{$node->{'content'}}) {
$self->{'xml'}->characters($self->content); #}
} # recursive iteration
foreach my $node(@{$self->{'nodes'}}) { $node->printNode(); } # end the tag
$self->{'xml'}->endTag() unless $self->{'empty'}; } # print all
}
requestContent()descriptionprevnextTop
sub requestContent() {
    my $self = shift;
    my $input;
    
    foreach my $item(@_) {
		print "Input $item\> ";
		$input = <STDIN>;
		chomp $input;
	
		$self->addNode($item)->content($input);
    }
}

# get current date in a nice format
}
xml()descriptionprevnextTop
sub xml() {
	my $self = shift;
	
	my $xml = shift if @_;
	
	if(defined $xml) {
		$self->{'xml'} = $xml;
		
		foreach my $node(@{$self->{'nodes'}}) {
			$node->xml($xml);
		}
	}
	
	return $self->{'xml'};
}

# fetch sequences using pfetch
}
General documentation
No general documentation available.