1 |
root |
1.1 |
package dinfo; |
2 |
|
|
|
3 |
|
|
use Carp; |
4 |
root |
1.3 |
use PApp::SQL; |
5 |
root |
1.1 |
|
6 |
root |
1.5 |
=head1 dinfo - THIS IS A PRIVATE MODULE, DON't COPY |
7 |
|
|
|
8 |
|
|
=cut |
9 |
|
|
|
10 |
|
|
BEGIN { |
11 |
|
|
$VERSION = 0.1; |
12 |
root |
1.6 |
use XSLoader; |
13 |
root |
1.5 |
XSLoader::load __PACKAGE__, $VERSION; |
14 |
|
|
} |
15 |
root |
1.1 |
|
16 |
|
|
sub new { |
17 |
|
|
my ($class, $dsn, $user, $pass) = @_; |
18 |
|
|
|
19 |
|
|
my $self = bless { |
20 |
|
|
dbh => (PApp::SQL::connect_cached "dinfo::", $dsn, $user, $pass), |
21 |
|
|
}, $class; |
22 |
|
|
|
23 |
root |
1.11 |
$self->{dbh}{mysql_auto_reconnect} = 1;#d# |
24 |
|
|
|
25 |
root |
1.1 |
$self; |
26 |
root |
1.3 |
} |
27 |
|
|
|
28 |
|
|
=item $result = $dinfo->search (column => type => value, ...) |
29 |
|
|
|
30 |
|
|
Initiate a search on the given columns. C<type> can be one of C<exact>, |
31 |
|
|
C<prefix>, C<like>, C<regexp> or C<match>, which specifies the sql-search |
32 |
|
|
mode used. For C<nummer>-columns, only C<exact> and C<prefix> are |
33 |
|
|
supported. |
34 |
|
|
|
35 |
|
|
Returns a C<dinfo::result> object. |
36 |
|
|
|
37 |
|
|
my $r = $dinfo->search(name => like => "Marc%"); |
38 |
|
|
|
39 |
|
|
my $r = $dinfo->search(plz => exact => 76139, branche => match => "psychologe"); |
40 |
|
|
|
41 |
|
|
Not all types are efficient on all columns.. check your indices! :) |
42 |
|
|
|
43 |
|
|
=cut |
44 |
|
|
|
45 |
|
|
my @cols = ( |
46 |
|
|
[ 1 => "name"], |
47 |
|
|
[ 2 => "vorname"], |
48 |
|
|
[ 3 => "zusatz1"], |
49 |
|
|
[ 4 => "zusatz2"], |
50 |
|
|
[ 5 => "zusatz3"], |
51 |
|
|
[ 6 => "vorwahl"], |
52 |
|
|
[ 7 => "strasse"], |
53 |
root |
1.7 |
[ 8 => "hausnr"], |
54 |
root |
1.3 |
[ 9 => "plz"], |
55 |
|
|
[10 => "ort"], |
56 |
|
|
[11 => "branche"], |
57 |
root |
1.8 |
[12 => "typ"], |
58 |
root |
1.3 |
); |
59 |
|
|
|
60 |
|
|
sub search { |
61 |
|
|
my ($self, @pred) = @_; |
62 |
|
|
|
63 |
|
|
my @args; |
64 |
|
|
my $select = "select\n nummer, " . (join ", ", map "$_->[1].data", @cols) . "\n" |
65 |
|
|
. "from row\n". (join "", map " inner join $_->[1] on (row.$_->[1] = $_->[1].id)\n", @cols) |
66 |
|
|
. "where (1=1)\n"; |
67 |
|
|
|
68 |
|
|
while (@pred) { |
69 |
|
|
my ($column, $type, $match) = splice @pred, 0, 3, (); |
70 |
|
|
$select .= " and "; |
71 |
|
|
if ($column eq "nummer") { |
72 |
|
|
if ($type eq "exact") { |
73 |
root |
1.7 |
$select .= "$column = ?"; |
74 |
|
|
push @args, nummer2str $match, 10; |
75 |
root |
1.3 |
} elsif ($type eq "prefix") { |
76 |
root |
1.7 |
$select .= "($column between ? and ?)"; |
77 |
root |
1.3 |
push @args, |
78 |
root |
1.9 |
(nummer2str $match, 0), |
79 |
root |
1.7 |
(nummer2str $match, 10); |
80 |
root |
1.3 |
} else { |
81 |
|
|
croak "illegal search type '$type', must be one of exact, prefix"; |
82 |
|
|
} |
83 |
|
|
} else { |
84 |
|
|
push @args, $match; |
85 |
|
|
if ($type eq "exact") { |
86 |
|
|
$select .= "($column.data = ?)"; |
87 |
|
|
} elsif ($type eq "like") { |
88 |
|
|
$select .= "($column.data like ?)"; |
89 |
|
|
} elsif ($type eq "prefix") { |
90 |
|
|
$select .= "($column.data like ?)"; |
91 |
|
|
$args[-1] .= "%"; |
92 |
|
|
} elsif ($type eq "regexp") { |
93 |
|
|
$select .= "($column.data regexp ?)"; |
94 |
|
|
} elsif ($type eq "match") { |
95 |
root |
1.9 |
$select .= "(match $column.data against (?))"; |
96 |
root |
1.3 |
} else { |
97 |
|
|
croak "illegal search type '$type', must be one of exact, like, regexp or match"; |
98 |
|
|
} |
99 |
|
|
} |
100 |
|
|
} |
101 |
|
|
|
102 |
root |
1.5 |
my $st = sql_exec $self->{dbh}, $select, @args |
103 |
|
|
or die "sql_exec returned no statement handle"; |
104 |
|
|
|
105 |
|
|
return bless { |
106 |
|
|
dinfo => $self, |
107 |
|
|
st => $st, |
108 |
|
|
}, dinfo::result; |
109 |
|
|
} |
110 |
|
|
|
111 |
|
|
=item my ($prefix, $local) = $dinfo->split_number($number) |
112 |
|
|
|
113 |
|
|
split a number into prefix and local part. |
114 |
|
|
|
115 |
|
|
=cut |
116 |
|
|
|
117 |
|
|
sub split_number { |
118 |
|
|
my ($self, $number) = @_; |
119 |
|
|
|
120 |
|
|
for ($number) { |
121 |
root |
1.8 |
y/0-9//cd; |
122 |
root |
1.5 |
s/^/0/ unless /^0/; |
123 |
|
|
|
124 |
|
|
for (3..6) { |
125 |
|
|
my $prefix = substr $number, 0, $_; |
126 |
|
|
my $isprefix = |
127 |
|
|
$cache{$prefix} |
128 |
|
|
||= sql_fetch $self->{dbh}, |
129 |
|
|
"select 1 + count(*) from vorwahl where data = ?", |
130 |
|
|
$prefix; |
131 |
|
|
return ($prefix, substr $number, $_) |
132 |
|
|
if $isprefix == 2; |
133 |
|
|
} |
134 |
root |
1.3 |
|
135 |
|
|
return (); |
136 |
|
|
} |
137 |
root |
1.5 |
} |
138 |
|
|
|
139 |
|
|
=item my $hash = $dinfo->identify_number ($number) |
140 |
|
|
|
141 |
|
|
Try to find out as much as possible about the given number. |
142 |
|
|
|
143 |
|
|
=cut |
144 |
|
|
|
145 |
|
|
sub identify_number { |
146 |
|
|
my ($self, $number) = @_; |
147 |
|
|
my %r; |
148 |
|
|
my ($prefix, $number) = $self->split_number ($number); |
149 |
|
|
|
150 |
|
|
if ($prefix) { |
151 |
|
|
$r{vorwahl} = $prefix; |
152 |
root |
1.9 |
$r{match} = "exact"; |
153 |
root |
1.5 |
|
154 |
|
|
while (1 < length $number) { |
155 |
|
|
for ($number, "${number}0") { |
156 |
|
|
my $result = $self->search (vorwahl => exact => $prefix, |
157 |
|
|
nummer => exact => $_); |
158 |
|
|
if ($result->rows > 1) { |
159 |
root |
1.9 |
return { %r, %{$result->fetch} }; |
160 |
root |
1.5 |
} elsif ($result->rows == 1) { |
161 |
root |
1.9 |
return { %r, %{$result->fetch} }; |
162 |
root |
1.5 |
} |
163 |
root |
1.9 |
|
164 |
|
|
$r{match} = "approx"; |
165 |
root |
1.5 |
} |
166 |
|
|
|
167 |
|
|
substr $number, -1, 1, ""; |
168 |
|
|
} |
169 |
|
|
} |
170 |
|
|
|
171 |
root |
1.9 |
#$r{ort} = join ", ", |
172 |
|
|
# sql_fetchall $self->{dbh}, |
173 |
|
|
# "select distinct ort.data |
174 |
|
|
# from row |
175 |
|
|
# inner join vorwahl on (vorwahl.id = row.vorwahl) |
176 |
|
|
# inner join ort on (ort.id = row.ort) |
177 |
|
|
# where vorwahl.data = ?", |
178 |
|
|
# $r{vorwahl}; |
179 |
|
|
|
180 |
root |
1.5 |
\%r; |
181 |
root |
1.3 |
} |
182 |
|
|
|
183 |
|
|
=head2 dinfo::result |
184 |
|
|
|
185 |
|
|
=item $count = $result->rows |
186 |
|
|
|
187 |
|
|
=cut |
188 |
|
|
|
189 |
|
|
sub dinfo::result::rows { |
190 |
|
|
$_[0]{st}->rows; |
191 |
|
|
} |
192 |
|
|
|
193 |
|
|
=item $hash = $result->fetch |
194 |
|
|
|
195 |
|
|
Fetch and return the next result row. |
196 |
|
|
|
197 |
|
|
=cut |
198 |
|
|
|
199 |
|
|
my %typ; |
200 |
|
|
|
201 |
|
|
sub dinfo::result::fetch { |
202 |
|
|
my ($self) = @_; |
203 |
|
|
|
204 |
|
|
my $row = $self->{st}->fetchrow_arrayref; |
205 |
|
|
|
206 |
|
|
if ($row) { |
207 |
|
|
my %r; |
208 |
|
|
|
209 |
|
|
$r{$_->[1]} = $row->[$_->[0]] for @cols; |
210 |
|
|
|
211 |
root |
1.8 |
$r{nummer} = str2nummer $row->[0]; |
212 |
root |
1.3 |
|
213 |
|
|
\%r; |
214 |
|
|
} else { |
215 |
|
|
return (); |
216 |
|
|
} |
217 |
root |
1.1 |
} |
218 |
|
|
|
219 |
root |
1.2 |
1; |