#!/usr/bin/perl

## LGPL copyright notice ##
#
# Copyright 2010 bed2UCSC
# See the enclosed file COPYING for license information (LGPL). 
# If you did not receive this file, see http://www.fsf.org/copyleft/lgpl.html.
#
# Stephan Struckmann
# stephan.struckmann@uni-rostock.de
#
##

use LWP::UserAgent ; # This is needed for upload
use strict ;
use warnings ;
# use Data::Dumper ;
sub Dumper { # enbale the Dumper module for debug reasons.
	
} ;

use Clone qw/ clone / ; # needed in current version, but dependency may be removed in future versions

my %args = @ARGV ; # to prevent from using command line argument interpreter module

my @records = ( ) ;

my $template = <<'TEMPLATE' ; # This template is used to generate the Wiki-entries. Do not make this too long, because wiki entries are created using a GET request. Probably this could be changed to POST to abandon this restriction. Wiki syntax may be used here -- and all record dependent variables: name, pmid(s), and all other. May be overriden using the -template argument (see below).
	Name: $name
	
	Pubmed-Ids: $pmid 
TEMPLATE

# Options as properties:

{
	my $db = $args{-db} || 'hg18' ;
	print "Using $db as default database for upload. Please be aware, that track lines having a db=... entry will be interpreted and may overwrite that default value!\n" ;
	warn 'When this script was written, only hg18, hg19 and mm9 were supported by WikiTracks.' unless {
		hg18 => 1,
		hg19 => 1,
		mm9  => 1,
	} -> {$db} ;
	my $user = $args{-user} ;
	die 'Please provide your user name using -user ...' unless $user ;
	my $bed = $args{-bed} ;
	die 'Please provide readable BED file with -bed ...' unless $bed && -r $bed ;
	if ($args{-template} && -r $args{-template}) {
		open TEMPLATE, '<' . $args{-template} ;
		$template = join '', <TEMPLATE> ;
		close TEMPLATE ;
	}
	print "Password (will be displayed): " ; # to keep it simple, as platform independent as possible, and to minimize dependencies, password is read from STDIN here 
	my $password = <STDIN> ;
	chomp $password ;
	my $login_url = $args{-login_url} || 'http://genomewiki.ucsc.edu/index.php?title=Special:UserloginUCSC&action=submitlogin&type=login' ;
	my $submit_url = $args{-submit_url} || 'http://genome.ucsc.edu/cgi-bin/hgc?g=htcCreateWikiItem&c=%chrom%&o=%start%&l=%start%&t=%stop%&r=%stop%&db=%db%&wikiItemStrand=%strand_plusminus%&i=%name%&colorPullDown=&wikiItemColor=%color%&wikiCommentText=%text%&submit=create+new+item&getDnaPos=%getDnaPos%' ;
	sub user { return $user ; } ;
	sub pass { return $password ; } ;
	sub db { return $db ; } ;
	sub set_db { return $db = shift ; } ;
	sub login_url { return $login_url ; } ;
	sub submit_url { return $submit_url ; } ;
	sub bed { return $bed ; } ;
}

# internal properties:

{

	my $browser = LWP::UserAgent->new;
	$browser->cookie_jar( {} );
	push @{ $browser->requests_redirectable }, 'POST';
	$browser -> timeout(60*60*24*365*10) ; # after ten years, we consider the server to be dead

	sub browser {
		return $browser ;
	}

	sub dump_cookies {
		print Dumper($browser -> cookie_jar) ;
	}
}

# Methods:

## template
# @param $fields ref HASH: Contains all data fields from one annotation record
# @return Returns a string of the template replaced with the data fields from the record

