#!/usr/bin/perl ######################################################################## # genbankx.pl: convert a Genbank flatfile into XML. # Copyright (C) 2001 bioxml.org # author: M.Driscoll, miked @ post.harvard.edu # # usage: perl genbankx.pl # # This script is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License. # https://www.gnu.org/copyleft/gpl.html ######################################################################## use XML::Writer; use IO::File; use IO::Handle; # global vars: $xml = ""; # XML::Writer object $output = ""; # IO::File object $source = ""; # name of input file # specials $/ = "\n\/\/"; # alter line delimiter (just '//' will catch on 'https://www.') %SECTION = ( "LOCUS " => \&LOCUS, "DEFINITION " => \&default, "CONTIG " => \&default, "ACCESSION " => \&default, "VERSION " => \&VERSION, "KEYWORDS " => \&KEYWORDS, "SEGMENT " => \&SEGMENT, "SOURCE " => \&SOURCE, "REFERENCE " => \&REFERENCE, "COMMENT " => \&default, "FEATURES " => \&FEATURES, "BASE COUNT " => \&BASE_COUNT, "ORIGIN " => \&ORIGIN, ); # top-level function calls &init(); &main(); &finalize(); # subroutines sub init { if (($ARGV[0]) && ($ARGV[1])) { $source = $ARGV[0]; my $target = $ARGV[1]; $output = new IO::File(">$target"); $xml = new XML::Writer(OUTPUT => $output, DATA_MODE => 1, DATA_INDENT => 2); } elsif ($ARGV[0]) { $source = $ARGV[0]; $output = new IO::Handle(); $output->fdopen(fileno(STDOUT), "w") || die("Cannot write to standard output"); $xml = new XML::Writer(OUTPUT => $output, DATA_MODE => 1, DATA_INDENT => 2); } else { die "usage: perl genbank2xml.pl \n"; } } sub finalize { $xml->end(); $output->close(); } sub main { my $public_id = "/dtds/genbank.dtd"; my $system_id = "/dtds/genbank.dtd"; $xml->xmlDecl("UTF-8"); $xml->doctype("genbank_db", $public_id, $system_id); $xml->startTag("genbank_db"); while (<>) { # split into sections (LOCUS, DEFINITION, ORIGIN, etc.) if ($_ =~ /^LOCUS/) { $_ = "\n".$_; } # if no \n, add one for regex my $regex = '\n([A-Z]{4}[A-Z ]{6}[ ]{2})'; my @record = split(/$regex/, $_); if (@record > 2) { $xml->startTag("genbank") ; for (my $i=1; $i < @record; $i+=2) { &handle_block($record[$i], $record[$i+1]); } $xml->endTag("genbank"); } } $xml->endTag("genbank_db"); } sub handle_block { my ($name, $block) = @_; if ($SECTION{$name}) { $SECTION{$name}->($name, $block); } else { print STDERR "Error - no function for: $name\n"; } } sub default { my ($name, $block) = @_; &trim_lc($name); &trim_space($block); $xml->dataElement($name, $block); } sub KEYWORDS { my ($name, $block) = @_; return if ($block eq "."); # skip if keywords are blank &trim_lc($name); &trim_space($block); $xml->dataElement($name, $block); } sub VERSION { my ($name, $block) = @_; if ($block =~ /^(\w+.\d+) +GI:(\d+)/) { &trim_lc($name); $xml->dataElement($name, $1); $xml->dataElement("gi", $2); } else { &parse_warning($name, $block); } } sub LOCUS { my ($name, $block) = @_; ($locus, $size, $mol, $type, $div, $date) = unpack("A10 A8 x4 A8 A10 A10 A11", $block); $size =~ s/^\s+//gm; $mol =~ s/^\s+//gm if $mol; $mol_att = "type" if $type; $xml->dataElement("locus", $locus); $xml->dataElement("size", $size); $xml->dataElement("molecule", $mol, $mol_att => $type); $xml->dataElement("division", $div); $xml->dataElement("date", $date); } sub SOURCE { my ($name, $block) = @_; my ($common, $taxon, $lineage); &trim_lc($name); $xml->startTag($name); if ($block =~ /^(.+(?:\n[ ]{12}.+)*)\n ORGANISM (.+)\n[ ]{12}((?:.+\n?)+)/mg) { ($common, $taxon, $lineage) = ($1, $2, $3); &trim_space($common); &trim_space($lineage); $xml->dataElement("common", $common); $xml->dataElement("taxon", $taxon); $xml->dataElement("taxon_lineage", $lineage); } else { &parse_warning($name, $block); } $xml->endTag($name); } sub SEGMENT { my ($name, $block) = @_; &trim_lc($name); if ($block =~ /^(\d+) of (\d+)$/) { $xml->dataElement($name, $1, "total"=>$2); } else { &parse_warning($name, $block); } } sub REFERENCE { my ($name, $block) = @_; &trim_lc($name); # split reference block my @items = split(/\n {2,3}([A-Z]{5,7}) {2,5}/, $block); # parse '1 (bases 1 to n)' item, set as attributes my $att = $items[0]; if ($att =~ /^(\d+) +\((.+)\)/gms) { &trim_space($att); my $id = $1; my $location = $2; $xml->startTag($name, "id" => $id, "location" => $location); } else { &parse_warning($name, $block); return; } # handle remaining for (my $i=1; $i < @items; $i+=2) { my $tag = lc($items[$i]); my $chars = $items[$i+1]; &trim_space($chars); $xml->dataElement($tag, $chars); } $xml->endTag($name); } sub handle_reference_item { my ($name, $block) = @_; } sub ORIGIN { my ($name, $block) = @_; &trim_lc($name); if ($block =~ /^(.*)((?:\n.+$)+)/gm) { my $att = $1; &trim($att); my $attname = "note" if $att; $xml->startTag("origin", $attname=>$1); my $seq = $2; $seq =~ tr/0-9\n\/ //d; # cheap performance trick; should be: $xml->characters($seq) $output->print($seq); $xml->endTag("origin"); } else { &parse_warning($name, $block); } } sub BASE_COUNT { my ($name, $block) = @_; $name = "base_count"; # match line '343 a 729 c 687 g 397 t 383 others' if ($block =~ /^ +(\d+) (\w) +(\d+) (\w) +(\d+) (\w) +(\d+) (\w)(?: +(\d+) (\w+))?$/) { $xml->emptyTag($name, $2 => $1, $4 => $3, $6 => $5, $8 => $7, $10 => $9); } else { &parse_warning($name, $block); } } sub FEATURES { my ($name, $block) = @_; &trim_lc($name); $xml->startTag("feature_table"); my @features = split(/\n[ ]{5}([\w]{1}[\w ]{14})[ ]{1}/, $block); for (my $i=1; $i < @features; $i+=2) { my $featname = $features[$i]; my $qualblock = $features[$i+1]; &handle_feature($featname, $qualblock); } $xml->endTag("feature_table"); } sub handle_feature { my ($name, $block) = @_; my $tagname = "feature"; my $attname = "key"; &trim($name); $xml->startTag($tagname, $attname => $name); my @quals = split(/\n[ ]{21}[\/]{1}([\w]{1,})[=]{0,1}/, $block); my $location = $quals[0]; $xml->dataElement("location", $location); for (my $i=1; $i < @quals; $i+=2) { my $name = $quals[$i]; my $block = $quals[$i+1]; &handle_qualifier($name, $block) } $xml->endTag($tagname); } sub handle_qualifier { my ($name, $block) = @_; $block = &handle_qualifier_value($block); $xml->dataElement("qual", $block, "name" => $name); } sub handle_qualifier_value { my ($value) = @_; if ($value) { $value =~ s/[ ]{21}//gm; if ($value =~ / /) { # if has spaces, replace \n with space $value =~ s/\n/ /gm; } else { # if no spaces, delete \n $value =~ s/\n//gm; } if ($value =~ /^\"(.*)\"$/) { # if quoted $value = $1; } return $value; } else { return; } } sub parse_warning { my ($name, $block) = @_; print STDERR "Warning at $source, record $. - couldn't parse (name, block):\n$name\n$block\n"; # note '$.' is an internal variable, equals line number } # trims all trailing white space sub trim { $_[0] =~ s/\s+$//gm; } # trims all trailing white space and makes lowercase sub trim_lc { $_[0] =~ s/\s+$//gm; $_[0] = lc($_[0]); } # trims leading 12-char white space, leaving one space btw lines sub trim_space { $_[0] =~ s/\n[ ]{12}/ /gm; chomp($_[0]); }