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