sub template {
	my $fields = shift ;
	my $res = $template ;
	foreach my $key (keys %$fields) {
		my $value = $fields -> { $key } ;
		if ($key eq 'pmid') {
			my @v = () ;
			foreach my $pmid ( @$value ) {
				my $url = "http://www.ncbi.nlm.nih.gov/entrez/eutils/efetch.fcgi?retmode=xml&rettype=abstract&id=$pmid&db=pubmed" ;
				my $abstract = `curl "$url" 2>/dev/null` ;
				my $title = $pmid ;
				$title = $1 if $abstract =~ /\<ArticleTitle\>([^<]+)\<\/ArticleTitle\>/msg ;
				my @authors = () ;
				while ($abstract =~ /\<Author.*?\<LastName\>(.*?)\<\/LastName\>.*?\<Initials\>(.*?)\<\/Initials\>.*?/msg) {
					(my $author1, my $author2) = ( $1 , $2 ) ;
					$author1 =~ s/\s//g ;
					$author2 =~ s/\s//g ;
					push @authors, $author1 . ', ' . $author2 ;
				}
				my $authors = join '; ' , @authors ;
				my $year = '?' ;
				$year = $1 if $abstract =~ /\<PubDate.*?\<Year\>(.*?)\<\/Year\>/msg ;
				push @v, "[http://www.ncbi.nlm.nih.gov/pubmed/$pmid $authors, $year: $title]" ;
			} 
			$value = join "\n\n" , @v ;
		} elsif (ref $value eq 'ARRAY') {
			$value = join ', ' , @$value ;
		} elsif (ref $value eq 'HASH') {
			my $v = '' ;
			foreach my $key ( keys %$value ) {
				$v .= $key . ': ' . $value -> { $key } . "\n" ;
			}
			$value = $v ;
		} ;
		$res =~ s/\$$key/$value/g ;
	}
	return $res ;
}

## urlencode
# @param $res STRING contains a string to be used in a url
# @return Returns $res, but url encoded

sub urlencode($) {
        my $res = shift ;
        $res =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg ;
        return $res ;
}

## create_submit_url
# @param %args All fields of an annotation record
# @return Returns the URL to be used as GET request to create the annotation in the wiki track.

{
	sub create_submit_url {
		my %args = @_ ;
		my $chrom = $args{-chrom} ;
		$chrom = 'chr' . $chrom unless $chrom =~ /^chr/ ;
		$args{-strand} = 1 unless exists $args{-strand} ;
		my $strand = { 1 => 'plus' , -1 => 'minus'} -> { 1*$args{-strand} } ;
		my $text = $args{-text} ;
		my $start = $args{-start} ;
		my $stop = $args{-stop} ;
		my $name = $args{-name} ;
		my $db = $args{-db} || db ;
		my $su = submit_url ;
		foreach my $var ( qw/chrom db strand text name start stop/ ) {
			eval "\$$var = urlencode(\$$var)" ;
		}
		$su =~ s/%chrom%/$chrom/g || die 'No chromosome' ;
		$su =~ s/%db%/$db/g ;
		$su =~ s/%strand_plusminus%/$strand/g ;
		$su =~ s/%text%/$text/g || die 'No text' ;
		$su =~ s/%name%/$name/g || die 'No name' ;
		$su =~ s/%start%/$start/g || die 'No start' ; # 0-based
		$su =~ s/%stop%/$stop/g || die 'No end' ; # stop not included
		$su =~ s/%color%//g ; # color not supported yet.
		my $getDnaPos = $chrom . ':' . ($start+1) . '-' . ($stop);
		$su =~ s/%getDnaPos%/$getDnaPos/g ;
		return $su ;
	} ;
	## Property error state for the browser
	my @error_state = ( ) ;
	sub error_state { 
		@error_state = @_ if @_ ;
		return @error_state ;
	} ;
	sub error {
		return $error_state[1] ;
	} ;
	sub error_msg {
		return $error_state[0] ;
	} ;
	## Property logged_in: true, if user has been logged in successfully
	my $logged_in = 0 ;
	sub logged_in { 
		$logged_in = shift if @_ ;
		return $logged_in ;
	} ;
}

