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