File Coverage

blib/lib/PFT/Map/Index.pm
Criterion Covered Total %
statement 63 83 75.9
branch 39 60 65.0
condition 8 20 40.0
subroutine 11 12 91.6
pod 3 4 75.0
total 124 179 69.2


line stmt bran cond sub pod time code
1             # Copyright 2014-2016 - Giovanni Simoni
2             #
3             # This file is part of PFT.
4             #
5             # PFT is free software: you can redistribute it and/or modify it under the
6             # terms of the GNU General Public License as published by the Free
7             # Software Foundation, either version 3 of the License, or (at your
8             # option) any later version.
9             #
10             # PFT is distributed in the hope that it will be useful, but WITHOUT ANY
11             # WARRANTY; without even the implied warranty of MERCHANTABILITY or
12             # FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
13             # for more details.
14             #
15             # You should have received a copy of the GNU General Public License along
16             # with PFT. If not, see .
17              
18             package PFT::Map::Index v1.3.0;
19              
20             =encoding utf8
21              
22             =head1 NAME
23              
24             PFT::Map::Index - Resolve symbols in PFT Entries
25              
26             =head1 SYNOPSIS
27              
28             Explicit construction:
29              
30             use PFT::Map::Index;
31              
32             die unless $map->isa('PFT::Map');
33             my $index = PFT::Map::Index->new($map);
34              
35             Using map property:
36              
37             my $index = $map->index;
38              
39             Resolution:
40              
41             die unless $node->isa('PFT::Map::Node');
42             die unless $sym->isa('PFT::Text::Symbol');
43             $index->resolve($node, $sym);
44              
45             =head1 DESCRIPTION
46              
47             A C object handles the unique identifiers of content
48             items mapped in a C object. It can be used to resolve symbols of
49             a C, or to query the map (e.g.
50             I)
51              
52             =cut
53              
54 3     3   37 use v5.16;
  3         10  
55 3     3   15 use strict;
  3         6  
  3         60  
56 3     3   15 use warnings;
  3         13  
  3         89  
57 3     3   15 use utf8;
  3         5  
  3         26  
58              
59 3     3   81 use Carp;
  3         6  
  3         3476  
60              
61             sub new {
62 27     27 0 51 my($cls, $map) = @_;
63 27         92 bless \$map, $cls;
64             }
65              
66             =head2 Properties
67              
68             =over
69              
70             =item map
71              
72             Reference to the associated map
73              
74             =cut
75              
76 22     22 1 28 sub map { return ${shift()} }
  22         80  