## login
# Logs in the user with the credentials given as command line argument (user) and at STDIN (password)
sub login {
	my $browser = browser ( ) ;
	my $login = user ( ) ;
	my $password = pass ( ) ;
	my $url = login_url ( ) ;
##	$browser->credentials( $url2, 'Realm', $login, $password ) ; in case of http-auth necessary
	my $response = $browser -> post ( $url ) ;
	$response = $browser -> post ( $url, {'wpName' => $login, 'wpPassword' => $password, 'wpLoginattempt' => 'Log in'} ) ;
	unless ($response->is_success) {
		error_state ( $response->status_line, 1 ) ;
		return ;
	}
	if ($response -> content ( ) =~ /Login error/) {
		error_state ( 'Invalid credentials', 1 ) ;
		return ;
	}
	error_state ( '', 0 ) ;
	logged_in(1);
	return ;
}


login ( ) ; # try to log in

die error_msg if error ; # die, if some error occurs in the http communication or in case of invalid credentials
die 'Not logged in' unless logged_in ; # something must be very wrong, if the assertion fails, that after login was successful (no error has occured), the user still is not logged in.


my $db = db ; # $db holds the database to use for the current annotations. More than one track could be given in a BED file, where each track may belong to another database.

open BED, bed ;
while (my $l = <BED>) { # read in the BED file line by line
	if ($l =~ /^chr(..?)\s+(\d+)\s+(\d+)\s+([^\s]+)?\s+(\d+)?\s+(\+|\-)?.*$/) { # an annotation line, a feature
		my $hash = {
				chrom  => $1,
				start  => $2, # 0-based
				end    => $3-1, # 0-based, excluded => 0-based, included: First 100 bases now are 0-99
				name   => $4, # includes description
				score  => $5, # 0-1000
				strand => $6,
				# remaining BED items are ignored, so far
				db     => $db,
			} ;
		my $chrom = $hash -> { chrom } ;
		my $start = $hash -> { start } ;
		my $end = $hash -> { end } ;
#		my $start1 = $start + 1 ; # dependent on curl and /dev/null; this code receives the dna sequence for the match
#		my $end1 = $end + 1 ;
#		my $seq = `curl http://genome.ucsc.edu/cgi-bin/das/$db/dna?segment=$chrom:$start1,$end1 2>/dev/null` ;
#		if ( $seq =~ /\<DNA length=\"\d+\"\>\s*([atgcn\s]+)\<\/DNA\>/ims ) {
#			$seq = $1 ;
#			$seq =~ s/\s//msg ;
#		} else {
#			$seq = '' ;
#			warn 'No sequence for ' . Dumper ( $hash ) ;
#		}
#		$hash -> { sequence } = $seq ;
		$hash -> { pmid } = [ ] ;
		while ($hash -> { name } =~ s/(?:^|\_)[A-Za-z][A-Za-z]+\d\d(?:\d\d)?\_(\d{1,9})\_//) { # pubmed ids may be included in the name of each bed record
			push @{$hash -> { pmid }}, $1 ;
		}
		$hash -> { name } =~ s/\_+/ /g ;
		$hash -> { name } =~ s/ +$//g ;
		$hash -> { name } =~ s/^ +//g ;
		$hash -> { name } =~ s/ +/ /g ;
		push @records, $hash ;
	} elsif ($l =~ /^track\s/) { # a track line
		if ($l =~ /\sdb=([^\s]+)/i) { # maybe with database given.
			$db = $1 ;
		} else {
			$db = db ;
		}
		die 'track offset not supported' if $l =~ /\soffset=\d+/i ;
	}
}
close BED ;

my @records2 = ( ) ;

