This file is indexed.

/usr/share/perl5/Rose/DB/Cache.pm is in librose-db-perl 0.775-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
package Rose::DB::Cache;

use strict;

use base 'Rose::Object';

use Scalar::Util qw(refaddr);
use Rose::DB::Cache::Entry;

our $VERSION = '0.755';

our $Debug = 0;

use Rose::Class::MakeMethods::Generic
(
  inheritable_scalar =>
  [
    'entry_class',
    '_default_use_cache_during_apache_startup',
  ],
);

__PACKAGE__->entry_class('Rose::DB::Cache::Entry');
__PACKAGE__->default_use_cache_during_apache_startup(0);

our($MP2_Is_Child, $Apache_Has_Started);

sub default_use_cache_during_apache_startup
{
  my($class) = shift;
  return $class->_default_use_cache_during_apache_startup($_[0] ? 1 : 0)  if(@_);
  return  $class->_default_use_cache_during_apache_startup;
}

sub use_cache_during_apache_startup
{
  my($self) = shift;

  return $self->{'use_cache_during_apache_startup'} = $_[0] ? 1 : 0  if(@_);

  if(defined $self->{'use_cache_during_apache_startup'})
  {
    return $self->{'use_cache_during_apache_startup'};
  }
  else
  {
    return $self->{'use_cache_during_apache_startup'} = 
      ref($self)->default_use_cache_during_apache_startup;
  }
}

sub prepare_for_apache_fork
{
  my($self) = shift;

  foreach my $entry ($self->db_cache_entries)
  {
    if($entry->created_during_apache_startup)
    {
      my $db = $entry->db;
      $Debug && warn "$$ Disconnecting and undef-ing ", $db->dbh, " contained in $db";
      $db->dbh->disconnect;
      $db->dbh(undef);
      $db = undef;
      $Debug && warn "$$ Deleting cache entry for $db";
      delete $self->{'cache'}{$entry->key};
    }
  }
}

sub build_cache_key
{
  my($class, %args) = @_;
  return join("\0", $args{'domain'}, $args{'type'});
}

QUIET:
{
  no warnings 'uninitialized';
  use constant MOD_PERL_1     => ($ENV{'MOD_PERL'} && !$ENV{'MOD_PERL_API_VERSION'})     ? 1 : 0;
  use constant MOD_PERL_2     => ($ENV{'MOD_PERL'} && $ENV{'MOD_PERL_API_VERSION'} == 2) ? 1 : 0;
  use constant APACHE_DBI     => ($INC{'Apache/DBI.pm'} || $Apache::DBI::VERSION)        ? 1 : 0;
  use constant APACHE_DBI_MP2 => (APACHE_DBI && MOD_PERL_2) ? 1 : 0;
  use constant APACHE_DBI_MP1 => (APACHE_DBI && MOD_PERL_1) ? 1 : 0;
}

sub db_cache_entries
{
  my($self) = shift;
  return wantarray ? values %{$self->{'cache'} || {}} : 
                     [ values %{$self->{'cache'} || {}} ];
}

sub db_cache_keys
{
  my($self) = shift;
  return wantarray ? keys %{$self->{'cache'} || {}} : 
                     [ keys %{$self->{'cache'} || {}} ];
}

sub get_db
{
  my($self) = shift;

  my $key = $self->build_cache_key(@_);

  if(my $entry = $self->{'cache'}{$key})
  {
    if(my $db = $entry->db)
    {
      $self->prepare_db($db, $entry);
      return $db;
    }
  }

  return undef;
}

sub set_db
{
  my($self, $db) = @_;

  my $key = 
    $self->build_cache_key(domain => $db->domain, 
                           type   => $db->type,
                           db     => $db);

  my $entry = ref($self)->entry_class->new(db => $db, key => $key);

  # Don't cache anything during apache startup if use_cache_during_apache_startup
  # is false.  Weird conditional structure is meant to encourage code elimination
  # thanks to the lone constants in the if/elsif conditions.
  if(MOD_PERL_1)
  {
    if($Apache::Server::Starting)
    {
      if($self->use_cache_during_apache_startup)
      {
        $entry->created_during_apache_startup(1);
        $entry->prepared(0);
      }
      else
      {
        $Debug && warn "Refusing to cache $db during apache server start-up ",
                       "because use_cache_during_apache_startup is false";

        return $db;
      }
    }
  }

  if(MOD_PERL_2)
  {
    if(!$MP2_Is_Child)
    {
      if($self->use_cache_during_apache_startup)
      {
        $entry->created_during_apache_startup(1);
        $entry->prepared(0);
      }
      else
      {
        $Debug && warn "Refusing to cache $db in pre-fork apache process ",
                       "because use_cache_during_apache_startup is false";
        return $db;
      }
    }
  }

  $self->{'cache'}{$key} = $entry;

  return $db;
}

