home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Cache.pm < prev    next >
Encoding:
Perl POD Document  |  2003-09-16  |  4.0 KB  |  164 lines
  1. # -*- perl -*-
  2.  
  3. #
  4. # $Id: Cache.pm,v 1.2 2003/09/16 18:16:45 joker Exp $
  5. # Author: Slaven Rezic
  6. #
  7. # Copyright (C) 2002 Slaven Rezic. All rights reserved.
  8. # This program is free software; you can redistribute it and/or
  9. # modify it under the same terms as Perl itself.
  10. #
  11. # Mail: slaven@rezic.de
  12. # WWW:  http://www.rezic.de/eserte/
  13. #
  14.  
  15. package Tk::Pod::Cache;
  16. use strict;
  17. use vars qw($VERSION $MAX_CACHE %CACHE);
  18.  
  19. BEGIN {  # Make a DEBUG constant very first thing...
  20.   if(defined &DEBUG) {
  21.   } elsif(($ENV{'TKPODDEBUG'} || '') =~ m/^(\d+)/) { # untaint
  22.     my $debug = $1;
  23.     *DEBUG = sub () { $debug };
  24.   } else {
  25.     *DEBUG = sub () {0};
  26.   }
  27. }
  28.  
  29. $VERSION = sprintf("%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/);
  30.  
  31. $MAX_CACHE = 20; # documents # XXX not yet used, LRU etc...
  32.  
  33. sub add_to_cache {
  34.     my($w, $pod) = @_;
  35.     $pod = $w->cget(-path) if !defined $pod;
  36.     return if !defined $pod;
  37.     return if exists $CACHE{$pod}; # XXX check for recentness
  38.     DEBUG and warn "Add contents for $pod to cache.\n";
  39.     $CACHE{$pod} = $w->dump_contents;
  40. }
  41.  
  42. sub get_from_cache {
  43.     my($w, $pod) = @_;
  44.     $pod = $w->cget(-path) if !defined $pod;
  45.     return 0 if !exists $CACHE{$pod};
  46.     # XXX check for recentness
  47.     $w->delete("1.0", "end");
  48.     DEBUG and warn "Restore contents for $pod from cache.\n";
  49.     $w->restore_contents($CACHE{$pod});
  50.     1;
  51. }
  52.  
  53. sub delete_from_cache {
  54.     my($w, $pod) = @_;
  55.     $pod = $w->cget(-path) if !defined $pod;
  56.     return if !defined $pod;
  57.     DEBUG and warn "Delete contents for $pod from cache.\n";
  58.     delete $CACHE{$pod};
  59. }
  60.  
  61. sub clear_cache {
  62.     %CACHE = ();
  63. }
  64.  
  65. sub dump_contents {
  66.     my $w = shift;
  67.     my @dump = $w->dump('-all', "1.0", "end");
  68.     my %tags_def;
  69.     foreach my $tag ($w->tagNames) {
  70.     # XXX check for used/existing tags missing
  71.     my @tag_def;
  72.     foreach my $item ($w->tagConfigure($tag)) {
  73.         my $value  = $item->[4];
  74.         my $option = $item->[0];
  75.         push @tag_def, $option, $value;
  76.     }
  77.     $tags_def{$tag} = \@tag_def;
  78.     }
  79.     return {Dump => \@dump,
  80.         Tags => \%tags_def,
  81.         Sections => $w->{'sections'},
  82.         PodTitle => $w->{'pod_title'},
  83.        };
  84. }
  85.  
  86. sub restore_contents {
  87.     my($w, $def) = @_;
  88.  
  89.     my $dumpref = $def->{Dump};
  90.     my $tagref  = $def->{Tags};
  91.     $w->{'sections'}  = $def->{Sections};
  92.     $w->{'pod_title'} = $def->{PodTitle};
  93.  
  94.     $w->toplevel->title( "Tkpod: " . $w->{'pod_title'} . " (restoring)");
  95.     $w->idletasks;
  96.     # XXX  Is it bad form to manipulate the top level?
  97.  
  98.     my $process_no;
  99.     $w->{ProcessNo}++;
  100.     $process_no = $w->{ProcessNo};
  101.  
  102.     if ($tagref) {
  103.     while(my($tag,$def) = each %$tagref) {
  104.         #XXX tagDelete?
  105.         $w->tagConfigure($tag, @$def);
  106.     }
  107.     }
  108.  
  109.     my @taglist;
  110.  
  111.     my $last_update = Tk::timeofday();
  112.     for(my $i=0; $i<$#$dumpref; $i+=3) {
  113.     my($key, $val, $index) = @{$dumpref}[$i..$i+2];
  114.     if      ($key eq 'text') {
  115.         $w->insert($index, $val, [@taglist]);
  116.     } elsif ($key eq 'tagon') {
  117.         unshift @taglist, $val;
  118.     } elsif ($key eq 'tagoff') {
  119.         my $j;
  120.         for (0 .. $#taglist) {
  121.         if ($taglist[$_] eq $val) {
  122.             $j = $_;
  123.             last;
  124.         }
  125.         }
  126.         if (defined $j) {
  127.         splice @taglist, $j, 1;
  128.         }
  129.         $w->tag('remove', $val, 'insert');
  130.     } elsif ($key eq 'mark') {
  131.         $w->markSet($val, $index); # XXX ->see() to current or insert?
  132.     } elsif ($key eq 'windows') {
  133.         die "not yet supported";
  134.     } elsif ($key eq 'image') {
  135.         die "not yet supported";
  136.     } elsif ($key eq 'imgdef') {
  137.         die "not yet supported";
  138.     }
  139.  
  140.     if (Tk::timeofday() > $last_update+0.5) { # XXX make configurable
  141.         $w->update;
  142.         $last_update = Tk::timeofday();
  143.         do { warn "ABORT!"; return } if $w->{ProcessNo} != $process_no;
  144.     }
  145.     }
  146.  
  147.     $w->parent->add_section_menu if $w->parent->can('add_section_menu');
  148.     $w->Callback('-poddone', $w->cget(-file));
  149.  
  150.     $w->toplevel->title( "Tkpod: " . $w->{'pod_title'});
  151. }
  152.  
  153. 1;
  154.  
  155. __END__
  156.  
  157. =head1 NAME
  158.  
  159. Tk::Pod::Cache - internal Tk-Pod module for cache control
  160.  
  161. =head1 DESCRIPTION
  162.  
  163. No user-servicable parts here.
  164.