r41928 - in /branches/upstream/libbio-scf-perl: ./ current/ current/SCF/ current/eg/ current/t/
plessy at users.alioth.debian.org
plessy at users.alioth.debian.org
Sun Aug 16 03:30:08 UTC 2009
Author: plessy
Date: Sun Aug 16 03:29:56 2009
New Revision: 41928
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=41928
Log:
[svn-inject] Installing original source of libbio-scf-perl
Added:
branches/upstream/libbio-scf-perl/
branches/upstream/libbio-scf-perl/current/
branches/upstream/libbio-scf-perl/current/DISCLAIMER
branches/upstream/libbio-scf-perl/current/INSTALL
branches/upstream/libbio-scf-perl/current/MANIFEST
branches/upstream/libbio-scf-perl/current/META.yml
branches/upstream/libbio-scf-perl/current/Makefile.PL
branches/upstream/libbio-scf-perl/current/README
branches/upstream/libbio-scf-perl/current/SCF/
branches/upstream/libbio-scf-perl/current/SCF.pm
branches/upstream/libbio-scf-perl/current/SCF.xs
branches/upstream/libbio-scf-perl/current/SCF/Arrays.pm
branches/upstream/libbio-scf-perl/current/eg/
branches/upstream/libbio-scf-perl/current/eg/read_test_obj.pl (with props)
branches/upstream/libbio-scf-perl/current/eg/read_test_tied.pl (with props)
branches/upstream/libbio-scf-perl/current/eg/write_test_obj.pl (with props)
branches/upstream/libbio-scf-perl/current/eg/write_test_tied.pl (with props)
branches/upstream/libbio-scf-perl/current/t/
branches/upstream/libbio-scf-perl/current/t/scf.t
branches/upstream/libbio-scf-perl/current/test.scf (with props)
Added: branches/upstream/libbio-scf-perl/current/DISCLAIMER
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libbio-scf-perl/current/DISCLAIMER?rev=41928&op=file
==============================================================================
--- branches/upstream/libbio-scf-perl/current/DISCLAIMER (added)
+++ branches/upstream/libbio-scf-perl/current/DISCLAIMER Sun Aug 16 03:29:56 2009
@@ -1,0 +1,23 @@
+The SCF package and all associated files are Copyright (c) 2006 Cold
+Spring Harbor Laboratory.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself. See the Artistic License file
+in the main Perl distribution for specific terms and conditions of
+use. In addition, the following disclaimers apply:
+
+CSHL makes no representations whatsoever as to the SOFTWARE contained
+herein. It is experimental in nature and is provided WITHOUT WARRANTY
+OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE OR ANY OTHER
+WARRANTY, EXPRESS OR IMPLIED. CSHL MAKES NO REPRESENTATION OR
+WARRANTY THAT THE USE OF THIS SOFTWARE WILL NOT INFRINGE ANY PATENT OR
+OTHER PROPRIETARY RIGHT.
+
+By downloading this SOFTWARE, your Institution hereby indemnifies CSHL
+against any loss, claim, damage or liability, of whatsoever kind or
+nature, which may arise from your Institution's respective use,
+handling or storage of the SOFTWARE.
+
+If publications result from research using this SOFTWARE, we ask that
+CSHL be acknowledged and/or credit be given to CSHL scientists, as
+scientifically appropriate.
Added: branches/upstream/libbio-scf-perl/current/INSTALL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libbio-scf-perl/current/INSTALL?rev=41928&op=file
==============================================================================
--- branches/upstream/libbio-scf-perl/current/INSTALL (added)
+++ branches/upstream/libbio-scf-perl/current/INSTALL Sun Aug 16 03:29:56 2009
@@ -1,0 +1,18 @@
+In order to install this perl extension you have to install io-lib
+version 1.9 or higher from the Staden library
+(staden.sourceforge.net). This can be downloaded from
+https://sourceforge.net/project/showfiles.php?group_id=100316&package_id=108243&release_id=340318. To
+confirm that the package installed correctly look for a library named
+"libread".
+
+You will also need the zlib library which can be found at
+http://www.zlib.net/.
+
+To install this extension:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+Dmitri Priimak
Added: branches/upstream/libbio-scf-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libbio-scf-perl/current/MANIFEST?rev=41928&op=file
==============================================================================
--- branches/upstream/libbio-scf-perl/current/MANIFEST (added)
+++ branches/upstream/libbio-scf-perl/current/MANIFEST Sun Aug 16 03:29:56 2009
@@ -1,0 +1,15 @@
+INSTALL
+MANIFEST
+Makefile.PL
+DISCLAIMER
+README
+SCF.pm
+SCF.xs
+SCF/Arrays.pm
+eg/read_test_obj.pl
+eg/read_test_tied.pl
+eg/write_test_obj.pl
+eg/write_test_tied.pl
+t/scf.t
+test.scf
+META.yml Module meta-data (added by MakeMaker)
Added: branches/upstream/libbio-scf-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libbio-scf-perl/current/META.yml?rev=41928&op=file
==============================================================================
--- branches/upstream/libbio-scf-perl/current/META.yml (added)
+++ branches/upstream/libbio-scf-perl/current/META.yml Sun Aug 16 03:29:56 2009
@@ -1,0 +1,10 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: Bio-SCF
+version: 1.01
+version_from: SCF.pm
+installdirs: site
+requires:
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
Added: branches/upstream/libbio-scf-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libbio-scf-perl/current/Makefile.PL?rev=41928&op=file
==============================================================================
--- branches/upstream/libbio-scf-perl/current/Makefile.PL (added)
+++ branches/upstream/libbio-scf-perl/current/Makefile.PL Sun Aug 16 03:29:56 2009
@@ -1,0 +1,10 @@
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ 'NAME' => 'Bio::SCF',
+ 'VERSION_FROM' => 'SCF.pm', # finds $VERSION
+ 'LIBS' => ['-lread -lz'], # e.g., '-lm'
+ 'DEFINE' => '-DLITTLE_ENDIAN', # e.g., '-DHAVE_SOMETHING'
+ 'INC' => '', # e.g., '-I/usr/include/other'
+);
Added: branches/upstream/libbio-scf-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libbio-scf-perl/current/README?rev=41928&op=file
==============================================================================
--- branches/upstream/libbio-scf-perl/current/README (added)
+++ branches/upstream/libbio-scf-perl/current/README Sun Aug 16 03:29:56 2009
@@ -1,0 +1,15 @@
+The Perl SCF module allows you to read and update (in a restricted
+way) SCF chromatographic sequence files. It is an interface to Roger
+Staden's io-lib. See the installation directions for further
+instructions.
+
+ - This software is free. You can use it under the terms of the Perl
+ Artistic License Please. Please see DISCLAIMER for limitations of
+ warranty, the academic citation policy and other legalese.
+
+Support is available by writing to Lincoln Stein <lstein at cshl.edu>.
+
+Lincoln Stein
+lstein at cshl.org
+January 30, 2006
+
Added: branches/upstream/libbio-scf-perl/current/SCF.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libbio-scf-perl/current/SCF.pm?rev=41928&op=file
==============================================================================
--- branches/upstream/libbio-scf-perl/current/SCF.pm (added)
+++ branches/upstream/libbio-scf-perl/current/SCF.pm Sun Aug 16 03:29:56 2009
@@ -1,0 +1,493 @@
+package Bio::SCF;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+require DynaLoader;
+use Bio::SCF::Arrays;
+use Carp 'croak';
+
+ at ISA = qw(DynaLoader);
+$VERSION = '1.01';
+use constant KEYS => {
+ index => 0,
+ A => 1,
+ C => 2,
+ G => 3,
+ T => 4,
+ bases => 5,
+ spare1 => 6,
+ spare1 => 7,
+ spare1 => 8,
+ samplesA => 11,
+ samplesC => 12,
+ samplesG => 13,
+ samplesT => 14
+ };
+
+use constant HEADER_FIELDS => {
+ samples_length => 0,
+ bases_length => 1,
+ version => 2,
+ sample_size => 3,
+ code_set => 4,
+};
+
+bootstrap Bio::SCF $VERSION;
+
+sub new {
+ my $class = shift;
+ my $file_name = shift;
+ my $sample_hash = shift || 0;
+
+ defined $file_name or die "SCF :: Unable to tie hash to undefined file name\n";
+ my $scf_pointer;
+ if ($sample_hash) {
+ $scf_pointer = $file_name; # file name became scf pointer
+ }
+ else {
+ if ( defined fileno($file_name)){
+ $scf_pointer = get_scf_fpointer($file_name); # file_name here is file handle
+ }else{
+ $scf_pointer = get_scf_pointer($file_name); # actually reads scf file into memory
+ }
+ }
+ my $scf_file = {
+ file_name => $file_name,
+ scf_pointer => $scf_pointer,
+ sample_hash => $sample_hash,
+ cache => {}
+ };
+ return bless $scf_file, $class;
+}
+
+
+sub TIEHASH {
+ shift->new(@_);
+}
+
+sub FETCH {
+ my $self = shift;
+ my $key = shift;
+ my @array;
+
+ if ($self->{sample_hash}) {
+ my $k = "sample_$key";
+ return $self->{cache}{$k} if exists $self->{cache}{$k};
+ tie @array, 'Bio::SCF::Arrays', $self->{scf_pointer}, $k;
+ return $self->{cache}{$k} = \@array;
+ }
+
+ else {
+
+ if (defined( my $header_field = HEADER_FIELDS->{$key})) {
+ return get_from_header($self->{scf_pointer}, $header_field);
+ }
+
+ elsif ($key eq "comments") {
+ return get_comments($self->{scf_pointer});
+ }
+
+ elsif ($key eq 'samples') {
+ return $self->{cache}{$key} if exists $self->{cache}{$key};
+ my %sample;
+ tie %sample, 'Bio::SCF', $self->{scf_pointer}, 1;
+ $self->{cache}{key} = \%sample;
+ return \%sample;
+ }
+
+ elsif (exists KEYS->{$key}) {
+ return $self->{cache}{$key} if exists $self->{cache}{$key};
+ tie @array, 'Bio::SCF::Arrays', $self->{scf_pointer}, $key;
+ $self->{cache}{$key} = \@array;
+ return \@array;
+ }
+
+ }
+}
+
+sub bases_length {
+ my $self = shift;
+ get_from_header($self->{scf_pointer},HEADER_FIELDS->{bases_length});
+}
+
+sub samples_length {
+ my $self = shift;
+ get_from_header($self->{scf_pointer},HEADER_FIELDS->{samples_length});
+}
+
+sub sample_size {
+ my $self = shift;
+ get_from_header($self->{scf_pointer},HEADER_FIELDS->{sample_size});
+}
+
+sub code_set {
+ my $self = shift;
+ get_from_header($self->{scf_pointer},HEADER_FIELDS->{code_set});
+}
+
+sub index {
+ my $self = shift;
+ my $index = shift;
+ my $d = $self->at('index',$index);
+ $self->set('index',$index,shift) if @_;
+ $d;
+}
+
+sub sample {
+ my $self = shift;
+ my $base = uc shift;
+ my $index = shift;
+ my $d = $self->at("samples${base}",$index);
+ $self->set("samples${base}",$index,shift) if @_;
+ $d;
+}
+
+sub base {
+ my $self = shift;
+ my $index = shift;
+ my $d = $self->at('bases',$index);
+ $self->set('bases',$index,shift) if @_;
+ $d;
+}
+
+sub base_score {
+ my $self = shift;
+ my $base = uc shift;
+ my $index = shift;
+ my $d = $self->at($base,$index);
+ $self->set($base,$index,shift) if @_;
+ $d;
+}
+
+sub score {
+ my $self = shift;
+ my $index = shift;
+ my $base = uc $self->base($index);
+ my $d = exists KEYS->{$base} ? $self->base_score($base,$index) : 0;
+ $self->set($base,$index,shift) if @_;
+ $d;
+}
+
+sub comments {
+ my $self = shift;
+ get_comments($self->{scf_pointer});
+}
+
+sub at {
+ my $self = shift;
+ # possible keys { bases, A, C, G, T, spare1/2/3, sampleA/C/G/T }
+ my $key = shift;
+ my $index = shift;
+ return get_at($self->{scf_pointer}, $index, KEYS->{$key});
+}
+
+sub set {
+ my $self = shift;
+ # possible keys { bases, A, C, G, T, spare1/2/3, sampleA/C/G/T }
+ my $key = shift;
+ my $index = shift;
+ my $value = shift or die "Bio::SCF::set(...) value not defined\n";
+ if ( $key eq "bases" ){
+ set_base_at($self->{scf_pointer}, $index, KEYS->{$key}, $value);
+ }else{
+ set_at($self->{scf_pointer}, $index, KEYS->{$key}, $value);
+ }
+}
+
+sub write {
+ my $self = shift;
+ my $file_name = shift || $self->{file_name};
+ return scf_write($self->{scf_pointer}, $file_name);
+}
+
+sub fwrite {
+ my $self = shift;
+ my $file_handle = shift ||
+ die "Bio::SCF::fwrite(...) : file handle is not defined\n";
+ return scf_fwrite($self->{scf_pointer}, $file_handle);
+}
+
+sub STORE {
+ my $self = shift;
+ my $key = shift;
+ my $value = shift;
+ SWITCH: {
+ $key eq "comments" && do {
+ set_comments($self->{scf_pointer}, $value);
+ last SWITCH;
+ };
+ die "Bio::SCF::STORE field $key doesn't exist or not allowed to be modified\n";
+ }
+}
+
+sub FIRSTKEY {
+ my $self = shift;
+ my $a = keys %{KEYS()};
+ each %{KEYS()}
+}
+
+sub NEXTKEY {
+ my $self = shift;
+ each %{KEYS()};
+}
+
+sub CLEAR {
+ croak "The Bio::SCF module does not support this operation";
+}
+
+sub DELETE {
+ croak "The Bio::SCF module does not support this operation";
+}
+
+sub DESTROY {
+ my $self = shift;
+ Bio::SCF::scf_free($self->{scf_pointer}) unless $self->{sample_hash};
+}
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+__END__
+
+=head1 NAME
+
+Bio::SCF - Perl extension for reading and writting SCF sequence files
+
+=head1 SYNOPSIS
+
+use Bio::SCF;
+
+# tied interface
+tie %hash,'Bio::SCF','my_scf_file.scf';
+
+my $sequence_length = $hash{bases_length};
+my $chromatogram_sample_length = $hash{samples_length};
+my $third_base = $hash{bases}[2];
+my $quality_score = $hash{$third_base}[2];
+my $sample_A_at_time_1400 = $hash{samples}{A}[1400];
+
+# change the third base and write out new file
+$hash{bases}[2] = 'C';
+tied (%hash)->write('new.scf');
+
+# object-oriented interface
+my $scf = Bio::SCF->new('my_scf_file.scf');
+my $sequence_length = $scf->bases_length;
+my $chromatogram_sample_length = $scf->samples_length;
+my $third_base = $scf->bases(2);
+my $quality_score = $scf->score(2);
+my $sample_A_at_time_1400 = $scf->sample('A',1400);
+
+# change the third base and write out new file
+$scf->bases(2,'C');
+$scf->write('new.scf');
+
+=head1 DESCRIPTION
+
+This module provides a perl interface to SCF DNA sequencing files. It
+has both tied hash and an object-oriented interfaces. It provides the
+ability to read fields from SCF files and limited ability to modify
+them and write them back.
+
+=head2 Tied Methods
+
+=over 4
+
+=item $obj = tie %hash,'Bio::SCF',$filename_or_handle
+
+Tie the Bio::SCF module to a filename or filehandle. If successful, tie()
+will return the object.
+
+=item $value = $hash{'key'}
+
+Fetch a field from the SCF file. Valid keys are as follows:
+
+ Key Value
+ --- -----
+
+ bases_length Number of called bases in the sequence (read-only)
+
+ samples_length Number of samples in the file (read-only)
+
+ version SCF version (read-only)
+
+ code_set Code set used to code bases (read-only)
+
+ comments Structured comments (read-only)
+
+ bases Array reference to a list of the base calls
+
+ index Array reference to a list of the sample position
+ for each of the base calls (e.g. the position of
+ the base calling peak)
+
+ A An array reference that can be used to determine the
+ probability that the base in position $i is an "A".
+
+ G An array reference that can be used to determine the
+ probability that the base in position $i is a "G".
+
+ C An array reference that can be used to determine the
+ probability that the base in position $i is a "C".
+
+ T An array reference that can be used to determine the
+ probability that the base in position $i is a "T".
+
+ samples A hash reference with keys "A", "C", "G" and "T". The
+ value of each hash is an array reference to the list
+ of intensity values for each sample.
+
+To get the length of the called sequence: $scf{bases_length}
+
+To get the value of the called sequence at position 3: $scf{bases}[3]
+
+To get the sample position at which base 3 was called: $scf{index}[3]
+
+To get the value of the "C" curve under base 3: $scf{samples}{C}[$scf{index}[3]]
+
+To get the probability that base 3 is a "C": $scf{C}[3]
+
+To print out the chromatogram as a four-column list:
+
+ my $samples = $scf{samples};
+ for (my $i = 0; $i<$scf{samples_length}; $i++) {
+ print join "\t",$samples->{C}[$i],$samples->{G}[$i],
+ $samples->{A}[$i],$samples->{T}[$i],"\n";
+ }
+
+=item $scf{bases}[$index] = $new_value
+
+The base call probability scores, base call values, base call
+positions, and sample values are all read/write, so that you can
+change them:
+
+ $samples->{C}[500] = 0;
+
+=item each %scf
+
+Will return keys and values for the tied object.
+
+=item delete $scf{$key}
+
+=item %scf = ()
+
+These operations are not supported and will return a run-time error
+
+=back
+
+=head2 Object Methods
+
+=over 4
+
+=item $scf = Bio::SCF->new($scf_file_or_filehandle)
+
+Create a new Bio::SCF object. The single argument is the name of a file or
+a previously-opened filehandle. If successful, new() returns the Bio::SCF
+object.
+
+=item $length = $scf->bases_length
+
+Return the length of the called sequence.
+
+=item $samples = $scf->samples_length
+
+Return the length of the list of chromatogram samples in the
+file. There are four sample series, one for each base.
+
+=item $sample_size = $scf->sample_size
+
+Returns the size of each sample (bytes).
+
+=item $code_set = $scf->code_set
+
+Return the code set used for base calling.
+
+=item $base = $scf->base($base_no [,$new_base])
+
+Get the base call at the indicated position. If a new value is
+provided, will change the base call to the indicated base.
+
+=item $index = $scf->index($base_no [,$new_index])
+
+Translates the indicated base position into the sample index for that
+called base. Here is how to fetch the intensity values at base number 5:
+
+ my $sample_index = $scf->index(5);
+ my ($g,$a,$t,$c) = map { $scf->sample($_,$sample_index) } qw(G A T C);
+
+If you provide a new value for the sample index, it will be updated.
+
+=item $base_score = $scf->base_score($base,$base_no [,$new_score])
+
+Get the probability that the indicated base occurs at position
+$base_no. Here is how to fetch the probabilities for the four bases at
+base position 5:
+
+ my ($g,$a,$t,$c) = map { $scf->base_score($_,5) } qw(G A T C);
+
+If you provide a new value for the base probability score, it will be
+updated.
+
+=item $score = $scf->score($base_no)
+
+Get the quality score for the called base at the indicated position.
+
+=item $intensity = $scf->sample($base,$sample_index [,$new_value])
+
+Get the intensity value for the channel corresponding to the indicated
+base at the indicated sample index. You may update the intensity by
+providing a new value.
+
+=item $scf->write('file_path')
+
+Write the updated SCF file to the indicated file path.
+
+=item $scf->fwrite($file_handle)
+
+Write the updated SCF file to the indicated filehandle. The file must
+previously have been opened for writing. The filehandle is actually
+reopened in append mode, so you can call fwrite() multiple times and
+interperse your own record separators.
+
+=back
+
+=head1 EXAMPLES
+
+Reading information from a preexisting file:
+
+ tie %scf, 'Bio::SCF', "data.scf";
+ print "Base calls:\n";
+ for ( my $i=0; $i<$scf{bases}; $i++ ){
+ print "$scf{base}[$i] ";
+ }
+ print "\n";
+
+ print "Intensity values for the A curve\n";
+ for ( my $i=0; $i<$scf{samples}; $i++ ){
+ print "$scf{sample}{A}[$i];
+ }
+ print "\n";
+
+Another example, where we set all bases to "A", indexes to 10 and write
+the file back:
+
+ my $obj = tie %scf,'Bio::SCF','data.scf';
+ for (0...@{$scf{bases}}-1){
+ $scf{base}[$_] = "A";
+ $obj->set('index', $_, 10);
+ }
+ $obj->write('data.scf');
+
+=head1 AUTHOR
+
+Dmitri Priimak, priimak at cshl.org (1999)
+
+with some cleanups by
+Lincoln Stein, lstein at cshl.edu (2006)
+
+=head1 SEE ALSO
+
+perl(1).
+
+=cut
Added: branches/upstream/libbio-scf-perl/current/SCF.xs
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libbio-scf-perl/current/SCF.xs?rev=41928&op=file
==============================================================================
--- branches/upstream/libbio-scf-perl/current/SCF.xs (added)
+++ branches/upstream/libbio-scf-perl/current/SCF.xs Sun Aug 16 03:29:56 2009
@@ -1,0 +1,297 @@
+#ifdef __cplusplus
+extern "C" {
+#endif
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include <fcntl.h>
+#include <string.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
+#include <io_lib/scf.h>
+#include <io_lib/mFILE.h>
+
+#define SV_SETUV(A) { ret_val = newSViv(1); sv_setuv(ret_val, (A)); }
+
+#ifdef __cplusplus
+}
+#endif
+
+MODULE = Bio::SCF PACKAGE = Bio::SCF
+
+SV *
+get_scf_pointer(file_name)
+char *file_name
+ CODE:
+ Scf *scf_data = NULL; /* internal representation of data from scf file */
+ struct stat *file_stat;
+ SV *ret_val; /* SV which content scf data */
+ int i;
+
+ /* checking for existance of file and its permissions */
+ if( file_name == NULL ) croak("readScf(...) : file_name is NULL");
+ file_stat = malloc(sizeof(struct stat));
+ i = stat(file_name, file_stat);
+ if( i == -1 ){
+ switch(errno){
+ case ENOENT :
+ croak("get_scf_pointer(...) : file %s doesn't exist\n", file_name);
+ break;
+ case EACCES :
+ croak("get_scf_pointer(...) : permission denied on file %s\n", file_name);
+ break;
+ case ENAMETOOLONG :
+ croak("get_scf_pointer(...) : file name %s too long\n", file_name);
+ break;
+ default :
+ croak("get_scf_pointer(...) : unable to get stat on file %s, errno %d\n", file_name, errno);
+ break;
+ }
+ }
+ free(file_stat);
+
+ /* Reading SCF file, into internal structure */
+ if ( (scf_data = read_scf(file_name)) == NULL )
+ croak("get_scf_pointer(...) : failed on read_scf(%s)\n", file_name);
+ ret_val = newSViv((int)scf_data);
+ RETVAL = ret_val;
+ OUTPUT:
+ RETVAL
+
+SV *
+get_scf_fpointer(file_handle)
+FILE *file_handle
+ CODE:
+ Scf *scf_data = NULL; /* internal representation of data read from scf file */
+ SV *ret_val; /* SV which content scf data */
+ mFILE *mf;
+
+ /* we don't need to check existance of file and its permissions becouse we operate
+ here with already opened file handle */
+ if( file_handle == NULL ) croak("get_scf_fpointer(...) : file_handle is NULL");
+
+ /* Reading SCF file, into internal structure */
+ mf = mfreopen(NULL,"r",file_handle);
+ if (mf == NULL)
+ croak("get_scf_fpointer(...) : failed on mfreopen(...)\n");
+ if ( (scf_data = mfread_scf(mf)) == NULL )
+ croak("get_scf_fpointer(...) : failed on fread_scf(...)\n");
+ ret_val = newSViv((int)scf_data);
+ RETVAL = ret_val;
+ OUTPUT:
+ RETVAL
+
+void
+scf_free(scf_pointer)
+int scf_pointer
+CODE:
+ scf_deallocate((Scf *)scf_pointer);
+
+SV *
+get_comments(scf_pointer)
+int scf_pointer
+ CODE:
+ Scf *scf_data = (Scf *)scf_pointer;
+ SV *ret_val;
+ if ( scf_data == NULL ) croak("get_comments(...) : scf_pointer is NULL\n");
+ ret_val = newSVpv(scf_data->comments, strlen(scf_data->comments));
+ RETVAL = ret_val;
+ OUTPUT:
+ RETVAL
+
+void
+set_comments(scf_pointer, comments)
+int scf_pointer
+char *comments
+ CODE:
+ Scf *scf_data = (Scf *)scf_pointer;
+ if ( comments == NULL ) croak("set_comments(...) : comments is NULL\n");
+ if ( scf_data == NULL ) croak("set_comments(...) : scf_pointer is NULL\n");
+ free(scf_data->comments);
+ scf_data->comments = malloc(strlen(comments));
+ memcpy(scf_data->comments, comments, strlen(comments));
+ (scf_data->header).comments_size = strlen(comments);
+
+SV *
+scf_write(scf_pointer, file_name)
+int scf_pointer
+char *file_name
+ CODE:
+ Scf *scf_data = (Scf *)scf_pointer;
+ if ( file_name == NULL ) croak("scf_write(...) : file_name is NULL\n");
+ if ( scf_data == NULL ) croak("scf_write(...) : scf_pointer is NULL\n");
+ if( write_scf(scf_data, file_name) == 0) RETVAL=(SV *)&PL_sv_yes;
+ else RETVAL=(SV *)&PL_sv_no;
+
+ OUTPUT:
+ RETVAL
+
+SV *
+scf_fwrite(scf_pointer, file_handle)
+int scf_pointer
+FILE *file_handle
+ CODE:
+ mFILE *mf;
+
+ Scf *scf_data = (Scf *)scf_pointer;
+ if ( file_handle == NULL ) croak("scf_fwrite(...) : file_handle is NULL\n");
+ if ( scf_data == NULL ) croak("scf_fwrite(...) : scf_pointer is NULL\n");
+
+ mf = mfreopen(NULL,"a",file_handle);
+ if ( mf == NULL ) croak("scf_fwrite(...) : could not reopen filehandle for writing\n");
+
+ if( mfwrite_scf(scf_data, mf) == 0)
+ RETVAL=(SV *)&PL_sv_yes;
+ else
+ RETVAL=(SV *)&PL_sv_no;
+ mfflush(mf);
+ mfdestroy(mf);
+ OUTPUT:
+ RETVAL
+
+SV *
+get_from_header(scf_pointer, what)
+int scf_pointer
+int what
+ CODE:
+ /* what = { 0 samples, 1 bases, 2 version, 3 sample size, 4 code_set } */
+ Scf *scf_data = (Scf *)scf_pointer;
+ SV *ret_val;
+ switch(what)
+ {
+ case 0 : ret_val = newSViv(1); sv_setuv(ret_val, (scf_data->header).samples); break;
+ case 1 : ret_val = newSViv(1); sv_setuv(ret_val, (scf_data->header).bases); break;
+ case 2 : ret_val = newSVpv((scf_data->header).version, 4); break;
+ case 3 : ret_val = newSViv(1); sv_setuv(ret_val, (scf_data->header).sample_size); break;
+ case 4 : ret_val = newSViv(1); sv_setuv(ret_val, (scf_data->header).code_set); break;
+
+ default:
+ croak("get_from_header(..., %d) : what out of range\n", what);
+ ret_val = NULL;
+ }
+ RETVAL = ret_val;
+ OUTPUT:
+ RETVAL
+
+SV *
+get_at(scf_pointer, index, what)
+int scf_pointer
+int index
+int what
+ CODE:
+ /* what = { 0 peak_index, 1 prob_A, 2 prob_C, 3 prob_G, 4 prob_T, 5 base } <= for bases
+ * what = { 11 sample_A, 12 sample_C, 13 sample_G, 14 sample_T } <= for samples
+ */
+ Scf *scf_data = (Scf *)scf_pointer;
+ SV *ret_val;
+ if ( scf_data == NULL ) croak("get_at(...) : scf_pointer is NULL\n");
+ if( ( what < 9 && what > -1 && ( index<0 || index>(scf_data->header).bases-1 ) )||
+ ( what > 10 && what < 15 && ( index<0 || index>(scf_data->header).samples-1 ) ) ){
+ croak("get_at(..., %d, ...) : index/what out of range\n", index);
+ ret_val = NULL;
+ }else{
+ switch(what){
+ case 0 : SV_SETUV((scf_data->bases+index)->peak_index); break;
+ case 1 : SV_SETUV((scf_data->bases+index)->prob_A); break;
+ case 2 : SV_SETUV((scf_data->bases+index)->prob_C); break;
+ case 3 : SV_SETUV((scf_data->bases+index)->prob_G); break;
+ case 4 : SV_SETUV((scf_data->bases+index)->prob_T); break;
+ case 5 : ret_val = newSVpv(&((scf_data->bases+index)->base), 1); break;
+
+ case 6 :
+ case 7 :
+ case 8 : SV_SETUV((scf_data->bases+index)->spare[what-6]); break;
+
+ case 11: /* samples_A */
+ if( scf_data->header.sample_size == 1 )
+ SV_SETUV(((scf_data->samples).samples1+index)->sample_A)
+ else SV_SETUV(((scf_data->samples).samples2+index)->sample_A);
+ break;
+ case 12: /* samples_C */
+ if( scf_data->header.sample_size == 1 )
+ SV_SETUV(((scf_data->samples).samples1+index)->sample_C)
+ else SV_SETUV(((scf_data->samples).samples2+index)->sample_C);
+ break;
+ case 13: /* samples_G */
+ if( scf_data->header.sample_size == 1 )
+ SV_SETUV(((scf_data->samples).samples1+index)->sample_G)
+ else SV_SETUV(((scf_data->samples).samples2+index)->sample_G);
+ break;
+ case 14: /* samples_T */
+ if( scf_data->header.sample_size == 1 )
+ SV_SETUV(((scf_data->samples).samples1+index)->sample_T)
+ else SV_SETUV(((scf_data->samples).samples2+index)->sample_T);
+ break;
+ default:
+ croak("get_at(..., ..., %d) : what out of range\n", what);
+ ret_val = NULL;
+ }
+ }
+ RETVAL = ret_val;
+ OUTPUT:
+ RETVAL
+
+void
+set_base_at(scf_pointer, index, what, value)
+int scf_pointer
+int index
+int what
+char value
+ CODE:
+ Scf *scf_data = (Scf *)scf_pointer;
+ if ( scf_data == NULL ) croak("get_at(...) : scf_pointer is NULL\n");
+ if( what == 5 && ( index<0 || index>(scf_data->header).bases-1 ) )
+ croak("set_base_at(..., %d, ...) : index/what out of range\n", index);
+ else (scf_data->bases+index)->base = value;
+
+void
+set_at(scf_pointer, index, what, value)
+int scf_pointer
+int index
+int what
+unsigned int value
+ CODE:
+ Scf *scf_data = (Scf *)scf_pointer;
+ if ( scf_data == NULL ) croak("get_at(...) : scf_pointer is NULL\n");
+ if( ( what < 9 && what > -1 && ( index<0 || index>(scf_data->header).bases-1 ) )||
+ ( what > 10 && what < 15 && ( index<0 || index>(scf_data->header).samples-1 ) )||
+ what == 5 )
+ croak("set_at(..., %d, ...) : index/what out of range\n", index);
+ else{
+ switch(what){
+ case 0 : (scf_data->bases+index)->peak_index = value; break;
+ case 1 : (scf_data->bases+index)->prob_A = value; break;
+ case 2 : (scf_data->bases+index)->prob_C = value; break;
+ case 3 : (scf_data->bases+index)->prob_G = value; break;
+ case 4 : (scf_data->bases+index)->prob_T = value; break;
+ case 5 : (scf_data->bases+index)->base = (char)value; break;
+
+ case 6 :
+ case 7 :
+ case 8 : (scf_data->bases+index)->spare[what-6] = value; break;
+
+ case 11 :
+ if( scf_data->header.sample_size == 1 )
+ ((scf_data->samples).samples1+index)->sample_A = value;
+ else ((scf_data->samples).samples2+index)->sample_A = value;
+ break;
+ case 12 :
+ if( scf_data->header.sample_size == 1 )
+ ((scf_data->samples).samples1+index)->sample_C = value;
+ else ((scf_data->samples).samples2+index)->sample_C = value;
+ break;
+ case 13 :
+ if( scf_data->header.sample_size == 1 )
+ ((scf_data->samples).samples1+index)->sample_G = value;
+ else ((scf_data->samples).samples2+index)->sample_G = value;
+ break;
+ case 14 :
+ if( scf_data->header.sample_size == 1 )
+ ((scf_data->samples).samples1+index)->sample_T = value;
+ else ((scf_data->samples).samples2+index)->sample_T = value;
+ break;
+ default:
+ croak("set_at(..., ..., %d, ...) : what out of range\n", what);
+ }
+ }
Added: branches/upstream/libbio-scf-perl/current/SCF/Arrays.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libbio-scf-perl/current/SCF/Arrays.pm?rev=41928&op=file
==============================================================================
--- branches/upstream/libbio-scf-perl/current/SCF/Arrays.pm (added)
+++ branches/upstream/libbio-scf-perl/current/SCF/Arrays.pm Sun Aug 16 03:29:56 2009
@@ -1,0 +1,57 @@
+package Bio::SCF::Arrays;
+
+use strict;
+
+require DynaLoader;
+use constant WHAT => {
+ index => 0,
+ A => 1,
+ C => 2,
+ G => 3,
+ T => 4,
+ bases => 5,
+ spare1 => 6,
+ spare2 => 7,
+ spare3 => 8,
+ sample_A => 11,
+ sample_C => 12,
+ sample_G => 13,
+ sample_T => 14
+};
+
+sub TIEARRAY {
+ my $class = shift;
+ my $scf_pointer = shift;
+ my $what_str = shift;
+ my $ret_val = {
+ scf_pointer => $scf_pointer,
+ what => WHAT->{$what_str},
+ };
+ return bless $ret_val, $class;
+}
+
+sub FETCH {
+ my ($self, $index) = @_;
+ return Bio::SCF::get_at($self->{scf_pointer}, $index, $self->{what});
+}
+
+sub STORE {
+ my ($self, $index, $value) = @_;
+ if ( $self->{what} == WHAT->{bases} ){
+ Bio::SCF::set_base_at($self->{scf_pointer}, $index, $self->{what}, $value);
+ }else{
+ Bio::SCF::set_at($self->{scf_pointer}, $index, $self->{what}, $value);
+ }
+}
+
+sub FETCHSIZE {
+ my $self = shift;
+ my $field = $self->{what} >= WHAT->{sample_A}
+ ? Bio::SCF::HEADER_FIELDS()->{samples_length}
+ : Bio::SCF::HEADER_FIELDS()->{bases_length};
+ return Bio::SCF::get_from_header($self->{scf_pointer}, $field);
+}
+
+1;
+
+__END__
Added: branches/upstream/libbio-scf-perl/current/eg/read_test_obj.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libbio-scf-perl/current/eg/read_test_obj.pl?rev=41928&op=file
==============================================================================
--- branches/upstream/libbio-scf-perl/current/eg/read_test_obj.pl (added)
+++ branches/upstream/libbio-scf-perl/current/eg/read_test_obj.pl Sun Aug 16 03:29:56 2009
@@ -1,0 +1,26 @@
+#!/usr/bin/perl -w
+
+use lib '..','../blib/lib','../blib/arch';
+use SCF;
+
+my $obj = SCF->new(shift || '../test.scf');
+
+1;
+
+for (my $i = 0; $i<$obj->bases_length; $i++){
+ my $peak = $obj->index($i);
+ print sprintf("%s (%02d) %02d %02d %02d %02d | %5d | %04d %04d %04d %04d\n",
+ $obj->base($i),
+ $obj->score($i),
+ $obj->base_score('A',$i),
+ $obj->base_score('C',$i),
+ $obj->base_score('G',$i),
+ $obj->base_score('T',$i),
+ $peak,
+ $obj->sample('A',$peak),
+ $obj->sample('C',$peak),
+ $obj->sample('G',$peak),
+ $obj->sample('T',$peak)
+ );
+}
+print "\n";
Propchange: branches/upstream/libbio-scf-perl/current/eg/read_test_obj.pl
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libbio-scf-perl/current/eg/read_test_tied.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libbio-scf-perl/current/eg/read_test_tied.pl?rev=41928&op=file
==============================================================================
--- branches/upstream/libbio-scf-perl/current/eg/read_test_tied.pl (added)
+++ branches/upstream/libbio-scf-perl/current/eg/read_test_tied.pl Sun Aug 16 03:29:56 2009
@@ -1,0 +1,25 @@
+#!/usr/bin/perl -w
+
+use lib './','../blib/lib','../blib/arch';
+use SCF;
+
+my %scf;
+tie %scf, 'SCF', (shift || '../test.scf');
+
+for (my $i = 0; $i<$scf{bases_length}; $i++){
+ my $peak = $scf{index}[$i];
+ print sprintf("%s %02d %02d %02d %02d | %5d | %04d %04d %04d %04d\n",
+ $scf{bases}[$i],
+ $scf{A}[$i],
+ $scf{C}[$i],
+ $scf{G}[$i],
+ $scf{T}[$i],
+ $peak,
+ $scf{samples}{A}[$peak],
+ $scf{samples}{C}[$peak],
+ $scf{samples}{G}[$peak],
+ $scf{samples}{T}[$peak],
+ );
+}
+
+print "\n";
Propchange: branches/upstream/libbio-scf-perl/current/eg/read_test_tied.pl
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libbio-scf-perl/current/eg/write_test_obj.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libbio-scf-perl/current/eg/write_test_obj.pl?rev=41928&op=file
==============================================================================
--- branches/upstream/libbio-scf-perl/current/eg/write_test_obj.pl (added)
+++ branches/upstream/libbio-scf-perl/current/eg/write_test_obj.pl Sun Aug 16 03:29:56 2009
@@ -1,0 +1,17 @@
+#!/usr/bin/perl -w
+
+
+use lib '..','../blib/lib','../blib/arch';
+use strict;
+use SCF;
+
+die "Usage : ./write_test.pl [file to read] [file to write]\n"
+ unless defined $ARGV[1];
+
+my $obj = SCF->new($ARGV[0]);
+
+for (0...$obj->bases_length-1){
+ $obj->base($_, "A");
+}
+$obj->write($ARGV[1]) or die "Cannot write to $ARGV[1]\n";
+warn "Wrote all A's into $ARGV[1]\n";
Propchange: branches/upstream/libbio-scf-perl/current/eg/write_test_obj.pl
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libbio-scf-perl/current/eg/write_test_tied.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libbio-scf-perl/current/eg/write_test_tied.pl?rev=41928&op=file
==============================================================================
--- branches/upstream/libbio-scf-perl/current/eg/write_test_tied.pl (added)
+++ branches/upstream/libbio-scf-perl/current/eg/write_test_tied.pl Sun Aug 16 03:29:56 2009
@@ -1,0 +1,18 @@
+#!/usr/bin/perl -w
+
+use lib '..','../blib/lib','../blib/arch';
+use strict;
+use SCF;
+
+die "Usage : ./write_test.pl [file to read] [file to write]\n"
+ unless defined $ARGV[1];
+
+my %scf;
+tie %scf, 'SCF', $ARGV[0];
+
+for (0...$scf{bases_length}-1){
+ $scf{bases}[$_] = "A";
+ $scf{index}[$_] = 10;
+}
+(tied %scf)->write($ARGV[1]) or die "Cannot write to $ARGV[1]\n";
+warn "Wrote all A's into $ARGV[1]\n";
Propchange: branches/upstream/libbio-scf-perl/current/eg/write_test_tied.pl
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libbio-scf-perl/current/t/scf.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libbio-scf-perl/current/t/scf.t?rev=41928&op=file
==============================================================================
--- branches/upstream/libbio-scf-perl/current/t/scf.t (added)
+++ branches/upstream/libbio-scf-perl/current/t/scf.t Sun Aug 16 03:29:56 2009
@@ -1,0 +1,48 @@
+#-*-Perl-*-
+## Bioperl Test Harness Script for Modules
+
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.t'
+
+use strict;
+use ExtUtils::MakeMaker;
+use constant TEST_COUNT => 18;
+
+BEGIN {
+ # to handle systems with no installed Test module
+ # we include the t dir (where a copy of Test.pm is located)
+ # as a fallback
+ eval { require Test; };
+ if( $@ ) {
+ use lib 't';
+ }
+ use Test;
+ plan test => TEST_COUNT;
+}
+
+use Bio::SCF;
+
+# object-oriented interface
+my $scf = Bio::SCF->new('./test.scf');
+ok($scf);
+ok($scf->bases_length,1525);
+ok($scf->samples_length,18610);
+ok($scf->base(10),'C');
+ok($scf->score(10),6);
+ok($scf->index(10),151);
+ok($scf->base_score('C',10),6);
+ok($scf->sample('C',10)>$scf->sample('G',10));
+ok($scf->write('./temp.scf'));
+ok(-S './temp.scf',-S './test.scf');
+
+# tied interface
+my %h;
+tie %h,'Bio::SCF','./test.scf';
+ok(tied %h);
+ok($h{bases_length},1525);
+ok($h{bases_length},scalar @{$h{bases}});
+ok($h{samples_length},18610);
+ok($h{bases}[10],'C');
+ok($h{C}[10],6);
+ok($h{index}[10],151);
+ok($h{samples}{C}[10]>$h{samples}{G}[10]);
Added: branches/upstream/libbio-scf-perl/current/test.scf
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libbio-scf-perl/current/test.scf?rev=41928&op=file
==============================================================================
Binary file - no diff available.
Propchange: branches/upstream/libbio-scf-perl/current/test.scf
------------------------------------------------------------------------------
svn:mime-type = application/octet-stream
More information about the Pkg-perl-cvs-commits
mailing list