sub clear { shift->{'cache'} = {} }

if(MOD_PERL_2)
{
  require Apache2::ServerUtil;
  require Apache2::RequestUtil;
  require Apache2::Const;
  Apache2::Const->import(-compile => qw(OK));

  $MP2_Is_Child = 0;

  if(__PACKAGE__->apache_has_started)
  {
    $Debug && warn "$$ is already MP2 child (not registering child init handler)\n";
    $MP2_Is_Child = 1;
  }
  elsif(!$ENV{'ROSE_DB_NO_CHILD_INIT_HANDLER'})
  {
    Apache2::ServerUtil->server->push_handlers(
      PerlChildInitHandler => \&__mod_perl_2_rose_db_child_init_handler);
  }
}

# http://mail-archives.apache.org/mod_mbox/perl-dev/200504.mbox/%3C4256B5FF.5060401@stason.org%3E
# To work around this issue, we'll use a named subroutine.
sub __mod_perl_2_rose_db_child_init_handler
{
  $Debug && warn "$$ is MP2 child\n";
  $MP2_Is_Child = 1;
  return Apache2::Const::OK();
}

sub apache_has_started
{
  my($class) = shift;

  if(@_)
  {
    return $Apache_Has_Started = $_[0] ? 1 : 0;
  }

  return $Apache_Has_Started  if(defined $Apache_Has_Started);

  if(MOD_PERL_2)
  {
    return $Apache_Has_Started = $MP2_Is_Child;
  }

  if(MOD_PERL_1)
  {
    return $Apache_Has_Started = $Apache::Server::Starting;
  }

  return undef;
}

sub prepare_db
{
  my($self, $db, $entry) = @_;

  if(MOD_PERL_1)
  {
    if($Apache::Server::Starting)
    {
      $entry->created_during_apache_startup(1);
      $entry->prepared(0);
    }
    elsif(!$entry->is_prepared)
    {
      if($entry->created_during_apache_startup)
      {  
        if($db->has_dbh)
        {
          $Debug && warn "$$ Disconnecting and undef-ing dbh ", $db->dbh, 
                         " created during apache startup from $db\n";

          my $error;

          TRY:
          {
            local $@;
            eval { $db->dbh->disconnect }; # will probably fail!
            $error = $@;
          }

          warn "$$ Could not disconnect dbh created during apache startup: ", 
               $db->dbh, " - $error"  if($error);

          $db->dbh(undef);
        }

        $entry->created_during_apache_startup(0);
      }

      Apache->push_handlers(PerlCleanupHandler => sub
      {
        $Debug && warn "$$ Clear dbh and prepared flag for $db, $entry\n";
        $db->dbh(undef)      if($db);
        $entry->prepared(0)  if($entry);
      });

      $entry->prepared(1);
    }
  }

  # Not a chained elsif to help Perl eliminate the unused code (maybe unnecessary?)
  if(MOD_PERL_2)
  {
    if(!$MP2_Is_Child)
    {
      $entry->created_during_apache_startup(1);
      $entry->prepared(0);
    }
    elsif(!$entry->is_prepared)
    {
      if($entry->created_during_apache_startup)
      {
        if($db->has_dbh)
        {
          $Debug && warn "$$ Disconnecting and undef-ing dbh ", $db->dbh, 
                         " created during apache startup from $db\n";

          my $error;

          TRY:
          {
            local $@;
            eval { $db->dbh->disconnect }; # will probably fail!
            $error = $@;
          }

          warn "$$ Could not disconnect dbh created during apache startup: ", 
               $db->dbh, " - $error"  if($error);

          $db->dbh(undef);
        }

        $entry->created_during_apache_startup(0);
      }

      my($r, $error);

      TRY:
      {
        local $@;
        eval { $r = Apache2::RequestUtil->request };
        $error = $@;
      }

      if($error)
      {
        $Debug && warn "Couldn't get apache request (restart count is ", 
                       Apache2::ServerUtil::restart_count(), ") - $error\n";
        $entry->created_during_apache_startup(1); # tag for cleanup
        $entry->prepared(0);

        return;
      }
      else
      {
        $r->push_handlers(PerlCleanupHandler => sub
        {
          $Debug && warn "$$ Clear dbh and prepared flag for $db, $entry\n";
          $db->dbh(undef)      if($db);
          $entry->prepared(0)  if($entry);
          return Apache2::Const::OK();
        });
      }

      $entry->prepared(1);
    }
  }
}

1;

__END__

=head1 NAME

Rose::DB::Cache - A mod_perl-aware cache for Rose::DB objects.