foreach my $record ( @records ) { # parse the records' name fields: Find identifiers as defined in the description below.
	my $refseq = $record -> { name } ;
	$record -> { refseq } = $refseq ;
	$refseq =~ s/\?//g ; # gf inserted question marks
	while ( $refseq =~ s/(^| )[a-z]+( |$)/ /g )  { } ; # remove comments (only lower case words without numbers or signs)
	$refseq =~ s/ (RE)?\d+\s*$// ; # gf numbered different tfbs of the same factor
	$refseq =~ s/(?:^| )R\(([^\)]+?)\)/ $1 /g ; # R(Oct and Sox)
	my @refseq = ( ) ;
	$refseq =~ s/([a-zA-Z0-9])([A-Z][a-z]+)/$1 $2/g ; # OctSox Oct4/6Sox
	$refseq =~ s/ +/ /g ;
	$refseq =~ s/^ // ;
	$refseq =~ s/ $// ;
	foreach my $rs ( split / / , $refseq ) {
		if ($rs =~ /^(.+?\d)\/(\d+\/)*(\d+)$/) {
			my $stem = $1 ;
			my $numbers = $2 ;
			my @numbers = ( $3 ) ;
			push @numbers, split /\//, $numbers if defined $numbers ;
			push @refseq, $stem ;
			$stem =~ s/\d+$// ;
			foreach my $number (@numbers) {
				push @refseq, $stem . $number ;
			}
		} else {
			push @refseq , $rs ;
		}
	}
	foreach my $rs ( @refseq ) {
		my $newRec = clone $record ;
		$newRec -> { refseq } = $rs ;
		push @records2, $newRec ;
	}
}

# Wiki entries are too hard to delete, if many are created in the wrong way.
warn 'Really upload the tracks to the db given in the BED file or to ' . $args{-db} . ', if no db was provided in the file? If so, please type "Okay".' ;
my $ok = <STDIN> ;

$ok =~ s/\s*$// ;

exit 0 unless $ok eq 'Okay' ;

my $nr_dup = scalar @records2 ;

print "Deduplicate\n" ; # the refseq entries may duplicate some records, that belong to more than one identifier. On the other hand, the template probably does not use those refseq entries, so we finally have duplicates here.

my %rec = ( ) ;
foreach my $record ( @records2 ) {
	print ".\n" ;
	my $url = create_submit_url( -start=>$record -> { start }, -stop=>$record -> { end }+1, -text=>template($record), -chrom=>$record->{chrom}, -name=>$record->{name}, -strand => 1, -db => $record -> {db} ); # create the upload URL
	$rec{ $url } = 1 ;
	warn template($record) ;
}

@records2 = keys %rec ;

my $nr = scalar @records2 ;

print $nr_dup . ' .. ' . $nr . "\n" ;

print "\nPress return again to start upload..." ; # another confirmation (see above)

$ok = <STDIN> ;

my $browser = browser ( ) ;

my $i = 0 ;
foreach my $url ( @records2 ) { # really implement the upload
	print "" . (++$i) . ' of ' . $nr . "\n" ;
	print $url . "\n" ;
	my $response = $browser -> get ( $url ) ;
	# die $response->content() ;
	unless ($response->is_success) { # only warn, if some records could not be uploaded.
		error_state ( $response->status_line, 1 ) ;
		warn $response->status_line ;
	}
	error_state ( '', 0 ) ;
}

# die Dumper(\@records2) ;

__END__

=pod

=head1 bed2UCSC.pl

bed2UCSC.pl - Convert a UCSC BED file to WikiTrack entries

=head1 SYNOPSIS

    ./bed2UCSC.pl -bed file.bed -db hg18 -user smith -template file.txt -login_url http://genomewiki.ucsc.edu/index.php?title=Special:UserloginUCSC&action=submitlogin&type=login -submit_url http://genome.ucsc.edu/cgi-bin/hgc?g=htcCreateWikiItem&c=%chrom%&o=%start%&l=%start%&t=%stop%&r=%stop%&db=%db%&wikiItemStrand=%strand_plusminus%&i=%name%&colorPullDown=&wikiItemColor=%color%&wikiCommentText=%text%&submit=create+new+item&getDnaPos=%getDnaPos%

=head1 ABSTRACT

To upload a bed format with some extensions in the feature name column as wiki track entries to UCSC, just call 
	
	bed2UCSC.pl -bed file.bed -db hg18 -user smith

Please be aware of the additional conventions to the bed name column below.

=head1 DESCRIPTION

