| 1 | package dinfo; |
1 | package dinfo; |
| 2 | |
2 | |
| 3 | use Carp; |
3 | use Carp; |
| 4 | use PApp::SQL; |
4 | use PApp::SQL; |
| 5 | |
5 | |
|
|
6 | =head1 dinfo - THIS IS A PRIVATE MODULE, DON't COPY |
|
|
7 | |
|
|
8 | =cut |
|
|
9 | |
|
|
10 | BEGIN { |
| 6 | $VERSION = 0.1; |
11 | $VERSION = 0.1; |
|
|
12 | use XSLoader; |
|
|
13 | XSLoader::load __PACKAGE__, $VERSION; |
|
|
14 | } |
| 7 | |
15 | |
| 8 | sub new { |
16 | sub new { |
| 9 | my ($class, $dsn, $user, $pass) = @_; |
17 | my ($class, $dsn, $user, $pass) = @_; |
| 10 | |
18 | |
| 11 | my $self = bless { |
19 | my $self = bless { |
| … | |
… | |
| 38 | [ 3 => "zusatz1"], |
46 | [ 3 => "zusatz1"], |
| 39 | [ 4 => "zusatz2"], |
47 | [ 4 => "zusatz2"], |
| 40 | [ 5 => "zusatz3"], |
48 | [ 5 => "zusatz3"], |
| 41 | [ 6 => "vorwahl"], |
49 | [ 6 => "vorwahl"], |
| 42 | [ 7 => "strasse"], |
50 | [ 7 => "strasse"], |
| 43 | [ 8 => "haus"], |
51 | [ 8 => "hausnr"], |
| 44 | [ 9 => "plz"], |
52 | [ 9 => "plz"], |
| 45 | [10 => "ort"], |
53 | [10 => "ort"], |
| 46 | [11 => "branche"], |
54 | [11 => "branche"], |
| 47 | ); |
55 | ); |
| 48 | |
56 | |
| … | |
… | |
| 56 | |
64 | |
| 57 | while (@pred) { |
65 | while (@pred) { |
| 58 | my ($column, $type, $match) = splice @pred, 0, 3, (); |
66 | my ($column, $type, $match) = splice @pred, 0, 3, (); |
| 59 | $select .= " and "; |
67 | $select .= " and "; |
| 60 | if ($column eq "nummer") { |
68 | if ($column eq "nummer") { |
| 61 | $select .= "($column between ? and ?)"; |
|
|
| 62 | if ($type eq "exact") { |
69 | if ($type eq "exact") { |
|
|
70 | $select .= "$column = ?"; |
|
|
71 | push @args, nummer2str $match, 10; |
|
|
72 | } elsif ($type eq "prefix") { |
|
|
73 | $select .= "($column between ? and ?)"; |
| 63 | push @args, |
74 | push @args, |
| 64 | (pack "H*", (substr "${match}000000000000", 0, 12) . sprintf "%x0", 12 - length $match), |
75 | (nummer2str $match), |
| 65 | (pack "H*", (substr "${match}000000000000", 0, 12) . sprintf "%xf", 12 - length $match); |
76 | (nummer2str $match, 10); |
| 66 | } elsif ($type eq "prefix") { |
|
|
| 67 | push @args, |
|
|
| 68 | (pack "H*", (substr "${match}00000000000000", 0, 14)), |
|
|
| 69 | (pack "H*", (substr "${match}a0000000000000", 0, 14)); |
|
|
| 70 | } else { |
77 | } else { |
| 71 | croak "illegal search type '$type', must be one of exact, prefix"; |
78 | croak "illegal search type '$type', must be one of exact, prefix"; |
| 72 | } |
79 | } |
| 73 | warn unpack "H*", $args[-2]; |
|
|
| 74 | warn unpack "H*", $args[-1]; |
|
|
| 75 | } else { |
80 | } else { |
| 76 | push @args, $match; |
81 | push @args, $match; |
| 77 | if ($type eq "exact") { |
82 | if ($type eq "exact") { |
| 78 | $select .= "($column.data = ?)"; |
83 | $select .= "($column.data = ?)"; |
| 79 | } elsif ($type eq "like") { |
84 | } elsif ($type eq "like") { |
| … | |
… | |
| 89 | croak "illegal search type '$type', must be one of exact, like, regexp or match"; |
94 | croak "illegal search type '$type', must be one of exact, like, regexp or match"; |
| 90 | } |
95 | } |
| 91 | } |
96 | } |
| 92 | } |
97 | } |
| 93 | |
98 | |
|
|
99 | warn $select, @args; |
| 94 | my $st = sql_exec $self->{dbh}, $select, @args; |
100 | my $st = sql_exec $self->{dbh}, $select, @args |
|
|
101 | or die "sql_exec returned no statement handle"; |
| 95 | |
102 | |
| 96 | if ($st) { |
|
|
| 97 | return bless { |
103 | return bless { |
| 98 | dinfo => $self, |
104 | dinfo => $self, |
| 99 | st => $st, |
105 | st => $st, |
| 100 | }, dinfo::result; |
106 | }, dinfo::result; |
| 101 | } else { |
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 | |
| 102 | return (); |
132 | return (); |
| 103 | } |
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; |
| 104 | } |
168 | } |
| 105 | |
169 | |
| 106 | =head2 dinfo::result |
170 | =head2 dinfo::result |
| 107 | |
171 | |
| 108 | =item $count = $result->rows |
172 | =item $count = $result->rows |