=head1 SYNOPSIS

  # Usage
  package My::DB;

  use base 'Rose::DB';
  ...

  $cache = My::DB->db_cache;

  $db = $cache->get_db(...);

  $cache->set_db($db);

  $cache->clear;


  # Subclassing
  package My::DB::Cache;

  use Rose::DB::Cache;
  our @ISA = qw(Rose::DB::Cache);

  # Override methods as desired
  sub get_db          { ... }
  sub set_db          { ... }
  sub prepare_db      { ... }
  sub build_cache_key { ... }
  sub clear           { ... }
  ...

=head1 DESCRIPTION

L<Rose::DB::Cache> provides both an API and a default implementation of a caching system for L<Rose::DB> objects.  Each L<Rose::DB>-derived class L<references|Rose::DB/db_cache> a L<Rose::DB::Cache>-derived object to which it delegates cache-related activities.  See the L<new_or_cached|Rose::DB/new_or_cached> method for an example.

The default implementation caches and returns L<Rose::DB> objects using the combination of their L<type|Rose::DB/type> and L<domain|Rose::DB/domain> as the cache key.  There is no cache expiration or other cache cleaning.

The only sophistication in the default implementation is that it is L<mod_perl>- and L<Apache::DBI>-aware.  When running under mod_perl, with or without L<Apache::DBI>, the L<dbh|Rose::DB/dbh> attribute of each cached L<Rose::DB> object is set to C<undef> at the end of each request.  Additionally, any db connections made in a pre-fork parent apache process are not cached.

When running under L<Apache::DBI>, the behavior described above will ensure that L<Apache::DBI>'s "ping" and rollback features work as expected, keeping the L<DBI> database handles L<contained|Rose::DB/dbh> within each L<Rose::DB> object connected and alive.

When running under mod_perl I<without> L<Apache::DBI>, the behavior described above will use a single L<DBI> database connection per cached L<Rose::DB> object per request, but will discard these connections at the end of each request.

Both mod_perl 1.x and 2.x are supported.  Under mod_perl 2.x, you should load L<Rose::DB> on server startup (e.g., in your C<startup.pl> file).  If this is not possible, then you must explicitly tell L<Rose::DB::Cache> that apache has started up already by setting L<apache_has_started|/apache_has_started> to a true value.

Subclasses can override any and all methods described below in order to implement their own caching strategy.

=head1 CLASS METHODS

=over 4

=item B<apache_has_started [BOOL]>

Get or set a boolean value indicating whether or not apache has completed its startup process.  If this value is not set explicitly, a best guess as to the answer will be returned.

=item B<build_cache_key PARAMS>

Given the name/value pairs PARAMS, return a string representing the corresponding cache key.  Calls to this method from within L<Rose::DB::Cache> will include at least C<type> and C<domain> parameters, but you may pass any parameters if you override all methods that call this method in your subclass.

=item B<default_use_cache_during_apache_startup [BOOL]>

Get or set a boolean value that determines the default value of the L<use_cache_during_apache_startup|/use_cache_during_apache_startup> object attribute.  The default value is false.  See the L<use_cache_during_apache_startup|/use_cache_during_apache_startup> documentation for more information.

=item B<entry_class [CLASS]>

Get or set the name of the L<Rose::DB::Cache::Entry>-derived class used to store cached L<Rose::DB> objects on behalf of this class.  The default value is L<Rose::DB::Cache::Entry>.

=back

=head1 CONSTRUCTORS

=over 4

=item B<new PARAMS>

Constructs a new L<Rose::DB::Cache> object based on PARAMS, where PARAMS are
name/value pairs.  Any object method is a valid parameter name.

=back

=head1 OBJECT METHODS

=over 4

=item B<clear>

Clear the cache entirely.

=item B<db_cache_entries>

Returns a list (in list context) or reference to an array (in scalar context) of L<cache entries|Rose::DB::Cache::Entry> for each cached db object.

=item B<db_cache_keys>

Returns a list (in list context) or reference to an array (in scalar context) of L<keys|Rose::DB::Cache::Entry/key> for each L <cache entries|Rose::DB::Cache::Entry>.

=item B<get_db [PARAMS]>

Return the cached L<Rose::DB>-derived object corresponding to the name/value pairs passed in PARAMS.  PARAMS are passed to the L<build_cache_key|/build_cache_key> method, and the key returned is used to look up the cached object.

If a cached object is found, the L<prepare_db|/prepare_db> method is called, passing the cached db object and its corresponding L<Rose::DB::Cache::Entry> object as arguments.  The cached db object is then returned.

If no such object exists in the cache, undef is returned.

=item B<prepare_for_apache_fork>

