| 1 | package dinfo; |
1 | package dinfo; |
| 2 | |
2 | |
| 3 | use Carp; |
3 | use Carp; |
|
|
4 | use PApp::SQL; |
| 4 | |
5 | |
| 5 | use PApp::SQL; |
6 | $VERSION = 0.1; |
| 6 | |
7 | |
| 7 | sub new { |
8 | sub new { |
| 8 | my ($class, $dsn, $user, $pass) = @_; |
9 | my ($class, $dsn, $user, $pass) = @_; |
| 9 | |
10 | |
| 10 | my $self = bless { |
11 | my $self = bless { |
| … | |
… | |
| 12 | }, $class; |
13 | }, $class; |
| 13 | |
14 | |
| 14 | $self; |
15 | $self; |
| 15 | } |
16 | } |
| 16 | |
17 | |
|
|
18 | =item $result = $dinfo->search (column => type => value, ...) |
|
|
19 | |
|
|
20 | Initiate a search on the given columns. C<type> can be one of C<exact>, |
|
|
21 | C<prefix>, C<like>, C<regexp> or C<match>, which specifies the sql-search |
|
|
22 | mode used. For C<nummer>-columns, only C<exact> and C<prefix> are |
|
|
23 | supported. |
|
|
24 | |
|
|
25 | Returns a C<dinfo::result> object. |
|
|
26 | |
|
|
27 | my $r = $dinfo->search(name => like => "Marc%"); |
|
|
28 | |
|
|
29 | my $r = $dinfo->search(plz => exact => 76139, branche => match => "psychologe"); |
|
|
30 | |
|
|
31 | Not all types are efficient on all columns.. check your indices! :) |
|
|
32 | |
|
|
33 | =cut |
|
|
34 | |
|
|
35 | my @cols = ( |
|
|
36 | [ 1 => "name"], |
|
|
37 | [ 2 => "vorname"], |
|
|
38 | [ 3 => "zusatz1"], |
|
|
39 | [ 4 => "zusatz2"], |
|
|
40 | [ 5 => "zusatz3"], |
|
|
41 | [ 6 => "vorwahl"], |
|
|
42 | [ 7 => "strasse"], |
|
|
43 | [ 8 => "haus"], |
|
|
44 | [ 9 => "plz"], |
|
|
45 | [10 => "ort"], |
|
|
46 | [11 => "branche"], |
|
|
47 | ); |
|
|
48 | |
|
|
49 | sub search { |
|
|
50 | my ($self, @pred) = @_; |
|
|
51 | |
|
|
52 | my @args; |
|
|
53 | my $select = "select\n nummer, " . (join ", ", map "$_->[1].data", @cols) . "\n" |
|
|
54 | . "from row\n". (join "", map " inner join $_->[1] on (row.$_->[1] = $_->[1].id)\n", @cols) |
|
|
55 | . "where (1=1)\n"; |
|
|
56 | |
|
|
57 | while (@pred) { |
|
|
58 | my ($column, $type, $match) = splice @pred, 0, 3, (); |
|
|
59 | $select .= " and "; |
|
|
60 | if ($column eq "nummer") { |
|
|
61 | $select .= "($column between ? and ?)"; |
|
|
62 | if ($type eq "exact") { |
|
|
63 | push @args, |
|
|
64 | (pack "H*", (substr "${match}000000000000", 0, 12) . sprintf "%x0", 12 - length $match), |
|
|
65 | (pack "H*", (substr "${match}000000000000", 0, 12) . sprintf "%xf", 12 - length $match); |
|
|
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 { |
|
|
71 | croak "illegal search type '$type', must be one of exact, prefix"; |
|
|
72 | } |
|
|
73 | warn unpack "H*", $args[-2]; |
|
|
74 | warn unpack "H*", $args[-1]; |
|
|
75 | } else { |
|
|
76 | push @args, $match; |
|
|
77 | if ($type eq "exact") { |
|
|
78 | $select .= "($column.data = ?)"; |
|
|
79 | } elsif ($type eq "like") { |
|
|
80 | $select .= "($column.data like ?)"; |
|
|
81 | } elsif ($type eq "prefix") { |
|
|
82 | $select .= "($column.data like ?)"; |
|
|
83 | $args[-1] .= "%"; |
|
|
84 | } elsif ($type eq "regexp") { |
|
|
85 | $select .= "($column.data regexp ?)"; |
|
|
86 | } elsif ($type eq "match") { |
|
|
87 | $select .= "(match $column.data against (?)"; |
|
|
88 | } else { |
|
|
89 | croak "illegal search type '$type', must be one of exact, like, regexp or match"; |
|
|
90 | } |
|
|
91 | } |
|
|
92 | } |
|
|
93 | |
|
|
94 | my $st = sql_exec $self->{dbh}, $select, @args; |
|
|
95 | |
|
|
96 | if ($st) { |
|
|
97 | return bless { |
|
|
98 | dinfo => $self, |
|
|
99 | st => $st, |
|
|
100 | }, dinfo::result; |
|
|
101 | } else { |
|
|
102 | return (); |
|
|
103 | } |
|
|
104 | } |
|
|
105 | |
|
|
106 | =head2 dinfo::result |
|
|
107 | |
|
|
108 | =item $count = $result->rows |
|
|
109 | |
|
|
110 | =cut |
|
|
111 | |
|
|
112 | sub dinfo::result::rows { |
|
|
113 | $_[0]{st}->rows; |
|
|
114 | } |
|
|
115 | |
|
|
116 | =item $hash = $result->fetch |
|
|
117 | |
|
|
118 | Fetch and return the next result row. |
|
|
119 | |
|
|
120 | =cut |
|
|
121 | |
|
|
122 | my %typ; |
|
|
123 | |
|
|
124 | sub dinfo::result::fetch { |
|
|
125 | my ($self) = @_; |
|
|
126 | |
|
|
127 | my $row = $self->{st}->fetchrow_arrayref; |
|
|
128 | |
|
|
129 | if ($row) { |
|
|
130 | my %r; |
|
|
131 | |
|
|
132 | $r{$_->[1]} = $row->[$_->[0]] for @cols; |
|
|
133 | |
|
|
134 | my $nummer = unpack "H*", $row->[0]; |
|
|
135 | |
|
|
136 | my $len = hex substr $nummer, -2, 1; |
|
|
137 | my $typ = hex substr $nummer, -1, 1; |
|
|
138 | |
|
|
139 | $r{nummer} = substr $nummer, 0, 12 - $len; |
|
|
140 | $r{typ} = $typ{$typ} |
|
|
141 | ||= sql_fetch $self->{dinfo}{dbh}, |
|
|
142 | "select data from typ where id = ?", |
|
|
143 | $typ; |
|
|
144 | |
|
|
145 | \%r; |
|
|
146 | } else { |
|
|
147 | return (); |
|
|
148 | } |
|
|
149 | } |
|
|
150 | |
| 17 | 1; |
151 | 1; |
