/[A3C]/lib/Strix.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Annotation of /lib/Strix.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 216 - (hide annotations)
Fri Jun 20 21:49:16 2008 UTC (15 years, 9 months ago) by dpavlin
File size: 9482 byte(s)
put cache all over the place and simplify it
1 dpavlin 167 package Strix;
2    
3     use strict;
4     use warnings;
5    
6 dpavlin 168 use base qw(Jifty::Object Class::Accessor::Fast);
7 dpavlin 174 __PACKAGE__->mk_accessors( qw(instance uid) );
8 dpavlin 167
9     use DBI;
10     use Data::Dump qw/dump/;
11 dpavlin 168 use Carp qw/confess/;
12 dpavlin 181 use Jifty;
13 dpavlin 167
14 dpavlin 213 use File::Slurp;
15     use JSON::XS;
16     use Carp qw/confess/;
17 dpavlin 216 use URI::Escape;
18 dpavlin 213
19 dpavlin 168 our $debug = 0;
20    
21 dpavlin 167 =head1 NAME
22    
23     Strix
24    
25     =head1 METHODS
26    
27 dpavlin 168 =head2 new
28    
29 dpavlin 174 my $strix = Strix->new({ instance => 'os-test0604-zg' });
30 dpavlin 168
31 dpavlin 167 =head2 dbh
32    
33 dpavlin 174 my $dbh = Strix->dbh( $strix_instance );
34 dpavlin 167
35 dpavlin 168 my $dbh = $strix->dbh;
36    
37 dpavlin 167 =cut
38    
39 dpavlin 174 our $instance_dbh;
40 dpavlin 193 our @instances_active;
41 dpavlin 171
42 dpavlin 167 sub dbh {
43     my $self = shift;
44    
45 dpavlin 177 my $instance = shift || ref($self) && $self->instance || confess "no instance";
46 dpavlin 167
47 dpavlin 174 return $instance_dbh->{$instance} if $instance_dbh->{$instance};
48 dpavlin 171
49 dpavlin 167 my $config = Jifty->config->app('strix') or die "need strix config";
50     my $database = $config->{database} or die "no strix.database in config";
51    
52     Jifty->log->debug("using config ", dump( $database ));
53    
54     my $dsn =
55 dpavlin 174 'DBI:Pg:dbname=' . $instance .
56 dpavlin 167 ';host=' . $database->{host} .
57     ';port=' . $database->{port};
58    
59 dpavlin 174 Jifty->log->info("Connect to instance $instance with dsn $dsn");
60 dpavlin 167
61 dpavlin 185 my $dbh = DBI->connect( $dsn, $database->{user}, $database->{passwd} ) or die "$DBI::errstr\n";
62 dpavlin 167
63 dpavlin 188 # force database to send us back UTF-8 no metter what it's encoding
64     $dbh->do("set client_encoding='utf-8'");
65     $dbh->{pg_enable_utf8} = 1;
66    
67 dpavlin 174 $instance_dbh->{$instance} = $dbh;
68 dpavlin 193 push @instances_active, $instance;
69 dpavlin 171
70 dpavlin 193 if ( $#instances_active > 5 ) {
71     my $i = shift @instances_active;
72     warn "## remove connection to instance $instance\n";
73     delete( $instance_dbh->{$i} );
74     }
75    
76 dpavlin 174 warn "## instance_dbh = ",dump( $instance_dbh ) if $debug;
77 dpavlin 171
78 dpavlin 167 return $dbh;
79     }
80    
81 dpavlin 168 =head2 category
82    
83     my $category = Strix->category( $url );
84    
85     =cut
86    
87     sub category {
88     my $self = shift;
89    
90     my $url = shift || confess "no url";
91    
92 dpavlin 216 my $data = $self->read_cache( uri_escape($url) );
93     return $data if $data;
94    
95 dpavlin 168 # sysinc/profiles.php
96     my $sth = $self->dbh->prepare(qq{
97     SELECT kategorija.*, lang.langid, lang.locale, template.tfilename, template.tflags, site.naziv as sitename, site.admin_mail, site.address, site.root as site_root, getPathFromNav(kategorija.id) as path, site.ordstr as site_ordstr FROM kategorija, template, site, lang WHERE kategorija.url = ? AND kategorija.template_id = template.id AND kategorija.site_id = site.id AND lang.id = kategorija.lang
98     });
99     $sth->execute($url);
100    
101 dpavlin 216 my $category = $sth->fetchrow_hashref() or die "can't fetch category $url from instance ",$self->instance,"\n";
102     $self->write_cache( $category, uri_escape($url) );
103 dpavlin 168 return $category;
104     }
105    
106     =head2 layout
107    
108     my $layout = $strix->layout( $url );
109    
110     =cut
111    
112     sub layout {
113     my $self = shift;
114    
115     my $url = shift || confess "no url";
116    
117 dpavlin 216 my $data = $self->read_cache( uri_escape($url) );
118     return $data if $data;
119    
120 dpavlin 168 my $dbh = $self->dbh;
121     my $category = $self->category( $url );
122    
123     my $sth = $dbh->prepare(qq{
124     SELECT template.tfilename, template.tflags FROM template WHERE id = ?
125     });
126     $sth->execute( $category->{template_id} );
127    
128     my $template = $sth->fetchrow_hashref() or die "can't fetch template";
129    
130     warn "template = ",dump( $template ) if $debug;
131    
132     my $page;
133     warn "### free layout...\n" if $debug;
134    
135     # index.php
136     $sth = $dbh->prepare(qq{
137     SELECT layout_id, module_id, pozicija, module_args, name, fname, notitle, class_name
138     FROM pre_layout, modules
139     WHERE id=module_id AND ? = template_id AND redoslijed >= 0
140     ORDER BY redoslijed DESC
141     });
142     $sth->execute( $category->{template_id} );
143    
144 dpavlin 173 sub module_args {
145     my $row = shift;
146     return undef unless $row->{module_args};
147     my $args;
148     foreach my $a ( split(/\&/, $row->{module_args} ) ) {
149     $args->{$1} = $2 if $a =~ m/^(.+)=(.+)$/;
150     }
151     return $args;
152     }
153    
154 dpavlin 168 while (my $row = $sth->fetchrow_hashref() ) {
155     warn dump( $row ) if $debug;
156 dpavlin 173 push @{ $page->{free} }, { $row->{name} => module_args( $row ) };
157 dpavlin 168 }
158    
159     warn "### pre layout...\n" if $debug;
160    
161     $sth = $dbh->prepare(qq{
162     SELECT
163     l.id as layout_id, l.user_id, l.kategorija_id, l.module_id, l.pozicija, l.redoslijed, l.module_args, l.state, l.notitle,
164     m.name, m.fname, m.hidden, m.nocache, m.pos, m.class_name,
165     acl_module.acl_register_id
166     FROM layout as l, modules as m LEFT JOIN acl_module ON (acl_module.modules_id = m.id)
167     WHERE l.user_id=?
168     AND l.kategorija_id=?
169     AND m.id=l.module_id
170     ORDER BY pozicija,redoslijed DESC
171     });
172     $sth->execute( 1, $category->{id} );
173    
174     while (my $row = $sth->fetchrow_hashref() ) {
175     warn dump( $row ) if $debug;
176 dpavlin 173 push @{ $page->{pre}->{ $row->{pos} } }, { $row->{name} => module_args( $row ) };
177 dpavlin 168 }
178    
179     warn "### post layout...\n" if $debug;
180    
181     $sth = $dbh->prepare(qq{
182     SELECT layout_id, module_id, pozicija, module_args, name, notitle
183     FROM pre_layout, modules
184     WHERE id=module_id AND ? = template_id AND redoslijed < 0
185     ORDER BY redoslijed DESC
186     });
187     $sth->execute( $category->{template_id} );
188    
189     while (my $row = $sth->fetchrow_hashref() ) {
190     warn dump( $row ) if $debug;
191 dpavlin 173 push @{ $page->{post}->{ $row->{pozicija} } }, { $row->{name} => module_args( $row ) };
192 dpavlin 168 }
193    
194 dpavlin 216 $self->write_cache( $page, uri_escape($url) );
195    
196 dpavlin 168 return $page;
197    
198     }
199    
200 dpavlin 193 =head2 sites
201 dpavlin 169
202 dpavlin 193 my @sites = $strix->sites;
203 dpavlin 169
204     =cut
205    
206 dpavlin 193 sub sites {
207 dpavlin 169 my $self = shift;
208    
209 dpavlin 216 my @sites = $self->read_cache;
210     return @sites if @sites;
211 dpavlin 169
212 dpavlin 193 my $sth = $self->dbh->prepare(
213     "SELECT *, coalesce(( length(ordstr)/3 ) - 1,0) AS depth FROM site ORDER BY ordstr"
214     );
215     $sth->execute;
216 dpavlin 169
217     while (my $row = $sth->fetchrow_hashref() ) {
218 dpavlin 193 push @sites, $row;
219 dpavlin 169 }
220    
221 dpavlin 216 $self->write_cache( \@sites );
222    
223 dpavlin 193 return @sites;
224 dpavlin 169 }
225    
226     =head2 site_navigation
227    
228     my $navigation = $strix->site_navigation( $site_id, $uid );
229    
230     =cut
231    
232     sub site_navigation {
233     my $self = shift;
234    
235     my ( $site_id, $uid ) = @_;
236    
237     $uid ||= 1; # anonymous
238     # $uid ||= 2; # admin
239    
240 dpavlin 216 my $data = $self->read_cache( $site_id, $uid );
241     return $data if $data;
242 dpavlin 213
243 dpavlin 169 my $sth = $self->dbh->prepare(
244     "SELECT kategorija.*, ((length(prikaz)+length(coalesce(ordstr,'')))/3)-1 as depth FROM kategorija JOIN navigacija ON (kategorija.id = kategorija_id), site WHERE site_id = ? AND site.id = site_id AND userCanDoOnObject(?, 1, 'kats', kategorija.id) ORDER BY prikaz");
245     $sth->execute( $site_id, $uid );
246    
247     Jifty->log->debug("site $site_id has ", $sth->rows, " categories for uid $uid");
248    
249     my $navigation = [];
250    
251     my @pos = ( 0 );
252    
253     while (my $kat = $sth->fetchrow_hashref() ) {
254     warn "# kat = ",dump( $kat ) if $debug;
255 dpavlin 193 if ( ! $kat->{depth} ) {
256     Jifty->log->error("depth increased to 1 in ",dump( $kat ));
257     $kat->{depth} = 1;
258     }
259 dpavlin 169
260     my $node = { type => 'category' };
261     foreach my $c ( qw/naziv url/ ) {
262     $node->{$c} = $kat->{$c};
263     }
264    
265     my $depth = $kat->{depth};
266 dpavlin 182 if ( ! defined $pos[ $depth - 2 ] ) {
267     warn "FIXING CATEGORY: ",dump( $kat );
268     $node->{class} = "error";
269     $depth--;
270     }
271 dpavlin 169 @pos = splice( @pos, 0, $depth );
272     $pos[ $depth - 1 ]++;
273    
274 dpavlin 173 warn "## category depth = $depth pos = ",dump( @pos ) if $debug;
275 dpavlin 169
276     my $code = '$navigation';
277     map { $code .= '->[' . ( $_ - 1 ) . ']->{children}' } @pos;
278     $code =~ s/->{children}$//;
279 dpavlin 173 warn "## category code: $code\n" if $debug;
280 dpavlin 169 eval $code . '= $node';
281     if ( $@ ) {
282     warn "SKIPPED CATEGORY: $@ ",dump( $kat );
283     next;
284     }
285    
286     my $sth_ms = $self->dbh->prepare(
287     "SELECT
288     multistatic.id, multistatic.title, multistatic.kname,
289     multistatic_navigation.kategorija_id, multistatic_navigation.prikaz,
290     (LENGTH(multistatic_navigation.prikaz)/3) AS depth
291     FROM multistatic, multistatic_navigation
292     WHERE multistatic.id = multistatic_navigation.multistatic_id
293     AND multistatic_navigation.prikaz != ''
294     AND multistatic_navigation.kategorija_id = ?
295     AND multistatic.title != ''
296     ORDER BY multistatic_navigation.prikaz");
297     $sth_ms->execute( $kat->{id} );
298    
299     if ( my $rows = $sth_ms->rows ) {
300     Jifty->log->debug("$site_id has $rows multistatic pages");
301    
302     while (my $ms = $sth_ms->fetchrow_hashref() ) {
303     warn "# ms = ",dump( $ms ) if $debug;
304    
305     my $node = {
306     naziv => $ms->{title},
307     url => $kat->{url} . '?ms_nav=' . $ms->{prikaz},
308     type => 'multistatic',
309     };
310    
311     my $ms_depth = $ms->{depth} + $depth;
312     my $p = $pos[ $ms_depth - 1 ]++;
313 dpavlin 173 warn "## multistatic depth = $ms_depth pos = ",dump( @pos ) if $debug;
314 dpavlin 169
315     my $ms_code = $code . '->{children}->[ ' . $p . '] = $node';
316 dpavlin 173 warn "## multistatic code: $ms_code\n" if $debug;
317 dpavlin 169 eval $ms_code;
318     if ( $@ ) {
319     warn "SKIPPED MULTISTATIC: $@ ",dump( $ms );
320     next;
321     }
322     }
323     }
324    
325     }
326    
327 dpavlin 216 $self->write_cache( $navigation, $site_id, $uid );
328 dpavlin 213
329 dpavlin 169 return $navigation;
330    
331     }
332    
333 dpavlin 213 =head2 cache_path
334    
335 dpavlin 216 Generate unique name for specified values
336 dpavlin 213
337 dpavlin 216 my $path = $strix->cache_path( $var, ... );
338    
339     Variables have to be path-safe (e.g. use C<uri_encode> if needed)
340    
341 dpavlin 213 =cut
342    
343     sub cache_path {
344     my $self = shift;
345    
346 dpavlin 216 #warn "# cache_path",dump( @_ );
347 dpavlin 213
348     my $path = Jifty::Util->absolute_path( 'var/strix' );
349    
350     if ( ! -e $path ) {
351     mkdir $path || die "can't create $path: $!";
352     }
353    
354 dpavlin 216 #warn "## caller = ",dump( (caller(2))[3] );
355     my $uid = (caller(2))[3];
356     $uid =~ s/^[^:]+:://;
357     $uid .= '-' . join('-', @_) if @_;
358     $uid .= '.js';
359    
360     return $path . '/' . $self->instance . '-' . $uid;
361 dpavlin 213 }
362    
363     =head2 write_cache
364    
365 dpavlin 216 write_cache( $data, $key_var, ... );
366 dpavlin 213
367     =cut
368    
369     sub write_cache {
370     my $self = shift;
371     my $data = shift || confess "no data?";
372     my $path = $self->cache_path( @_ );
373     write_file( $path, encode_json( $data )) || die "can't save into $path: $!";
374     }
375    
376     =head2 read_cache
377    
378     my $data = read_cache( 'format-%d', $var ... );
379    
380     =cut
381    
382     sub read_cache {
383     my $self = shift;
384     my $path = $self->cache_path( @_ );
385     return unless -e $path;
386 dpavlin 216 #warn "# read_cache( $path )";
387 dpavlin 213 return decode_json( read_file( $path ) ) || die "can't read $path: $!";
388     }
389    
390 dpavlin 167 1;

  ViewVC Help
Powered by ViewVC 1.1.26