En esta ocasión vamos a utilizar un módulo llamado DNA.pm que nos
va a proporcionar las funciones que hemos estado utilizando estos dias,
pero todas juntas en un módulo Perl que define la clase DNA.
Así reutilizaremos el código en dos scripts que a su vez utilizarán otros
módulos
- dna.pl - Será un filtro de caracter generál que nos permitirá
hacer todas las funcionalidades vistas en las prácticas
anteriores pasándole parámetros (usa
Getopt::Std).
- dna.cgi - Nos permitirá a través de un formulario en una
página web, explotar también las funciones que nos aporta el módulo
DNA.pm. (usa también
CGI).
A continuación se da el código de estos dos scripts, seguidos por el
código del módulo.
| dna.pl |
|---|
#!/usr/bin/perl -w
use DNA;
use Getopt::Std;
# Permitimos pasar parametros desde linea de comando:
# -r Muestra RNA
# -c Muestra el complementario
# -x Cuenta A, T, G y C
# -p Pasa a proteina
# -i fichero Lee datos del fichero
# -o fichero Saca los datos al fichero
my %O;
getopts('rcxpi:o:',\%O);
comprueba_parametros_y_ofrece_ayuda(\%O);
# Creamos el dna usando el modulo DNA. Bien de fichero,
# o lo que entre por STDIN.
if ($O{i}) {
$dna = new DNA($O{i});
} else {
$dna = new DNA(<STDIN>);
};
# Si nos dicen que el resultado salga en un fichero,
# redirigimos la salida estandar (STDOUT)
if ($O{o}) {
open(STDOUT,">$O{o}");
}
# Hacemos lo que nos pidan.
print $dna->rna,"\n\n" if $O{r};
print $dna->cdna,"\n\n" if $O{c};
print $dna->prot,"\n\n" if $O{p};
if ($O{x}) {
my %cont=$dna->base_cont;
print<<"EOTEXT";
Numero de A: $cont{A}
Numero de T: $cont{T}
Numero de G: $cont{G}
Numero de C: $cont{C}
EOTEXT
}
sub comprueba_parametros_y_ofrece_ayuda {
my ($rO)=@_;
my $valido;
for ('r','c','x','p') {
if ($rO->{$_}) {$valido=1; last;};
}
return if $valido;
print <<"EOTXT";
uso del programa:
$0 -r [opciones] => Pasa a rna
$0 -c [opciones] => Pasa dna complementario
$0 -p [opciones] => Pasa a proteina
$0 -x [opciones] => Cuenta bases
las opciones son:
-i fichero => Toma datos de 'fichero'
-o fichero => Saca los resultados a 'fichero'
si no, utiliza la entrada y salida estandar.
EOTXT
exit; # Sale del programa
}
|
| dna.cgi |
|---|
#!/usr/bin/perl -w
use DNA;
use CGI qw/:standard/;
my %color_ing=( 'rojo' => 'red',
'verde' => 'green',
'azul' => 'blue',
'rosa' => 'pink'
);
my @colores=keys %color_ing;
print header,
start_html('Un ejemplo sencillo de CGI'),
h1('Un ejemplo sencillo'),
start_form,
"Introduce la sequencia ",p,textarea(-name=>'dna',
-rows=>10,
-columns=>50),p,
"Que opciones quieres?", p,
checkbox_group(-name=>'opciones',
-values=>['RNA','Complementario','Proteina','Contar']), p,
"Buscar motivo: ",textfield('motivo')," y ponerlo en color ",
popup_menu(-name=>'color',
-values=>\@colores),p,
submit,
end_form,
hr;
if (param()) {
my $dna = new DNA(param('dna'));
$dna->format('columnas');
my $formato_dna=$dna->dna;
my $motivo=uc(param('motivo'));
$motivo=join("[^ATGC]{0,2}",split('',$motivo));
my $color=param('color');
$color=$color_ing{$color}; # Lo traducimos al ingles ;-)
$formato_dna=~s*($motivo)*<span style=\"color: $color\">$1</span>*g;
print "El DNA introducido es:",p,pre($formato_dna),hr;
for (param('opciones')) {
/RNA/ && do { print "El rna es:",p,pre($dna->rna),hr; next; };
/Comp/ && do { print "El complementario es:",p,pre($dna->cdna),hr; next; };
/Prot/ && do { print "La proteina es:",p,pre($dna->prot),hr; next; };
/Cont/ && do {
my %cont=$dna->base_cont;
print "Contaje",
ul(li({},["A: $cont{'A'}",
"T: $cont{'T'}",
"G: $cont{'G'}",
"C: $cont{'C'}"
])),
hr;
next;
};
}
}
print end_html;
|
| DNA.pm |
|---|
package DNA;
use Carp;
use strict;
use warnings;
my %codon = (
'TCA' => 'S', # Serine
'TCC' => 'S', # Serine
'TCG' => 'S', # Serine
'TCT' => 'S', # Serine
'TTC' => 'F', # Phenilalanine
'TTT' => 'F', # Phenilalanine
'TTA' => 'L', # Leucine
'TTG' => 'L', # Leucine
'TAC' => 'Y', # Tyrosine
'TAT' => 'Y', # Tyrosine
'TAA' => '_', # STOP
'TAG' => '_', # STOP
'TGC' => 'C', # Cysteine
'TGT' => 'C', # Cysteine
'TGA' => '_', # STOP
'TGG' => 'W', # Tryptophan
'CTA' => 'L', # Leucine
'CTC' => 'L', # Leucine
'CTG' => 'L', # Leucine
'CTT' => 'L', # Leucine
'CCA' => 'P', # Proline
'CCC' => 'P', # Proline
'CCG' => 'P', # Proline
'CCT' => 'P', # Proline
'CAC' => 'H', # Histidine
'CAT' => 'H', # Histidine
'CAA' => 'Q', # Glutamine
'CAG' => 'Q', # Glutamine
'CGA' => 'R', # Arginine
'CGC' => 'R', # Arginine
'CGG' => 'R', # Arginine
'CGT' => 'R', # Arginine
'ATA' => 'I', # Isoleucine
'ATC' => 'I', # Isoleucine
'ATT' => 'I', # Isoleucine
'ATG' => 'M', # Methionine
'ACA' => 'T', # Threonine
'ACC' => 'T', # Threonine
'ACG' => 'T', # Threonine
'ACT' => 'T', # Threonine
'AAC' => 'N', # Asparagine
'AAT' => 'N', # Asparagine
'AAA' => 'K', # Lysine
'AAG' => 'K', # Lysine
'AGC' => 'S', # Serine
'AGT' => 'S', # Serine
'AGA' => 'R', # Arginine
'AGG' => 'R', # Arginine
'GTA' => 'V', # Valine
'GTC' => 'V', # Valine
'GTG' => 'V', # Valine
'GTT' => 'V', # Valine
'GCA' => 'A', # Alanine
'GCC' => 'A', # Alanine
'GCG' => 'A', # Alanine
'GCT' => 'A', # Alanine
'GAC' => 'D', # Aspartic Acid
'GAT' => 'D', # Aspartic Acid
'GAA' => 'E', # Glutamic Acid
'GAG' => 'E', # Glutamic Acid
'GGA' => 'G', # Glycine
'GGC' => 'G', # Glycine
'GGG' => 'G', # Glycine
'GGT' => 'G' # Glycine
);
#####################################
# Constructor de la clase
sub new {
# Siempre empieza igual (ver perlboot)
my $proto = shift;
my $class = ref($proto) || $proto;
my $self ={};
bless($self, $class);
# El resto de los parámetros se utilizan para
# iniciar la instancia.
return ($self->dna(@_))?$self:undef;
}
#####################################
# dna
# Devuelve el dna
# Si se le pasa un parámetro, lo mete en 'dna'
sub dna {
my $self = shift; # El primer parametro de cualquier método siempre
# es la propia instancia de la clase.
my @params = @_;
chomp(@params);
return $self->_format_output($self->{'dna'})
unless scalar(@params); # Si no se pasa parametro
# vuelve sin más
if (scalar(@params)==1) { # Si se pasa un parámetro
my $param=$params[0];
@params=split(/\n/,$param);
if (scalar(@params)==1) { # ... no es multilinea
if ( -r $param ) { # ... y es un fichero
open DNA_F, $param;
@params=<DNA_F>; # lo lee
close DNA_F;
chomp @params;
} else { # ... si es un escalar
$param=uc($param);
$param=~s/[^ATGC]//g; # lo filtra,
$self->{'dna'}=$param; # lo mete en 'dna',
return $self->_format_output($param);
# y retorna.
}
}
}
# En caso de ser varias lineas (por ser varios parámetros o por ser
# un fichero) carga en $dna las lineas que contengan la secuencia.
# Permite un caracter extra al principio y espacios varios, pero el
# resto debe ser ATG o C hasta fin de linea
my $dna;
for (@params) {
$_=uc;
if (/^[^ATGC]?\s*\d*\s*([ ATGC]+)\r?$/) {
$dna.=$1;
} elsif ($dna) {
last;
}
}
$dna=~s/ //g;
$self->{'dna'} = $dna;
return $self->_format_output($dna);
}
#####################################
# _format_output
# Devuelve la ccadena formateada segun lo pudi 'formato'
sub _format_output {
my $self = shift;
my ($cadena) = @_;
return $cadena unless $self->{formato} && $self->{formato}!~/crudo/i;
for ($self->{formato}) {
/column/i && do {
$cadena=~s/(.{10})/$1 /g;
$cadena=~s/(.{66})/$1\n/g;
return $cadena;
};
}
retrun $cadena;
}
#####################################
# format
# Indica con que formato se va a retornar las cadenas
sub format {
my $self = shift;
($self->{formato}) = @_;
return;
}
#####################################
# cdna
# Devuelve el dna complementario
sub cdna {
my $self = shift;
my $cdna=$self->{'dna'};
$cdna=~tr/ATGC/TACG/;
return $self->_format_output($cdna);
}
#####################################
# rna
# Devuelve el rna
sub rna {
my $self = shift;
my $rna=$self->{'dna'};
$rna=~tr/T/U/;
return $self->_format_output($rna);
}
#####################################
# base_cont
# Devuelve el numero de A,T,C y G en un hash
# Si se le pasa una base como parámetro, solo cuenta esa base.
sub base_cont {
my $self = shift;
my ($base) = @_;
my $dna=$self->{'dna'};
my %rslt;
$rslt{'A'}=($dna=~tr/A//);
$rslt{'T'}=($dna=~tr/T//);
$rslt{'C'}=($dna=~tr/C//);
$rslt{'G'}=($dna=~tr/G//);
return $rslt{$base} if $base;
return %rslt;
}
#####################################
# prot
# Devuelve la secuencia de aminoácidos
sub prot {
my $self = shift;
my $dna=$self->{'dna'};
my $prot;
while ($dna=~s/(.{3})//) {
$prot.=$codon{$1}?$codon{$1}:"*";
}
return $self->_format_output($prot);
}
1; # Los paquetes siempre retornan TRUE = 1;
|
|
Email: