view release on metacpan or  search on metacpan

lib/Bio/JBrowse/Store/NCList/JSONFileStorage.pm  view on Meta::CPAN

use strict;
use warnings;
use File::Spec ();
use File::Path ();
use JSON 2 ();
use IO::File;
use Fcntl ":flock";
use PerlIO::gzip;

use constant DEFAULT_MAX_JSON_DEPTH => 2048;


sub new {
    my ($class, $outDir, $compress, $opts) = @_;

    # create JSON object
    my $json = JSON->new->relaxed->max_depth( DEFAULT_MAX_JSON_DEPTH );
    # set opts
    if (defined($opts) and ref($opts) eq 'HASH') {
        for my $method (keys %$opts) {
            $json->$method( $opts->{$method} );
        }
    }

    my $self = {
                outDir => $outDir,
                ext => $compress ? ".jsonz" : ".json",
                compress => $compress,
                json => $json
               };
    bless $self, $class;

    File::Path::mkpath( $outDir ) unless (-d $outDir);

    return $self;
}

sub _write_htaccess {
    my ( $self ) = @_;

    if( $self->{compress} && ! $self->{htaccess_written} ) {
        my $hn = File::Spec->catfile( $self->{outDir}, '.htaccess' );
        return if -e $hn;

        open my $h, '>', $hn or die "$! writing $hn";

        my @extensions = qw( .jsonz .txtz .txt.gz );
        my $re = '('.join('|',@extensions).')$';
        $re =~ s/\./\\./g;

        print $h <<EOA;
# This Apache .htaccess file is for
# serving precompressed files (@extensions) with the proper
# Content-Encoding HTTP headers.  In order for Apache to pay attention
# to this, its AllowOverride configuration directive for this
# filesystem location must allow FileInfo overrides.
<IfModule mod_gzip.c>
    mod_gzip_item_exclude "$re"
</IfModule>
<IfModule setenvif.c>
    SetEnvIf Request_URI "$re" no-gzip dont-vary
</IfModule>
<IfModule mod_headers.c>
  <FilesMatch "$re">
    Header onsuccess set Content-Encoding gzip
  </FilesMatch>
</IfModule>
EOA
        $self->{htaccess_written} = 1;
    }
}


sub fullPath {
    my ($self, $path) = @_;
    return File::Spec->join($self->{outDir}, $path);
}


sub ext {
    return shift->{ext};
}


sub encodedSize {
    my ($self, $obj) = @_;
    return length($self->{json}->encode($obj));
}


sub put {
    my ($self, $path, $toWrite) = @_;

    $self->_write_htaccess;

    my $file = $self->fullPath($path);
    my $fh = IO::File->new( $file, O_WRONLY | O_CREAT )
      or die "couldn't open $file: $!";
    flock $fh, LOCK_EX;
    $fh->seek(0, SEEK_SET);
    $fh->truncate(0);
    if ($self->{compress}) {
        binmode($fh, ":gzip")
            or die "couldn't set binmode: $!";
    }
    $fh->print($self->{json}->encode($toWrite))
      or die "couldn't write to $file: $!";
    $fh->close()
      or die "couldn't close $file: $!";
}


sub get {
    my ($self, $path, $default) = @_;

    my $file = $self->fullPath($path);
    if (-s $file) {
        my $OLDSEP = $/;
        my $fh = IO::File->new( $file, O_RDONLY )
            or die "couldn't open $file: $!";