3 |
# $Id$ |
# $Id$ |
4 |
# |
# |
5 |
# $Log$ |
# $Log$ |
6 |
|
# Revision 1.7 2002/11/29 04:44:53 joko |
7 |
|
# - sub array_getRelations |
8 |
|
# + sub getNewPerlObjectByPkgName |
9 |
|
# |
10 |
|
# Revision 1.6 2002/11/17 07:18:59 joko |
11 |
|
# + sub deep_copy |
12 |
|
# |
13 |
|
# Revision 1.5 2002/10/27 18:34:28 joko |
14 |
|
# + sub now |
15 |
|
# |
16 |
|
# Revision 1.4 2002/08/16 19:06:39 cvsjoko |
17 |
|
# + sub getDirList |
18 |
|
# |
19 |
# Revision 1.3 2002/07/19 18:13:50 cvsjoko |
# Revision 1.3 2002/07/19 18:13:50 cvsjoko |
20 |
# no message |
# no message |
21 |
# |
# |
30 |
|
|
31 |
package libp; |
package libp; |
32 |
|
|
33 |
|
use strict; |
34 |
|
use warnings; |
35 |
|
|
36 |
require Exporter; |
require Exporter; |
37 |
@ISA = qw( Exporter ); |
our @ISA = qw( Exporter ); |
38 |
@EXPORT = qw( |
our @EXPORT_OK = qw( |
39 |
Dumper |
Dumper |
40 |
md5 md5_hex md5_base64 |
md5 md5_hex md5_base64 |
41 |
ParseDate UnixDate |
ParseDate UnixDate |
43 |
stripHtml stripSpaces stripNewLines toReal trim |
stripHtml stripSpaces stripNewLines toReal trim |
44 |
croak |
croak |
45 |
array_getDifference |
array_getDifference |
46 |
|
getDirList |
47 |
|
now |
48 |
|
deep_copy |
49 |
|
getNewPerlObjectByPkgName |
50 |
); |
); |
51 |
|
|
|
use strict; |
|
|
use warnings; |
|
|
|
|
52 |
use Data::Dumper; |
use Data::Dumper; |
53 |
use Digest::MD5 qw(md5 md5_hex md5_base64); |
use Digest::MD5 qw(md5 md5_hex md5_base64); |
54 |
|
|
64 |
|
|
65 |
use Carp; |
use Carp; |
66 |
|
|
67 |
|
use DirHandle; |
68 |
|
|
69 |
|
|
70 |
######################################## |
######################################## |
71 |
|
|
116 |
return $result; |
return $result; |
117 |
} |
} |
118 |
|
|
119 |
sub array_getRelations { |
|
120 |
my $a_ref = shift; |
|
121 |
my $b_ref = shift; |
|
122 |
my @a = @{$a_ref}; |
# ============================================= |
123 |
my @b = @{$b_ref}; |
# "global" vars used in directory-recursive-parsing |
124 |
|
my $dirlist_buf; |
125 |
my @isect = my @diff = my @union = (); |
my @dirlist_path; |
126 |
my $e; |
my $dirlist_base; |
127 |
my %count; |
|
128 |
|
sub entry_callback { |
129 |
foreach $e (@a, @b) { $count{$e}++ } |
|
130 |
|
my $entry = shift; |
131 |
foreach $e (keys %count) { |
|
132 |
push(@union, $e); |
# CHECKS |
133 |
push @{ $count{$e} == 2 ? \@isect : \@diff }, $e; |
# dont't use this: |
134 |
|
if ($entry eq '.' || $entry eq '..') { return; } |
135 |
|
|
136 |
|
# PREPARE |
137 |
|
# prepare path to current entry |
138 |
|
my $cur_entry = join('/', @dirlist_path, $entry); |
139 |
|
# prepare path to current entry (absolute) |
140 |
|
my $cur_entry_abs = join('/', $dirlist_base, @dirlist_path, $entry); |
141 |
|
|
142 |
|
# ENTRY |
143 |
|
# add current entry to buffer |
144 |
|
$dirlist_buf .= $cur_entry . "\n"; |
145 |
|
|
146 |
|
# (SUB-)DIRECTORY |
147 |
|
# check if current entry is a (sub-)directory ... |
148 |
|
if (-d $cur_entry_abs) { |
149 |
|
push @dirlist_path, $cur_entry; |
150 |
|
# ... and parse this (recursion here!!!) |
151 |
|
iterate_path($cur_entry_abs); |
152 |
|
pop @dirlist_path; |
153 |
|
} |
154 |
|
} |
155 |
|
|
156 |
|
sub iterate_path { |
157 |
|
|
158 |
|
my $path = shift; |
159 |
|
|
160 |
|
# create new "DirHandle"-object |
161 |
|
my $d = new DirHandle $path; |
162 |
|
if (defined $d) { |
163 |
|
|
164 |
|
# iterate through all entries in $path ($d->read) and call out entry-handler on each entry |
165 |
|
while (defined(my $line = $d->read)) { |
166 |
|
entry_callback($line); |
167 |
|
} |
168 |
|
|
169 |
|
undef $d; |
170 |
} |
} |
171 |
|
} |
172 |
my $result = { |
|
173 |
union => \@union, |
sub getDirList { |
174 |
isect => \@isect, |
|
175 |
diff => \@diff, |
$dirlist_base = shift; |
176 |
}; |
|
177 |
|
# reset vars |
178 |
|
$dirlist_buf = ''; |
179 |
|
@dirlist_path = (); |
180 |
|
|
181 |
|
# start parsing file-structure |
182 |
|
iterate_path($dirlist_base); |
183 |
|
|
184 |
|
# return complete list of directory-content including files and subdirs |
185 |
|
# entries are newline (\n) - seperated |
186 |
|
return $dirlist_buf; |
187 |
|
|
188 |
|
} |
189 |
|
# ============================================= |
190 |
|
|
191 |
|
|
192 |
|
sub now { |
193 |
|
return strftime("%Y-%m-%d %H:%M:%S", localtime); |
194 |
|
} |
195 |
|
|
196 |
|
# ACK's go to ... |
197 |
|
sub deep_copy { |
198 |
|
my $this = shift; |
199 |
|
if (not ref $this) { |
200 |
|
$this; |
201 |
|
} elsif (ref $this eq "ARRAY") { |
202 |
|
[map deep_copy($_), @$this]; |
203 |
|
} elsif (ref $this eq "HASH") { |
204 |
|
+{map { $_ => deep_copy($this->{$_}) } keys %$this}; |
205 |
|
} elsif (ref $this eq "CODE") { |
206 |
|
$this; |
207 |
|
} else { die "what type is $_?" } |
208 |
} |
} |
209 |
|
|
210 |
sub array_getDifference { |
sub getNewPerlObjectByPkgName { |
211 |
my $res = array_getRelations(shift, shift); |
my $pkgname = shift; |
212 |
return $res->{diff}; |
my $args = shift; |
213 |
|
#$logger->debug( __PACKAGE__ . "->getNewPerlObjectByPkgName( pkgname $pkgname args $args )" ); |
214 |
|
my $evstring = "use $pkgname;"; |
215 |
|
eval($evstring); |
216 |
|
#$@ && $logger->error( __PACKAGE__ . ':' . __LINE__ . " Error in eval $evstring: " . $@ ); |
217 |
|
$@ && print( __PACKAGE__ . ':' . __LINE__ . " Error in eval \"$evstring\": " . $@ ); |
218 |
|
return $pkgname->new($args); |
219 |
} |
} |
220 |
|
|
221 |
1; |
1; |