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