ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cvsroot/Coro/myhttpd/tbf.pl
Revision: 1.5
Committed: Thu Nov 21 09:52:34 2002 UTC (21 years, 7 months ago) by root
Content type: text/plain
Branch: MAIN
CVS Tags: rel-2_5, rel-4_22, rel-4_21, rel-4_0, rel-4_3, rel-3_41, rel-4_13, rel-4_11, rel-3_55, rel-3_51, rel-4_01, rel-4_03, rel-4_02, rel-2_0, rel-2_1, rel-1_1, rel-1_0, rel-1_9, rel-1_2, rel-3_6, rel-3_62, rel-3_63, rel-3_61, rel-1_5, rel-1_4, rel-1_7, rel-1_6, rel-3_4, rel-3_1, rel-3_5, rel-3_3, rel-3_2, rel-3_0, rel-3_01, rel-3_11, rel-1_31, rel-4_1, rel-4_2, stack_sharing, rel-3_501, rel-4_31
Changes since 1.4: +1 -1 lines
Log Message:
config.pl.dist

File Contents

# Content
1 package tbf;
2
3 # kind of token-bucket-filter
4
5 my $max_per_client = $::TBF_MAX_PER_CLIENT || 24000;
6
7 sub new {
8 my $class = shift;
9 my %arg = @_;
10 my $self = bless \%arg, $class;
11
12 $self->{maxbucket} ||= $self->{rate} * 3; # max 3s bucket
13 $self->{minbucket} ||= $self->{rate}; # minimum bucket to share
14 $self->{interval} ||= $::BUFSIZE / $max_per_client; # good default interval
15
16 if ($self->{rate}) {
17 $self->{w} = Event->timer(hard => 1, after => 0, interval => $self->{interval}, repeat => 1, cb => sub {
18 $self->inject($self->{rate} * $self->{interval});
19 });
20 } else {
21 die "chaining not yet implemented\n";
22 }
23
24 $self;
25 }
26
27 sub DESTROY {
28 my $self = shift;
29
30 $self->{w}->cancel;
31 }
32
33 sub inject {
34 my ($self, $bytes) = @_;
35
36 $self->{bucket} += $bytes;
37
38 while ($self->{bucket} >= $self->{minbucket}) {
39 if ($self->{waitw}) {
40 my $rate = $self->{bucket} / $self->{waitw};
41
42 for my $v (values %{$self->{waitq}}) {
43 $self->{bucket} -= $rate * $v->[0];
44 $v->[1] += $rate * $v->[0];
45
46 if ($v->[1] >= $v->[2]) {
47 $self->{bucket} += $v->[1] - $v->[2];
48 $v->[3]->();
49 }
50 }
51
52 }
53 last;
54 }
55
56 if ($self->{maxbucket} < $self->{bucket}) {
57 ::unused_bandwidth ($self->{bucket} - $self->{maxbucket});
58 $self->{bucket} = $self->{maxbucket};
59 }
60 }
61
62 my $_tbf_id;
63
64 sub request {
65 my ($self, $bytes, $weight) = @_;
66
67 $weight ||= 1;
68
69 my $coro = $Coro::current;
70 my $id = $_tbf_id++;
71
72 $self->{waitw} += $weight;
73 $self->{waitq}{$id} = [$weight, 0, $bytes, sub {
74 delete $self->{waitq}{$id};
75 $self->{waitw} -= $weight;
76 $coro->ready;
77 }];
78
79 Coro::schedule;
80 }
81
82 1;