File: PAML.pm

package info (click to toggle)
libhttp-body-perl 1.06-1
  • links: PTS, VCS
  • area: main
  • in suites: squeeze
  • size: 492 kB
  • ctags: 142
  • sloc: perl: 1,731; makefile: 4
file content (84 lines) | stat: -rw-r--r-- 1,645 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
package PAML;
use strict;
use warnings;

# "PAML Ain't Markup Language"!!!

use Carp         qw[croak];
use Data::Dumper qw[];
use IO::File     qw[];

BEGIN {
    our @EXPORT_OK = qw(
        DumpFile
        LoadFile
    );

    require Exporter;
    *import = \&Exporter::import;
}

sub DumpFile ($$) {
    my ($path, $struct) = @_;

    my $data = do {
        local $Data::Dumper::Indent = 1;
        local $Data::Dumper::Purity = 1;
        local $Data::Dumper::Terse  = 1;
        local $Data::Dumper::Useqq  = 1;
        Data::Dumper->Dump([$struct], ['PAML']);
    };

    my $io = IO::File->new($path, '>')
      || croak(qq[Couldn't open path '$path' in write mode: $!]);

    $io->binmode
      || croak(qq[Couldn't binmode filehandle: $!]);

    $io->print($data)
      || croak(qq[Couldn't write filehandle: $!]);

    $io->close
      || croak(qq[Couldn't close filehandle: $!]);

    1;
}

sub LoadFile ($) {
    my ($path) = @_;

    my $data = do {

        my $io = IO::File->new($path, '<')
          || corak(qq[Couldn't open path '$path' in read mode: $!]);

        $io->binmode
          || croak(qq[Couldn't binmode filehandle: $!]);

        my $exp = -s $path;
        my $buf = do { local $/; <$io> };
        my $got = length $buf;

        $io->close
          || croak(qq[Couldn't close filehandle: $!]);

        ($exp == $got)
          || croak(qq[I/O read mismatch, expexted: $exp got: $got]);

        $buf;
    };

    if (substr($data, 0, 1) eq '{') {
        substr($data, 0, 0, '+');
    }

    my $struct = eval($data);

    (!$@)
      || croak(qq[LoadFile couldn't eval data: $@]);

    $struct;
}

1;