cvsroot/dinfo/dinfo.pm

package dinfo;

use Carp;
use PApp::SQL;

=head1 dinfo - THIS IS A PRIVATE MODULE, DON't COPY

=cut

BEGIN  {
   $VERSION = 0.1;
   use XSLoader;
   XSLoader::load __PACKAGE__, $VERSION;
}

sub new {
   my ($class, $dsn, $user, $pass) = @_;

   my $self = bless {
      dbh => (PApp::SQL::connect_cached "dinfo::", $dsn, $user, $pass),
   }, $class;

   $self;
}

=item $result = $dinfo->search (column => type => value, ...)

Initiate a search on the given columns. C<type> can be one of C<exact>,
C<prefix>, C<like>, C<regexp> or C<match>, which specifies the sql-search
mode used. For C<nummer>-columns, only C<exact> and C<prefix> are
supported.

Returns a C<dinfo::result> object.

 my $r = $dinfo->search(name => like => "Marc%");

 my $r = $dinfo->search(plz => exact => 76139, branche => match => "psychologe");

Not all types are efficient on all columns.. check your indices! :)

=cut

my @cols = (
  [ 1 => "name"],
  [ 2 => "vorname"],
  [ 3 => "zusatz1"],
  [ 4 => "zusatz2"],
  [ 5 => "zusatz3"],
  [ 6 => "vorwahl"],
  [ 7 => "strasse"],
  [ 8 => "hausnr"],
  [ 9 => "plz"],
  [10 => "ort"],
  [11 => "branche"],
  [12 => "typ"],
);

sub search {
   my ($self, @pred) = @_;

   my @args;
   my $select = "select\n  nummer, " . (join ", ", map "$_->[1].data", @cols) . "\n"
              . "from row\n". (join "", map "  inner join $_->[1] on (row.$_->[1] = $_->[1].id)\n", @cols)
              . "where  (1=1)\n";

   while (@pred) {
      my ($column, $type, $match) = splice @pred, 0, 3, ();
      $select .= "  and ";
      if ($column eq "nummer") {
         if ($type eq "exact") {
            $select .= "$column = ?";
            push @args, nummer2str $match, 10;
            warn unpack "H*", $args[-1];#d#
         } elsif ($type eq "prefix") {
            $select .= "($column between ? and ?)";
            push @args, 
               (nummer2str $match, 0),
               (nummer2str $match, 10);
            warn unpack "H*", $args[-2];#d#
            warn unpack "H*", $args[-1];#d#
         } else {
            croak "illegal search type '$type', must be one of exact, prefix";
         }
      } else {
         push @args, $match;
         if ($type eq "exact") {
            $select .= "($column.data = ?)";
         } elsif ($type eq "like") {
            $select .= "($column.data like ?)";
         } elsif ($type eq "prefix") {
            $select .= "($column.data like ?)";
            $args[-1] .= "%";
         } elsif ($type eq "regexp") {
            $select .= "($column.data regexp ?)";
         } elsif ($type eq "match") {
            $select .= "(match $column.data against (?))";
         } else {
            croak "illegal search type '$type', must be one of exact, like, regexp or match";
         }
      }
   }

   my $st = sql_exec $self->{dbh}, $select, @args
      or die "sql_exec returned no statement handle";

   return bless {
      dinfo => $self,
      st    => $st,
   }, dinfo::result;
}

=item my ($prefix, $local) = $dinfo->split_number($number)

split a number into prefix and local part.

=cut

sub split_number {
   my ($self, $number) = @_;

   for ($number) {
      y/0-9//cd;
      s/^/0/ unless /^0/;

      for (3..6) {
         my $prefix = substr $number, 0, $_;
         my $isprefix =
            $cache{$prefix}
               ||= sql_fetch $self->{dbh}, 
                             "select 1 + count(*) from vorwahl where data = ?",
                             $prefix;
         return ($prefix, substr $number, $_)
            if $isprefix == 2;
      }

      return ();
   }
}

=item my $hash = $dinfo->identify_number ($number)

Try to find out as much as possible about the given number.

=cut

sub identify_number {
   my ($self, $number) = @_;
   my %r;
   my ($prefix, $number) = $self->split_number ($number);

   if ($prefix) {
      $r{vorwahl} = $prefix;
      $r{match} = "exact";

      while (1 < length $number) {
         for ($number, "${number}0") {
            my $result = $self->search (vorwahl => exact => $prefix,
                                        nummer => exact => $_);
            if ($result->rows > 1) {
               return { %r, %{$result->fetch} };
            } elsif ($result->rows == 1) {
               return { %r, %{$result->fetch} };
            }

            $r{match} = "approx";
         }

         substr $number, -1, 1, "";
      }
   }

   #$r{ort} = join ", ",
   #            sql_fetchall $self->{dbh},
   #                         "select distinct ort.data
   #                          from row
   #                             inner join vorwahl on (vorwahl.id = row.vorwahl)
   #                             inner join ort     on (ort.id     = row.ort)
   #                          where vorwahl.data = ?",
   #                         $r{vorwahl};
   
   \%r;
}

=head2 dinfo::result

=item $count = $result->rows

=cut

sub dinfo::result::rows {
   $_[0]{st}->rows;
}

=item $hash = $result->fetch

Fetch and return the next result row.

=cut

my %typ;

sub dinfo::result::fetch {
   my ($self) = @_;

   my $row = $self->{st}->fetchrow_arrayref;

   if ($row) {
      my %r;

      $r{$_->[1]} = $row->[$_->[0]] for @cols;

            warn unpack "H*", $row->[0];#d#
      $r{nummer} = str2nummer $row->[0];

      \%r;
   } else {
      return ();
   }
}

