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