File Coverage

lib/SQL/Loader.pm
Criterion Covered Total %
statement 63 158 39.8
branch 22 56 39.2
condition 0 11 0.0
subroutine 13 22 59.0
pod 12 12 100.0
total 110 259 42.4


line stmt bran cond sub pod time code
1             package SQL::Loader;
2              
3 2     2   12 use strict;
  2         2  
  2         61  
4 2     2   9 use warnings;
  2         3  
  2         46  
5              
6 2     2   1954 use LWP::Simple;
  2         302682  
  2         19  
7 2     2   5673 use DBI;
  2         38820  
  2         3745  
8              
9             our $VERSION = '0.02';
10              
11             =head1 NAME
12              
13             SQL::Loader
14              
15             =head1 SYNOPSIS
16              
17             use base qw( SQL::Loader );
18              
19             =head1 DESCRIPTION
20              
21             Base class for L
22              
23             =head1 SEE ALSO
24              
25             L
26              
27             =head1 METHODS
28              
29             =cut
30              
31             =head2 new
32              
33             constructor
34              
35             =cut
36             sub new {
37 5     5 1 1126 my $class = shift;
38 5 100       16 if ( $class eq 'SQL::Loader' ) {
39 1         6 die __PACKAGE__ . "cannot be called directly\n";
40             }
41 4         9 my $self = {};
42 4         9 bless $self, $class;
43 4         22 $self->_init(@_);
44 3         17 return $self;
45             }
46              
47             =head2 run
48              
49             main app loop
50              
51             =cut
52             sub run {
53 0     0 1 0 my $self = shift;
54              
55 0         0 my $tcounter = 0;
56 0         0 my $tcounted = 0;
57 0         0 my $purpose = 0;
58 0         0 my $table = 0;
59 0         0 my $content;
60 0         0 my $title = undef;
61              
62             # sql
63 0         0 my $titles = [];
64 0         0 my $col_vals = [];
65 0         0 my $table_col = [];
66              
67 0         0 my $url = $self->{url};
68 0         0 my $print_http_headers = $self->print_http_headers();
69              
70             # server response test only and quit
71 0 0       0 return $self->_print_http_headers if $print_http_headers;
72              
73 0         0 $content = get($url);
74 0 0       0 die "couldn't get URL $url: $!\n" if !$content;
75            
76 0         0 my @arr = split(/\n+/, $content);
77              
78             # start loop - find each table
79 0         0 LINE: foreach my $line (@arr) {
80 0         0 chomp($line);
81              
82             # find title
83 0 0       0 if (!defined($title)) {
84 0         0 $title = $self->_set_table_title($line, $titles, $title);
85 0         0 next LINE;
86             }
87              
88             # find the 'purpose' keyword and start of new table, indicating new, valid table
89 0         0 ($purpose, $table) = $self->_set_purpose_and_table($line, $purpose, $table);
90 0 0 0     0 next LINE unless ($purpose && $table);
91              
92             # we've found title, purpose and hit start of a table for db
93 0 0 0     0 if ($purpose && $table) {
94             # get all the column names
95 0         0 $self->_work_out_table_cols($line, $col_vals, $table_col);
96 0         0 $col_vals = [];
97              
98 0 0       0 if ($line =~ /^<\/table/) {
99             # end of table - create this one
100 0         0 $self->create_table($titles, $table_col);
101 0         0 $purpose = 0;
102 0         0 $table = 0;
103 0         0 $title = undef;
104 0         0 $titles = [];
105 0         0 $table_col = [];
106 0         0 next LINE;
107             }
108             }
109             }
110 0         0 $self->dbh->disconnect();
111             }
112              
113             =head2 create_table
114              
115             create the sql tables. must be overridden in subclass.
116              
117             =cut
118             sub create_table {
119 0     0 1 0 my $self = shift;
120 0         0 die __PACKAGE__ . "->create_table is abstract\n";
121             }
122              
123             =head2 _work_out_table_cols
124              
125             define the columns of the given table
126              
127             =cut
128             sub _work_out_table_cols {
129 0     0   0 my $self = shift;
130 0         0 my $line = shift;
131 0         0 my $col_vals = shift;
132 0         0 my $table_col = shift;
133              
134 0 0       0 if ($line =~ /^
135             # print "found new col..\n";
136 0         0 my @row_items = split(/<\/td>/, $line);
137 0         0 ROW: for (my $i=0;$i<$#row_items;$i++) {
138 0 0       0 if ($row_items[$i] =~ /">\s*([\w -\\\/]+)\s*$/) {
139 0         0 my $rname = $1;
140 0         0 $rname = $self->_clean($rname);
141 0         0 push @{$col_vals}, $rname; # sql
  0         0  
142             }
143             }
144 0         0 push @{$table_col}, $col_vals;
  0         0  
145             }
146 0         0 return $table_col;
147             }
148              
149             =head2 _set_purpose_and_table
150              
151             helper sub to determine if a table is valid and should be created. a table is considered valid if it has
152             a 'Purpose' defined on the twiki page.
153              
154             This sub gets called repeatedly once a purpose has been found until a line is found,
155             indicating start of a db table.
156              
157             =cut
158             sub _set_purpose_and_table {
159 0     0   0 my $self = shift;
160 0         0 my $line = shift;
161 0         0 my $purpose = shift;
162 0         0 my $table = shift;
163              
164 0 0       0 if ($line =~ /Purpose\s*<\/h3>/) {
165             #

line indicates purpose

166 0         0 $purpose = 1;
167             }
168 0 0 0     0 if (($purpose) && ($line =~ /
169 0         0 $table = 1;
170             }
171              
172 0         0 return ($purpose, $table);
173             }
174              
175             =head2 _set_table_title
176              
177             helper sub to extract the name that should be used for the table currently being created.
178              
179             =cut
180             sub _set_table_title {
181 0     0   0 my $self = shift;
182 0         0 my $line = shift;
183 0         0 my $titles = shift;
184 0         0 my $title = shift;
185              
186 0 0       0 if ($line =~ /(\w+)\s*<\/h2>$/) {
187             #

line is considered title of table

188 0         0 $title = $1;
189 0         0 $self->_clean($title);
190 0         0 push @{$titles}, $title;
  0         0  
191             }
192              
193 0         0 return $title;
194             }
195              
196             =head2 _clean
197              
198             helper sub to clean leading, tailing and excessive whitespace from a string.
199              
200             =cut
201             sub _clean {
202 0     0   0 my $self = shift;
203 0         0 my $s = shift;
204 0         0 $s =~ s/^\s+//;
205 0         0 $s =~ s/\s+$//;
206 0         0 $s =~ s/\s+/ /;
207 0         0 $s;
208             }
209              
210             =head2 _print_http_headers
211              
212             print headers option, invoked if the --print-http-headers switch is used. Use to test server response for example. Does not rebuild database.
213              
214             =cut
215             sub _print_http_headers {
216 0     0   0 my $self = shift;
217 0         0 my $url = $self->{url};
218              
219 0         0 my @head = head($url);
220 0 0       0 if (!@head) {
221 0         0 die "couldn't get URL $url: $!\n";
222             }
223             else {
224 0         0 foreach (@head) {
225 0 0       0 next if !defined($_);
226 0         0 chomp();
227 0 0       0 next if /^\s*$/;
228 0         0 print $_, "\n";
229             }
230             }
231             }
232              
233             =head2 _init
234              
235             initialize class
236              
237             =cut
238             sub _init {
239 4     4   7 my $self = shift;
240 4         16 my (%args) = @_;
241              
242 4         26 $self->print_http_headers( $args{print_http_headers} );
243 4         22 $self->url( $args{url} );
244 4 100       10 die "no URL specified\n" if ( !$self->url() );
245 3 100       8 if ( $self->print_http_headers() ) {
246 1         7 $self->initialized( 1 );
247 1         2 return $self;
248             }
249            
250 2         16 $self->dbname( $args{dbname} );
251 2 50       5 die "no dbname specified\n" if ( !$self->dbname );
252 2         17 $self->dbuser( $args{dbuser} );
253 2 50       7 die "no dbuser specified\n" if ( !$self->dbuser );
254 2         13 $self->dbpass( $args{dbpass} );
255 2 50       5 die "no dbpass specified\n" if ( !$self->dbpass );
256 2         17 $self->quiet( $args{quiet} );
257              
258 2         11 $self->initialized( 1 );
259              
260 2         4 return $self;
261             }
262              
263             =head2 initialized
264              
265             get/set initialized param
266              
267             =cut
268             sub initialized {
269 4     4 1 7 my ( $self, $initialized ) = @_;
270 4 100       11 if ( $initialized ) {
271 3         6 $self->{initialized} = $initialized;
272             }
273 4         18 return $self->{initialized};
274             }
275              
276             =head2 print_http_headers
277              
278             get/set print_http_headers param
279              
280             =cut
281             sub print_http_headers {
282 7     7 1 12 my ( $self, $print_http_headers ) = @_;
283 7 100       16 if ( $print_http_headers ) {
284 1         2 $self->{print_http_headers} = $print_http_headers;
285             }
286 7         24 return $self->{print_http_headers};
287             }
288              
289             =head2 url
290              
291             get/set url to be scraped
292              
293             =cut
294             sub url {
295 9     9 1 13 my ( $self, $url ) = @_;
296 9 100       23 if ( $url ) {
297 3         7 $self->{url} = $url;
298             }
299 9         35 return $self->{url};
300             }
301              
302             =head2 dbname
303              
304             get/set dbname
305              
306             =cut
307             sub dbname {
308 5     5 1 10 my ( $self, $dbname ) = @_;
309 5 100       19 if ( $dbname ) {
310 2         5 $self->{dbname} = $dbname;
311             }
312 5         20 return $self->{dbname};
313             }
314              
315             =head2 dbuser
316              
317             get/set dbuser
318              
319             =cut
320             sub dbuser {
321 5     5 1 10 my ( $self, $dbuser ) = @_;
322 5 100       13 if ( $dbuser ) {
323 2         6 $self->{dbuser} = $dbuser;
324             }
325 5         17 return $self->{dbuser};
326             }
327              
328             =head2 dbpass
329              
330             get/set dbpass
331              
332             =cut
333             sub dbpass {
334 5     5 1 10 my ( $self, $dbpass ) = @_;
335 5 100       12 if ( $dbpass ) {
336 2         49 $self->{dbpass} = $dbpass;
337             }
338 5         17 return $self->{dbpass};
339             }
340              
341             =head2 dbh
342              
343             get/set database handle
344              
345             =cut
346             sub dbh {
347 0     0 1 0 my $self = shift;
348 0 0       0 if ( !defined( $self->{dbh} ) ) {
349 0   0     0 my $dbh = DBI->connect( $self->connect_string(),
350             { RaiseError => 1,
351             AutoCommit => 0,
352             ChopBlanks => 1
353             }
354             ) || die DBI->errstr;
355 0         0 $self->{dbh} = $dbh;
356             }
357 0         0 return $self->{dbh};
358             }
359              
360             =head2 quiet
361              
362             get/set quiet param
363              
364             =cut
365             sub quiet {
366 2     2 1 5 my ( $self, $quiet ) = @_;
367 2 50       7 if ( $quiet ) {
368 0         0 $self->{quiet} = $quiet;
369             }
370 2         5 return $self->{quiet};
371             }
372              
373             =head2 connect_string
374              
375             return dbh connect string. must be overridden in subclass.
376              
377             =cut
378             sub connect_string {
379 0     0 1   my $self = shift;
380 0           die __PACKAGE__ . "->connect_string() is abstract\n";
381             }
382              
383             1;
384              
385             __END__