File Coverage

blib/lib/Palm/Progect/VersionDelegator.pm
Criterion Covered Total %
statement 12 45 26.6
branch 0 14 0.0
condition 0 5 0.0
subroutine 4 6 66.6
pod 0 1 0.0
total 16 71 22.5


line stmt bran cond sub pod time code
1              
2             =head1 NAME
3              
4             Palm::Progect::VersionDelegator - Delegate to specific Progect db driver based on version
5              
6             =head1 SYNOPSIS
7              
8             package Palm::Progect::Record;
9             use vars qw(@ISA);
10              
11             @ISA = qw(Palm::Progect::Record);
12              
13             1;
14              
15             =head1 DESCRIPTION
16              
17             Delegate to specific database driver based on database version. If
18             version is not specified, then it will delegate to the database driver
19             with the highest number.
20              
21             For instance to create a version 0.18 Record, the user can do the following:
22              
23             my $record = Palm::Progect::Record->new(
24             raw_record => $some_raw_data,
25             version => 18,
26             );
27              
28             Behind the scenes, this call will be translated into the equivalent of:
29              
30             require 'Palm/Progect/DB_18/Record.pm';
31             my $record = Palm::Progect::DB_18::Record->new(
32             raw_record => $some_raw_data,
33             );
34              
35             =cut
36              
37             package Palm::Progect::VersionDelegator;
38              
39 7     7   42 use strict;
  7         12  
  7         203  
40 7     7   167 use 5.004;
  7         23  
  7         232  
41 7     7   37 use File::Spec;
  7         20  
  7         160  
42 7     7   52 use Carp;
  7         29  
  7         3699  
43              
44             sub new {
45 0     0 0   my $proto = shift;
46 0   0       my $this_class = ref $proto || $proto;
47              
48 0           my @base_class = split /::/, $this_class; # e.g. ('Palm', 'Progect')
49 0           my $module_name = pop @base_class; # e.g. 'Record'
50              
51 0           my %args = @_;
52              
53 0   0       my $version = delete $args{'version'} || 0;
54              
55 0           my $version_class = '';
56 0 0         if ($version > 0) {
57 0           $version_class = 'DB_' . $version;
58             }
59             else {
60             # Latest version was requested.
61 0           $version_class = 'DB_' . _latest_version(File::Spec->join(@base_class));
62             }
63              
64 0           my $module_path = File::Spec->join(@base_class,$version_class, $module_name . '.pm');
65 0           my $module_class = join '::', @base_class, $version_class, $module_name;
66              
67 0           require $module_path;
68              
69 0           return $module_class->new(%args);
70             }
71              
72             # Cache the latest version to avoid repeatedly searching
73             # through the filesystem
74              
75             # Find latest version of module
76             # find directories matching DB_yy
77             # and pick the one where yy is the greatest
78              
79             my %Latest_Version;
80             sub _latest_version {
81 0     0     my $base_class_path = shift;
82              
83 0 0         if (! exists $Latest_Version{$base_class_path}) {
84              
85              
86 0           local *DIR;
87              
88 0           my $max_version = 0;
89 0           my $max_version_filename = '';
90              
91 0           foreach my $inc (@INC) {
92 0           my $path = File::Spec->join($inc, $base_class_path);
93              
94 0 0         next unless -d $path;
95              
96 0 0         if (opendir DIR, $path) {
97 0           my @subdirs = readdir(DIR);
98 0           close DIR;
99              
100 0           foreach my $subdir (@subdirs) {
101 0 0         next unless -d File::Spec->join($path, $subdir);
102 0 0         next unless $subdir =~ /^DB_(\d+)$/;
103              
104 0           my $subdir_version = $1;
105              
106 0 0         next unless $subdir_version > $max_version;
107              
108 0           $max_version = $subdir_version;
109             }
110             }
111             }
112 0           $Latest_Version{$base_class_path} = $max_version;
113             }
114              
115 0           return $Latest_Version{$base_class_path};
116             }
117              
118             1;
119              
120             __END__