File Coverage

blib/lib/Net/DRI/Logging/Files.pm
Criterion Covered Total %
statement 15 57 26.3
branch 0 22 0.0
condition 0 6 0.0
subroutine 5 11 45.4
pod 4 5 80.0
total 24 101 23.7


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, Logging into files
2             ##
3             ## Copyright (c) 2009,2010,2013 Patrick Mevzek . All rights reserved.
4             ##
5             ## This file is part of Net::DRI
6             ##
7             ## Net::DRI is free software; you can redistribute it and/or modify
8             ## it under the terms of the GNU General Public License as published by
9             ## the Free Software Foundation; either version 2 of the License, or
10             ## (at your option) any later version.
11             ##
12             ## See the LICENSE file that comes with this distribution for more details.
13             #########################################################################################
14              
15             package Net::DRI::Logging::Files;
16              
17 1     1   660 use strict;
  1         1  
  1         22  
18 1     1   4 use warnings;
  1         1  
  1         20  
19              
20 1     1   3 use base qw/Net::DRI::Logging/;
  1         1  
  1         54  
21              
22 1     1   4 use Net::DRI::Exception;
  1         2  
  1         13  
23              
24 1     1   2 use IO::Handle; ## needed for the autoflush method on any lexical $fh
  1         6  
  1         451  
25              
26             ####################################################################################################
27              
28             sub new
29             {
30 0     0 1   my ($class,$data)=@_;
31 0           my $self=$class->SUPER::new($data);
32 0 0 0       if (! exists $self->{output_directory} || ! defined $self->{output_directory} ) { $self->{output_directory}='.'; }
  0            
33 0 0         if (! -d $self->{output_directory}) { Net::DRI::Exception->die(0,'logging',1,'Directory '.$self->{output_directory}.' does not exist'); }
  0            
34 0 0         if (! -w $self->{output_directory}) { Net::DRI::Exception->die(0,'logging',2,'Directory '.$self->{output_directory}.' is not writable'); }
  0            
35 0           $self->{fh}={};
36 0           return $self;
37             }
38              
39 0     0 1   sub name { return 'files'; }
40              
41             sub setup_channel
42             {
43 0     0 1   my ($self,$source,$type,$data)=@_;
44 0           my $name=$self->generate_filename($type,$data);
45 0 0         if (exists $self->{fh}->{$name}) { return; }
  0            
46 0           my $fh;
47 0 0         open $fh,'>>',$name or Net::DRI::Exception->die(0,'logging',3,'File '.$name.' can not be open for writing: '.$!); ## no critic (InputOutput::RequireBriefOpen)
48 0           $fh->autoflush(1); ## this is possible thanks to IO::Handle
49 0           $self->{fh}->{$name}=$fh;
50 0           return;
51             }
52              
53             sub output
54             {
55 0     0 1   my ($self,$level,$type,$data)=@_;
56 0 0         if (! $self->should_log($level)) { return; }
  0            
57 0           my $name=$self->generate_filename($type,$data);
58 0 0         if (! exists $self->{fh}->{$name})
59             {
60 0           my $core=$self->generate_filename('core');
61 0 0         if (exists $self->{fh}->{$core})
62             {
63 0           $self->output('critical','core',sprintf('File "%s" (type "%s") has not been setup (no previous call to setup_channel or invalid type?), switching to "core" logging file',$name,$type));
64 0           $name=$core;
65             } else
66             {
67 0           Net::DRI::Exception->die(1,'logging',3,sprintf('File "%s" (type "%s") has not been setup (no previous call to setup_channel or invalid type?), and can not switch to "core" logging file',$name,$type));
68             }
69             }
70 0           print { $self->{fh}->{$name} } $self->tostring($level,$type,$data),"\n";
  0            
71 0           return;
72             }
73              
74             ####################################################################################################
75              
76             sub generate_filename
77             {
78 0     0 0   my ($self,$type,$ctx)=@_;
79 0 0         return sprintf '%s/%s',$self->{output_directory},$self->{output_filename} if exists $self->{output_filename};
80 0 0 0       my $name=(defined $ctx && ref $ctx eq 'HASH')? sprintf('%s-%s-%s',$ctx->{registry},$ctx->{profile},$type) : $type;
81 0           return sprintf '%s/%d-%s.log',$self->{output_directory},$$,$name;
82             }
83              
84             sub DESTROY
85             {
86 0     0     my ($self)=@_;
87 0           foreach my $fh (values %{$self->{fh}})
  0            
88             {
89 0 0         close $fh or 1;
90             }
91 0           return;
92             }
93              
94             ####################################################################################################
95             1;
96              
97             __END__