Prepares the cache for the initial fork of the apache parent process by L<disconnect()ing|DBI/disconnect> all database handles and deleting all cache entries that were L<created during apache startup|Rose::DB::Cache::Entry/created_during_apache_startup>.  This call is only necessary if running under L<mod_perl> I<and> L<use_cache_during_apache_startup|/use_cache_during_apache_startup> set set to true.  See the L<use_cache_during_apache_startup|/use_cache_during_apache_startup> documentation for more information.

=item B<prepare_db [DB, ENTRY]>

Prepare the cached L<Rose::DB>-derived object DB for usage.  The cached's db object's L<Rose::DB::Cache::Entry> object, ENTRY, is also passed.

When I<NOT> running under L<mod_perl>, this method does nothing.

When running under L<mod_perl> (version 1.x or 2.x), this method will do the following:

=over 4

=item * Any L<DBI> database handle created inside a L<Rose::DB> object during apache server startup will be L<marked|Rose::DB::Cache::Entry/created_during_apache_startup> as such.  Any attempt to use such an object after the apache startup process has completed (i.e., in a child apache process) will cause it to be discarded and replaced.  Note that you usually don't want it to come to this.  It's better to cleanly disconnect all such database handles before the first apache child forks off.  See the documentation for the L<use_cache_during_apache_startup|/use_cache_during_apache_startup> and L<prepare_for_apache_fork|/prepare_for_apache_fork> methods for more information.

=item * All L<DBI> database handles contained in cached L<Rose::DB> objects will be cleared at the end of each request using a C<PerlCleanupHandler>.  This will cause L<DBI-E<gt>connect|DBI/connect> to be called the next time a L<dbh|Rose::DB/dbh> is requested from a cached L<Rose::DB> object, which in turn will trigger L<Apache::DBI>'s ping mechanism to ensure that the database handle is fresh.

=back

Putting all the pieces together, the following implementation of the L<init_db|Rose::DB::Object/init_db> method in your L<Rose::DB::Object>-derived common base class will ensure that database connections are shared and fresh under L<mod_perl> and (optionally) L<Apache::DBI>, but I<unshared> elsewhere:

  package My::DB::Object;

  use base 'Rose::DB::Object';

  use My::DB; # isa Rose::DB
  ...

  BEGIN:
  {
    if($ENV{'MOD_PERL'})
    {
      *init_db = sub { My::DB->new_or_cached };
    }
    else # act "normally" when not under mod_perl
    {
      *init_db = sub { My::DB->new };
    }
  }

=item B<set_db DB>

Add the L<Rose::DB>-derived object DB to the cache.  The DB's L<domain|Rose::DB/domain>, L<type|Rose::DB/type>, and the db object itself (under the parameter name C<db>) are all are passed to the L<build_cache_key|/build_cache_key> method and the DB object is stored under the key returned.

If running under L<mod_perl> I<and> the apache server is starting up I<and> L<use_cache_during_apache_startup|/use_cache_during_apache_startup> is set to true, then the DB object is I<not> added to the cache, but merely returned.

=item B<use_cache_during_apache_startup [BOOL]>

Get or set a boolean value that determines whether or not to cache database objects during the apache server startup process.  The default value is determined by the L<default_use_cache_during_apache_startup|/default_use_cache_during_apache_startup> class method.

L<DBI> database handles created in the parent apache process cannot be used in child apache processes.  Furthermore, in the case of at least L<one|DBD::Informix> one L<DBI driver class|DBI::DBD>, you must I<also> ensure that any database handles created in the apache parent process during server startup are properly L<disconnect()ed|DBI/disconnect> I<before> you fork off the first apache child.  Failure to do so may cause segmentation faults(!) in child apache processes.

The upshot is that if L<use_cache_during_apache_startup|/use_cache_during_apache_startup> is set to true, you should call L<prepare_for_apache_fork|/prepare_for_apache_fork> at the very end of the apache startup process (i.e., once all other Perl modules have been loaded and all other Perl code has run).  This is usually done by placing a call at the bottom of the traditional C<startup.pl> file.  Assuming C<My::DB> is your L<Rose::DB|Rose::DB>-derived class:

    My::DB->db_cache->prepare_for_apache_fork();

A L<convenience method|Rose::DB/prepare_cache_for_apache_fork> exists in L<Rose::DB> as well, which simply translates into call shown above:

    My::DB->prepare_cache_for_apache_fork();

=back

=head1 AUTHOR

John C. Siracusa (siracusa@gmail.com)

=head1 LICENSE

Copyright (c) 2010 by John C. Siracusa.  All rights reserved.  This program is
free software; you can redistribute it and/or modify it under the same terms
as Perl itself.