77              
78             =back
79              
80             =head2 Methods
81              
82             =over
83              
84             =item content_id
85              
86             Given a PFT::Content::Base (or any subclass) object, returns a
87             string uniquely identifying it across the site. E.g.:
88              
89             my $id = $resolver->content_id($content);
90             my $id = $resolver->content_id($virtual_page, $hdr);
91             my $id = $resolver->content_id(undef, $hdr);
92              
93             The header is optional for the first two forms: unless supplied it will be
94             retrieved by the content. In the third form the content is not supplied,
95             so the header is mandatory.
96              
97             =cut
98              
99             sub content_id {
100 25     25 1 51 my($self, $cntnt, $hdr) = @_;
101              
102 25 50       56 unless (defined $cntnt) {
103 0 0       0 confess 'No content, no header?' unless defined $hdr;
104 0         0 $cntnt = $self->map->{tree}->entry($hdr);
105             }
106              
107 25 50       137 ref($cntnt) =~ /PFT::Content::(Page|Blog|Picture|Attachment|Tag|Month)/
108             or confess 'Unsupported in content to id: ' . ref($cntnt);
109              
110             # NOTE: changes here must be reflected down this file, in
111             # _resolve_local
112 25 100       135 if ($1 eq 'Page') {
    100          
    100          
    100          
    100          
    50          
113 5   33     34 'p:' . ($hdr || $cntnt->header)->slug
114             } elsif ($1 eq 'Tag') {
115 3   33     15 't:' . ($hdr || $cntnt->header)->slug
116             } elsif ($1 eq 'Blog') {
117 10   33     44 my $hdr = ($hdr || $cntnt->header);
118 10         40 'b:' . $hdr->date->repr . ':' . $hdr->slug
119             } elsif ($1 eq 'Month') {
120 3   33     11 my $hdr = ($hdr || $cntnt->header);
121 3         11 'm:' . $hdr->date->repr
122             } elsif ($1 eq 'Picture') {
123 2         17 'i:' . join '/', $cntnt->relpath # No need for portability
124             } elsif ($1 eq 'Attachment') {
125 2         21 'a:' . join '/', $cntnt->relpath # Ditto
126 0         0 } else { die };
127             }
128              
129             =item resolve
130              
131             The function resolves a symbol retrieved from the text of a
132             C. The returned value will be one of the following:
133              
134             =over
135              
136             =item A list of nodes (i.e. a C instances);
137              
138             =item A list of strings (e.g. C);
139              
140             =item An empty list (meaning: failed resolution).
141              
142             =back
143              
144             =cut
145              
146             sub resolve {
147 15     15 1 33 my($self, $node, $symbol) = @_;
148              
149 15 50 0     44 confess 'Third argument (', ($symbol || 'undef'),
      33        
150             ') must be PFT::Text::Symbol'
151             unless $symbol && $symbol->isa('PFT::Text::Symbol');
152              
153 15         47 my $kwd = $symbol->keyword;
154 15 50       82 if ($kwd =~ /^(?:pic|page|blog|attach|tag)$/) {
155 15         44 &_resolve_local
156             } else {
157 0         0 &_resolve_remote
158             }
159             }
160              
161             sub _resolve_local {
162 15     15   30 my($self, $node, $symbol) = @_;
163              
164 15         39 my $map = $self->map;
165 15         37 my $kwd = $symbol->keyword;
166              
167 15 100       40 if ($kwd eq 'blog') {
168             # Treated as special case since the blog query parametrization can
169             # yield more entries.
170 7         13 return &_resolve_local_blog;
171             }
172              
173             # All the following can yield only one entry. We have to return entries
174             # or an empty list.
175 8         13 my $out = do {
176 8 100       28 if ($kwd eq 'pic') {
    100          
    100          
    50          
177 3         11 $map->id_to_node('i:' . join '/', $symbol->args);
178             } elsif ($kwd eq 'attach') {
179 2         6 $map->id_to_node('a:' . join '/', $symbol->args);
180             } elsif ($kwd eq 'page') {
181 2         14 $map->id_to_node(
182             'p:' . PFT::Header::slugify(join ' ', $symbol->args)
183             );
184             } elsif ($kwd eq 'tag') {
185 1         5 $map->id_to_node(
186             't:' . PFT::Header::slugify(join ' ', $symbol->args)
187             );
188             } else {
189 0         0 confess "Unrecognized keyword $kwd";
190             }
191             };
192              
193 8 100       36 defined $out ? $out : ();
194             }
195              
196             sub _resolve_local_blog {
197 7     7   13 my($self, $node, $symbol) = @_;
198 7         12 my $map = $self->map;
199              
200 7         26 my @args = $symbol->args;
201 7         13 my $method = shift @args;
202 7 100       31 if ($method eq 'back') {
    50          
203 4 100       10 my $steps = @args ? shift(@args) : 1;
204 4 50       11 $steps > 0 or confess "Going back $steps <= 0 from $node";
205 4   100     13 while ($node && $steps-- > 0) {
206 5         19 $node = $node->prev;
207             }
208 4 100       26 defined $node ? $node : ();
209             } elsif ($method =~ /^(?:d|date)$/) {
210 3 50       13 confess "Incomplete date" if 3 > grep defined, @args;
211 3 100       11 push @args, '.*' if 3 == @args;
212 3         17 my $pattern = sprintf 'b:%04d-%02d-%02d:%s', @args;
213 3         11 my @select = grep /^$pattern$/, $map->ids;
214 3 100       187 confess 'No entry matches ', join('/', @select), "\n" unless @select;
215 2         7 $map->nodes(@select);
216             } else {
217 0           confess "Unrecognized blog lookup $method";
218             }
219             }
220              
221             sub _resolve_remote {
222 0     0     my($self, $node, $symbol) = @_;
223              
224 0           my $out;
225 0           my $kwd = $symbol->keyword;
226 0 0         if ($kwd eq 'web') {
227 0           my @args = $symbol->args;
228 0 0         if ((my $service = shift @args) eq 'ddg') {
    0          
229 0           $out = 'https://duckduckgo.com/?q=';
230 0 0         if ((my $bang = shift @args)) { $out .= "%21$bang%20" }
  0            
231 0           $out .= join '%20', @args
232             }
233             elsif ($service eq 'man') {
234 0           $out = join '/', 'http://manpages.org', @args
235             }
236             }
237              
238 0 0         unless (defined $out) {
239 0           confess 'Never implemented magic link "', $symbol->keyword, "\"\n";
240             }
241             $out
242 0           }
243              
244             =back
245              
246             =cut
247              
248             1;