=head2 Parameters

	-bed file.bed
    
Use file.bed as BED file (see below for information about BED format).
    
	-db hg18 

Track lines are scanned for db=... entries to setup the database to upload the annotations to. If no such entry is found, the -db paramter will be used instead.
It is set to hg18 by default.

	-user smith
	
Username for the UCSC GenomeWiki. The password will be fetched from the command line (Attention: It will be visible, when typing).
	
	-template file.txt
	
Here, you can provide your own template for the wiki pages, that will be generated for each feature. See <L/"Template file format"> below.
	
	-login_url http://genomewiki.ucsc.edu/index.php?title=Special:UserloginUCSC&action=submitlogin&type=login
	
URL of the login page of the wiki system. This is called via POST request with a fixed set of POST vars. Useful but not tested, if you
want to use a UCSC mirror. Should be more flexible, maybe, to support future versions of the genome wiki.
	
	-submit_url http://genome.ucsc.edu/cgi-bin/hgc?g=htcCreateWikiItem&c=%chrom%&o=%start%&l=%start%&t=%stop%&r=%stop%&db=%db%&wikiItemStrand=%strand_plusminus%&i=%name%&colorPullDown=&wikiItemColor=%color%&wikiCommentText=%text%&submit=create+new+item&getDnaPos=%getDnaPos%

The URL used for the GET request, that generates the UCSC GenomeWiki entry. Each %...% is a variable that will be substituted by the corresponding value of each
record. Please note, that %color% is not supported yet.

=head2 BED entries

Please see also the UCSC BED format at http://genome.ucsc.edu/FAQ/FAQformat.html#format1

Besides the definition of BED, some more conventions:

First, all underscores _ will be replaced by spaces. Then, all lower case only words will be considered to be comments and deleted. Space is normalized to one
space charcter for each number of any whitespace characters. Leading and tailing space if removed. All numbers with 1-9 digits will be interpreted as Pubmed ids,
if they follow a reference: E.g. "Struckmann2008_1234567". This reference information is then removed from the name.

This, lateron will be available as $name and as $pmid (see Template file format below).

Another field is generated from that name, called $refseq:

Slashes are resolved:

Oct3/4 generates two entries, one as Oct3 and one Oct4. 

R(...) becomes ... .

Question marks are removed. Numbers in the end or RE1, RE2, ... are removed.

=head2 Template file format

In the template file, you may use Wiki syntax as provided by the GenomeWiki: http://genomewiki.ucsc.edu/ . Furthermore, the following variables may be used:

	$chrom	the chromosome of the feaure

	$start	the 0-based start coordinate of the feature

	$end    the 0-based and included end coordinate of the feature: First 100 bases are 0-99
	
	$name   the name of the feature (see above in the bed file description for addtional conventions)
	
	$score	a score for the feature
	
	$strand	the strand of the feature
	
	$db	the database, the feature belongs to (hg18, hg19 or mm9, maybe more in future)

	$pmid	pubmed ids of the feature (resolved and linked to PubMed)
	
	$refseq	the name of the feature

=head1 DEPENDENCIES

This scripts need curl installed. The CPAN modules Clone and LWP::UserAgent are needed. The greater than symbol should work as redirection operator for STDOUT
on the shell and /dev/null should be a valid target for that redirection. The curl dependency could be broken by commenting out the corresponding lines, but then,
PubMed ids won't be resolved.

=head1 SEE ALSO

The UCSC BED format: http://genome.ucsc.edu/FAQ/FAQformat.html#format1

UCSC WikiTrack: http://genome.ucsc.edu/cgi-bin/hgTrackUi?hgsid=163123136&g=wikiTrack&hgTracksConfigPage=configure

=head1 LICENSE

LGPL copyright notice

Copyright 2010

See the enclosed file COPYING for license information (LGPL). 
If you did not receive this file, see http://www.fsf.org/copyleft/lgpl.html.

=head1 AUTHOR

Copyright (C) Stephan Struckmann 2010
All rights Reserved

=cut