This file is indexed.

/usr/share/perl5/Perlbal/Plugin/Highpri.pm is in libperlbal-perl 1.80-3.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
###########################################################################
# plugin that makes some requests high priority.  this is very LiveJournal
# specific, as this makes requests to the client protocol be treated as
# high priority requests.
###########################################################################

package Perlbal::Plugin::Highpri;

use strict;
use warnings;

# keep track of services we're loaded for
our %Services;

# called when we're being added to a service
sub register {
    my ($class, $svc) = @_;

    # create a compiled regexp for very frequent use later
    my $uri_check = qr{^(?:/interface/(?:xmlrpc|flat)|/login\.bml)$};
    my $host_check = undef;

    # setup default extra config info
    $svc->{extra_config}->{highpri_uri_check_str} = '^(?:/interface/(?:xmlrpc|flat)|/login\.bml)$';
    $svc->{extra_config}->{highpri_host_check_str} = 'undef';

    # config setter reference
    my $config_set = sub {
        my ($out, $what, $val) = @_;
        return 0 unless $what && $val;

        # setup an error sub
        my $err = sub {
            $out->("ERROR: $_[0]") if $out;
            return 0;
        };

        # if they said undef, that's not a regexp, that means use none
        my $temp;
        unless ($val eq 'undef' || $val eq 'none' || $val eq 'null') {
            # verify this regexp works?  do it in an eval because qr will die
            # if we give it something invalid
            eval {
                $temp = qr{$val};
            };
            return $err->("Invalid regular expression") if $@ || !$temp;
        }

        # see what they want to set and set it
        if ($what =~ /^uri_pattern/i) {
            $uri_check = $temp;
            $svc->{extra_config}->{highpri_uri_check_str} = $val;
        } elsif ($what =~ /^host_pattern/i) {
            $host_check = $temp;
            $svc->{extra_config}->{highpri_host_check_str} = $val;
        } else {
            return $err->("Plugin understands: uri_pattern, host_pattern");
        }

        # 1 for success!
        return 1;
    };

    # register things to take in configuration regular expressions
    $svc->register_setter('Highpri', 'uri_pattern', $config_set);
    $svc->register_setter('Highpri', 'host_pattern', $config_set);

    # more complicated statistics
    $svc->register_hook('Highpri', 'make_high_priority', sub {
        my Perlbal::ClientProxy $cp = shift;

        # check it against our compiled regexp
        return 1 if $uri_check &&
                    $cp->{req_headers}->request_uri =~ /$uri_check/;
        if ($host_check) {
            my $hostname = $cp->{req_headers}->header('Host');
            return 1 if $hostname && $hostname =~ /$host_check/;
        }

        # doesn't fit, so return 0
        return 0;
    });

    # mark this service as being active in this plugin
    $Services{"$svc"} = $svc;

    return 1;
}

# called when we're no longer active on a service
sub unregister {
    my ($class, $svc) = @_;

    # clean up time
    $svc->unregister_hooks('Highpri');
    $svc->unregister_setters('Highpri');
    return 1;
}

# load global commands for querying this plugin on what's up
sub load {
    # setup a command to see what the patterns are
    Perlbal::register_global_hook('manage_command.patterns', sub {
        my @res = ("High priority pattern buffer:");

        foreach my $svc (values %Services) {
            push @res, "SET $svc->{name}.highpri.uri_pattern = $svc->{extra_config}->{highpri_uri_check_str}";
            push @res, "SET $svc->{name}.highpri.host_pattern = $svc->{extra_config}->{highpri_host_check_str}";
        }

        push @res, ".";
        return \@res;
    });

    return 1;
}

# unload our global commands, clear our service object
sub unload {
    Perlbal::unregister_global_hook('manage_command.patterns');
    %Services = ();
    return 1;
}

1;