1;
Revision:	1.9
Committed:	Wed Sep 3 23:45:19 2003 UTC (23 years, 2 months ago) by root
Branch:	MAIN
Changes since 1.8:	+20 -6 lines
Log Message:	* empty log message *
#	User	Rev	Content
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			$self;
24	root	1.3	}
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	root	1.7	[ 8 => "hausnr"],
52	root	1.3	[ 9 => "plz"],
53			[10 => "ort"],
54			[11 => "branche"],
55	root	1.8	[12 => "typ"],
56	root	1.3	);
57
58			sub search {
59			my ($self, @pred) = @_;
60
61			my @args;
62			my $select = "select\n nummer, " . (join ", ", map "$_->[1].data", @cols) . "\n"
63			. "from row\n". (join "", map " inner join $_->[1] on (row.$_->[1] = $_->[1].id)\n", @cols)
64			. "where (1=1)\n";
65
66			while (@pred) {
67			my ($column, $type, $match) = splice @pred, 0, 3, ();
68			$select .= " and ";
69			if ($column eq "nummer") {
70			if ($type eq "exact") {
71	root	1.7	$select .= "$column = ?";
72			push @args, nummer2str $match, 10;
73	root	1.9	warn unpack "H*", $args[-1];#d#
74	root	1.3	} elsif ($type eq "prefix") {
75	root	1.7	$select .= "($column between ? and ?)";
76	root	1.3	push @args,
77	root	1.9	(nummer2str $match, 0),
78	root	1.7	(nummer2str $match, 10);
79	root	1.9	warn unpack "H*", $args[-2];#d#
80			warn unpack "H*", $args[-1];#d#
81	root	1.3	} else {
82			croak "illegal search type '$type', must be one of exact, prefix";
83			}
84			} else {
85			push @args, $match;
86			if ($type eq "exact") {
87			$select .= "($column.data = ?)";
88			} elsif ($type eq "like") {
89			$select .= "($column.data like ?)";
90			} elsif ($type eq "prefix") {
91			$select .= "($column.data like ?)";
92			$args[-1] .= "%";
93			} elsif ($type eq "regexp") {
94			$select .= "($column.data regexp ?)";
95			} elsif ($type eq "match") {
96	root	1.9	$select .= "(match $column.data against (?))";
97	root	1.3	} else {
98			croak "illegal search type '$type', must be one of exact, like, regexp or match";
99			}
100			}
101			}
102
103	root	1.5	my $st = sql_exec $self->{dbh}, $select, @args
104			or die "sql_exec returned no statement handle";
105
106			return bless {
107			dinfo => $self,
108			st => $st,
109			}, dinfo::result;
110			}
111
112			=item my ($prefix, $local) = $dinfo->split_number($number)
113
114			split a number into prefix and local part.
115
116			=cut
117
118			sub split_number {
119			my ($self, $number) = @_;
120
121			for ($number) {
122	root	1.8	y/0-9//cd;
123	root	1.5	s/^/0/ unless /^0/;
124
125			for (3..6) {
126			my $prefix = substr $number, 0, $_;
127			my $isprefix =
128			$cache{$prefix}
129			\|\|= sql_fetch $self->{dbh},
130			"select 1 + count(*) from vorwahl where data = ?",
131			$prefix;
132			return ($prefix, substr $number, $_)
133			if $isprefix == 2;
134			}
135	root	1.3
136			return ();
137			}
138	root	1.5	}
139
140			=item my $hash = $dinfo->identify_number ($number)
141
142			Try to find out as much as possible about the given number.
143
144			=cut
145
146			sub identify_number {
147			my ($self, $number) = @_;
148			my %r;
149			my ($prefix, $number) = $self->split_number ($number);
150
151			if ($prefix) {
152			$r{vorwahl} = $prefix;
153	root	1.9	$r{match} = "exact";
154	root	1.5
155			while (1 < length $number) {
156			for ($number, "${number}0") {
157			my $result = $self->search (vorwahl => exact => $prefix,
158			nummer => exact => $_);
159			if ($result->rows > 1) {
160	root	1.9	return { %r, %{$result->fetch} };
161	root	1.5	} elsif ($result->rows == 1) {
162	root	1.9	return { %r, %{$result->fetch} };
163	root	1.5	}
164	root	1.9
165			$r{match} = "approx";
166	root	1.5	}
167
168			substr $number, -1, 1, "";
169			}
170			}
171
172	root	1.9	#$r{ort} = join ", ",
173			# sql_fetchall $self->{dbh},
174			# "select distinct ort.data
175			# from row
176			# inner join vorwahl on (vorwahl.id = row.vorwahl)
177			# inner join ort on (ort.id = row.ort)
178			# where vorwahl.data = ?",
179			# $r{vorwahl};
180
181	root	1.5	\%r;
182	root	1.3	}
183
184			=head2 dinfo::result
185
186			=item $count = $result->rows
187
188			=cut
189
190			sub dinfo::result::rows {
191			$_[0]{st}->rows;
192			}
193
194			=item $hash = $result->fetch
195
196			Fetch and return the next result row.
197
198			=cut
199
200			my %typ;
201
202			sub dinfo::result::fetch {
203			my ($self) = @_;
204
205			my $row = $self->{st}->fetchrow_arrayref;
206
207			if ($row) {
208			my %r;
209
210			$r{$_->[1]} = $row->[$_->[0]] for @cols;
211
212	root	1.9	warn unpack "H*", $row->[0];#d#
213	root	1.8	$r{nummer} = str2nummer $row->[0];
214	root	1.3
215			\%r;
216			} else {
217			return ();
218			}
219	root	1.1	}
220
221	root	1.2	1;