File Coverage

blib/lib/DJabberd/Util.pm
Criterion Covered Total %
statement 3 48 6.2
branch 0 16 0.0
condition 0 15 0.0
subroutine 1 11 9.0
pod 0 9 0.0
total 4 99 4.0


line stmt bran cond sub pod time code
1             package DJabberd::Util;
2 20     20   116 use strict;
  20         42  
  20         28153  
3             require Exporter;
4             our @ISA = qw(Exporter);
5             our @EXPORT_OK = qw(exml tsub lbsub as_bool as_num as_abs_path as_bind_addr);
6              
7             sub as_bool {
8 0     0 0   my $val = shift;
9 0 0         return 1 if $val =~ /^1|y|yes|true|t|on|enabled?$/i;
10 0 0         return 0 if $val =~ /^0|n|no|false|f|off|disabled?$/i;
11 0           die "Can't determine booleanness of '$val'\n";
12             }
13              
14             sub as_num {
15 0     0 0   my $val = shift;
16 0 0         return $val if $val =~ /^\d+$/;
17 0           die "'$val' is not a number\n";
18             }
19              
20             sub as_bind_addr {
21 0     0 0   my $val = shift;
22             # Must either be like 127.0.0.1:1234, a bare port number or an absolute path to a unix domain socket
23 0 0 0       if ($val =~ /^(\d\d?\d?\.\d\d?\d?\.\d\d?\d?\.\d\d?\d?:)?\d+$/ || ($val =~ m!^/! && -e $val)) {
      0        
24 0           return $val;
25             }
26 0           die "'$val' is not a valid bind address or port\n";
27             }
28              
29             sub as_abs_path {
30 0     0 0   my $val = shift;
31 0 0         die "Path '$val' isn't absolute" unless $val =~ m!^/!;
32 0 0         die "File '$val' doesn't exist" unless -f $val;
33 0           return $val;
34             }
35              
36             sub exml
37             {
38             # fast path for the commmon case:
39 0 0   0 0   return $_[0] unless $_[0] =~ /[&\"\'<>\x00-\x08\x0B\x0C\x0E-\x1F]/;
40             # what are those character ranges? XML 1.0 allows:
41             # #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]
42              
43 0           my $a = shift;
44 0           $a =~ s/\&/&/g;
45 0           $a =~ s/\"/"/g;
46 0           $a =~ s/\'/'/g;
47 0           $a =~ s/
48 0           $a =~ s/>/>/g;
49 0           $a =~ s/[\x00-\x08\x0B\x0C\x0E-\x1F]//g;
50 0           return $a;
51             }
52              
53             sub durl {
54 0     0 0   my ($a) = @_;
55 0           $a =~ tr/+/ /;
56 0           $a =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
  0            
57 0           return $a;
58             }
59              
60             # tracked sub
61             sub tsub (&) {
62 0     0 0   my $subref = shift;
63 0           bless $subref, 'DJabberd::TrackedSub';
64 0           DJabberd->track_new_obj($subref);
65 0           return $subref;
66             }
67              
68             # line-blessed sub
69             sub lbsub (&) {
70 0     0 0   my $subref = shift;
71 0           my ($pkg, $file, $line) = caller;
72 0           my $bpkg = $file . "_" . $line;
73 0           $bpkg =~ s/[^\w]/_/g;
74 0           return bless $subref, "DJabberd::AnonSubFrom::$bpkg";
75             }
76              
77             sub numeric_entity_clean {
78 0     0 0   my $hex = $_[0];
79 0           my $val = hex $hex;
80              
81             # under a space, only \n, \r, and \t are allowed.
82 0 0 0       if ($val < 32 && ($val != 13 && $val != 10 && $val != 9)) {
      0        
      0        
83 0           return "";
84             }
85              
86 0           return "&#$hex;";
87             }
88              
89             package DJabberd::TrackedSub;
90              
91             sub DESTROY {
92 0     0     my $self = shift;
93 0           DJabberd->track_destroyed_obj($self);
94             }
95              
96             1;