blib/lib/Search/Circa/Categorie.pm | |||
---|---|---|---|
Criterion | Covered | Total | % |
statement | 9 | 120 | 7.5 |
branch | 0 | 36 | 0.0 |
condition | 0 | 24 | 0.0 |
subroutine | 3 | 19 | 15.7 |
pod | 14 | 16 | 87.5 |
total | 26 | 215 | 12.0 |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package Search::Circa::Categorie; | ||||||
2 | |||||||
3 | # module Circa::Categorie : See Circa::Indexer | ||||||
4 | # Copyright 2000 A.Barbet alian@alianwebserver.com. All rights reserved. | ||||||
5 | |||||||
6 | # $Log: Categorie.pm,v $ | ||||||
7 | # Revision 1.13 2002/08/17 18:19:02 alian | ||||||
8 | # - Minor changes to all code suite to tests | ||||||
9 | # | ||||||
10 | # Revision 1.12 2002/08/15 23:10:11 alian | ||||||
11 | # Minor changes to all code suite to tests. Try to adopt generic return | ||||||
12 | # code for all method: undef on error, 0 on no result, ... | ||||||
13 | # | ||||||
14 | # Revision 1.11 2001/10/28 12:22:37 alian | ||||||
15 | # - Ajout de la methode move_categorie | ||||||
16 | # | ||||||
17 | # Revision 1.10 2001/08/29 16:23:47 alian | ||||||
18 | # - Add get_liste_categorie_fils routine | ||||||
19 | # - Update POD documentation for new namespace | ||||||
20 | # | ||||||
21 | |||||||
22 | 12 | 12 | 5868 | use strict; | |||
12 | 33 | ||||||
12 | 450 | ||||||
23 | 12 | 12 | 2188 | use DBI; | |||
12 | 17342 | ||||||
12 | 554 | ||||||
24 | 12 | 12 | 87 | use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); | |||
12 | 29 | ||||||
12 | 32781 | ||||||
25 | require Exporter; | ||||||
26 | |||||||
27 | @ISA = qw(Exporter); | ||||||
28 | @EXPORT = qw(); | ||||||
29 | $VERSION = ('$Revision: 1.13 $ ' =~ /(\d+\.\d+)/)[0]; | ||||||
30 | |||||||
31 | #------------------------------------------------------------------------------ | ||||||
32 | # new | ||||||
33 | #------------------------------------------------------------------------------ | ||||||
34 | sub new { | ||||||
35 | 0 | 0 | 1 | my $class = shift; | |||
36 | 0 | my $self = {}; | |||||
37 | 0 | my $indexer = shift; | |||||
38 | 0 | bless $self, $class; | |||||
39 | 0 | $self->{INDEXER} = $indexer; | |||||
40 | 0 | $self->{DBH} = $indexer->{DBH}; | |||||
41 | 0 | return $self; | |||||
42 | } | ||||||
43 | |||||||
44 | #------------------------------------------------------------------------------ | ||||||
45 | # set_masque | ||||||
46 | #------------------------------------------------------------------------------ | ||||||
47 | sub set_masque { | ||||||
48 | 0 | 0 | 1 | my ($this,$compte,$id,$file)=@_; | |||
49 | 0 | my $r = $this->{DBH}->do("update ".$this->{INDEXER}->pre_tbl.$compte. | |||||
50 | "categorie set masque='$file' where id = $id"); | ||||||
51 | 0 | 0 | 0 | return ((!$r or $r eq '0E0') ? 0 : 1); | |||
52 | } | ||||||
53 | |||||||
54 | #------------------------------------------------------------------------------ | ||||||
55 | # get_masque | ||||||
56 | #------------------------------------------------------------------------------ | ||||||
57 | sub get_masque { | ||||||
58 | 0 | 0 | 1 | my ($this,$compte,$id)=@_; | |||
59 | 0 | 0 | return 0 if (!$id); | ||||
60 | 0 | my ($m) = $this->{INDEXER}->fetch_first | |||||
61 | ("select masque from ".$this->{INDEXER}->pre_tbl.$compte."categorie ". | ||||||
62 | "where id = $id"); | ||||||
63 | 0 | return $m; | |||||
64 | } | ||||||
65 | |||||||
66 | #------------------------------------------------------------------------------ | ||||||
67 | # delete | ||||||
68 | #------------------------------------------------------------------------------ | ||||||
69 | sub delete { | ||||||
70 | 0 | 0 | 1 | my ($self,$compte,$id)=@_; | |||
71 | 0 | my $pre = $self->{INDEXER}->pre_tbl.$compte; | |||||
72 | 0 | my $sth = $self->{DBH}->prepare("select id from ".$pre."links ". | |||||
73 | "where categorie=$id"); | ||||||
74 | 0 | 0 | if ($sth->execute) { | ||||
75 | # Pour chaque categorie | ||||||
76 | 0 | while (my @row = $sth->fetchrow_array) { | |||||
77 | 0 | $self->{DBH}->do("delete from ".$pre."relation where id_site = $row[0]"); | |||||
78 | } | ||||||
79 | 0 | $sth->finish; | |||||
80 | 0 | $self->{DBH}->do("delete from ".$pre."links where categorie = $id"); | |||||
81 | 0 | my $r = $self->{DBH}->do("delete from ".$pre."categorie where id = $id"); | |||||
82 | 0 | 0 | 0 | return ((!$r or $r eq '0E0') ? 0 : 1); | |||
83 | } else { | ||||||
84 | 0 | $self->{INDEXER}->trace(1,"Erreur:delete_categorie:$DBI::errstr "); |
|||||
85 | 0 | return undef; | |||||
86 | } | ||||||
87 | } | ||||||
88 | |||||||
89 | #------------------------------------------------------------------------------ | ||||||
90 | # rename | ||||||
91 | #------------------------------------------------------------------------------ | ||||||
92 | sub rename { | ||||||
93 | 0 | 0 | 1 | my ($this,$compte,$id,$nom)=@_; | |||
94 | 0 | $nom=~s/'/\\'/g; | |||||
95 | 0 | 0 | my $r = $this->{DBH}->do("update ".$this->{INDEXER}->pre_tbl.$compte. | ||||
96 | "categorie set nom='$nom' where id = $id") | ||||||
97 | || return undef; | ||||||
98 | 0 | 0 | 0 | return ((!$r or $r eq '0E0') ? 0 : 1); | |||
99 | } | ||||||
100 | |||||||
101 | #------------------------------------------------------------------------------ | ||||||
102 | # move | ||||||
103 | #------------------------------------------------------------------------------ | ||||||
104 | sub move | ||||||
105 | { | ||||||
106 | 0 | 0 | 1 | my ($this,$compte,$id1,$id2)=@_; | |||
107 | 0 | 0 | $this->{DBH}->do("update ".$this->{INDEXER}->pre_tbl.$compte."links ". | ||||
108 | "set categorie=$id2 where categorie = $id1") | ||||||
109 | || print STDERR "Erreur:$DBI::errstr \n"; |
||||||
110 | } | ||||||
111 | |||||||
112 | #------------------------------------------------------------------------------ | ||||||
113 | # move_categorie | ||||||
114 | #------------------------------------------------------------------------------ | ||||||
115 | sub move_categorie | ||||||
116 | { | ||||||
117 | 0 | 0 | 1 | my ($this,$compte,$id1,$id2)=@_; | |||
118 | 0 | 0 | $this->{DBH}->do("update ".$this->{INDEXER}->pre_tbl.$compte."categorie ". | ||||
119 | "set parent=$id2 where parent = $id1") | ||||||
120 | || print STDERR "Erreur:$DBI::errstr \n"; |
||||||
121 | } | ||||||
122 | |||||||
123 | #------------------------------------------------------------------------------ | ||||||
124 | # get_liste | ||||||
125 | #------------------------------------------------------------------------------ | ||||||
126 | sub get_liste | ||||||
127 | { | ||||||
128 | 0 | 0 | 1 | my ($self,$id,$cgi)=@_; | |||
129 | 0 | my (%tab,$tab2,$erreur); | |||||
130 | 0 | $tab2 = $self->loadAll($id); | |||||
131 | 0 | my $sth = $self->{DBH}->prepare("select count(1),categorie from ". | |||||
132 | $self->{INDEXER}->pre_tbl.$id."links ". | ||||||
133 | "group by categorie"); | ||||||
134 | 0 | 0 | $sth->execute() || return; | ||||
135 | 0 | while (my @row=$sth->fetchrow_array) {$tab{$row[1]}=$row[0];} | |||||
0 | |||||||
136 | 0 | $sth->finish; | |||||
137 | 0 | 0 | if (!$$tab2{0}) {$$tab2{0}[0]='Racine';$$tab2{0}[1]=0;} | ||||
0 | |||||||
0 | |||||||
138 | 0 | 0 | foreach (keys %$tab2) | ||||
0 | |||||||
139 | {$tab{$_}= $self->getParent($_,%$tab2)." (".($tab{$_}||0).")";} | ||||||
140 | 0 | my @l =sort { $tab{$a} cmp $tab{$b} } keys %tab; | |||||
0 | |||||||
141 | 0 | return (\@l,\%tab); | |||||
142 | } | ||||||
143 | |||||||
144 | #------------------------------------------------------------------------------ | ||||||
145 | # get | ||||||
146 | #------------------------------------------------------------------------------ | ||||||
147 | sub get | ||||||
148 | { | ||||||
149 | 0 | 0 | 1 | my ($self,$rep,$responsable) = @_; | |||
150 | 0 | my $ori = $self->{INDEXER}->host_indexed; | |||||
151 | 0 | $rep=~s/$ori//g; | |||||
152 | 0 | my @l = split(/\//,$rep); | |||||
153 | 0 | my $parent=0; | |||||
154 | 0 | my $regexp = qr/\.(htm|html|txt|java)$/; | |||||
155 | 0 | foreach (@l) | |||||
156 | { | ||||||
157 | 0 | 0 | 0 | if (($_) && ($_ !~ $regexp)) | |||
0 | |||||||
158 | {$parent = $self->create($_,$parent,$responsable);} | ||||||
159 | } | ||||||
160 | 0 | return $parent; | |||||
161 | } | ||||||
162 | |||||||
163 | #------------------------------------------------------------------------------ | ||||||
164 | # create | ||||||
165 | #------------------------------------------------------------------------------ | ||||||
166 | sub create { | ||||||
167 | 0 | 0 | 1 | my ($self,$nom,$parent,$responsable)=@_; | |||
168 | 0 | $nom=ucfirst($nom); | |||||
169 | 0 | $nom=~s/_/ /g; | |||||
170 | 0 | $nom=~s/'/\\'/g; | |||||
171 | 0 | my $id; | |||||
172 | 0 | 0 | if ($nom) { | ||||
173 | 0 | ($id) = $self->{INDEXER}->fetch_first | |||||
174 | ("select id from ".$self->{INDEXER}->pre_tbl.$responsable."categorie ". | ||||||
175 | "where nom='$nom' and parent=$parent"); | ||||||
176 | } | ||||||
177 | 0 | 0 | 0 | if ((!$id) && (defined $parent)) { | |||
178 | 0 | my $sth = $self->{DBH}->prepare("insert into ". | |||||
179 | $self->{INDEXER}->pre_tbl.$responsable. | ||||||
180 | "categorie(nom,parent) ". | ||||||
181 | "values('$nom',$parent)"); | ||||||
182 | 0 | 0 | if ($sth->execute) { | ||||
183 | 0 | $sth->finish; | |||||
184 | 0 | $id = $sth->{'mysql_insertid'}; | |||||
185 | } | ||||||
186 | 0 | else { return undef; } | |||||
187 | } | ||||||
188 | 0 | 0 | return $id || 0; | ||||
189 | } | ||||||
190 | |||||||
191 | #------------------------------------------------------------------------------ | ||||||
192 | # auto | ||||||
193 | #------------------------------------------------------------------------------ | ||||||
194 | sub auto | ||||||
195 | { | ||||||
196 | 0 | 0 | 1 | my ($self,$idp) = @_; | |||
197 | 0 | my @tab = $self->{INDEXER}->fetch_first | |||||
198 | ("select categorieAuto from ".$self->{INDEXER}->pre_tbl."responsable ". | ||||||
199 | "where id=$idp"); | ||||||
200 | 0 | return $tab[0]; | |||||
201 | } | ||||||
202 | |||||||
203 | #------------------------------------------------------------------------------ | ||||||
204 | # loadAll | ||||||
205 | #------------------------------------------------------------------------------ | ||||||
206 | sub loadAll { | ||||||
207 | 0 | 0 | 1 | my ($self,$idr)=@_; | |||
208 | 0 | my %tab; | |||||
209 | 0 | my $sth = $self->{DBH}->prepare | |||||
210 | ("select id,nom,parent from ".$self->{INDEXER}->pre_tbl.$idr."categorie"); | ||||||
211 | #print "requete:$requete\n"; | ||||||
212 | 0 | 0 | if ($sth->execute()) { | ||||
213 | 0 | while (my ($id,$nom,$parent)=$sth->fetchrow_array) { | |||||
214 | 0 | $tab{$id}[0]=$nom; | |||||
215 | 0 | $tab{$id}[1]=$parent; | |||||
216 | } | ||||||
217 | 0 | $tab{0}[1] = 0 ; | |||||
218 | 0 | $tab{0}[0] = "Racine du site"; | |||||
219 | 0 | return \%tab; | |||||
220 | } else { | ||||||
221 | 0 | $self->{INDEXER}->trace(1,"Circa::Categorie->loadAll $DBI::errstr\n"); | |||||
222 | 0 | return undef; | |||||
223 | } | ||||||
224 | } | ||||||
225 | |||||||
226 | #------------------------------------------------------------------------------ | ||||||
227 | # getParent | ||||||
228 | #------------------------------------------------------------------------------ | ||||||
229 | sub getParent | ||||||
230 | { | ||||||
231 | 0 | 0 | 1 | my ($self,$id,%tab)=@_; | |||
232 | 0 | my $parent; | |||||
233 | 0 | 0 | 0 | if ($tab{$id}[1] and $tab{$id}[0]) | |||
0 | |||||||
234 | {$parent = $self->getParent($tab{$id}[1],%tab);} | ||||||
235 | 0 | 0 | if (!$tab{$id}[0]) {$tab{$id}[0]='Home';} | ||||
0 | |||||||
236 | 0 | $parent.=">$tab{$id}[0]"; | |||||
237 | 0 | return $parent; | |||||
238 | } | ||||||
239 | |||||||
240 | |||||||
241 | #------------------------------------------------------------------------------ | ||||||
242 | # get_liste_categorie_fils | ||||||
243 | #------------------------------------------------------------------------------ | ||||||
244 | sub get_liste_categorie_fils | ||||||
245 | { | ||||||
246 | 0 | 0 | 1 | my ($self,$id,$idr)=@_; | |||
247 | sub get_liste_categorie_fils_inner | ||||||
248 | { | ||||||
249 | 0 | 0 | 0 | my ($id,%tab)=@_; | |||
250 | 0 | my (@l,@l2); | |||||
251 | 0 | 0 | foreach my $key (keys %tab) {push (@l,$key) if ($tab{$key}[1]==$id);} | ||||
0 | |||||||
252 | 0 | foreach (@l) {push(@l2,get_liste_categorie_fils_inner($_,%tab));} | |||||
0 | |||||||
253 | 0 | return (@l,@l2); | |||||
254 | } | ||||||
255 | 0 | my $tab = $self->loadAll($idr); | |||||
256 | 0 | return get_liste_categorie_fils_inner($id,%$tab); | |||||
257 | } | ||||||
258 | |||||||
259 | #------------------------------------------------------------------------------ | ||||||
260 | # get_link | ||||||
261 | #------------------------------------------------------------------------------ | ||||||
262 | sub get_link | ||||||
263 | { | ||||||
264 | 0 | 0 | 0 | my ($self,$script_name,$no_categorie,$id,$first) = @_; | |||
265 | 0 | 0 | if (defined($first)) | ||||
0 | |||||||
266 | 0 | {return $script_name."?categorie=$no_categorie&id=$id&first=$first";} | |||||
267 | else {return $script_name."?categorie=$no_categorie&id=$id";} | ||||||
268 | } | ||||||
269 | |||||||
270 | #------------------------------------------------------------------------------ | ||||||
271 | # POD DOCUMENTATION | ||||||
272 | #------------------------------------------------------------------------------ | ||||||
273 | |||||||
274 | =head1 NAME | ||||||
275 | |||||||
276 | Search::Circa::Categorie - provide functions to manage categorie of Circa | ||||||
277 | |||||||
278 | =head1 SYNOPSIS | ||||||
279 | |||||||
280 | my $indexer = new Search::Circa::Indexer; | ||||||
281 | # ... | ||||||
282 | # Delete categorie 2 for account 1 | ||||||
283 | $indexer->categorie->delete(1,2); | ||||||
284 | ... | ||||||
285 | |||||||
286 | =head1 DESCRIPTION | ||||||
287 | |||||||
288 | This module provide several function to manage categorie of Circa. | ||||||
289 | |||||||
290 | =head1 VERSION | ||||||
291 | |||||||
292 | $Revision: 1.13 $ | ||||||
293 | |||||||
294 | =head1 Public Class Interface | ||||||
295 | |||||||
296 | =over | ||||||
297 | |||||||
298 | =item new($indexer_instance) | ||||||
299 | |||||||
300 | Create a new Search::Circa::Categorie object with indexer instance properties | ||||||
301 | |||||||
302 | =item set_masque($compte,$id,$file) | ||||||
303 | |||||||
304 | Set a different masque ($file) for browse this categorie $id for account | ||||||
305 | |||||||
306 | =item get_masque($compte,$id) | ||||||
307 | |||||||
308 | Return path of masque for this categorie for account | ||||||
309 | |||||||
310 | =item delete($compte,$id) | ||||||
311 | |||||||
312 | Drop categorie $id for account $compte. (All url and words for this account) | ||||||
313 | |||||||
314 | Supprime la categorie $id pour le compte de responsable $compte et | ||||||
315 | tous les liens et relation qui sont dans cette categorie | ||||||
316 | |||||||
317 | =item rename($compte,$id,$nom) | ||||||
318 | |||||||
319 | Rename category $id for account $compte in $name | ||||||
320 | |||||||
321 | Renomme la categorie $id pour le compte $compte en $nom | ||||||
322 | |||||||
323 | =item move($compte,$id1,$id2) | ||||||
324 | |||||||
325 | Move url for account $compte from one categorie $id1 to another $id2 | ||||||
326 | |||||||
327 | =item move_categorie($compte,$id1,$id2) | ||||||
328 | |||||||
329 | Move categories for account $compte from one categorie $id1 to another $id2 | ||||||
330 | |||||||
331 | =item get_liste($id,$cgi) | ||||||
332 | |||||||
333 | Return two references to a list and a hash. | ||||||
334 | The hash have name of categorie as key, and number of site in this categorie | ||||||
335 | as value. The list is ordered keys of hash. | ||||||
336 | |||||||
337 | =item get($rep,$responsable) | ||||||
338 | |||||||
339 | Return id of directory $rep. If directory didn't exist, function create it. | ||||||
340 | |||||||
341 | =item create($nom,$parent,$responsable) | ||||||
342 | |||||||
343 | Create categorie $nom with parent $parent for account $responsable | ||||||
344 | |||||||
345 | =item auto($idp) | ||||||
346 | |||||||
347 | Return 1 if account $idp want auto categorie. 0 else. | ||||||
348 | |||||||
349 | =item loadAll($account) | ||||||
350 | |||||||
351 | Return reference to hash with all categorie for account $account. | ||||||
352 | Hash use id as key, and array as value. Array has two field, first | ||||||
353 | name of categorie, second id of father categorie | ||||||
354 | |||||||
355 | =item get_liste_categorie_fils($id,$idr) | ||||||
356 | |||||||
357 | $id : Id de la categorie parent | ||||||
358 | $idr : Site selectionne | ||||||
359 | |||||||
360 | Retourne la liste des categories fils de $id dans le site $idr | ||||||
361 | |||||||
362 | =back | ||||||
363 | |||||||
364 | =head1 Private Class Interface | ||||||
365 | |||||||
366 | =over | ||||||
367 | |||||||
368 | =item getParent($id,%tab) | ||||||
369 | |||||||
370 | Rend la chaine correspondante à la catégorie $id avec ses rubriques parentes | ||||||
371 | |||||||
372 | =back | ||||||
373 | |||||||
374 | =head1 AUTHOR | ||||||
375 | |||||||
376 | Alain BARBET alian@alianwebserver.com | ||||||
377 | |||||||
378 | =cut |