1package GrianUtils; 2use strict; 3use warnings; 4use Carp qw/carp croak/; 5use Fcntl qw(:flock); 6use File::Spec; 7use Scalar::Util qw(refaddr reftype); 8use List::Util qw(max); 9use base 'Exporter'; 10use Data::Dumper; 11use warnings 'all'; 12BEGIN{ 13 no strict 'refs'; 14 *{caller()."::".$_} = \&Data::Dumper::Dumper for 'Dumper'; #for tests 15} 16 17our (@EXPORT, @EXPORT_OK); 18our $msg; 19@EXPORT_OK=qw(ref_mem_safe my_readdir my_readfile loose $msg total_sv); 20 21*total_sv = \&Storable::AMF::Util::total_sv; 22sub loose(&){ 23 my $sub = shift; 24 my $have = total_sv(); 25 my $delta; 26 27 { 28 my $c; 29 &$sub() for 1; 30 }; 31 return $delta unless $delta = $msg = total_sv() - $have; 32 33 { 34 my $c = &$sub(); 35 }; 36 return 0 if total_sv() - $have == $delta; 37 return $delta unless $delta = $msg = total_sv() - $have; 38 39 $have = total_sv(); 40 41 { 42 my $c = &$sub(); 43 }; 44 return $delta = $msg = total_sv() - $have; 45} 46 47use Carp qw(croak); 48#@$a = __PACKAGE__->my_items( 't/AMF0' ); 49sub my_items{ 50 my $self = shift; 51 my $directory = shift; 52 croak "GrianUtils::my_items list context required" unless wantarray; 53 my @dir_content ; 54 @dir_content = GrianUtils->my_readdir( ($directory) ); 55 my %items; 56 my %values; 57 my %eval; 58 for (@dir_content){ 59 m/.*[\/\\](.*)\.(.*)/ and $items{ $1}{$2} = $_ or next; 60 my $val = $values{$1}{$2} = GrianUtils->my_readfile($_); 61 } 62 my @item = map $items{$_}, sort keys %items; 63 64 # set name property 65 $_->{ (keys %$_)[0]} =~m/([-\.()\w]+)\./ and $_->{name} ||= $1 for @item; 66 ! $values{$_->{name}} && warn "No name for '".$_->{ (keys %$_)[0]} ."'"for @item; 67 68 #read package if ext is pack 69 for (@item){ 70 if (keys %$_ == 2 && $_->{'pack'}){ 71 my $val = $values{$_->{name}} or next; 72 %$_ = (%$_ , %{_unpack($val->{'pack'})}); 73 $_->{dump} = $_->{eval} unless defined $_->{dump}; 74 } 75 else { 76 my $item = $_; 77 $_ ne 'name' and $item->{$_} = $values{ $item->{name}}{$_} for keys %$item; 78 } 79 } 80 81 @item = grep { defined $_->{dump}} @item; 82 83 for my $item ( @item){ 84 my $eval = $item->{dump}||=$item->{eval}; 85 no strict; 86 $item->{obj} = eval $eval; 87 use strict; 88 $item->{eval} = $eval; 89 croak "$item->{name}: $@" if $@; 90 if ( defined $item->{xml} ){ 91 $item->{eval_xml} = $item->{xml}; 92 $item->{obj_xml} = eval $item->{xml}; 93 croak "$item->{name}: $@" if $@; 94 } 95 else { 96 $item->{eval_xml} = $item->{eval}; 97 $item->{obj_xml} = $item->{obj}; 98 } 99 } 100 return @item; 101} 102 103sub my_readdir{ 104 my $class = shift; 105 my $dirname = shift; 106 my $option = shift || 'abs'; 107 opendir my $SP, $dirname 108 or die "Can't opendir $dirname for reading"; 109 if ($option eq 'abs') { 110 return map {File::Spec->catfile($dirname, $_)} grep { $_ !~ m/^\.\.?$/ } readdir $SP; 111 } 112 elsif( $option eq 'rel' ) { 113 return map {$dirname ."/". $_} grep { $_ !~ m/^\./ } readdir $SP; 114 } 115 else { 116 carp "unknown option: $option. Available options are 'abs' or 'rel'"; 117 return (); 118 } 119} 120sub my_readfile{ 121 my $class = shift; 122 my $file = shift; 123 my @dirs = @_; 124 my $buf; 125 $file = File::Spec->catfile(@_, $file); 126 open my $filefh, "<", $file 127 or die "Can't open file '$file' for reading"; 128 binmode($filefh); 129 flock $filefh, LOCK_SH; 130 read $filefh, $buf, -s $filefh; 131 flock $filefh, LOCK_UN; 132 close ($filefh); 133 return $buf; 134} 135 136BEGIN { 137 our $pack = "(w/a)*"; 138 our @fixed_names = qw(eval amf0 amf3); 139 sub _pack{ 140 my $hash = shift; 141 my (@fixed) = delete @$hash{@fixed_names}; 142 #my $s = \ pack "N/aN/aN/a(N/aN/a)*", $eval, $amf0, $amf3, %$hash; 143 my $s = \ pack $pack, @fixed, %$hash; 144 @$hash{@fixed_names} = (@fixed); 145 return $$s; 146 } 147 sub _unpack{ 148 my (@fixed, %rest); 149 (@fixed[0..$#fixed_names], %rest) = unpack $pack, $_[0]; 150 @rest{@fixed_names} = (@fixed); 151 return \%rest; 152 }; 153}; 154 155sub create_pack{ 156 my $class = shift; 157 my $dir = shift; 158 my $name = shift; 159 my $value = shift; 160 161 $dir=~s/[\/\\]$//; 162 my $pack_name = File::Spec->catfile($dir, "$name.pack"); 163 my $sname = $pack_name; 164 $sname =~ s/\.pack$//; 165 our %folder; 166 167 $folder{$sname} = $value; 168 delete $folder{$sname}{'pack'}; 169 open my $fh, ">", $pack_name or die "can't create $pack_name"; 170 binmode($fh); 171 print $fh _pack($folder{$sname}); 172 close($fh); 173 174} 175 176 177sub abs2rel{ 178 my $class = shift; 179 my $abs_path = shift; 180 my $base = shift; 181 $base=~s/[\\\/]$//; 182 $base=~s/\\/\//g; 183 $abs_path=~s/\\/\//g; 184 if ($base eq '.'){ 185 $base=~s/^\.//g; 186 $abs_path=~s/^\.\///g; 187 return "./$abs_path"; 188 } 189 print STDERR "path='$abs_path' base='$base'\n"; 190 carp "Path can't transformed to relative: path='$abs_path' base='$base'" unless substr($abs_path, 0, length($base)) eq $base; 191 return ".".substr($abs_path, length($base)); 192} 193 194# not tested yet 195sub rel2abs{ 196 my $class = shift; 197 my $rel_path = shift; 198 my $base = shift; 199 $base=~s/[\\\/]$//; 200 $rel_path=~s/^\.\///; 201 carp "Path isn't relative: path='$rel_path' base='$base'" if $rel_path=~/^[\\\/]/; 202 return File::Spec->catfile($base, $rel_path); 203} 204 205sub _all_refs_addr{ 206 my $c = shift; 207 while(@_){ 208 my $item = shift; 209 210 next unless refaddr $item; 211 next if $$c{refaddr $item}; 212 #print refaddr $item, "\n"; 213 $$c{refaddr $item} = 1; 214 if (reftype $item eq 'ARRAY'){ 215 _all_refs_addr($c, @$item); 216 } 217 elsif (reftype $item eq 'HASH') { 218 _all_refs_addr($c, $_); 219 } 220 elsif (reftype $item eq 'SCALAR') { 221 } 222 elsif (reftype $item eq 'REF'){ 223 _all_refs_addr($c, $$item) 224 } 225 else { 226 croak "Unsupported type ". reftype $item; 227 } 228 } 229 return keys %$c; 230} 231sub ref_mem_safe { 232 my $sub = shift; 233 my $count_to_execute = shift || 400; 234 my $count_to_be_ok = shift || 50; 235 236 my $nu = -1; 237 my @addresses; 238 my %addr; 239 my $old_max = 0; 240 for ( my $round = 1 ; $round <= $count_to_execute ; ++$round ) { 241 my @seq = &$sub(); 242 push @seq, ( \my $b ), [], {}, [], {}, \my $a; 243 my $new_max = max( _all_refs_addr( {}, @seq, ) ); 244 if ( $old_max < $new_max ) { 245 $old_max = $new_max; 246 $nu = -1; 247 } 248 else { 249 ++$nu; 250 } 251 return $round, $round if ( $nu > $count_to_be_ok ); 252 @seq = (); 253 } 254 return ( 0, "$nu/$count_to_be_ok, $count_to_execute" ) if wantarray; 255 return 0; 256} 257sub my_create_file{ 258 my $class = shift; 259 my $file = shift; 260 my $content = shift; 261 my $base = shift; 262 my $usage = 'GrianUtils->my_create_file($file, $content, $base)...'; 263 warn "$usage: \$base not is option" unless $base; 264 croak "$usage: double dot in \$file restricted" if $file=~m/\.\./; 265 $base ||= '.'; 266 carp "$usage: \$base --- ($base) is not a directory" unless -d $base; 267 my @r = split "/", $file; 268 my $lfile = pop @r; 269 270 my $loc_folder = File::Spec->catfile($base, @r); 271 if (-d -w $loc_folder) { 272 my $loc_file; 273 open my $fh, ">", $loc_file = File::Spec->catfile($base, $file) 274 or croak "$usage: Can't create file($loc_file)"; 275 binmode($fh); 276 print $fh $content; 277 close($fh); 278 } 279 elsif (-d _) { 280 croak "$usage: Not writeable directory($loc_folder)"; 281 } 282 else { 283 # Generate path for 284 285 my @folders; 286 my $folder = $base; 287 288 for my $r (@r){ 289 $folder = File::Spec->catfile($folder, $r); 290 next if (-d $folder); 291 mkdir($folder) 292 or croak "$usage: Can't create directory ($folder) for path($loc_folder)"; 293 } 294 $class->my_create_file($file, $content, $base); 295 } 296} 2971; 298