1package CHI::Util;
2$CHI::Util::VERSION = '0.60';
3use Carp qw( croak longmess );
4use Module::Runtime qw(require_module);
5use Data::Dumper;
6use Data::UUID;
7use Fcntl qw( :DEFAULT );
8use File::Spec::Functions qw(catdir catfile);
9use JSON::MaybeXS;
10use Time::Duration::Parse;
11use Try::Tiny;
12use strict;
13use warnings;
14use base qw(Exporter);
15
16our @EXPORT_OK = qw(
17  can_load
18  dump_one_line
19  fast_catdir
20  fast_catfile
21  has_moose_class
22  json_decode
23  json_encode
24  parse_duration
25  parse_memory_size
26  read_file
27  read_dir
28  unique_id
29  write_file
30);
31
32my $Fetch_Flags = O_RDONLY | O_BINARY;
33my $Store_Flags = O_WRONLY | O_CREAT | O_BINARY;
34
35sub can_load {
36
37    # Load $class_name if possible. Return 1 if successful, 0 if it could not be
38    # found, and rethrow load error (other than not found).
39    #
40    my ($class_name) = @_;
41
42    my $result;
43    try {
44        require_module($class_name);
45        $result = 1;
46    }
47    catch {
48        if ( /Can\'t locate .* in \@INC/ && !/Compilation failed/ ) {
49            $result = 0;
50        }
51        else {
52            die $_;
53        }
54    };
55    return $result;
56}
57
58sub dump_one_line {
59    my ($value) = @_;
60
61    return Data::Dumper->new( [$value] )->Indent(0)->Sortkeys(1)->Quotekeys(0)
62      ->Terse(1)->Dump();
63}
64
65# Simplified read_dir cribbed from File::Slurp
66sub read_dir {
67    my ($dir) = @_;
68
69    ## no critic (RequireInitializationForLocalVars)
70    local *DIRH;
71    opendir( DIRH, $dir ) or croak "cannot open '$dir': $!";
72    return grep { $_ ne "." && $_ ne ".." } readdir(DIRH);
73}
74
75sub read_file {
76    my ($file) = @_;
77
78    # Fast slurp, adapted from File::Slurp::read, with unnecessary options removed
79    #
80    my $buf = "";
81    my $read_fh;
82    unless ( sysopen( $read_fh, $file, $Fetch_Flags ) ) {
83        croak "read_file '$file' - sysopen: $!";
84    }
85    my $size_left = -s $read_fh;
86    while (1) {
87        my $read_cnt = sysread( $read_fh, $buf, $size_left, length $buf );
88        if ( defined $read_cnt ) {
89            last if $read_cnt == 0;
90            $size_left -= $read_cnt;
91            last if $size_left <= 0;
92        }
93        else {
94            croak "read_file '$file' - sysread: $!";
95        }
96    }
97    return $buf;
98}
99
100sub write_file {
101    my ( $file, $data, $file_create_mode ) = @_;
102    $file_create_mode = oct(666) if !defined($file_create_mode);
103
104    # Fast spew, adapted from File::Slurp::write, with unnecessary options removed
105    #
106    {
107        my $write_fh;
108        unless ( sysopen( $write_fh, $file, $Store_Flags, $file_create_mode ) )
109        {
110            croak "write_file '$file' - sysopen: $!";
111        }
112        my $size_left = length($data);
113        my $offset    = 0;
114        do {
115            my $write_cnt = syswrite( $write_fh, $data, $size_left, $offset );
116            unless ( defined $write_cnt ) {
117                croak "write_file '$file' - syswrite: $!";
118            }
119            $size_left -= $write_cnt;
120            $offset += $write_cnt;
121        } while ( $size_left > 0 );
122    }
123}
124
125{
126
127    # For efficiency, use Data::UUID to generate an initial unique id, then suffix it to
128    # generate a series of 0x10000 unique ids. Not to be used for hard-to-guess ids, obviously.
129
130    my $uuid;
131    my $suffix = 0;
132
133    sub unique_id {
134        if ( !$suffix || !defined($uuid) ) {
135            my $ug = Data::UUID->new();
136            $uuid = $ug->create_hex();
137        }
138        my $hex = sprintf( '%s%04x', $uuid, $suffix );
139        $suffix = ( $suffix + 1 ) & 0xffff;
140        return $hex;
141    }
142}
143
144use constant _FILE_SPEC_USING_UNIX =>
145  ( $File::Spec::ISA[0] eq 'File::Spec::Unix' );
146
147sub fast_catdir {
148    if (_FILE_SPEC_USING_UNIX) {
149        return join '/', @_;
150    }
151    else {
152        return catdir(@_);
153    }
154}
155
156sub fast_catfile {
157    if (_FILE_SPEC_USING_UNIX) {
158        return join '/', @_;
159    }
160    else {
161        return catfile(@_);
162    }
163}
164
165my %memory_size_units = ( 'k' => 1024, 'm' => 1024 * 1024 );
166
167sub parse_memory_size {
168    my $size = shift;
169    if ( $size =~ /^\d+b?$/ ) {
170        return $size;
171    }
172    elsif ( my ( $quantity, $unit ) = ( $size =~ /^(\d+)\s*([km])b?$/i ) ) {
173        return $quantity * $memory_size_units{ lc($unit) };
174    }
175    else {
176        croak "cannot parse memory size '$size'";
177    }
178}
179
180my $json = JSON::MaybeXS->new( utf8 => 1, canonical => 1 );
181
182sub json_decode {
183    $json->decode( $_[0] );
184}
185
186sub json_encode {
187    $json->encode( $_[0] );
188}
189
1901;
191
192__END__
193