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/\&/&amp;/g;
45    $a =~ s/\"/&quot;/g;
46    $a =~ s/\'/&apos;/g;
47    $a =~ s/</&lt;/g;
48    $a =~ s/>/&gt;/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