File Coverage

blib/lib/Marky/DbTable.pm
Criterion Covered Total %
statement 61 497 12.2
branch 17 192 8.8
condition 1 36 2.7
subroutine 12 35 34.2
pod 7 7 100.0
total 98 767 12.7


line stmt bran cond sub pod time code
1             package Marky::DbTable;
2             $Marky::DbTable::VERSION = '0.035';
3             #ABSTRACT: Marky::DbTable - querying one database table
4              
5 1     1   262 use common::sense;
  1         11  
  1         4  
6 1     1   1060 use DBI;
  1         12083  
  1         50  
7 1     1   10 use Path::Tiny;
  1         13  
  1         41  
8 1     1   297 use Search::Query;
  1         127956  
  1         26  
9 1     1   343 use Sort::Naturally;
  1         2683  
  1         51  
10 1     1   282 use Text::NeatTemplate;
  1         2919  
  1         29  
11 1     1   207 use YAML::Any;
  1         807  
  1         4  
12 1     1   5088 use POSIX qw(ceil);
  1         2  
  1         7  
13 1     1   305 use HTML::TagCloud;
  1         1104  
  1         25  
14 1     1   6 use Mojo::URL;
  1         1  
  1         9  
15              
16              
17             sub new {
18 1     1 1 11 my $class = shift;
19 1         4 my %parameters = (@_);
20 1   33     9 my $self = bless ({%parameters}, ref ($class) || $class);
21              
22 1         4 $self->_set_defaults();
23              
24 1         3 return ($self);
25             } # new
26              
27              
28             sub query_raw {
29 0     0 1 0 my $self = shift;
30 0         0 my %args = @_;
31              
32 0 0       0 if (!$self->_connect())
33             {
34 0         0 return undef;
35             }
36              
37 0         0 my $data = $self->_search(%args);
38 0         0 return $data;
39             } # query_raw
40              
41              
42             sub query {
43 0     0 1 0 my $self = shift;
44 0         0 my %args = @_;
45              
46 0 0       0 if (!$self->_connect())
47             {
48 0         0 return undef;
49             }
50              
51 0         0 return $self->_process_request(%args);
52             } # query
53              
54              
55             sub taglist {
56 0     0 1 0 my $self = shift;
57 0         0 my %args = @_;
58              
59 0 0       0 if (!$self->_connect())
60             {
61 0         0 return undef;
62             }
63              
64 0         0 return $self->_process_taglist(%args);
65             } # taglist
66              
67              
68             sub tagcloud {
69 0     0 1 0 my $self = shift;
70 0         0 my %args = @_;
71              
72 0 0       0 if (!$self->_connect())
73             {
74 0         0 return undef;
75             }
76              
77 0         0 return $self->_process_tagcloud(%args);
78             } # tagcloud
79              
80              
81             sub total_records {
82 0     0 1 0 my $self = shift;
83 0         0 my %args = @_;
84              
85 0 0       0 if (!$self->_connect())
86             {
87 0         0 return undef;
88             }
89              
90 0         0 return $self->_total_records(%args);
91             } # total_records
92              
93              
94             sub what_error {
95 0     0 1 0 my $self = shift;
96 0         0 my %args = @_;
97              
98 0         0 return $self->{error};
99             } # what_error
100              
101              
102             sub _set_defaults {
103 1     1   2 my $self = shift;
104              
105 1 50       5 $self->{route_prefix} = '' if !defined $self->{route_prefix};
106              
107 1 50       3 $self->{user} = '' if !defined $self->{user};
108 1 50       3 $self->{password} = '' if !defined $self->{password};
109              
110 1 50       2 if (!defined $self->{database})
111             {
112 0         0 die "No database given";
113             }
114 1 50       2 if (!defined $self->{table})
115             {
116 0         0 die "No table given";
117             }
118 1 50       3 if (!defined $self->{columns})
119             {
120 0         0 die "No columns given";
121             }
122 1 50       2 if (!defined $self->{sort_columns})
123             {
124 1         1 $self->{sort_columns} = $self->{columns};
125             }
126 1 50       2 $self->{tagfield} = 'tags' if !defined $self->{tagfield};
127 1 50       2 $self->{default_limit} = 100 if !defined $self->{default_limit};
128              
129 1 50       3 if (!defined $self->{row_template})
130             {
131 0         0 $self->{row_template} =<<'EOT';
132            
  • 133            
    134             {$title}
    135            
    136             {?description [$description:html]}
    137            
    138             {?all_tags
    [$all_tags]
    }
    139            
    140            
    141             EOT
    142             }
    143              
    144 1 50       2 if (!defined $self->{tags_template})
    145             {
    146 1         1 $self->{tags_template} =<<'EOT';
    147             {?not_in_list } {$tag_label}{?num_tags ([$num_tags])}
    148             EOT
    149             }
    150 1 50       2 if (!defined $self->{tag_query_template})
    151             {
    152 1         2 $self->{tag_query_template} =<<'EOT';
    153             {$tag}
    154             EOT
    155             }
    156 1 50       3 if (!defined $self->{q_query_template})
    157             {
    158 1         2 $self->{q_query_template} =<<'EOT';
    159             {$qterm}
    160             EOT
    161             }
    162 1 50       3 if (!defined $self->{results_template})
    163             {
    164 1         1 $self->{results_template} =<<'EOT';
    165             {?searchform [$searchform]}
    166             {?pagination [$pagination]}
    167             {?total

    [$total] records found. Page [$p] of [$num_pages].

    }
    168             {?query
    [$query]
    }
    169             {?sql

    [$sql]

    }
    170             {?result
    [$result]
    }
    171             EOT
    172             }
    173 1 50       3 if (!defined $self->{pagination_template})
    174             {
    175 1         2 $self->{pagination_template} =<<'EOT';
    176            
    177             {?prev_page } Prev{?prev_page }
    178             {?next_page }Next {?next_page }
    179            
    180             EOT
    181             }
    182 1 50       3 if (!defined $self->{searchform})
    183             {
    184 1         2 $self->{searchform} =<<'EOT';
    185            
    186            
    187            
    188            
    189             {$selectP}
    190            
    191            
    192            
    193             {$selectN}
    194             {$sorting}
    195            
    196            
    197             EOT
    198 1 50       2 if ($self->{use_where})
    199             {
    200 0         0 my $whereness =<<'EOW';
    201            
    202             EOW
    203 0         0 $self->{searchform} =~ s/()/${whereness}$1/;
    204             }
    205             }
    206 1         2 return $self;
    207              
    208             } # _set_defaults
    209              
    210              
    211             sub _connect {
    212 0     0     my $self = shift;
    213              
    214 0           my $old_dbh = $self->{dbh};
    215 0 0         if ($old_dbh)
    216             {
    217 0           return 1;
    218             }
    219              
    220             # The database is either a DSN (data source name)
    221             # or a file name. If it's a file name, assume it's SQLite
    222 0           my $database = $self->{database};
    223 0 0         if ($database)
    224             {
    225 0           my $dsn = $database;
    226 0           my $user = $self->{user};
    227 0           my $pw = $self->{password};
    228 0 0         if (-f $database)
    229             {
    230 0           $dsn = "dbi:SQLite:dbname=$database";
    231             }
    232 0           my $dbh = DBI->connect($dsn, $user, $pw);
    233 0 0         if (!$dbh)
    234             {
    235 0           $self->{error} = "Can't connect to $database $DBI::errstr";
    236 0           return 0;
    237             }
    238 0           $self->{dbh} = $dbh;
    239             }
    240             else
    241             {
    242 0           $self->{error} = "No Database given." . Dump($self);
    243 0           return 0;
    244             }
    245              
    246 0           return 1;
    247             } # _connect
    248              
    249              
    250             sub _search {
    251 0     0     my $self = shift;
    252 0           my %args = @_;
    253              
    254 0           my $dbh = $self->{dbh};
    255              
    256             # first find the total
    257 0           my $q = $self->_query_to_sql(%args,get_total=>1);
    258 0           my $sth = $dbh->prepare($q);
    259 0 0         if (!$sth)
    260             {
    261 0           $self->{error} = "FAILED to prepare '$q' $DBI::errstr";
    262 0           return undef;
    263             }
    264 0           my $ret = $sth->execute();
    265 0 0         if (!$ret)
    266             {
    267 0           $self->{error} = "FAILED to execute '$q' $DBI::errstr";
    268 0           return undef;
    269             }
    270 0           my @ret_rows=();
    271 0           my $total = 0;
    272 0           my @row;
    273 0           while (@row = $sth->fetchrow_array)
    274             {
    275 0           $total = $row[0];
    276             }
    277 0           my $num_pages = 1;
    278 0 0         if ($args{n})
    279             {
    280 0           $num_pages = ceil($total / $args{n});
    281 0 0         $num_pages = 1 if $num_pages < 1;
    282             }
    283              
    284 0 0         if ($total > 0)
    285             {
    286 0           $q = $self->_query_to_sql(%args,total=>$total);
    287 0           $sth = $dbh->prepare($q);
    288 0 0         if (!$sth)
    289             {
    290 0           $self->{error} = "FAILED to prepare '$q' $DBI::errstr";
    291 0           return undef;
    292             }
    293 0           $ret = $sth->execute();
    294 0 0         if (!$ret)
    295             {
    296 0           $self->{error} = "FAILED to execute '$q' $DBI::errstr";
    297 0           return undef;
    298             }
    299              
    300 0           while (my $hashref = $sth->fetchrow_hashref)
    301             {
    302 0           push @ret_rows, $hashref;
    303             }
    304             }
    305 0           return {rows=>\@ret_rows,
    306             total=>$total,
    307             num_pages=>$num_pages,
    308             sql=>$q};
    309             } # _search
    310              
    311              
    312             sub _process_request {
    313 0     0     my $self = shift;
    314 0           my %args = @_;
    315              
    316 0           my $dbh = $self->{dbh};
    317 0           my $location = $args{location};
    318 0 0         $args{n} = 20 if !defined $args{n};
    319 0           my $tobj = Text::NeatTemplate->new();
    320              
    321 0           my $data = $self->_search(
    322             %args
    323             );
    324 0 0         if (!defined $data)
    325             {
    326 0           return undef;
    327             }
    328              
    329 0           my $searchform = $self->_format_searchform(
    330             %args,
    331             data=>$data,
    332             );
    333 0           my $pagination = $self->_format_pagination(
    334             %args,
    335             data=>$data,
    336             );
    337             my $result = $self->_format_rows(
    338             %args,
    339             rows=>$data->{rows},
    340             total=>$data->{total},
    341             tags_query=>$args{tags},
    342 0           tags_action=>"$location/tags",
    343             );
    344             my %all_tags = $self->_create_taglist(
    345             rows=>$data->{rows},
    346             total=>$data->{total},
    347 0           );
    348             my $query_tags = $self->_format_taglist(
    349             %args,
    350             all_tags=>\%all_tags,
    351             tags_query=>$args{tags},
    352 0           tags_action=>"$location/tags",
    353             );
    354             my $tquery_str = $self->_format_tag_query(
    355             %args,
    356             tags_query=>$args{tags},
    357 0           tags_action=>"$location/tags");
    358             my $qquery_str = $self->_format_q_query(
    359             %args,
    360             tags_query=>$args{tags},
    361 0           action=>$location);
    362 0           my $query_str = join(' ', $tquery_str, $qquery_str);
    363             my $html = $tobj->fill_in(
    364             data_hash=>{
    365             %args,
    366             p=>($args{p} ? $args{p} : 1),
    367             sql=>($args{show_sql} ? $data->{sql} : ''),
    368             query=>$query_str,
    369             result=>$result,
    370             total=>$data->{total},
    371             num_pages=>$data->{num_pages},
    372             searchform=>$searchform,
    373             pagination=>$pagination,
    374             },
    375             template=>$self->{results_template},
    376 0 0         );
        0          
    377              
    378             return { results=>$html,
    379             query_tags=>$query_tags,
    380             searchform=>$searchform,
    381             pagination=>$pagination,
    382             total=>$data->{total},
    383             num_pages=>$data->{num_pages},
    384 0           };
    385             } # _process_request
    386              
    387              
    388             sub _process_taglist {
    389 0     0     my $self = shift;
    390 0           my %args = @_;
    391              
    392 0           my $dbh = $self->{dbh};
    393 0           my $location = $args{location};
    394 0 0         $args{n} = 20 if !defined $args{n};
    395 0           my $tobj = Text::NeatTemplate->new();
    396              
    397 0           my $data = $self->_search(
    398             %args
    399             );
    400              
    401             my %all_tags = $self->_create_taglist(
    402             rows=>$data->{rows},
    403             total=>$data->{total},
    404 0           );
    405 0           my $count = keys %all_tags;
    406             my $query_tags = $self->_format_taglist(
    407             %args,
    408             all_tags=>\%all_tags,
    409             total_tags=>$count,
    410             tags_query=>$args{tags},
    411 0           tags_action=>"$location/tags",
    412             );
    413              
    414             return { results=>$query_tags,
    415             query_tags=>$query_tags,
    416             total=>$data->{total},
    417             total_tags=>$count,
    418             num_pages=>$data->{num_pages},
    419 0           };
    420             } # _process_taglist
    421              
    422              
    423             sub _process_tagcloud {
    424 0     0     my $self = shift;
    425 0           my %args = @_;
    426              
    427 0           my $dbh = $self->{dbh};
    428 0           my $location = $args{location};
    429 0 0         $args{n} = 20 if !defined $args{n};
    430 0           my $tobj = Text::NeatTemplate->new();
    431              
    432 0           my $data = $self->_search(
    433             %args
    434             );
    435              
    436             my %all_tags = $self->_create_taglist(
    437             rows=>$data->{rows},
    438             total=>$data->{total},
    439 0           );
    440 0           my $count = keys %all_tags;
    441             my $query_tags = $self->_format_taglist(
    442             %args,
    443             all_tags=>\%all_tags,
    444             tags_query=>$args{tags},
    445 0           tags_action=>"$location/tags",
    446             );
    447             my $tagcloud = $self->_format_tagcloud(
    448             %args,
    449             all_tags=>\%all_tags,
    450             tags_query=>$args{tags},
    451 0           tags_action=>"$location/tags",
    452             );
    453              
    454             return { results=>$tagcloud,
    455             query_tags=>$query_tags,
    456             total=>$data->{total},
    457             total_tags=>$count,
    458             num_pages=>$data->{num_pages},
    459 0           };
    460             } # _process_tagcloud
    461              
    462              
    463             sub _total_records {
    464 0     0     my $self = shift;
    465              
    466 0           my $dbh = $self->{dbh};
    467              
    468 0           my $q = $self->_query_to_sql(get_total=>1);
    469              
    470 0           my $sth = $dbh->prepare($q);
    471 0 0         if (!$sth)
    472             {
    473 0           $self->{error} = "FAILED to prepare '$q' $DBI::errstr";
    474 0           return undef;
    475             }
    476 0           my $ret = $sth->execute();
    477 0 0         if (!$ret)
    478             {
    479 0           $self->{error} = "FAILED to execute '$q' $DBI::errstr";
    480 0           return undef;
    481             }
    482 0           my $total = 0;
    483 0           my @row;
    484 0           while (@row = $sth->fetchrow_array)
    485             {
    486 0           $total = $row[0];
    487             }
    488 0           return $total;
    489             } # _total_records
    490              
    491              
    492             sub _build_where {
    493 0     0     my $self = shift;
    494 0           my %args = @_;
    495 0           my $field = $args{field};
    496 0           my $query_string = $args{q};
    497            
    498             # no query, no WHERE
    499 0 0         if (!$query_string)
    500             {
    501 0           return '';
    502             }
    503              
    504 0           my $sql_where = '';
    505              
    506             # If there is no field, it is a simple query string;
    507             # the simple query string will search all columns in OR fashion
    508             # that is (col1 GLOB term OR col2 GLOB term...) etc
    509             # only allow for '-' prefix, not the complex Search::Query stuff
    510             # Note that if this is a NOT term, the query clause needs to be
    511             # (col1 NOT GLOB term AND col2 NOT GLOB term)
    512             # and checking for NULL too
    513 0 0 0       if (!$field)
        0          
    514             {
    515 0           my @and_clauses = ();
    516 0           my @terms = split(/[ +]/, $query_string);
    517 0           for (my $i=0; $i < @terms; $i++)
    518             {
    519 0           my $term = $terms[$i];
    520 0           my $not = 0;
    521 0 0         if ($term =~ /^-(.*)/)
    522             {
    523 0           $term = $1;
    524 0           $not = 1;
    525             }
    526 0 0         if ($not) # negative term, match NOT AND
    527             {
    528 0           my @and_not_clauses = ();
    529 0           foreach my $col (@{$self->{columns}})
      0            
    530             {
    531 0           my $clause = sprintf('(%s IS NULL OR %s NOT GLOB "*%s*")', $col, $col, $term);
    532 0           push @and_not_clauses, $clause;
    533             }
    534 0           push @and_clauses, "(" . join(" AND ", @and_not_clauses) . ")";
    535             }
    536             else # positive term, match OR
    537             {
    538 0           my @or_clauses = ();
    539 0           foreach my $col (@{$self->{columns}})
      0            
    540             {
    541 0           my $clause = sprintf('%s GLOB "*%s*"', $col, $term);
    542 0           push @or_clauses, $clause;
    543             }
    544 0           push @and_clauses, "(" . join(" OR ", @or_clauses) . ")";
    545             }
    546             }
    547 0           $sql_where = join(" AND ", @and_clauses);
    548             }
    549             elsif ($field eq 'tags'
    550             or $field eq $self->{tagfield})
    551             {
    552 0           my $tagfield = $self->{tagfield};
    553 0           my @and_clauses = ();
    554 0           my @terms = split(/[ +]/, $query_string);
    555 0           for (my $i=0; $i < @terms; $i++)
    556             {
    557 0           my $term = $terms[$i];
    558 0           my $not = 0;
    559 0           my $equals = 1; # make tags match exactly by default
    560 0 0         if ($term =~ /^-(.*)/)
    561             {
    562 0           $term = $1;
    563 0           $not = 1;
    564             }
    565             # use * for a glob marker
    566 0 0         if ($term =~ /^\*(.*)/)
    567             {
    568 0           $term = $1;
    569 0           $equals = 0;
    570             }
    571 0 0 0       if ($not and !$equals)
        0 0        
        0          
    572             {
    573 0           my $clause = sprintf('(%s IS NULL OR %s NOT GLOB "*%s*")', $tagfield, $tagfield, $term);
    574 0           push @and_clauses, $clause;
    575             }
    576             elsif ($not and $equals) # negative term, match NOT AND
    577             {
    578 0           my $clause = sprintf('(%s IS NULL OR (%s != "%s" AND %s NOT GLOB "%s|*" AND %s NOT GLOB "*|%s|*" AND %s NOT GLOB "*|%s"))',
    579             $tagfield,
    580             $tagfield, $term,
    581             $tagfield, $term,
    582             $tagfield, $term,
    583             $tagfield, $term,
    584             );
    585 0           push @and_clauses, $clause;
    586             }
    587             elsif ($equals) # positive term, match OR
    588             {
    589 0           my $clause = sprintf('(%s = "%s" OR %s GLOB "%s|*" OR %s GLOB "*|%s|*" OR %s GLOB "*|%s")',
    590             $tagfield, $term,
    591             $tagfield, $term,
    592             $tagfield, $term,
    593             $tagfield, $term,
    594             );
    595 0           push @and_clauses, $clause;
    596             }
    597             else
    598             {
    599 0           my $clause = sprintf('%s GLOB "*%s*"', $tagfield, $term);
    600 0           push @and_clauses, $clause;
    601             }
    602             }
    603 0           $sql_where = join(" AND ", @and_clauses);
    604             }
    605             else # other columns
    606             {
    607 0           my $parser = Search::Query->parser(
    608             query_class => 'SQL',
    609             query_class_opts => {
    610             like => 'GLOB',
    611             wildcard => '*',
    612             fuzzify2 => 1,
    613             },
    614             null_term => 'NULL',
    615             default_field => $field,
    616             default_op => '~',
    617             fields => [$field],
    618             );
    619 0           my $query = $parser->parse($args{q});
    620 0           $sql_where = $query->stringify;
    621             }
    622              
    623 0 0         return ($sql_where ? "(${sql_where})" : '');
    624             } # _build_where
    625              
    626              
    627             sub _query_to_sql {
    628 0     0     my $self = shift;
    629 0           my %args = @_;
    630              
    631 0           my $p = $args{p};
    632 0           my $items_per_page = $args{n};
    633 0 0         my $total = ($args{total} ? $args{total} : 0);
    634 0           my $order_by = '';
    635 0 0 0       if ($args{sort_by} and $args{sort_by2} and $args{sort_by3})
        0 0        
        0 0        
    636             {
    637 0           $order_by = join(', ', $args{sort_by}, $args{sort_by2}, $args{sort_by3});
    638             }
    639             elsif ($args{sort_by} and $args{sort_by2})
    640             {
    641 0           $order_by = join(', ', $args{sort_by}, $args{sort_by2});
    642             }
    643             elsif ($args{sort_by})
    644             {
    645 0           $order_by = $args{sort_by};
    646             }
    647             else
    648             {
    649 0           $order_by = join(', ', @{$self->{default_sort}});
      0            
    650             }
    651              
    652 0           my $offset = 0;
    653 0 0 0       if ($p and $items_per_page)
    654             {
    655 0           $offset = ($p - 1) * $items_per_page;
    656 0 0 0       if ($total > 0 and $offset >= $total)
        0          
    657             {
    658 0           $offset = $total - 1;
    659             }
    660             elsif ($offset <= 0)
    661             {
    662 0           $offset = 0;
    663             }
    664             }
    665              
    666 0           my @and_clauses = ();
    667 0           foreach my $col (@{$self->{columns}})
      0            
    668             {
    669 0 0         if ($args{$col})
    670             {
    671 0           my $clause = $self->_build_where(field=>$col, q=>$args{$col});
    672 0           push @and_clauses, $clause;
    673             }
    674             }
    675 0 0 0       if ($args{'tags'} and $self->{tagfield} ne 'tags')
    676             {
    677 0           my $clause = $self->_build_where(field=>'tags', q=>$args{'tags'});
    678 0           push @and_clauses, $clause;
    679             }
    680              
    681 0 0         if ($args{q})
    682             {
    683 0           my $clause = $self->_build_where(field=>'', q=>$args{q});
    684 0           push @and_clauses, $clause;
    685             }
    686             # a freeform where condition
    687 0 0         if ($args{where})
    688             {
    689 0           push @and_clauses, $args{where};
    690             }
    691             # if there's an extra condition in the configuration, add it here
    692 0 0         if ($self->{extra_cond})
    693             {
    694 0 0         if (@and_clauses)
    695             {
    696 0           push @and_clauses, "(" . $self->{extra_cond} . ")";
    697             }
    698             else
    699             {
    700 0           push @and_clauses, $self->{extra_cond};
    701             }
    702             }
    703 0           my $sql_where = join(" AND ", @and_clauses);
    704              
    705 0           my $q = '';
    706 0 0         if ($args{get_total})
    707             {
    708 0           $q = "SELECT COUNT(*) FROM " . $self->{table};
    709 0 0         $q .= " WHERE $sql_where" if $sql_where;
    710             }
    711             else
    712             {
    713 0           $q = "SELECT * FROM " . $self->{table};
    714 0 0         $q .= " WHERE $sql_where" if $sql_where;
    715 0 0         $q .= " ORDER BY $order_by" if $order_by;
    716 0 0         $q .= " LIMIT $items_per_page" if $items_per_page;
    717 0 0         $q .= " OFFSET $offset" if $offset;
    718             }
    719              
    720 0           return $q;
    721             } # _query_to_sql
    722              
    723              
    724             sub _format_searchform {
    725 0     0     my $self = shift;
    726 0           my %args = @_;
    727              
    728 0           my $data = $args{data};
    729 0           my $location = $args{location};
    730 0           my $tobj = Text::NeatTemplate->new();
    731              
    732 0           my $selectN = '';
    733 0           my @os = ();
    734 0           push @os, '
    735 0           foreach my $limit (qw(10 20 50 100))
    736             {
    737 0 0         if ($limit == $args{n})
    738             {
    739 0           push @os, "";
    740             }
    741             else
    742             {
    743 0           push @os, "";
    744             }
    745             }
    746 0           push @os, '';
    747 0           $selectN = join("\n", @os);
    748              
    749 0           my $total = $data->{total};
    750 0           my $num_pages = $data->{num_pages};
    751 0 0         if ($args{p} > $num_pages)
    752             {
    753 0           $args{p} = 1;
    754             }
    755              
    756 0           my $selectP = '';
    757 0           @os = ();
    758 0           push @os, '
    759 0           for (my $p = 1; $p <= $num_pages; $p++)
    760             {
    761 0 0         if ($p == $args{p})
    762             {
    763 0           push @os, "";
    764             }
    765             else
    766             {
    767 0           push @os, "";
    768             }
    769             }
    770 0           push @os, '';
    771 0           $selectP = join("\n", @os);
    772              
    773 0           my $db = $args{db};
    774 0           my $sorting = '';
    775 0           @os = ();
    776 0           foreach my $sf (qw(sort_by sort_by2 sort_by3))
    777             {
    778 0           push @os, "
    779 0           push @os, "";
    780 0           foreach my $s (sort @{$self->{sort_columns}})
      0            
    781             {
    782 0 0         if ($s eq $args{$sf})
    783             {
    784 0           push @os, "";
    785             }
    786             else
    787             {
    788 0           push @os, "";
    789             }
    790 0           my $s_desc = "${s} DESC";
    791 0 0         if ($s_desc eq $args{$sf})
    792             {
    793 0           push @os, "";
    794             }
    795             else
    796             {
    797 0           push @os, "";
    798             }
    799             }
    800 0           push @os, '';
    801             }
    802 0           $sorting = join("\n", @os);
    803              
    804             my $searchform = $tobj->fill_in(
    805             data_hash=>{
    806             %args,
    807             action=>$location,
    808             selectN=>$selectN,
    809             selectP=>$selectP,
    810             sorting=>$sorting,
    811             },
    812             template=>$self->{searchform},
    813 0           );
    814              
    815 0           return $searchform;
    816             } # _format_searchform
    817              
    818              
    819             sub _format_pagination {
    820 0     0     my $self = shift;
    821 0           my %args = @_;
    822              
    823 0           my $data = $args{data};
    824 0           my $location = $args{location};
    825 0           my $tobj = Text::NeatTemplate->new();
    826              
    827 0           my $total = $data->{total};
    828 0           my $num_pages = $data->{num_pages};
    829 0 0         if ($args{p} > $num_pages)
    830             {
    831 0           $args{p} = $num_pages;
    832             }
    833 0 0         if ($args{p} < 1)
    834             {
    835 0           $args{p} = 1;
    836             }
    837 0           my $prev_page = $args{p} - 1;
    838 0 0         if ($prev_page < 1)
    839             {
    840 0           $prev_page = 0;
    841             }
    842 0           my $next_page = $args{p} + 1;
    843 0 0         if ($next_page > $num_pages)
    844             {
    845 0           $next_page = 0;
    846             }
    847 0           my $tq = '';
    848 0 0         if ($args{tags})
    849             {
    850 0           $tq = 'tags/' . $args{tags};
    851             }
    852              
    853             my $pagination = $tobj->fill_in(
    854             data_hash=>{
    855             %args,
    856             tq=>$tq,
    857             prev_page=>$prev_page,
    858             next_page=>$next_page,
    859             },
    860             template=>$self->{pagination_template},
    861 0           );
    862              
    863 0           return $pagination;
    864             } # _format_pagination
    865              
    866              
    867             sub _format_rows {
    868 0     0     my $self = shift;
    869 0           my %args = @_;
    870              
    871 0           my @rows = @{$args{rows}};
      0            
    872 0           my $total = $args{total};
    873              
    874 0           my @out = ();
    875 0           push @out, '
      ';
    876 0           my $tobj = Text::NeatTemplate->new();
    877 0           foreach my $row_hash (@rows)
    878             {
    879             # format the tags, then format the row
    880             # may need to remove trailing empty tags
    881 0           my $proper_tags = $row_hash->{$self->{tagfield}};
    882 0           $proper_tags =~ s/^[|]//;
    883 0           $proper_tags =~ s/[|]$//;
    884 0           my @tags = split(/\|/, $proper_tags);
    885 0           my $tags_str = $self->_format_tag_collection(
    886             %args,
    887             in_list=>0,
    888             tags_array=>\@tags);
    889 0           $row_hash->{all_tags} = $tags_str;
    890 0           $row_hash->{route_prefix} = $self->{route_prefix};
    891             my $text = $tobj->fill_in(data_hash=>$row_hash,
    892 0           template=>$self->{row_template});
    893 0           push @out, $text;
    894             }
    895 0           push @out, "\n";
    896              
    897 0           my $results = join("\n", @out);
    898              
    899 0           return $results;
    900             } # _format_rows
    901              
    902              
    903             sub _create_taglist {
    904 0     0     my $self = shift;
    905 0           my %args = @_;
    906              
    907 0           my @rows = @{$args{rows}};
      0            
    908              
    909 0           my %all_tags = ();
    910 0           foreach my $row_hash (@rows)
    911             {
    912             # iterate over the tags
    913 0           my @tags = split(/\|/, $row_hash->{$self->{tagfield}});
    914 0           foreach my $tag (@tags)
    915             {
    916 0 0         if ($tag)
    917             {
    918 0           $all_tags{$tag}++;
    919             }
    920             }
    921             }
    922 0           return %all_tags;
    923             } # _create_taglist
    924              
    925              
    926             sub _format_tagcloud {
    927 0     0     my $self = shift;
    928 0           my %args = @_;
    929              
    930 0           my $cloud = HTML::TagCloud->new(levels=>30);
    931 0           my @out = ();
    932 0           push @out, '
    ';
    933 0           foreach my $tag (nsort keys %{$args{all_tags}})
      0            
    934             {
    935 0           my $tq = '';
    936 0 0         if (!$args{tags_query})
        0          
    937             {
    938 0           $tq = $tag;
    939             }
    940             elsif ($args{tags_query} =~ /\Q$tag\E/)
    941             {
    942             # this tag is already in the query
    943 0           $tq = $args{tags_query};
    944             }
    945             else
    946             {
    947 0           $tq = "$args{tags_query}+${tag}";
    948             }
    949 0           my $tag_url = "$args{location}/tags/$tq";
    950 0           $cloud->add($tag, $tag_url, $args{all_tags}->{$tag});
    951             }
    952 0           my $tc = $cloud->html_and_css();
    953 0           push @out, $tc;
    954 0           push @out, "\n";
    955              
    956 0           my $taglist = join("\n", @out);
    957              
    958 0           return $taglist;
    959             } # _format_tagcloud
    960              
    961              
    962             sub _format_taglist {
    963 0     0     my $self = shift;
    964 0           my %args = @_;
    965              
    966 0           my @out = ();
    967 0           push @out, '
    ';
    968 0 0 0       if (exists $args{total_tags}
          0        
    969             and defined $args{total_tags}
    970             and $args{total_tags})
    971             {
    972 0           push @out, "

    Tag-count: $args{total_tags}

    ";
    973             }
    974 0           push @out, "
      \n";
    975 0           my $tl = $self->_format_tag_collection(
    976             %args,
    977             in_list=>1,
    978             );
    979 0           push @out, $tl;
    980 0           push @out, "\n";
    981 0           push @out, "\n";
    982              
    983 0           my $taglist = join("\n", @out);
    984              
    985 0           return $taglist;
    986             } # _format_taglist
    987              
    988              
    989             sub _format_tag_collection {
    990 0     0     my $self = shift;
    991 0           my %args = @_;
    992              
    993 0           my $tags_query = $args{tags_query};
    994 0           my $tags_action = $args{tags_action};
    995 0 0         my @tags = ($args{all_tags} ? nsort keys %{$args{all_tags}} : nsort @{$args{tags_array}});
      0            
      0            
    996 0           my $qquery = '';
    997 0           my @qq = ();
    998 0 0         push @qq, "q=$args{q}" if $args{q};
    999 0 0         push @qq, "p=$args{p}" if $args{p};
    1000 0           my $qquery = join('&', @qq);
    1001              
    1002 0           my $tobj = Text::NeatTemplate->new();
    1003 0           my @out = ();
    1004 0           foreach my $tag (@tags)
    1005             {
    1006 0           my $tag_label = $tag;
    1007 0           $tag_label =~ s/-/ /g; # remove dashes
    1008 0           my $tq = '';
    1009 0 0         if (!$tags_query)
        0          
    1010             {
    1011 0           $tq = $tag;
    1012             }
    1013             elsif ($tags_query =~ /\Q$tag\E/)
    1014             {
    1015             # this tag is already in the query
    1016 0           $tq = $tags_query;
    1017             }
    1018             else
    1019             {
    1020 0           $tq = "${tags_query}+${tag}";
    1021             }
    1022 0 0         push @out, "
  • " if $args{in_list};
  • 1023             push @out, $tobj->fill_in(data_hash=>{tag=>$tag,
    1024             tag_label=>$tag_label,
    1025             num_tags=>(defined $args{all_tags} ? $args{all_tags}->{$tag} : undef),
    1026             in_list=>$args{in_list},
    1027             not_in_list=>!$args{in_list},
    1028             tags_query=>$tq,
    1029             qquery=>$qquery,
    1030             url=>$tags_action},
    1031 0 0         template=>$self->{tags_template});
    1032 0 0         push @out, "\n" if $args{in_list};
    1033             }
    1034              
    1035 0           my $taglist = join("\n", @out);
    1036              
    1037 0           return $taglist;
    1038             } # _format_tag_collection
    1039              
    1040              
    1041             sub _format_tag_query {
    1042 0     0     my $self = shift;
    1043 0           my %args = @_;
    1044              
    1045 0           my $tags_query = $args{tags_query};
    1046 0           my $tags_action = $args{tags_action};
    1047 0           my @terms = split(/[ +]/, $tags_query);
    1048              
    1049 0           my $tobj = Text::NeatTemplate->new();
    1050 0           my @out = ();
    1051 0           foreach my $tag (@terms)
    1052             {
    1053 0           my $tq = '';
    1054 0 0         if (!$tags_query)
        0          
    1055             {
    1056 0           $tq = $tag;
    1057             }
    1058             elsif ($tags_query =~ /\Q$tag\E/)
    1059             {
    1060             # this tag is already in the query
    1061 0           $tq = $tags_query;
    1062             }
    1063             else
    1064             {
    1065 0           $tq = "${tags_query}+${tag}";
    1066             }
    1067             push @out, $tobj->fill_in(data_hash=>{
    1068             %args,
    1069             tag=>$tag,
    1070             tags_query=>$tq,
    1071             url=>$tags_action},
    1072 0           template=>$self->{tag_query_template});
    1073             }
    1074              
    1075 0           my $taglist = join("\n", @out);
    1076              
    1077 0           return $taglist;
    1078             } # _format_tag_query
    1079              
    1080              
    1081             sub _format_q_query {
    1082 0     0     my $self = shift;
    1083 0           my %args = @_;
    1084              
    1085 0 0         if (!$args{q})
    1086             {
    1087 0           return '';
    1088             }
    1089 0           my @terms = split(/[ +]/, $args{q});
    1090              
    1091 0           my $tobj = Text::NeatTemplate->new();
    1092 0           my @out = ();
    1093 0           foreach my $term (@terms)
    1094             {
    1095             push @out, $tobj->fill_in(data_hash=>{
    1096             %args,
    1097             qterm=>$term,
    1098             tags_query=>$args{tags_query},
    1099             qquery=>$args{q},
    1100             url=>$args{action}},
    1101 0           template=>$self->{q_query_template});
    1102             }
    1103              
    1104 0           my $qlist = join("\n", @out);
    1105              
    1106 0           return $qlist;
    1107             } # _format_q_query
    1108              
    1109             1; # End of Marky::DbTable
    1110              
    1111             __END__