X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=code_perl%2FMaasha%2FBiopieces.pm;h=161f73d16eb39daa0d0f388f1082240bc10798ac;hb=55ce9bcb65d11cdebe020d16078013e282b5bd7c;hp=f7ec3ae86c57ce23f361d85e9b77b1c8b2a95b97;hpb=4011531389e8cf5e6964f838200647b87245340c;p=biopieces.git diff --git a/code_perl/Maasha/Biopieces.pm b/code_perl/Maasha/Biopieces.pm index f7ec3ae..161f73d 100644 --- a/code_perl/Maasha/Biopieces.pm +++ b/code_perl/Maasha/Biopieces.pm @@ -36,6 +36,7 @@ use Time::HiRes qw( gettimeofday ); use Storable qw( dclone ); use Maasha::Config; use Maasha::Common; +use Maasha::Filesys; use Maasha::Fasta; use Maasha::Align; use Maasha::Matrix; @@ -47,6 +48,8 @@ use Maasha::Patscan; use Maasha::Plot; use Maasha::Calc; use Maasha::UCSC; +use Maasha::UCSC::BED; +use Maasha::UCSC::Wiggle; use Maasha::NCBI; use Maasha::GFF; use Maasha::TwoBit; @@ -87,8 +90,8 @@ $SIG{ 'TERM' } = \&sig_handler; my ( $script, $BP_TMP ); -$script = Maasha::Common::get_scriptname(); -$BP_TMP = Maasha::Common::get_tmpdir(); +$script = Maasha::Common::get_scriptname(); +$BP_TMP = Maasha::Common::get_tmpdir(); # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> LOG <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @@ -185,6 +188,8 @@ sub run_script elsif ( $script eq "read_solexa" ) { script_read_solexa( $in, $out, $options ) } elsif ( $script eq "read_solid" ) { script_read_solid( $in, $out, $options ) } elsif ( $script eq "read_mysql" ) { script_read_mysql( $in, $out, $options ) } + elsif ( $script eq "read_ucsc_config" ) { script_read_ucsc_config( $in, $out, $options ) } + elsif ( $script eq "assemble_tag_contigs" ) { script_assemble_tag_contigs( $in, $out, $options ) } elsif ( $script eq "format_genome" ) { script_format_genome( $in, $out, $options ) } elsif ( $script eq "length_seq" ) { script_length_seq( $in, $out, $options ) } elsif ( $script eq "uppercase_seq" ) { script_uppercase_seq( $in, $out, $options ) } @@ -229,9 +234,12 @@ sub run_script elsif ( $script eq "write_fixedstep" ) { script_write_fixedstep( $in, $out, $options ) } elsif ( $script eq "write_2bit" ) { script_write_2bit( $in, $out, $options ) } elsif ( $script eq "write_solid" ) { script_write_solid( $in, $out, $options ) } + elsif ( $script eq "write_ucsc_config" ) { script_write_ucsc_config( $in, $out, $options ) } elsif ( $script eq "head_records" ) { script_head_records( $in, $out, $options ) } elsif ( $script eq "remove_keys" ) { script_remove_keys( $in, $out, $options ) } elsif ( $script eq "remove_adaptor" ) { script_remove_adaptor( $in, $out, $options ) } + elsif ( $script eq "remove_mysql_tables" ) { script_remove_mysql_tables( $in, $out, $options ) } + elsif ( $script eq "remove_ucsc_tracks" ) { script_remove_ucsc_tracks( $in, $out, $options ) } elsif ( $script eq "rename_keys" ) { script_rename_keys( $in, $out, $options ) } elsif ( $script eq "uniq_vals" ) { script_uniq_vals( $in, $out, $options ) } elsif ( $script eq "merge_vals" ) { script_merge_vals( $in, $out, $options ) } @@ -318,7 +326,9 @@ sub get_options { @options = qw( data_in|i=s + cols|c=s num|n=s + check|C ); } elsif ( $script eq "read_fixedstep" ) @@ -412,6 +422,25 @@ sub get_options password|p=s ); } + elsif ( $script eq "read_ucsc_config" ) + { + @options = qw( + data_in|i=s + num|n=s + ); + } + elsif ( $script eq "assemble_tag_contigs" ) + { + @options = qw( + check|C + ); + } + elsif ( $script eq "calc_fixedstep" ) + { + @options = qw( + check|C + ); + } elsif ( $script eq "format_genome" ) { @options = qw( @@ -441,13 +470,6 @@ sub get_options percent|p ); } - elsif ( $script eq "calc_fixedstep" ) - { - @options = qw( - score|S - log10|L - ); - } elsif ( $script eq "transliterate_seq" ) { @options = qw( @@ -662,6 +684,8 @@ sub get_options elsif ( $script eq "write_bed" ) { @options = qw( + cols|c=s + check|C no_stream|x data_out|o=s compress|Z @@ -700,6 +724,13 @@ sub get_options compress|Z ); } + elsif ( $script eq "write_ucsc_config" ) + { + @options = qw( + no_stream|x + data_out|o=s + ); + } elsif ( $script eq "plot_seqlogo" ) { @options = qw( @@ -751,6 +782,29 @@ sub get_options offset|o=s ); } + elsif ( $script eq "remove_mysql_tables" ) + { + @options = qw( + database|d=s + tables|t=s + keys|k=s + user|u=s + password|p=s + no_stream|x + ); + } + elsif ( $script eq "remove_ucsc_tracks" ) + { + @options = qw( + database|d=s + tracks|t=s + keys|k=s + config_file|c=s + user|u=s + password|p=s + no_stream|x + ); + } elsif ( $script eq "rename_keys" ) { @options = qw( @@ -948,7 +1002,7 @@ sub get_options use_score|u visibility|V=s color|c=s - chunk_size|C=s + check|C ); } @@ -981,6 +1035,8 @@ sub get_options $options{ "frames" } = [ split ",", $options{ "frames" } ] if defined $options{ "frames" }; $options{ "formats" } = [ split ",", $options{ "formats" } ] if defined $options{ "formats" }; $options{ "samples" } = [ split ",", $options{ "samples" } ] if defined $options{ "samples" }; + $options{ "tables" } = [ split ",", $options{ "tables" } ] if defined $options{ "tables" }; + $options{ "tracks" } = [ split ",", $options{ "tracks" } ] if defined $options{ "tracks" }; # ---- check arguments ---- @@ -995,7 +1051,7 @@ sub get_options # print STDERR Dumper( \%options ); - $real = "beg|end|word_size|wrap|chunk_size|tile_size|len|prefix_length|mismatches|offset|num|skip|cpus|window_size|step_size"; + $real = "beg|end|word_size|wrap|tile_size|len|prefix_length|mismatches|offset|num|skip|cpus|window_size|step_size"; foreach $opt ( keys %options ) { @@ -1392,7 +1448,9 @@ sub script_read_bed # Returns nothing. - my ( $file, $record, $entry, $data_in, $num ); + my ( $cols, $file, $record, $bed_entry, $data_in, $num ); + + $cols = $options->{ 'cols' }->[ 0 ]; while ( $record = get_record( $in ) ) { put_record( $record, $out ); @@ -1404,9 +1462,11 @@ sub script_read_bed { $data_in = Maasha::Common::read_open( $file ); - while ( $entry = Maasha::UCSC::bed_get_entry( $data_in ) ) + while ( $bed_entry = Maasha::UCSC::BED::bed_entry_get( $data_in, $cols, $options->{ 'check' } ) ) { - put_record( $entry, $out ); + $record = Maasha::UCSC::BED::bed2biopiece( $bed_entry ); + + put_record( $record, $out ); goto NUM if $options->{ "num" } and $num == $options->{ "num" }; @@ -1435,7 +1495,7 @@ sub script_read_fixedstep # Returns nothing. - my ( $file, $record, $entry, $head, $chr, $chr_beg, $step, $data_in, $num ); + my ( $file, $record, $entry, $data_in, $num ); while ( $record = get_record( $in ) ) { put_record( $record, $out ); @@ -1447,18 +1507,9 @@ sub script_read_fixedstep { $data_in = Maasha::Common::read_open( $file ); - while ( $entry = Maasha::UCSC::fixedstep_get_entry( $data_in ) ) + while ( $entry = Maasha::UCSC::Wiggle::fixedstep_entry_get( $data_in ) ) { - $head = shift @{ $entry }; - - if ( $head =~ /^chrom=([^ ]+) start=(\d+) step=(\d+)$/ ) - { - $record->{ "REC_TYPE" } = "fixed_step"; - $record->{ "CHR" } = $1; - $record->{ "CHR_BEG" } = $2; - $record->{ "STEP" } = $3; - $record->{ "VALS" } = join ";", @{ $entry }; - } + $record = Maasha::UCSC::Wiggle::fixedstep2biopiece( $entry ); put_record( $record, $out ); @@ -2022,7 +2073,7 @@ sub script_read_solid REC_TYPE => 'SOLID', SEQ_NAME => $seq_name, SEQ_CS => $seq_cs, - SEQ_QUAL => $seq_qual, + SEQ_QUAL => join( ";", @scores ), SEQ_LEN => length $seq_cs, SEQ => join( "", @seqs ), SCORE_MEAN => sprintf( "%.2f", Maasha::Calc::mean( \@scores ) ), @@ -2076,6 +2127,115 @@ sub script_read_mysql } +sub script_read_ucsc_config +{ + # Martin A. Hansen, November 2008. + + # Read track entries from UCSC Genome Browser '.ra' files. + + my ( $in, # handle to in stream + $out, # handle to out stream + $options, # options hash + ) = @_; + + # Returns nothing. + + my ( $record, $file, $data_in, $entry, $num ); + + while ( $record = get_record( $in ) ) { + put_record( $record, $out ); + } + + $num = 1; + + foreach $file ( @{ $options->{ "files" } } ) + { + $data_in = Maasha::Common::read_open( $file ); + + while ( $record = Maasha::UCSC::ucsc_config_entry_get( $data_in ) ) + { + $record->{ 'REC_TYPE' } = "UCSC Config"; + + put_record( $record, $out ); + + goto NUM if $options->{ "num" } and $num == $options->{ "num" }; + + $num++; + } + + close $data_in; + } + + NUM: + + close $data_in if $data_in; +} + + +sub script_assemble_tag_contigs +{ + # Martin A. Hansen, November 2008. + + # Assemble tags from the stream into + # tag contigs. + + # The current implementation is quite + # slow because of heavy use of temporary + # files. + + my ( $in, # handle to in stream + $out, # handle to out stream + $options, # options hash + ) = @_; + + # Returns nothing. + + my ( $bed_file, $tag_file, $fh_in, $fh_out, $cols, $record, $bed_entry, $file_hash, $chr, $strand ); + + $bed_file = "$BP_TMP/assemble_tag_contigs.bed"; + $fh_out = Maasha::Filesys::file_write_open( $bed_file ); + $cols = 6; # we only need the first 6 BED columns + + while ( $record = get_record( $in ) ) + { + if ( $bed_entry = Maasha::UCSC::BED::biopiece2bed( $record, $cols ) ) + { + $strand = $record->{ 'STRAND' } || '+'; + + Maasha::UCSC::BED::bed_entry_put( $bed_entry, $fh_out, $cols, $options->{ 'check' } ); + } + } + + close $fh_out; + + $file_hash = Maasha::UCSC::BED::bed_file_split_on_chr( $bed_file, $BP_TMP, $cols ); + + unlink $bed_file; + + foreach $chr ( sort keys %{ $file_hash } ) + { + $bed_file = $file_hash->{ $chr }; + $tag_file = "$bed_file.tc"; + + Maasha::Common::run( "bed2tag_contigs", "< $bed_file > $tag_file" ); + + $fh_in = Maasha::Filesys::file_read_open( $tag_file ); + + while ( $bed_entry = Maasha::UCSC::BED::bed_entry_get( $fh_in, $cols, $options->{ 'check' } ) ) + { + if ( $record = Maasha::UCSC::BED::bed2biopiece( $bed_entry ) ) { + put_record( $record, $out ); + } + } + + close $fh_in; + + unlink $bed_file; + unlink $tag_file; + } +} + + sub script_format_genome { # Martin A. Hansen, Juli 2008. @@ -2124,7 +2284,7 @@ sub script_format_genome while ( $record = get_record( $in ) ) { - if ( $fh_out and $entry = record2fasta( $record ) ) + if ( $fh_out and $entry = Maasha::Fasta::biopiece2fasta( $record ) ) { Maasha::Fasta::put_entry( $entry, $fh_out, $options->{ "wrap" } ); } @@ -2509,99 +2669,45 @@ sub script_calc_fixedstep # Returns nothing. - my ( $record, %fh_hash, $fh_in, $fh_out, $chr, $chr, $beg, $end, $q_id, $block, $entry, $clones, $beg_block, $max, $i ); + my ( $bed_file, $fh_in, $fh_out, $cols, $record, $file_hash, $chr, $bed_entry, $fixedstep_file, $fixedstep_entry ); + + $bed_file = "$BP_TMP/calc_fixedstep.bed"; + $fh_out = Maasha::Filesys::file_write_open( $bed_file ); + $cols = 5; # we only need the first 5 BED columns while ( $record = get_record( $in ) ) { - $record->{ "CHR" } = $record->{ "S_ID" } if not defined $record->{ "CHR" }; - $record->{ "CHR_BEG" } = $record->{ "S_BEG" } if not defined $record->{ "CHR_BEG" }; - $record->{ "CHR_END" } = $record->{ "S_END" } if not defined $record->{ "CHR_END" }; - - if ( $record->{ "CHR" } and defined $record->{ "CHR_BEG" } and $record->{ "CHR_END" } ) - { - $fh_hash{ $record->{ "CHR" } } = Maasha::Common::write_open( "$BP_TMP/$record->{ 'CHR' }" ) if not exists $fh_hash{ $record->{ "CHR" } }; - - $fh_out = $fh_hash{ $record->{ "CHR" } }; - - Maasha::UCSC::bed_put_entry( $record, $fh_out, 5 ); + if ( $bed_entry = Maasha::UCSC::BED::biopiece2bed( $record, $cols ) ) { + Maasha::UCSC::BED::bed_entry_put( $bed_entry, $fh_out, $cols, $options->{ 'check' } ); } } - map { close $_ } keys %fh_hash; - - foreach $chr ( sort keys %fh_hash ) - { - Maasha::Common::run( "bedSort", "$BP_TMP/$chr $BP_TMP/$chr" ); - - $fh_in = Maasha::Common::read_open( "$BP_TMP/$chr" ); - - undef $block; - - while ( $entry = Maasha::UCSC::bed_get_entry( $fh_in, 5 ) ) - { - $chr = $entry->{ 'CHR' }; - $beg = $entry->{ 'CHR_BEG' }; - $end = $entry->{ 'CHR_END' }; - $q_id = $entry->{ 'Q_ID' }; - - if ( $options->{ "score" } ) { - $clones = $entry->{ 'SCORE' }; - } elsif ( $q_id =~ /_(\d+)$/ ) { - $clones = $1; - } else { - $clones = 1; - } - - if ( $block ) - { - if ( $beg > $max ) - { - map { $_ = sprintf( "%.4f", Maasha::Calc::log10( $_ ) ) } @{ $block } if $options->{ "log10" }; - - $record->{ "CHR" } = $chr; - $record->{ "CHR_BEG" } = $beg_block; - $record->{ "STEP" } = 1; - $record->{ "VALS" } = join ";", @{ $block }; - $record->{ "REC_TYPE" } = "fixed_step"; + close $fh_out; - put_record( $record, $out ); + $file_hash = Maasha::UCSC::BED::bed_file_split_on_chr( $bed_file, $BP_TMP, $cols ); - undef $block; - } - else - { - for ( $i = $beg - $beg_block; $i < ( $beg - $beg_block ) + ( $end - $beg ); $i++ ) { - $block->[ $i ] += $clones; - } + unlink $bed_file; - $max = Maasha::Calc::max( $max, $end ); - } - } + foreach $chr ( sort keys %{ $file_hash } ) + { + $bed_file = $file_hash->{ $chr }; + $fixedstep_file = "$bed_file.fixedstep"; + + Maasha::Common::run( "bed2fixedstep", "< $bed_file > $fixedstep_file" ); - if ( not $block ) - { - $beg_block = $beg; - $max = $end; + $fh_in = Maasha::Filesys::file_read_open( $fixedstep_file ); - for ( $i = 0; $i < ( $end - $beg ); $i++ ) { - $block->[ $i ] += $clones; - } + while ( $fixedstep_entry = Maasha::UCSC::Wiggle::fixedstep_entry_get( $fh_in ) ) + { + if ( $record = Maasha::UCSC::Wiggle::fixedstep2biopiece( $fixedstep_entry ) ) { + put_record( $record, $out ); } } close $fh_in; - map { $_ = sprintf( "%.4f", Maasha::Calc::log10( $_ ) ) } @{ $block } if $options->{ "log10" }; - - $record->{ "CHR" } = $chr; - $record->{ "CHR_BEG" } = $beg_block; - $record->{ "STEP" } = 1; - $record->{ "VALS" } = join ";", @{ $block }; - $record->{ "REC_TYPE" } = "fixed_step"; - - put_record( $record, $out ); - - unlink "$BP_TMP/$chr"; + unlink $bed_file; + unlink $fixedstep_file; } } @@ -3060,6 +3166,10 @@ sub script_get_genome_align { $align = Maasha::UCSC::maf_extract( $BP_TMP, $options->{ "genome" }, $maf_track, $record->{ "CHR" }, $record->{ "CHR_BEG" }, $record->{ "CHR_END" }, $record->{ "STRAND" } ); } + elsif ( $record->{ "REC_TYPE" } eq "VMATCH" ) + { + $align = Maasha::UCSC::maf_extract( $BP_TMP, $options->{ "genome" }, $maf_track, $record->{ "S_ID" }, $record->{ "S_BEG" }, $record->{ "S_END" } + 1, $record->{ "STRAND" } ); + } elsif ( $record->{ "REC_TYPE" } eq "PSL" ) { $align = Maasha::UCSC::maf_extract( $BP_TMP, $options->{ "genome" }, $maf_track, $record->{ "S_ID" }, $record->{ "S_BEG" }, $record->{ "S_END" }, $record->{ "STRAND" } ); @@ -3537,7 +3647,7 @@ sub script_create_blast_db { put_record( $record, $out ) if not $options->{ "no_stream" }; - if ( $entry = record2fasta( $record ) ) + if ( $entry = Maasha::Fasta::biopiece2fasta( $record ) ) { $seq_type = Maasha::Seq::seq_guess_type( $entry->[ SEQ ] ) if not $seq_type; @@ -3582,11 +3692,11 @@ sub script_blast_seq $tmp_in = "$BP_TMP/blast_query.seq"; $tmp_out = "$BP_TMP/blast.result"; - $fh_out = Maasha::Common::write_open( $tmp_in ); + $fh_out = Maasha::Filesys::file_write_open( $tmp_in ); while ( $record = get_record( $in ) ) { - if ( $entry = record2fasta( $record ) ) + if ( $entry = Maasha::Fasta::biopiece2fasta( $record ) ) { $q_type = Maasha::Seq::seq_guess_type( $entry->[ SEQ ] ) if not $q_type; @@ -3655,7 +3765,7 @@ sub script_blast_seq unlink $tmp_in; - $fh_out = Maasha::Common::read_open( $tmp_out ); + $fh_out = Maasha::Filesys::file_read_open( $tmp_out ); undef $record; @@ -3737,7 +3847,7 @@ sub script_blat_seq while ( $record = get_record( $in ) ) { - if ( $entry = record2fasta( $record ) ) + if ( $entry = Maasha::Fasta::biopiece2fasta( $record ) ) { $type = Maasha::Seq::seq_guess_type( $entry->[ SEQ ] ) if not $type; Maasha::Fasta::put_entry( $entry, $fh_out, 80 ); @@ -3798,7 +3908,7 @@ sub script_soap_seq while ( $record = get_record( $in ) ) { - if ( $entry = record2fasta( $record ) ) + if ( $entry = Maasha::Fasta::biopiece2fasta( $record ) ) { Maasha::Fasta::put_entry( $entry, $fh_out ); @@ -3922,7 +4032,7 @@ sub script_create_vmatch_index while ( $record = get_record( $in ) ) { - if ( $options->{ "index_name" } and $entry = record2fasta( $record ) ) + if ( $options->{ "index_name" } and $entry = Maasha::Fasta::biopiece2fasta( $record ) ) { Maasha::Fasta::put_entry( $entry, $fh_tmp ); @@ -4019,7 +4129,7 @@ sub script_write_fasta while ( $record = get_record( $in ) ) { - if ( $entry = record2fasta( $record ) ) { + if ( $entry = Maasha::Fasta::biopiece2fasta( $record ) ) { Maasha::Fasta::put_entry( $entry, $fh, $options->{ "wrap" } ); } @@ -4205,70 +4315,21 @@ sub script_write_bed # Returns nothing. - my ( $fh, $record, $new_record ); + my ( $cols, $fh, $record, $bed_entry, $new_record ); - $fh = write_stream( $options->{ "data_out" }, $options->{ "compress" } ); + $cols = $options->{ 'cols' }->[ 0 ]; + + $fh = write_stream( $options->{ 'data_out' }, $options->{ 'compress' } ); while ( $record = get_record( $in ) ) { - if ( $record->{ "REC_TYPE" } eq "BED" ) # ---- Hits from BED ---- - { - Maasha::UCSC::bed_put_entry( $record, $fh, $record->{ "BED_COLS" } ); - } - elsif ( $record->{ "REC_TYPE" } eq "PSL" and $record->{ "S_ID" } =~ /^chr/i ) # ---- Hits from BLAT (PSL) ---- - { - $new_record->{ "CHR" } = $record->{ "S_ID" }; - $new_record->{ "CHR_BEG" } = $record->{ "S_BEG" }; - $new_record->{ "CHR_END" } = $record->{ "S_END" }; - $new_record->{ "Q_ID" } = $record->{ "Q_ID" }; - $new_record->{ "SCORE" } = $record->{ "SCORE" } || 999; - $new_record->{ "STRAND" } = $record->{ "STRAND" }; - - Maasha::UCSC::bed_put_entry( $new_record, $fh, 6 ); - } - elsif ( $record->{ "REC_TYPE" } eq "PATSCAN" and $record->{ "CHR" } ) # ---- Hits from patscan_seq ---- - { - Maasha::UCSC::bed_put_entry( $record, $fh, 6 ); - } - elsif ( $record->{ "REC_TYPE" } eq "BLAST" and $record->{ "S_ID" } =~ /^chr/i ) # ---- Hits from BLAST ---- - { - $new_record->{ "CHR" } = $record->{ "S_ID" }; - $new_record->{ "CHR_BEG" } = $record->{ "S_BEG" }; - $new_record->{ "CHR_END" } = $record->{ "S_END" }; - $new_record->{ "Q_ID" } = $record->{ "Q_ID" }; - $new_record->{ "SCORE" } = $record->{ "SCORE" } || 999; # or use E_VAL somehow - $new_record->{ "STRAND" } = $record->{ "STRAND" }; - - Maasha::UCSC::bed_put_entry( $new_record, $fh, 6 ); - } - elsif ( $record->{ "REC_TYPE" } eq "VMATCH" and $record->{ "S_ID" } =~ /^chr/i ) # ---- Hits from Vmatch ---- - { - $new_record->{ "CHR" } = $record->{ "S_ID" }; - $new_record->{ "CHR_BEG" } = $record->{ "S_BEG" }; - $new_record->{ "CHR_END" } = $record->{ "S_END" }; - $new_record->{ "Q_ID" } = $record->{ "Q_ID" }; - $new_record->{ "SCORE" } = $record->{ "SCORE" } || 999; # or use E_VAL somehow - $new_record->{ "STRAND" } = $record->{ "STRAND" }; + $record = Maasha::UCSC::psl2record( $record ) if $record->{ 'tBaseInsert' }; # Dirty addition to allow Affy data from MySQL to be dumped - Maasha::UCSC::bed_put_entry( $new_record, $fh, 6 ); - } - elsif ( $record->{ "REC_TYPE" } eq "SOAP" and $record->{ "S_ID" } =~ /^chr/i ) # ---- Hits from Vmatch ---- - { - $new_record->{ "CHR" } = $record->{ "S_ID" }; - $new_record->{ "CHR_BEG" } = $record->{ "S_BEG" }; - $new_record->{ "CHR_END" } = $record->{ "S_END" }; - $new_record->{ "Q_ID" } = $record->{ "Q_ID" }; - $new_record->{ "SCORE" } = $record->{ "SCORE" } || 999; - $new_record->{ "STRAND" } = $record->{ "STRAND" }; - - Maasha::UCSC::bed_put_entry( $new_record, $fh, 6 ); - } - elsif ( $record->{ "CHR" } and defined $record->{ "CHR_BEG" } and $record->{ "CHR_END" } ) # ---- Generic data from tables ---- - { - Maasha::UCSC::bed_put_entry( $record, $fh ); + if ( $bed_entry = Maasha::UCSC::BED::biopiece2bed( $record, $cols ) ) { + Maasha::UCSC::BED::bed_entry_put( $bed_entry, $fh, $cols, $options->{ 'check' } ); } - put_record( $record, $out ) if not $options->{ "no_stream" }; + put_record( $record, $out ) if not $options->{ 'no_stream' }; } close $fh; @@ -4323,21 +4384,14 @@ sub script_write_fixedstep # Returns nothing. - my ( $fh, $record, $vals ); + my ( $fh, $record, $entry ); $fh = write_stream( $options->{ "data_out" }, $options->{ "compress" } ); while ( $record = get_record( $in ) ) { - if ( $record->{ "CHR" } and $record->{ "CHR_BEG" } and $record->{ "STEP" } and $record->{ "VALS" } ) - { - print $fh "fixedStep chrom=$record->{ 'CHR' } start=$record->{ 'CHR_BEG' } step=$record->{ 'STEP' }\n"; - - $vals = $record->{ 'VALS' }; - - $vals =~ tr/;/\n/; - - print $fh "$vals\n"; + if ( $entry = Maasha::UCSC::Wiggle::biopiece2fixedstep( $record ) ) { + Maasha::UCSC::Wiggle::fixedstep_entry_put( $entry, $fh ); } put_record( $record, $out ) if not $options->{ "no_stream" }; @@ -4371,7 +4425,7 @@ sub script_write_2bit while ( $record = get_record( $in ) ) { - if ( $entry = record2fasta( $record ) ) { + if ( $entry = Maasha::Fasta::biopiece2fasta( $record ) ) { Maasha::Fasta::put_entry( $entry, $fh_tmp ); } @@ -4410,7 +4464,7 @@ sub script_write_solid while ( $record = get_record( $in ) ) { - if ( $entry = record2fasta( $record ) ) + if ( $entry = Maasha::Fasta::biopiece2fasta( $record ) ) { $entry->[ SEQ ] = Maasha::Solid::seq2color_space( uc $entry->[ SEQ ] ); @@ -4424,6 +4478,35 @@ sub script_write_solid } +sub script_write_ucsc_config +{ + # Martin A. Hansen, November 2008. + + # Write UCSC Genome Broser configuration (.ra file type) from + # records in the stream. + + my ( $in, # handle to in stream + $out, # handle to out stream + $options, # options hash + ) = @_; + + # Returns nothing. + + my ( $record, $fh ); + + $fh = write_stream( $options->{ "data_out" } ); + + while ( $record = get_record( $in ) ) + { + Maasha::UCSC::ucsc_config_entry_put( $record, $fh ) if $record->{ "REC_TYPE" } eq "UCSC Config"; + + put_record( $record, $out ) if not $options->{ "no_stream" }; + } + + close $fh; +} + + sub script_plot_seqlogo { # Martin A. Hansen, August 2007. @@ -4753,6 +4836,127 @@ sub script_remove_adaptor } +sub script_remove_mysql_tables +{ + # Martin A. Hansen, November 2008. + + # Remove MySQL tables from values in stream. + + my ( $in, # handle to in stream + $out, # handle to out stream + $options, # options hash + ) = @_; + + # Returns nothing. + + my ( $record, %table_hash, $dbh, $table ); + + $options->{ "user" } ||= Maasha::UCSC::ucsc_get_user(); + $options->{ "password" } ||= Maasha::UCSC::ucsc_get_password(); + + map { $table_hash{ $_ } = 1 } @{ $options->{ 'tables' } }; + + while ( $record = get_record( $in ) ) + { + map { $table_hash{ $record->{ $_ } } = 1 } @{ $options->{ 'keys' } }; + + put_record( $record, $out ) if not $options->{ 'no_stream' }; + } + + $dbh = Maasha::SQL::connect( $options->{ "database" }, $options->{ "user" }, $options->{ "password" } ); + + foreach $table ( sort keys %table_hash ) + { + if ( Maasha::SQL::table_exists( $dbh, $table ) ) + { + print STDERR qq(Removing table "$table" from database "$options->{ 'database' }" ... ) if $options->{ 'verbose' }; + Maasha::SQL::delete_table( $dbh, $table ); + print STDERR "done.\n" if $options->{ 'verbose' }; + } + else + { + print STDERR qq(WARNING: table "$table" not found in database "$options->{ 'database' }\n"); + } + } + + Maasha::SQL::disconnect( $dbh ); +} + + +sub script_remove_ucsc_tracks +{ + # Martin A. Hansen, November 2008. + + # Remove track from MySQL tables and config file. + + my ( $in, # handle to in stream + $out, # handle to out stream + $options, # options hash + ) = @_; + + # Returns nothing. + + my ( $record, %track_hash, $fh_in, $fh_out, $track, @tracks, @new_tracks, $dbh ); + + $options->{ 'user' } ||= Maasha::UCSC::ucsc_get_user(); + $options->{ 'password' } ||= Maasha::UCSC::ucsc_get_password(); + $options->{ 'config_file' } ||= "$ENV{ 'HOME' }/ucsc/my_tracks.ra"; + + map { $track_hash{ $_ } = 1 } @{ $options->{ 'tracks' } }; + + while ( $record = get_record( $in ) ) + { + map { $track_hash{ $record->{ $_ } } = 1 } @{ $options->{ 'keys' } }; + + put_record( $record, $out ) if not $options->{ 'no_stream' }; + } + + # ---- locate track in config file ---- + + $fh_in = Maasha::Common::read_open( $options->{ 'config_file' } ); + + while ( $track = Maasha::UCSC::ucsc_config_entry_get( $fh_in ) ) { + push @tracks, $track; + } + + close $fh_in; + + map { push @new_tracks, $_ if not exists $track_hash{ $_->{ 'track' } } } @tracks; + + print STDERR qq(WARNING: track not found in config file: "$options->{ 'config_file' }"\n) if scalar @tracks == scalar @new_tracks; + + rename "$options->{ 'config_file' }", "$options->{ 'config_file' }~"; + + $fh_out = Maasha::Common::write_open( $options->{ 'config_file' } ); + + map { Maasha::UCSC::ucsc_config_entry_put( $_, $fh_out ) } @new_tracks; + + close $fh_out; + + # ---- locate track in database ---- + + $dbh = Maasha::SQL::connect( $options->{ "database" }, $options->{ "user" }, $options->{ "password" } ); + + foreach $track ( sort keys %track_hash ) + { + if ( Maasha::SQL::table_exists( $dbh, $track ) ) + { + print STDERR qq(Removing table "$track" from database "$options->{ 'database' }" ... ) if $options->{ 'verbose' }; + Maasha::SQL::delete_table( $dbh, $track ); + print STDERR "done.\n" if $options->{ 'verbose' }; + } + else + { + print STDERR qq(WARNING: table "$track" not found in database "$options->{ 'database' }\n"); + } + } + + Maasha::SQL::disconnect( $dbh ); + + Maasha::Common::run( "ucscMakeTracks.pl", "-b > /dev/null 2>&1" ); +} + + sub script_rename_keys { # Martin A. Hansen, August 2007. @@ -5043,28 +5247,40 @@ sub script_grab # Returns nothing. - my ( $patterns, $pattern, $record, $key, $pos, $op, $val, %lookup_hash ); + my ( $keys, $vals_only, $keys_only, $invert, $patterns, $pattern, $regex, $record, $key, $op, $val, %lookup_hash, $found ); - if ( $options->{ "patterns" } ) + $keys = $options->{ 'keys' }; + $vals_only = $options->{ 'vals_only' }; + $keys_only = $options->{ 'keys_only' }; + $invert = $options->{ 'invert' }; + + if ( $options->{ 'patterns' } ) { - $patterns = [ split ",", $options->{ "patterns" } ]; + $patterns = [ split ",", $options->{ 'patterns' } ]; } - elsif ( -f $options->{ "patterns_in" } ) + elsif ( -f $options->{ 'patterns_in' } ) { - $patterns = Maasha::Patscan::read_patterns( $options->{ "patterns_in" } ); + $patterns = Maasha::Patscan::read_patterns( $options->{ 'patterns_in' } ); + } + elsif ( $options->{ 'regex' } ) + { + if ( $options->{ 'case_insensitive' } ) { + $regex = qr/$options->{ 'regex' }/i; + } else { + $regex = qr/$options->{ 'regex' }/; + } } - elsif ( -f $options->{ "exact_in" } ) + elsif ( -f $options->{ 'exact_in' } ) { - $patterns = Maasha::Patscan::read_patterns( $options->{ "exact_in" } ); + $patterns = Maasha::Patscan::read_patterns( $options->{ 'exact_in' } ); map { $lookup_hash{ $_ } = 1 } @{ $patterns }; undef $patterns; } - - if ( $options->{ "eval" } ) + elsif ( $options->{ 'eval' } ) { - if ( $options->{ "eval" } =~ /^([^><=! ]+)\s*(>=|<=|>|<|=|!=|eq|ne)\s*(.+)$/ ) + if ( $options->{ 'eval' } =~ /^([^><=! ]+)\s*(>=|<=|>|<|=|!=|eq|ne)\s*(.+)$/ ) { $key = $1; $op = $2; @@ -5074,151 +5290,21 @@ sub script_grab while ( $record = get_record( $in ) ) { - $pos = -1; - - if ( %lookup_hash ) - { - if ( $options->{ "keys" } ) - { - foreach $key ( @{ $options->{ "keys" } } ) - { - if ( exists $lookup_hash{ $record->{ $key } } ) - { - $pos = 1; - goto FOUND; - } - } - } - else - { - foreach $key ( keys %{ $record } ) - { - if ( not $options->{ "vals_only" } ) - { - if ( exists $lookup_hash{ $key } ) - { - $pos = 1; - goto FOUND; - } - } - - if ( not $options->{ "keys_only" } ) - { - if ( exists $lookup_hash{ $record->{ $key } } ) - { - $pos = 1; - goto FOUND; - } - } - } - } - } - elsif ( $patterns ) - { - foreach $pattern ( @{ $patterns } ) - { - if ( $options->{ "keys" } ) - { - foreach $key ( @{ $options->{ "keys" } } ) - { - $pos = index $record->{ $key }, $pattern; - - goto FOUND if $pos >= 0; - } - } - else - { - foreach $key ( keys %{ $record } ) - { - if ( not $options->{ "vals_only" } ) - { - $pos = index $key, $pattern; - - goto FOUND if $pos >= 0; - } - - if ( not $options->{ "keys_only" } ) - { - $pos = index $record->{ $key }, $pattern; - - goto FOUND if $pos >= 0; - } - } - } - } - } - elsif ( $options->{ "regex" } ) - { - if ( $options->{ "keys" } ) - { - foreach $key ( @{ $options->{ "keys" } } ) - { - if ( $options->{ "case_insensitive" } ) { - $pos = 1 if $record->{ $key } =~ /$options->{'regex'}/i; - } else { - $pos = 1 if $record->{ $key } =~ /$options->{'regex'}/; - } + $found = 0; - goto FOUND if $pos >= 0; - } - } - else - { - foreach $key ( keys %{ $record } ) - { - if ( not $options->{ "vals_only" } ) - { - if ( $options->{ "case_insensitive" } ) { - $pos = 1 if $key =~ /$options->{'regex'}/i; - } else { - $pos = 1 if $key =~ /$options->{'regex'}/; - } - - goto FOUND if $pos >= 0; - } - - if ( not $options->{ "keys_only" } ) - { - if ( $options->{ "case_insensitive" } ) { - $pos = 1 if $record->{ $key } =~ /$options->{'regex'}/i; - } else { - $pos = 1 if $record->{ $key } =~ /$options->{'regex'}/; - } - - goto FOUND if $pos >= 0; - } - } - } - } - elsif ( $options->{ "eval" } ) - { - if ( defined $record->{ $key } ) - { - if ( $op eq "<" and $record->{ $key } < $val ) { - $pos = 1 and goto FOUND; - } elsif ( $op eq ">" and $record->{ $key } > $val ) { - $pos = 1 and goto FOUND; - } elsif ( $op eq ">=" and $record->{ $key } >= $val ) { - $pos = 1 and goto FOUND; - } elsif ( $op eq "<=" and $record->{ $key } <= $val ) { - $pos = 1 and goto FOUND; - } elsif ( $op eq "=" and $record->{ $key } == $val ) { - $pos = 1 and goto FOUND; - } elsif ( $op eq "!=" and $record->{ $key } != $val ) { - $pos = 1 and goto FOUND; - } elsif ( $op eq "eq" and $record->{ $key } eq $val ) { - $pos = 1 and goto FOUND; - } elsif ( $op eq "ne" and $record->{ $key } ne $val ) { - $pos = 1 and goto FOUND; - } - } + if ( %lookup_hash ) { + $found = grab_lookup( \%lookup_hash, $record, $keys, $vals_only, $keys_only ); + } elsif ( $patterns ) { + $found = grab_patterns( $patterns, $record, $keys, $vals_only, $keys_only ); + } elsif ( $regex ) { + $found = grab_regex( $regex, $record, $keys, $vals_only, $keys_only ); + } elsif ( $op ) { + $found = grab_eval( $key, $op, $val, $record ); } - FOUND: - - if ( $pos >= 0 and not $options->{ "invert" } ) { + if ( $found and not $invert ) { put_record( $record, $out ); - } elsif ( $pos < 0 and $options->{ "invert" } ) { + } elsif ( not $found and $invert ) { put_record( $record, $out ); } } @@ -5238,29 +5324,33 @@ sub script_compute # Returns nothing. - my ( $record, $eval_key, $eval_val, $check, @keys ); + my ( $record, $eval_key, @keys, $eval_val ); while ( $record = get_record( $in ) ) { if ( $options->{ "eval" } ) { - if ( $options->{ "eval" } =~ /^(.+)\s*=\s*(.+)$/ ) + if ( $options->{ "eval" } =~ /^(\S+)\s*=\s*(.+)$/ ) { $eval_key = $1; $eval_val = $2; - } - if ( not $check ) - { - @keys = split /\W+/, $eval_val; - @keys = grep { ! /^\d+$/ } @keys; + if ( not @keys ) + { + @keys = split /\s+|\+|-|\*|\/|\*\*/, $eval_val; - $check = 1; - } + @keys = grep { exists $record->{ $_ } } @keys; + } - map { $eval_val =~ s/$_/$record->{ $_ }/g } @keys; + map { $eval_val =~ s/\Q$_\E/$record->{ $_ }/g } @keys; - $record->{ $eval_key } = eval "$eval_val" or Maasha::Common::error( "eval failed -> $@" ); + $record->{ $eval_key } = eval "$eval_val"; + Maasha::Common::error( qq(eval "$eval_key = $eval_val" failed -> $@) ) if $@; + } + else + { + Maasha::Common::error( qq(Bad compute expression: "$options->{ 'eval' }"\n) ); + } } put_record( $record, $out ); @@ -6057,7 +6147,7 @@ sub script_upload_to_ucsc # Returns nothing. - my ( $record, $file, $wib_file, $wig_file, $wib_dir, $fh_out, $i, $first, $format, $type, $columns, $append, $vals ); + my ( $record, $file, $wib_file, $wig_file, $wib_dir, $fh_out, $i, $first, $format, $type, $columns, $append, $entry ); $options->{ "short_label" } ||= $options->{ 'table' }; $options->{ "long_label" } ||= $options->{ 'table' }; @@ -6067,13 +6157,10 @@ sub script_upload_to_ucsc $options->{ "color" } ||= join( ",", int( rand( 255 ) ), int( rand( 255 ) ), int( rand( 255 ) ) ); $options->{ "chunk_size" } ||= 10_000_000_000; # Due to 32-bit UCSC compilation really large tables cannot be loaded in one go. - $file = "$BP_TMP/ucsc_upload.tmp"; - + $file = "$BP_TMP/ucsc_upload.tmp"; $append = 0; - - $first = 1; - - $i = 0; + $first = 1; + $i = 0; $fh_out = Maasha::Common::write_open( $file ); @@ -6083,27 +6170,27 @@ sub script_upload_to_ucsc if ( $record->{ "REC_TYPE" } eq "fixed_step" ) { - $vals = $record->{ "VALS" }; - $vals =~ tr/;/\n/; - - print $fh_out "fixedStep chrom=$record->{ 'CHR' } start=$record->{ 'CHR_BEG' } step=$record->{ 'STEP' }\n"; - print $fh_out "$vals\n"; + $format = "WIGGLE"; - $format = "WIGGLE" if not $format; + if ( $entry = Maasha::UCSC::Wiggle::biopiece2fixedstep( $record ) ) { + Maasha::UCSC::Wiggle::fixedstep_entry_put( $entry, $fh_out ); + } } elsif ( $record->{ "REC_TYPE" } eq "PSL" ) { + $format = "PSL"; + Maasha::UCSC::psl_put_header( $fh_out ) if $first; Maasha::UCSC::psl_put_entry( $record, $fh_out ); $first = 0; - - $format = "PSL" if not $format; } elsif ( $record->{ "REC_TYPE" } eq "BED" and $record->{ "SEC_STRUCT" } ) { # chrom chromStart chromEnd name score strand size secStr conf + $format = "BED_SS"; + print $fh_out join ( "\t", $record->{ "CHR" }, $record->{ "CHR_BEG" }, @@ -6115,47 +6202,44 @@ sub script_upload_to_ucsc $record->{ "SEC_STRUCT" }, $record->{ "CONF" }, ), "\n"; - - $format = "BED_SS" if not $format; } elsif ( $record->{ "REC_TYPE" } eq "BED" ) { - Maasha::UCSC::bed_put_entry( $record, $fh_out, $record->{ "BED_COLS" } ); + $format = "BED"; + $columns = $record->{ "BED_COLS" }; - $format = "BED" if not $format; - $columns = $record->{ "BED_COLS" } if not $columns; + if ( $entry = Maasha::UCSC::BED::biopiece2bed( $record, $columns ) ) { + Maasha::UCSC::BED::bed_entry_put( $entry, $fh_out, $columns, $options->{ 'check' } ); + } } elsif ( $record->{ "REC_TYPE" } eq "PATSCAN" and $record->{ "CHR" } ) { - Maasha::UCSC::bed_put_entry( $record, $fh_out, 6 ); + $format = "BED"; + $columns = 6; - $format = "BED" if not $format; - $columns = 6 if not $columns; + if ( $entry = Maasha::UCSC::BED::biopiece2bed( $record, $columns ) ) { + Maasha::UCSC::BED::bed_entry_put( $entry, $fh_out, $columns, $options->{ 'check' } ); + } } elsif ( $record->{ "REC_TYPE" } eq "BLAST" and $record->{ "S_ID" } =~ /^chr/ ) { - $record->{ "CHR" } = $record->{ "S_ID" }; - $record->{ "CHR_BEG" } = $record->{ "S_BEG" }; - $record->{ "CHR_END" } = $record->{ "S_END" }; - $record->{ "SCORE" } = $record->{ "BIT_SCORE" } * 1000; + $format = "BED"; + $columns = 6; - $format = "BED" if not $format; - $columns = 6 if not $columns; + $record->{ "SCORE" } = $record->{ "BIT_SCORE" } * 1000; - Maasha::UCSC::bed_put_entry( $record, $fh_out ); + if ( $entry = Maasha::UCSC::BED::biopiece2bed( $record, $columns ) ) { + Maasha::UCSC::BED::bed_entry_put( $entry, $fh_out, $columns, $options->{ 'check' } ); + } } elsif ( $record->{ "REC_TYPE" } eq "VMATCH" and $record->{ "S_ID" } =~ /^chr/i ) { - $record->{ "CHR" } = $record->{ "S_ID" }; - $record->{ "CHR_BEG" } = $record->{ "S_BEG" }; - $record->{ "CHR_END" } = $record->{ "S_END" }; - $record->{ "SCORE" } = $record->{ "SCORE" } || 999; - $record->{ "SCORE" } = int( $record->{ "SCORE" } ); + $format = "BED"; + $columns = 6; - $format = "BED" if not $format; - $columns = 6 if not $columns; - - Maasha::UCSC::bed_put_entry( $record, $fh_out, 6 ); + if ( $entry = Maasha::UCSC::BED::biopiece2bed( $record, $columns ) ) { + Maasha::UCSC::BED::bed_entry_put( $entry, $fh_out, $columns, $options->{ 'check' } ); + } } if ( $i == $options->{ "chunk_size" } ) @@ -6192,9 +6276,7 @@ sub script_upload_to_ucsc } elsif ( $format eq "BED_SS" ) { - $options->{ "sec_struct" } = 1; - - $type = "sec_struct"; + $type = "type bed 6 +"; Maasha::UCSC::bed_upload_to_ucsc( $BP_TMP, $file, $options, $append ); } @@ -6234,7 +6316,7 @@ sub script_upload_to_ucsc unlink $file; - Maasha::UCSC::update_my_tracks( $options, $type ); + Maasha::UCSC::ucsc_update_config( $options, $type ); } } @@ -6242,29 +6324,146 @@ sub script_upload_to_ucsc # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -sub record2fasta +sub grab_lookup { - # Martin A. Hansen, July 2008. + # Martin A. Hansen, November 2009. + + # Uses keys from a lookup hash to search records. Optionally, a list of + # keys can be given so the lookup is limited to these, also, flags + # can be given to limit lookup to keys or vals only. Returns 1 if lookup + # succeeded, else 0. + + my ( $lookup_hash, # hashref with patterns + $record, # hashref + $keys, # list of keys - OPTIONAL + $vals_only, # only vals flag - OPTIONAL + $keys_only, # only keys flag - OPTIONAL + ) = @_; - # Given a biopiece record converts it to a FASTA record. - # If no generic SEQ or SEQ_NAME is found, the Q_* and S_* are - # tried in that order. + # Returns boolean. - my ( $record, # record + if ( $keys ) + { + map { return 1 if exists $lookup_hash->{ $record->{ $_ } } } @{ $keys }; + } + else + { + if ( not $vals_only ) { + map { return 1 if exists $lookup_hash->{ $_ } } keys %{ $record }; + } + + if ( not $keys_only ) { + map { return 1 if exists $lookup_hash->{ $record->{ $_ } } } keys %{ $record }; + } + } + + return 0; +} + + +sub grab_patterns +{ + # Martin A. Hansen, November 2009. + + # Uses patterns to match records containing the pattern as a substring. + # Returns 1 if the record is matched, else 0. + + my ( $patterns, # list of patterns + $record, # hashref + $keys, # list of keys - OPTIONAL + $vals_only, # only vals flag - OPTIONAL + $keys_only, # only keys flag - OPTIONAL ) = @_; - # Returns a tuple. + # Returns boolean. + + my ( $pattern ); - my ( $seq_name, $seq ); + foreach $pattern ( @{ $patterns } ) + { + if ( $keys ) + { + map { return 1 if index( $record->{ $_ }, $pattern ) >= 0 } @{ $keys }; + } + else + { + if ( not $vals_only ) { + map { return 1 if index( $_, $pattern ) >= 0 } keys %{ $record }; + } - $seq_name = $record->{ "SEQ_NAME" } || $record->{ "Q_ID" } || $record->{ "S_ID" }; - $seq = $record->{ "SEQ" } || $record->{ "Q_SEQ" } || $record->{ "S_SEQ" }; + if ( not $keys_only ) { + map { return 1 if index( $record->{ $_ }, $pattern ) >= 0 } keys %{ $record }; + } + } + } - if ( defined $seq_name and defined $seq ) { - return wantarray ? ( $seq_name, $seq ) : [ $seq_name, $seq ]; - } else { - return; + return 0; +} + + +sub grab_regex +{ + # Martin A. Hansen, November 2009. + + # Uses regex to match records. + # Returns 1 if the record is matched, else 0. + + my ( $regex, # regex to match + $record, # hashref + $keys, # list of keys - OPTIONAL + $vals_only, # only vals flag - OPTIONAL + $keys_only, # only keys flag - OPTIONAL + ) = @_; + + # Returns boolean. + + if ( $keys ) + { + map { return 1 if $record->{ $_ } =~ /$regex/ } @{ $keys }; + } + else + { + if ( not $vals_only ) { + map { return 1 if $_ =~ /$regex/ } keys %{ $record }; + } + + if ( not $keys_only ) { + map { return 1 if $record->{ $_ } =~ /$regex/ } keys %{ $record }; + } + } + + return 0; +} + + +sub grab_eval +{ + # Martin A. Hansen, November 2009. + + # Test if the value of a given record key evaluates according + # to a given operator. Returns 1 if eval is OK, else 0. + + my ( $key, # record key + $op, # operator + $val, # value + $record, # hashref + ) = @_; + + # Returns boolean. + + if ( defined $record->{ $key } ) + { + return 1 if ( $op eq "<" and $record->{ $key } < $val ); + return 1 if ( $op eq ">" and $record->{ $key } > $val ); + return 1 if ( $op eq ">=" and $record->{ $key } >= $val ); + return 1 if ( $op eq "<=" and $record->{ $key } <= $val ); + return 1 if ( $op eq "=" and $record->{ $key } == $val ); + return 1 if ( $op eq "!=" and $record->{ $key } != $val ); + return 1 if ( $op eq "eq" and $record->{ $key } eq $val ); + return 1 if ( $op eq "ne" and $record->{ $key } ne $val ); } + + return 0; }