File Coverage

blib/lib/NOTEDB.pm
Criterion Covered Total %
statement 10 120 8.3
branch 1 38 2.6
condition 0 3 0.0
subroutine 3 16 18.7
pod 0 11 0.0
total 14 188 7.4


line stmt bran cond sub pod time code
1             #
2             # this is a generic module, used by note database
3             # backend modules.
4             #
5             # Copyright (c) 2000-2017 T.v.Dein
6              
7              
8             package NOTEDB;
9              
10 1     1   88972 use Exporter ();
  1         2  
  1         153  
11 1     1   8 use vars qw(@ISA @EXPORT $crypt_supported);
  1         2  
  1         141  
12              
13             $NOTEDB::VERSION = "1.45";
14              
15             BEGIN {
16             # make sure, it works, otherwise encryption
17             # is not supported on this system!
18 1     1   4 eval { require Crypt::CBC; };
  1         68  
19 1 50       5 if($@) {
20 1         1463 $NOTEDB::crypt_supported = 0;
21             }
22             else {
23 0           $NOTEDB::crypt_supported = 1;
24             }
25             }
26              
27              
28             sub no_crypt {
29 0     0 0   $NOTEDB::crypt_supported = 0;
30             }
31              
32              
33             sub use_crypt {
34 0     0 0   my($this,$key,$method) = @_;
35 0           my($cipher);
36 0 0         if($NOTEDB::crypt_supported == 1) {
37 0           eval {
38 0           $cipher = new Crypt::CBC($key, $method);
39             };
40 0 0         if($@) {
41 0           print "warning: Crypt::$method not supported by system!\n";
42 0           $NOTEDB::crypt_supported = 0;
43             }
44             else {
45 0           $this->{cipher} = $cipher;
46             }
47             }
48             else{
49 0           print "warning: Crypt::CBC not supported by system!\n";
50             }
51             }
52              
53              
54             sub use_cache {
55             #
56             # this sub turns on cache support
57             #
58 0     0 0   my $this = shift;
59 0           $this->{use_cache} = 1;
60 0           $this->{changed} = 1;
61             }
62              
63             sub cache {
64             #
65             # store the whole db as hash
66             # if use_cache is turned on
67             #
68 0     0 0   my $this = shift;
69 0 0         if ($this->{use_cache}) {
70 0           my %res = @_;
71 0           %{$this->{cache}} = %res;
  0            
72             }
73             }
74              
75             sub unchanged {
76             #
77             # return true if $this->{changed} is true, this will
78             # be set to true by writing subs using $this->changed().
79             #
80 0     0 0   my $this = shift;
81 0 0         return 0 if(!$this->{use_cache});
82 0 0         if ($this->{changed}) {
83 0           $this->{changed} = 0;
84 0           return 0;
85             }
86             else {
87 0           print "%\n";
88 0           return 1;
89             }
90             }
91              
92             sub changed {
93             #
94             # turn on $this->{changed}
95             # this will be used by update or create subs.
96             #
97 0     0 0   my $this = shift;
98 0           $this->{changed} = 1;
99 0           return 1;
100             }
101              
102              
103             sub generate_search {
104             #
105             # get user input and create perlcode ready for eval
106             # sample input:
107             # "ann.a OR eg???on AND u*do$"
108             # resulting output:
109             # "$match = 1 if(/ann\.a/i or /eg...on/i and /u.*do\$/i );
110             #
111 0     0 0   my($this, $string) = @_;
112              
113 0           my $case = "i";
114              
115 0 0         if ($string =~ /^\/.+?\/$/) {
    0          
116 0           return $string;
117             }
118             elsif (!$string) {
119 0           return "/^/";
120             }
121              
122             # we will get a / in front of the first word too!
123 0           $string = " " . $string . " ";
124              
125             # check for apostrophs
126 0           $string =~ s/(?<=\s)(\(??)("[^"]+"|\S+)(\)??)(?=\s)/$1 . $this->check_exact($2) . $3/ge;
  0            
127              
128             # remove odd spaces infront of and after »and« and »or«
129 0           $string =~ s/\s\s*(AND|OR)\s\s*/ $1 /g;
130              
131             # remove odd spaces infront of »(« and after »)«
132 0           $string =~ s/(\s*\()/\(/g;
133 0           $string =~ s/(\)\s*)/\)/g;
134              
135             # remove first and last space so it will not masked!
136 0           $string =~ s/^\s//;
137 0           $string =~ s/\s$//;
138              
139             # mask spaces if not infront of or after »and« and »or«
140 0           $string =~ s/(?
  0            
141              
142             # add first space again
143 0           $string = " " . $string;
144              
145             # lowercase AND and OR
146 0           $string =~ s/(\s??OR\s??|\s??AND\s??)/\L$1\E/g;
147              
148             # surround brackets with at least one space
149 0           $string =~ s/(?
150              
151             # surround strings with slashes
152 0           $string =~ s/(?<=\s)(\S+)/ $this->check_or($1, $case) /ge;
  0            
153              
154             # remove slashes on »and« and »or«
155 0           $string =~ s/\/(and|or)\/$case/$1/g;
156              
157             # remove spaces inside /string/ constructs
158 0           $string =~ s/(?
159              
160 0           $string =~ s/\/\s*(?!and|or)/\//g;
161              
162             #my $res = qq(\$match = 1 if($string););
163 0           return qq(\$match = 1 if($string););
164             #print $res . "\n";
165             #return $res;
166             }
167              
168             sub check_or {
169             #
170             # surrounds string with slashes if it is not
171             # »and« or »or«
172             #
173 0     0 0   my($this, $str, $case) = @_;
174 0 0         if ($str =~ /^\s*(or|and)\s*$/) {
    0          
175 0           return " $str ";
176             }
177             elsif ($str =~ /(?
178 0           return $str;
179             }
180             else {
181 0           return " \/$str\/$case ";
182             }
183             }
184              
185              
186             sub check_exact {
187             #
188             # helper for generate_search()
189             # masks special chars if string
190             # not inside ""
191             #
192 0     0 0   my($this, $str) = @_;
193              
194 0           my %wildcards = (
195             '*' => '.*',
196             '?' => '.',
197             '[' => '[',
198             ']' => ']',
199             '+' => '\+',
200             '.' => '\.',
201             '$' => '\$',
202             '@' => '\@',
203             '/' => '\/',
204             '|' => '\|',
205             '}' => '\}',
206             '{' => '\{',
207             );
208              
209 0           my %escapes = (
210             '*' => '\*',
211             '?' => '\?',
212             '[' => '[',
213             ']' => ']',
214             '+' => '\+',
215             '.' => '\.',
216             '$' => '\$',
217             '@' => '\@',
218             '(' => '\(',
219             ')' => '\)',
220             '/' => '\/',
221             '|' => '\|',
222             '}' => '\}',
223             '{' => '\{',
224             );
225              
226             # mask backslash
227 0           $str =~ s/\\/\\\\/g;
228              
229              
230 0 0 0       if ($str =~ /^"/ && $str =~ /"$/) {
231             # mask bracket-constructs
232 0 0         $str =~ s/(.)/$escapes{$1} || "$1"/ge;
  0            
233             }
234             else {
235 0 0         $str =~ s/(.)/$wildcards{$1} || "$1"/ge;
  0            
236             }
237              
238 0           $str =~ s/^"//;
239 0           $str =~ s/"$//;
240              
241             # mask spaces
242 0           $str =~ s/\s/\\s/g;
243 0           return $str;
244             }
245              
246              
247              
248              
249             sub lock {
250 0     0 0   my ($this) = @_;
251              
252 0 0         if (-e $this->{LOCKFILE}) {
253 0 0         open LOCK, "<$this->{LOCKFILE}" or die "could not open $this->{LOCKFILE}: $!\n";
254 0           my $data = ;
255 0           close LOCK;
256 0           chomp $data;
257 0           print "-- waiting for lock by $data --\n";
258 0           print "-- remove the lockfile if you are sure: \"$this->{LOCKFILE}\" --\n";
259             }
260              
261 0           my $timeout = 60;
262              
263 0           eval {
264 0     0     local $SIG{ALRM} = sub { die "timeout" };
  0            
265 0     0     local $SIG{INT} = sub { die "interrupted" };
  0            
266 0           alarm $timeout - 2;
267 0           while (1) {
268 0 0         if (! -e $this->{LOCKFILE}) {
269 0           umask 022;
270 0 0         open LOCK, ">$this->{LOCKFILE}" or die "could not open $this->{LOCKFILE}: $!\n";
271 0           flock LOCK, LOCK_EX;
272              
273 0           my $now = scalar localtime();
274 0           print LOCK "$ENV{USER} since $now (PID: $$)\n";
275              
276 0           flock LOCK, LOCK_UN;
277 0           close LOCK;
278 0           alarm 0;
279 0           return 0;
280             }
281 0           printf " %0d\r", $timeout;
282 0           $timeout--;
283 0           sleep 1;
284             }
285             };
286 0 0         if($@) {
287 0 0         if ($@ =~ /^inter/) {
288 0           print " interrupted\n";
289             }
290             else {
291 0           print $@;
292 0           print " timeout\n";
293             }
294 0           return 1;
295             }
296 0           return 0;
297             }
298              
299             sub unlock {
300 0     0 0   my ($this) = @_;
301 0           unlink $this->{LOCKFILE};
302             }
303              
304              
305              
306             1;