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