Skip to content
This repository
Browse code

Initial commit.

  • Loading branch information...
commit 61155fb7cd4633e688e9433c305c111f5229be22 0 parents
Dmitry Koterov authored November 27, 2009

Showing 124 changed files with 6,960 additions and 0 deletions. Show diff stats Hide diff stats

  1. 261  Connection/In.pm
  2. 129  Connection/Wait.pm
  3. 85  Event/Lib/Connection.pm
  4. 161  Event/Lib/Server.pm
  5. 107  README.txt
  6. 246  Realplexor/Common.pm
  7. 104  Realplexor/Config.pm
  8. 38  Realplexor/Tools.pm
  9. 49  Storage/CleanupTimers.pm
  10. 52  Storage/ConnectedFhs.pm
  11. 72  Storage/DataToSend.pm
  12. 76  Storage/Events.pm
  13. 73  Storage/OnlineTimers.pm
  14. 51  Storage/PairsByFhs.pm
  15. 1  api/README.txt
  16. 278  api/php/Dklab/Realplexor.php
  17. 35  api/php/t/500_phpapi_json.phpt
  18. 36  api/php/t/505_phpapi_json_ns.phpt
  19. 70  api/php/t/505_phpapi_json_ns_limited.phpt
  20. 35  api/php/t/520_phpapi_stamps.phpt
  21. 34  api/php/t/530_phpapi_errors.phpt
  22. 26  api/php/t/540_phpapi_online.phpt
  23. 14  api/php/t/542_phpapi_online_empty.phpt
  24. 26  api/php/t/545_phpapi_online_prefix.phpt
  25. 27  api/php/t/545_phpapi_online_prefix_ns.phpt
  26. 24  api/php/t/547_phpapi_no_online_prefix.phpt
  27. 48  api/php/t/560_phpapi_watch.phpt
  28. 14  api/php/t/562_phpapi_watch_event_empty.phpt
  29. 57  api/php/t/562_phpapi_watch_ns.phpt
  30. 51  api/php/t/564_phpapi_watch_idp_ns.phpt
  31. 37  api/php/t/600_phpapi_login.phpt
  32. 27  api/php/t/605_phpapi_login_invalid.phpt
  33. 38  api/php/t/610_phpapi_login_ns.phpt
  34. 29  api/php/t/620_phpapi_login_online.phpt
  35. 4  api/php/t/init.php
  36. 103  dklab_realplexor.conf
  37. 307  dklab_realplexor.html
  38. 10  dklab_realplexor.htpasswd
  39. 122  dklab_realplexor.init
  40. 148  dklab_realplexor.js
  41. 17  dklab_realplexor.license-additional.txt
  42. 339  dklab_realplexor.license-gpl-2.0.txt
  43. 159  dklab_realplexor.pl
  44. 0  empty.txt b/t/jstest/contrib/empty.txt
  45. 5  t/crashtest/1_run_realplexor.sh
  46. 15  t/crashtest/t_ab_connect_and_get_data.pl
  47. 6  t/crashtest/t_ab_connect_and_get_iframe.pl
  48. 30  t/crashtest/t_clients_abnormal_disconnect.pl
  49. 58  t/crashtest/t_connect_many_clients_and_wait.pl
  50. 28  t/crashtest/t_push_many_data_items.pl
  51. 4  t/demo/_common.php
  52. 14  t/demo/ajax_post.php
  53. 35  t/demo/cron_online_updater.php
  54. 69  t/demo/fr_form.php
  55. 112  t/demo/fr_ids.php
  56. 8  t/demo/index.php
  57. BIN  t/demo/static/close.gif
  58. BIN  t/demo/static/indicator.gif
  59. 19  t/demo/static/jquery.min.js
  60. BIN  t/demo/static/loading_green.gif
  61. 2  t/jstest/.htaccess
  62. 50  t/jstest/0000_all.php
  63. 59  t/jstest/0100_success.jst
  64. 62  t/jstest/0102_success_ns.jst
  65. 63  t/jstest/0103_success_ns_login.jst
  66. 34  t/jstest/0105_setpos.jst
  67. 47  t/jstest/0110_abort_not_bounce.jst
  68. 63  t/jstest/0110_error_skip_ok.jst
  69. 44  t/jstest/0120_error_incomplete_resp.jst
  70. 255  t/jstest/0120_js_error_is_not_bounce.jst
  71. 35  t/jstest/0130_disconnect_no_warn.jst
  72. 27  t/jstest/0140_long_ids_list.jst
  73. 86  t/jstest/0200_eval_error.jst
  74. 42  t/jstest/0200_subscribe_same_callback.jst
  75. 32  t/jstest/0210_no_req_if_execute_in_callback.jst
  76. 15  t/jstest/JsTest/JsTest.css
  77. 100  t/jstest/JsTest/JsTest.js
  78. 71  t/jstest/JsTest/JsTestIterator.js
  79. 8  t/jstest/contrib/iframe.php
  80. 109  t/jstest/contrib/init.php
  81. 22  t/jstest/contrib/tests_result.php
  82. 36  t/servertest/010_send.phpt
  83. 40  t/servertest/025_send_multi_with_stamp.phpt
  84. 37  t/servertest/026_send_ignore_referrer.phpt
  85. 40  t/servertest/027_send_multi_limited.phpt
  86. 71  t/servertest/030_pass_to_connected.phpt
  87. 41  t/servertest/040_stamp_compare_empty.phpt
  88. 69  t/servertest/045_not_grouped_sequence.phpt
  89. 75  t/servertest/047_grouped_sorted.phpt
  90. 38  t/servertest/049_multiple_matched_read_own_ids_only.phpt
  91. 51  t/servertest/050_pass_to_online_buffered_multi.phpt
  92. 130  t/servertest/060_multiple_matched_limited.phpt
  93. 37  t/servertest/070_pass_to_connected_readmulti.phpt
  94. 75  t/servertest/210_stats_after_wait.phpt
  95. 55  t/servertest/220_watch_event_online_offline.phpt
  96. 17  t/servertest/222_watch_event_empty.phpt
  97. 98  t/servertest/230_watch_event_chain_size.phpt
  98. 72  t/servertest/320_rotate_queue.phpt
  99. 53  t/servertest/330_cleanup_queue_on_expire.phpt
  100. 71  t/servertest/400_iframe.phpt
  101. 46  t/servertest/410_script.phpt
  102. 43  t/servertest/500_login_send_unknown_user.phpt
  103. 43  t/servertest/510_login_send_wrong_pass.phpt
  104. 39  t/servertest/520_login_send_pass_skip_not_own.phpt
  105. 39  t/servertest/530_login_send_ok.phpt
  106. 30  t/servertest/535_login_online_no_id.phpt
  107. 50  t/servertest/540_login_online_not_own.phpt
  108. 50  t/servertest/540_login_watch.phpt
  109. 6  t/servertest/fixture/iframe_stub.conf
  110. 1  t/servertest/fixture/iframe_stub.html
  111. 3  t/servertest/fixture/medium_offline_timeout.conf
  112. 6  t/servertest/fixture/non_anonymous.conf
  113. 1  t/servertest/fixture/non_anonymous.htpasswd
  114. 6  t/servertest/fixture/script_stub.conf
  115. 1  t/servertest/fixture/script_stub.js
  116. 3  t/servertest/fixture/small_chain_len.conf
  117. 3  t/servertest/fixture/small_cleanup_timeout.conf
  118. 3  t/servertest/fixture/small_offline_timeout.conf
  119. 3  t/servertest/fixture/small_queue_sz.conf
  120. 3  t/servertest/fixture/small_wait_timeout.conf
  121. 183  t/servertest/init.php
  122. 10  t/servertest/run_all.sh
  123. 17  t/servertest/run_all_forever.sh
  124. 16  t/servertest/run_apply_ok_out.pl
261  Connection/In.pm
... ...
@@ -0,0 +1,261 @@
  1
+##
  2
+## IN connection.
  3
+##
  4
+package Connection::In;
  5
+use base 'Event::Lib::Connection';
  6
+use strict;
  7
+use POSIX '_exit';
  8
+use Storage::PairsByFhs; 
  9
+use Storage::ConnectedFhs; 
  10
+use Storage::OnlineTimers; 
  11
+use Storage::DataToSend;
  12
+use Storage::CleanupTimers;
  13
+use Storage::Events;
  14
+use Realplexor::Config;
  15
+
  16
+# Called on a new connection.
  17
+sub new {
  18
+	my ($class, @args) = @_;
  19
+	my $self = $class->SUPER::new(@args);
  20
+	$self->{data} = "";
  21
+	$self->{pairs} = undef;
  22
+	$self->{limit_ids} = undef;
  23
+	$self->{cred} = undef;
  24
+	return $self;
  25
+}
  26
+
  27
+# Called on timeout.
  28
+sub ontimeout {
  29
+	my ($self) = @_;
  30
+	$self->SUPER::ontimeout();
  31
+	$self->{pairs} = undef;
  32
+}
  33
+
  34
+# Called on error.	
  35
+sub onerror {
  36
+	my ($self, $msg) = @_;
  37
+	$self->SUPER::onerror();
  38
+	$self->{pairs} = undef;
  39
+}	
  40
+
  41
+# Called when a data is available to read.
  42
+sub onread {
  43
+	my ($self, $data) = @_;
  44
+	$self->SUPER::onread($data);
  45
+
  46
+	# Append data.
  47
+	$self->{data} .= $data if defined $self->{data};
  48
+
  49
+	# Try to extract ID from the new data chunk.
  50
+	if (!defined $self->{pairs}) {
  51
+		my ($pairs, $limit_ids, $cred) = Realplexor::Common::extract_pairs($self->{data}, 1);
  52
+		if (defined $pairs) {
  53
+			$self->{pairs} = $pairs;
  54
+			$self->{limit_ids} = $limit_ids;
  55
+			$self->{cred} = $cred;
  56
+			$self->debug(
  57
+				"parsed IDs" 
  58
+				. ($limit_ids? "; limiters are (" . join(", ", sort keys %$limit_ids) . ")" : "")
  59
+				. ($cred? "; login is \"" . $cred->[0] . "\"" : "")
  60
+			);
  61
+			$self->assert_auth();
  62
+		}
  63
+	}
  64
+
  65
+	# Try to process cmd.
  66
+	$self->try_process_cmd() and return;
  67
+
  68
+	# Check for the data overflow.
  69
+	if (length($self->{data}) > $CONFIG{IN_MAXLEN}) {
  70
+		die "overflow (received " . length($data) . " bytes total)\n";
  71
+	}
  72
+}
  73
+
  74
+# Called on client side disconnect.
  75
+sub onclose {
  76
+	my ($self) = @_;
  77
+	# First, try to process cmd.
  78
+	$self->try_process_cmd(1) and return;
  79
+	# Then, try to send messages.
  80
+	$self->try_process_pairs() and return;
  81
+}
  82
+
  83
+# Assert that authentication is OK.
  84
+sub assert_auth {
  85
+	my ($self) = @_;
  86
+	my $cred = $self->{cred};
  87
+	eval {
  88
+		if ($cred) {
  89
+			# Login + password are passed. Check credentials.
  90
+			my $login = $cred->[0];
  91
+			if (!defined $CONFIG{USERS}{$login}) {
  92
+				die "unknown login: $login\n";
  93
+			}
  94
+			my $pwd_hash = $CONFIG{USERS}{$login};
  95
+			if (crypt($cred->[1], $pwd_hash) ne $pwd_hash) {
  96
+				die "invalid password for login: $login\n";
  97
+			}
  98
+		} elsif (!defined $CONFIG{USERS}{""}) {
  99
+			# Guest access, but no guest account is found.
  100
+			die "access denied for guest user\n";
  101
+		}
  102
+	};
  103
+	if ($@) {
  104
+		$self->{pairs} = undef;
  105
+		$self->{data} = undef;
  106
+		$self->_send_response($@, "403 Access Deined");
  107
+		die $@;
  108
+	}
  109
+}
  110
+
  111
+# Process aux commands (may be started from the beginning
  112
+# of the data of from the first \r\n\r\n part and finished
  113
+# always by \n).
  114
+sub try_process_cmd {
  115
+	my ($self, $finished_reading) = @_;
  116
+	$self->{data} or return 0;
  117
+	# Try to extract cmd.
  118
+	my $tail_re = $finished_reading? qr/\r?\n\r?\n|$/s : qr/\r?\n\r?\n/s;
  119
+	$self->{data} =~ m/(?: ^ | \r?\n\r?\n) (ONLINE|STATS|WATCH) (?:\s+ ([^\r\n]*) )? (?: $tail_re )/six or return 0;
  120
+	# Cmd extracted, process it.
  121
+	$self->{pairs} = undef;
  122
+	# Assert authorization.
  123
+	$self->assert_auth();
  124
+	my $cmd = uc $1;
  125
+	my $arg = $2;
  126
+	$self->debug("received aux command: $cmd" . (defined $arg && length($arg)? " $arg" : ""));
  127
+	shutdown($self->fh, 0); # stop reading
  128
+	my $method = "cmd_" . lc($cmd);
  129
+	$self->$method($arg);
  130
+	return 1;
  131
+}
  132
+
  133
+# Try to process pairs.
  134
+sub try_process_pairs {
  135
+	my ($self) = @_;
  136
+	$self->{data} or return;
  137
+	my $pairs = $self->{pairs};
  138
+	if (defined $pairs) {
  139
+		# Clear headers from the data.
  140
+		my (undef, $data) = split /\r?\n\r?\n/s, $self->{data}, 2;
  141
+		my $login = $self->{cred}? $self->{cred}[0] : undef;
  142
+		my @ids_to_process = ();
  143
+		foreach my $pair (@$pairs) {
  144
+			my ($cursor, $id) = @$pair;
  145
+			# Check if it is not own pair.
  146
+			if (defined $login && substr($id, 0, length($login) + 1) ne $login . "_") {
  147
+				$self->debug("skipping not owned [$id] for login $login");
  148
+				next;
  149
+			}
  150
+			# Add data to queue and set lifetime.
  151
+			push @ids_to_process, $id;
  152
+			$self->debug("adding data for [$id]");
  153
+			$data_to_send->add_dataref_to_id($id, $cursor, \$data, $self->{limit_ids});
  154
+			my $timeout = $CONFIG{CLEAN_ID_AFTER};
  155
+			$cleanup_timers->start_timer_for_id($id, $timeout, sub {
  156
+				$data_to_send->clear_id($id); 
  157
+				Realplexor::Common::logger("[$id] cleaned, because no data is pushed within last $timeout seconds");
  158
+			});
  159
+		}
  160
+		# Send pending data.
  161
+		Realplexor::Common::send_pendings(\@ids_to_process);
  162
+	}
  163
+}
  164
+
  165
+# Run a sub asynchronously.
  166
+sub _async {
  167
+	my ($self, $sub) = @_;
  168
+	my $pid = fork();
  169
+	if (!defined $pid) {
  170
+		$self->debug("cannot fork: $!");
  171
+	} elsif ($pid > 0) {
  172
+		# Parent process detaches.
  173
+		# Do nothing here.
  174
+	} else {
  175
+		# Child process.
  176
+		$sub->();
  177
+		close($self->fh);
  178
+		# We MUST use _exit(0) to avoid destructor calls.
  179
+		_exit(0);
  180
+	}
  181
+	
  182
+}
  183
+
  184
+# Convert space-delimited ID prefixes list to regexp.
  185
+sub _id_prefixes_to_re {
  186
+	my ($self, $id_prefixes) = @_;
  187
+	my $re = (sub {
  188
+		return undef if !defined $id_prefixes;
  189
+		$id_prefixes =~ s/^\s+|\s+$//sg;
  190
+		return undef if !$id_prefixes;
  191
+		my @prefixes = split /\s+/, $id_prefixes;
  192
+		my $login = $self->{cred}? $self->{cred}[0] : undef;
  193
+		@prefixes = grep { substr($_, 0, length($login) + 1) eq $login . "_" } @prefixes if defined $login;
  194
+		return undef if !@prefixes;
  195
+		return "^(?:" . join("|", map { "\Q$_" } @prefixes) . ")";
  196
+	})->();
  197
+	# In case of an empty regexp (which means "no check needed") and
  198
+	# if a login is presented, return never-matched regexp.
  199
+	if (!defined $re && $self->{cred}) {
  200
+		return "^!";
  201
+	}
  202
+	return $re;
  203
+}
  204
+
  205
+# Command: fetch all online IDs.
  206
+sub cmd_online {
  207
+	my ($self, $id_prefixes) = @_;
  208
+	$self->_async(sub {
  209
+		my $rids = $online_timers->get_ids_ref($self->_id_prefixes_to_re($id_prefixes));
  210
+		$self->debug("sending " . scalar(@$rids) . " online identifiers");
  211
+		$self->_send_response(@$rids? join(",", @$rids) . "\n" : "");
  212
+	});
  213
+}
  214
+
  215
+
  216
+# Command: watch for clients online/offline status changes.
  217
+sub cmd_watch {
  218
+	my ($self, $arg) = @_;
  219
+	$arg = "" if !defined $arg;
  220
+	my ($cursor, $id_prefixes) = split /\s+/, $arg, 2;
  221
+	$cursor = Realplexor::Tools::time_hi_res() if !defined $cursor || !length $cursor;
  222
+	$id_prefixes = "" if !defined $id_prefixes || !length $id_prefixes;
  223
+	my $list = $events->get_recent_events($cursor, $self->_id_prefixes_to_re($id_prefixes));
  224
+	$self->debug("sending " . @$list . " events");
  225
+	$self->_send_response(join "", map { $_->[1] . " " . $_->[0] . ":" . $_->[2] . "\n" } @$list);
  226
+}
  227
+
  228
+# Command: dump debug statistics.
  229
+# This command is for internal debugging only.
  230
+sub cmd_stats {
  231
+	my ($self) = @_;
  232
+	return if $self->{cred};
  233
+	$self->_async(sub {
  234
+		$self->debug("sending stats");
  235
+		$self->_send_response(
  236
+			"[data_to_send]\n" .
  237
+			$data_to_send->get_stats() .
  238
+			"\n[connected_fhs]\n" .
  239
+			$connected_fhs->get_stats() .
  240
+			"\n[online_timers]\n" .
  241
+			$online_timers->get_stats() .
  242
+			"\n[cleanup_timers]\n" .
  243
+			$cleanup_timers->get_stats() .
  244
+			"\n[pairs_by_fhs]\n" .
  245
+			$pairs_by_fhs->get_stats()
  246
+		);
  247
+	});
  248
+}
  249
+
  250
+# Send response anc close the connection.
  251
+sub _send_response {
  252
+	my ($self, $rdata, $code) = ($_[0], \$_[1], $_[2]);
  253
+	my $fh = $self->fh;
  254
+	print $fh "HTTP/1.0 " . ($code || "200 OK") . "\r\n";
  255
+	print $fh "Content-Type: text/plain\r\n";
  256
+	print $fh "Content-Length: " . length($$rdata) . "\r\n\r\n";
  257
+	print $fh $$rdata;
  258
+	shutdown($fh, 2);
  259
+}
  260
+
  261
+return 1;
129  Connection/Wait.pm
... ...
@@ -0,0 +1,129 @@
  1
+##
  2
+## WAIT connection.
  3
+##
  4
+package Connection::Wait;
  5
+use base 'Event::Lib::Connection';
  6
+use strict;
  7
+use Event::Lib;
  8
+use Storage::PairsByFhs; 
  9
+use Storage::ConnectedFhs; 
  10
+use Storage::OnlineTimers; 
  11
+use Storage::DataToSend;
  12
+use Realplexor::Config;
  13
+use Storage::Events;
  14
+
  15
+# Called on a new connection.
  16
+sub new {
  17
+	my ($class, @args) = @_;
  18
+	my $self = $class->SUPER::new(@args);
  19
+	$self->{pairs} = undef;
  20
+	$self->{data} = "";
  21
+	return $self;
  22
+}
  23
+
  24
+# Called when a data is available to read.
  25
+sub onread {
  26
+	my ($self, $data) = @_;
  27
+	$self->SUPER::onread($data);
  28
+
  29
+	# Data must be ignored, identifier is already extracted.
  30
+	if (defined $self->{pairs}) {
  31
+		return;
  32
+	}
  33
+	# Append data.
  34
+	$self->{data} .= $data;
  35
+
  36
+	# Try to extract IDs from the new data chunk.
  37
+	#print "----------\n" . $self->{data} . "\n---------------\n";
  38
+	my $pairs = Realplexor::Common::extract_pairs($self->{data});
  39
+	if (defined $pairs) {
  40
+		# Check if we have special marker: IFRAME.
  41
+		if ($pairs->[0][1] eq $CONFIG{IFRAME_ID}) {
  42
+			$self->debug("IFRAME marker received, sending content");
  43
+			Realplexor::Common::send_static($self->fh, 'IFRAME', 'text/html');
  44
+			return;
  45
+		}
  46
+		# Check if we have special marker: SCRIPT.
  47
+		if ($pairs->[0][1] eq $CONFIG{SCRIPT_ID}) {
  48
+			$self->debug("SCRIPT marker received, sending content");
  49
+			Realplexor::Common::send_static($self->fh, 'SCRIPT', 'text/javascript');
  50
+			return;
  51
+		}
  52
+		
  53
+		# IDs are extracted. Send response headers immediately.
  54
+		# We send response AFTER reading IDs, because before 
  55
+		# this reading we don't know if a static page or 
  56
+		# a data was requested.
  57
+		my $fh = $self->fh;
  58
+		print $fh 
  59
+			"HTTP/1.1 200 OK\r\n" .
  60
+			"Connection: close\r\n" .
  61
+			"Cache-Control: no-store, no-cache, must-revalidate\r\n" .
  62
+			"Expires: Mon, 26 Jul 1997 05:00:00 GMT\r\n" .
  63
+			"Content-Type: text/javascript; charset=$CONFIG{CHARSET}\r\n\r\n" .
  64
+			" \r\n"; # this immediate space plus text/javascript hides XMLHttpRequest in FireBug console
  65
+		$fh->flush();
  66
+		
  67
+		# Ignore all other input from IN and register identifiers.
  68
+		$self->{pairs} = $pairs;
  69
+		$self->{data} = undef; # GC
  70
+		$pairs_by_fhs->set_pairs_for_fh($self->fh, $pairs);
  71
+		foreach my $pair (@$pairs) {
  72
+			my ($cursor, $id) = @$pair;
  73
+			$self->debug("registering [$id]");
  74
+			$connected_fhs->add_to_id($id, $cursor, $self->fh);
  75
+			# Create new online timer, but do not start it - it is 
  76
+			# started at LAST connection close, later.
  77
+			my $firstTime = $online_timers->assign_stopped_timer_for_id($id, sub { 
  78
+				Realplexor::Common::logger("[$id] is now offline");
  79
+				$events->notify("offline", $id);
  80
+			});
  81
+			if ($firstTime) {
  82
+				# If above returned true, this ID was offline, but become online.
  83
+				$events->notify("online", $id);
  84
+			}
  85
+		}
  86
+		# Try to send pendings.
  87
+		Realplexor::Common::send_pendings([map { $_->[1] } @$pairs]);
  88
+		return;
  89
+	}
  90
+
  91
+	# Check for the data overflow.
  92
+	if (length($self->{data}) > $CONFIG{WAIT_MAXLEN}) {
  93
+		die "overflow (received " . length($data) . " bytes total)\n";
  94
+	}
  95
+}
  96
+
  97
+# Called on timeout (send error message).
  98
+sub ontimeout {
  99
+	my ($self) = @_;
  100
+	my $fh = $self->fh;
  101
+	if ($fh) {
  102
+		shutdown($fh, 2);
  103
+	}
  104
+	$self->SUPER::ontimeout();
  105
+}
  106
+
  107
+# Called on client disconnect.
  108
+sub onclose {
  109
+	my ($self) = @_;
  110
+	my $pairs = $self->{pairs};
  111
+	if (defined $pairs) {
  112
+		foreach my $pair (@$pairs) {
  113
+			my ($cursor, $id) = @$pair;
  114
+			# Remove the client from all lists.
  115
+			$connected_fhs->del_from_id_by_fh($id, $self->fh);
  116
+			# Turn on or restart online timer.
  117
+			$online_timers->start_timer_by_id($id, $CONFIG{OFFLINE_TIMEOUT});
  118
+		}
  119
+	}
  120
+	$pairs_by_fhs->remove_by_fh($self->fh);
  121
+}
  122
+
  123
+# Connection name is its ID.
  124
+sub name {
  125
+	my ($self) = @_;
  126
+	return $self->{pairs}? join(',', map { $_->[0] . ":" . $_->[1] } @{$self->{pairs}}) : undef;
  127
+}
  128
+
  129
+return 1;
85  Event/Lib/Connection.pm
... ...
@@ -0,0 +1,85 @@
  1
+##
  2
+## Connection abstraction.
  3
+##
  4
+## Object of this class is created when a connection is accepted
  5
+## and destroyed when its connection is closed. Each object
  6
+## represents a separated connection and may hold intermediate
  7
+## data collected while its connection is processed.
  8
+##
  9
+package Event::Lib::Connection;
  10
+use strict;
  11
+
  12
+# Called on new connection.
  13
+# DO NOT save $event object here to avoid cyclic references!
  14
+sub new {
  15
+	my ($class, $fh, $server) = @_;
  16
+	my $self = bless {
  17
+		fh     => $fh,
  18
+		server => $server,
  19
+		# Save peer address now, because it may be inaccessible
  20
+		# in case of the manual socket shutdown.
  21
+		addr   => ($fh->peerhost||'?') . ":" . ($fh->peerport||'?'),
  22
+	}, $class;
  23
+	$self->debug("connection opened");
  24
+	return $self;
  25
+}
  26
+
  27
+# Called on connection close.
  28
+sub DESTROY {
  29
+	my ($self) = @_;
  30
+	eval {
  31
+		$self->onclose();
  32
+	};
  33
+	if ($@) {
  34
+		$self->server->error($self->fh, $@);
  35
+	}
  36
+	$self->debug("connection closed");
  37
+}
  38
+
  39
+# Called on timeout.
  40
+sub ontimeout {
  41
+	my ($self) = @_;
  42
+	$self->debug("timeout");
  43
+}
  44
+
  45
+# Called on event exception.
  46
+sub onerror {
  47
+	my ($self, $msg) = @_;
  48
+	$self->debug("error: $msg");
  49
+}
  50
+
  51
+# Called on data read.
  52
+sub onread {
  53
+	my ($self, $data) = @_;
  54
+	$self->debug("read " . length($data) . " bytes");
  55
+}
  56
+
  57
+# Called on close.
  58
+sub onclose {
  59
+}
  60
+
  61
+# Returns the socket.
  62
+sub fh {
  63
+	my ($self) = @_;
  64
+	return $self->{fh};
  65
+}
  66
+
  67
+# Returns the server.
  68
+sub server {
  69
+	my ($self) = @_;
  70
+	return $self->{server};
  71
+}
  72
+
  73
+# Returns this connection name.
  74
+sub name {
  75
+	return undef;
  76
+}
  77
+
  78
+# Prints a debug message.
  79
+sub debug {
  80
+	my ($self, $msg) = @_;
  81
+	my $name = $self->name;
  82
+	$self->{server}->debug($self->{addr}, ($name? "[$name] " : "") . $msg);
  83
+}
  84
+
  85
+return 1;
161  Event/Lib/Server.pm
... ...
@@ -0,0 +1,161 @@
  1
+##
  2
+## Server abstraction.
  3
+##
  4
+## Object of this class listens for incoming connection, accepts
  5
+## it and creates corresponding Event::Lib::Connection object.
  6
+##
  7
+package Event::Lib::Server;
  8
+use strict;
  9
+use IO::Socket::INET;
  10
+use Event::Lib;
  11
+use Carp;
  12
+use Time::HiRes 'time';
  13
+
  14
+# Static function.
  15
+# Runs the event mainloop.
  16
+sub mainloop {
  17
+	event_mainloop();
  18
+}
  19
+
  20
+# Static function.
  21
+# Assigns signal handler.
  22
+sub signal {
  23
+	my ($type, $sub) = @_;
  24
+	my $signal = signal_new($type, $sub);
  25
+	$signal->add();
  26
+}
  27
+
  28
+# Creates a new server pool.
  29
+sub new {
  30
+	my ($class, %params) = @_;
  31
+	my $self = bless {
  32
+		%params,
  33
+		name    => ($params{name} or croak "Argument 'name' required"),
  34
+		listen  => ($params{listen} or croak "Argument 'listen' required"),
  35
+		timeout => (defined $params{timeout}? $params{timeout} : croak "Argument 'timeout' required"),
  36
+		connectionclass => ($params{connectionclass} or croak "Argument 'connectionclass' required"),
  37
+	}, $class;
  38
+	my @events = ();
  39
+	my $lastAddr = undef;
  40
+	eval {
  41
+		foreach my $addr (@{$self->{listen}}) {
  42
+			$lastAddr = $addr;
  43
+			push @events, $self->add_listen($addr);
  44
+		}
  45
+	};
  46
+	if ($@) {
  47
+		$_->remove() foreach @events;
  48
+		croak(($lastAddr? "$lastAddr: " : "") . $@);
  49
+	}
  50
+	return $self;
  51
+}
  52
+
  53
+# Adds a new listen address to the pool.
  54
+# Croaks in case of error.
  55
+sub add_listen {
  56
+	my ($self, $addr) = @_;
  57
+	my $server = IO::Socket::INET->new(
  58
+		LocalAddr   => $addr,
  59
+		Proto       => 'tcp',
  60
+		ReuseAddr   => SO_REUSEADDR,
  61
+		Listen      => 50000,
  62
+		Blocking    => 1,
  63
+	) or croak $@;
  64
+	my $event  = event_new(
  65
+		$server, EV_READ|EV_PERSIST, 
  66
+		\&handle_connect,
  67
+		$self
  68
+	);
  69
+	$event->add();
  70
+	$self->message(undef, "listening $addr");
  71
+	return $event;
  72
+}
  73
+
  74
+# Called on a new connect.
  75
+sub handle_connect {
  76
+	my ($e, $type, $self) = @_;
  77
+	eval {
  78
+		my $socket = $e->fh->accept() or die "accept failed: $@";
  79
+		$socket->blocking(0);
  80
+		# Try to add an event.
  81
+		my $event = event_new($socket, EV_READ|EV_PERSIST, \&handle_read);
  82
+		$event->add($self->{timeout});
  83
+		# If we are here, event is successfully added. Assign error handler.
  84
+		my $connection = $self->{connectionclass}->new($socket, $self);
  85
+		$event->args($self, $connection);
  86
+		$event->except_handler(\&handle_except);
  87
+	};
  88
+	$self->error($e->fh, $@) if $@;
  89
+}
  90
+
  91
+# Called on data read.
  92
+sub handle_read {
  93
+	my ($e, $type, $self, $connection) = @_;
  94
+	eval {
  95
+		my $h = $e->fh;
  96
+	
  97
+		# Timeout?
  98
+		if ($type == EV_TIMEOUT) {
  99
+			$connection->ontimeout();
  100
+			$e->remove();
  101
+			return;
  102
+		}
  103
+	
  104
+		# Read the next data chunk.
  105
+		local $/;
  106
+		my $data = <$h>;
  107
+			
  108
+		# End of the request reached.
  109
+		if (!defined $data) {
  110
+			$e->remove();
  111
+			return;
  112
+		}
  113
+	
  114
+		# Run data handler.
  115
+		$connection->onread($data);
  116
+	};
  117
+	if ($@) {
  118
+		$self->error($e->fh, $@);
  119
+		$e->remove();
  120
+	}
  121
+}
  122
+
  123
+# Called on error.
  124
+sub handle_except {
  125
+	my ($e, $msg, $type, $self, $connection) = @_;
  126
+	eval {
  127
+		$connection->onerror($msg);
  128
+		$e->remove();
  129
+	};
  130
+	$self->error($e->fh, $@) if $@;
  131
+}
  132
+
  133
+# Controls debug messages.
  134
+sub debug {
  135
+	my ($self, $fh, $msg) = @_;
  136
+	$self->message($fh, "DEBUG: $msg");
  137
+}
  138
+
  139
+# Controls error messages.
  140
+sub error {
  141
+	my ($self, $fh, $msg) = @_;
  142
+	$self->message($fh, "ERROR: $msg");
  143
+}
  144
+
  145
+# Controls info messages.
  146
+sub message {
  147
+	my ($self, $addr, $msg) = @_;
  148
+	chomp($msg);
  149
+	if (ref $addr) {
  150
+		$addr = ($addr->peerhost||'?') . ":" . ($addr->peerport||'?');
  151
+	}
  152
+	$msg = $addr . ": " . $msg if $addr;
  153
+	$msg = $self->{name} . ": " . $msg;
  154
+	if (exists $self->{logger}) {
  155
+		$self->{logger}->($msg) if $self->{logger};
  156
+	} else {
  157
+		print "[" . localtime(time) . "] $msg\n";
  158
+	}
  159
+}
  160
+
  161
+return 1;
107  README.txt
... ...
@@ -0,0 +1,107 @@
  1
+Dklab Realplexor v1.20: Comet server which handles 1000000+ parallel browser connections.
  2
+(C) dkLab, http://dklab.ru/lib/dklab_realplexor/
  3
+Changelog: http://github.com/DmitryKoterov/dklab_realplexor/commits/master/
  4
+
  5
+
  6
+INSTALLATION ON LINUX
  7
+---------------------
  8
+
  9
+0. First of all, run ./dklab_realplexor.pl manually and check that all
  10
+   needed libraries are installed. If not, compile & install them:
  11
+   - For RHEL (RedHat, CentOS):
  12
+     # yum install libevent-devel gcc
  13
+     # perl -MCPAN -e "install Event::Lib"
  14
+   - For Debian (or Ubuntu):
  15
+     # apt-get install libevent-dev gcc
  16
+     # perl -MCPAN -e "install Event::Lib"
  17
+
  18
+1. Copy Realplexor to /opt/dklab_realplexor (or you may create a symlink).
  19
+   # cp -a . /opt/dklab_realplexor
  20
+     - or -
  21
+   # ln -s `pws` /opt/dklab_realplexor
  22
+
  23
+2. Create /etc/dklab_realplexor.conf if you need a custom configuration.
  24
+   (You may create a symlink instead of creating the file.)
  25
+
  26
+   # cat > /etc/dklab_realplexor.conf
  27
+   $CONFIG{WAIT_ADDR} = [ '1.2.3.4:80' ];  # your IP address and port
  28
+   $CONFIG{IN_ADDR} = [ '5.6.7.8:10010' ]; # for IN line
  29
+   return 1;
  30
+   ^D
  31
+
  32
+     - or -
  33
+
  34
+   # ln -s /path/to/your/config.conf /etc/dklab_realplexor.conf 
  35
+   
  36
+3. Use bundled init-script to start Realplexor as a Linux service:
  37
+   # ln -s /opt/dklab_realplexor/dklab_realplexor.init /etc/init.d/dklab_realplexor
  38
+   
  39
+4. Tell your system to start Realplexor at boot:
  40
+   - For RHEL (RedHat, CentOS):
  41
+     # chkconfig --add dklab_realplexor
  42
+     # chkconfig dklab_realplexor on
  43
+   - For Debian (or Ubuntu):
  44
+     # update-rc.d dklab_realplexor defaults
  45
+     # update-rc.d dklab_realplexor start
  46
+
  47
+
  48
+SYNOPSYS
  49
+--------
  50
+
  51
+1. In JavaScript code, execute:
  52
+<script type="text/javascript" src="/path/to/dklab_realplexor.js"></script>
  53
+var realplexor = new Dklab_Realplexor("http://rpl.yoursite.com/");
  54
+realplexor.subscribe("alpha", function(data) { alert("alpha: " + data) });
  55
+realplexor.subscribe("beta", function(data) { alert("beta: " + data) });
  56
+realplexor.execute();
  57
+
  58
+2. In PHP code, execute:
  59
+require dirname(__FILE__) . '/Dklab/Realplexor.php';
  60
+$realplexor = new Dklab_Realplexor("127.0.0.1", "10010");
  61
+$realplexor->send(array("alpha", "beta"), "hello!");
  62
+
  63
+3. See more details in Realplexor documentation.
  64
+
  65
+
  66
+LOG MNEMONICS
  67
+-------------
  68
+
  69
+pairs_by_fhs
  70
+  Number of active TCP connections on WAIT line (clients).
  71
+
  72
+data_to_send
  73
+  Number of IDs with non-empty command queue.
  74
+
  75
+connected_fhs
  76
+  Number of IDs which are listened by at least one client.
  77
+  
  78
+online_timers
  79
+  Number of "online" client identifiers. Client is treated as online if:
  80
+  - it has an active connection;
  81
+  - or it does not have a connection, but disconnected no more than
  82
+    OFFLINE_TIMEOUT seconds ago.
  83
+
  84
+cleanup_timers
  85
+  Number of IDs which queue must be cleaned if no activity is present for
  86
+  a long time. This is a unused IDs garbage collector statistics.
  87
+
  88
+events
  89
+  How many events (e.g. ONLINE/OFFLINE status changes) are collected
  90
+  by realplexor. Event queue is limited by size.
  91
+
  92
+
  93
+CHANGELOG
  94
+---------
  95
+
  96
+* Dklab Realplexor 2009-12-22: v1.20
  97
+  - [NEW] ID queue is cleaned after CLEAN_ID_AFTER seconds when no data arrived
  98
+    (previously OFFLINE_TIMEOUT was used for that).
  99
+
  100
+* Dklab Realplexor 2009-12-16: v1.15
  101
+  - [NEW] When IDs list is long, JS API uses POST request instead of GET.
  102
+  - [NEW] IN line now fully supports HTTP POST.
  103
+  - [NEW] Non-200 responses from IN line are converted to exceptions.
  104
+  - [NEW] Content-Length verification in PHP API.
  105
+  - [NEW] Support for SSL in IN line for PHP API (use 443 port).
  106
+  - [BUG] If callback called execute(), extra request was performed.
  107
+  - [BUG] Referrer header was not ignored by server engine (bad if it contains IFRAME marker).
246  Realplexor/Common.pm
... ...
@@ -0,0 +1,246 @@
  1
+##
  2
+## Realplexor shared routines.
  3
+##
  4
+package Realplexor::Common;
  5
+use strict;
  6
+use Storage::DataToSend;
  7
+use Storage::ConnectedFhs;
  8
+use Storage::OnlineTimers;
  9
+use Storage::PairsByFhs;
  10
+use Storage::CleanupTimers;
  11
+use Storage::Events;
  12
+use Event::Lib::Connection;
  13
+use Event::Lib::Server;
  14
+use Connection::Wait;
  15
+use Connection::In;
  16
+use Realplexor::Config;
  17
+use Realplexor::Tools;
  18
+use Time::HiRes;
  19
+use Digest::MD5;
  20
+
  21
+# Extract pairs [cursor, ID] from the client data. 
  22
+# Return [ [cursor1, id1], [cursor2, id2], ... ] or undef if 
  23
+# no "identifier" marker is found yet.
  24
+#
  25
+# If you call this sub in a list context, the second return
  26
+# value is the list of IDs marked by "*" at identifier=...
  27
+# (this means that these IDs must be listened by a client
  28
+# too to receive the data).
  29
+#
  30
+# If login and password are specified, third return value
  31
+# is [login, password] pair.
  32
+# 
  33
+# Format: 
  34
+# - identifier=abc                         [single identifier]
  35
+# - identifier=abc,def,ghi                 [multiple identifiers]
  36
+# - identifier=12345.23:abc,12345:def      [where 12345... is the cursor]
  37
+# - identifier=abc,def,*ghi,*jkl           [multiple ids, and (ghi, jkl) is returned as second list element]
  38
+# - identifier=LOGIN:PASS@abc,10:def,*ghi  [same as above, but login and password are specified]
  39
+sub extract_pairs {
  40
+	my $rdata = \$_[0];
  41
+	my $from_in_line = $_[1];
  42
+	# Return fast if no identifier marker is presented yet.
  43
+	return undef if index($$rdata, "$CONFIG{IDENTIFIER}=") < 0;
  44
+	# Identifier marker seems to be presented. Remove referrer headers.
  45
+	# TODO: speed optimization.
  46
+	my $data = $$rdata; 
  47
+	$data =~ s/^[ \t]*Referer:[^\r\n]*//mgi;
  48
+	# Now check for identifier freely.
  49
+	my ($login, $password, $ids) = $data =~ m{
  50
+		\b 
  51
+		$CONFIG{IDENTIFIER} =
  52
+		(?: (\w+) : ([^@\s]+) @ )?
  53
+		([*\w,.:]*)
  54
+		# At the end, find a character, NOT end of string! 
  55
+		# Because only a chunk may finish, not the whole data.
  56
+		[^*\w,.:] 
  57
+	}sx or return undef;
  58
+	# By default, current HiRes time is returned for cursor.
  59
+	# It's very important that time_hi_res() returns Math::BigFloat, because
  60
+	# system timer resolution is not enough to differ sequential calls.
  61
+	my $time = Realplexor::Tools::time_hi_res();
  62
+	my %limit_ids = ();
  63
+	my @pairs = map {
  64
+		if (m/^ (\*?) (?: (\d+(?:\.\d+)?) : )? (\w+) $/sx) {
  65
+			if ($1) {
  66
+				# ID with limiter.
  67
+				$limit_ids{$3} = 1;
  68
+			}
  69
+			if (!$1 || !$from_in_line) {
  70
+				# Not limiter or limiter, but in WAIT line.
  71
+				defined $2 && length($2) ? [ $2, $3 ] : [ $time, $3 ];
  72
+			} else {
  73
+				();
  74
+			}
  75
+		} else {
  76
+			();
  77
+		}
  78
+	} split(/,/, $ids);
  79
+	return wantarray()? (\@pairs, (%limit_ids? \%limit_ids : undef), ($login? [$login, $password] : undef)) : \@pairs;
  80
+}
  81
+
  82
+# Shutdown a connection and remove all references to it.
  83
+sub shutdown_fh {
  84
+	my ($fh) = @_;
  85
+	# Remove all references to $fh from everywhere.
  86
+	foreach my $pair ($pairs_by_fhs->get_pairs_by_fh($fh)) {
  87
+		$connected_fhs->del_from_id_by_fh($pair->[1], $fh);
  88
+	}
  89
+	$pairs_by_fhs->remove_by_fh($fh);
  90
+	return shutdown($fh, 2);
  91
+}
  92
+
  93
+# Send first pending data to clients with specified IDs.
  94
+# Remove sent data from the queue and close connections to clients.
  95
+sub send_pendings {
  96
+	my ($ids) = @_;
  97
+	
  98
+	# Functions to be called to check data visibility.
  99
+	my @visibility_checkers =  (
  100
+		\&hook_check_visibility, 
  101
+		grep { $_ } ($CONFIG{HOOK_CHECK_VISIBILITY})
  102
+	);
  103
+	
  104
+	# Collect data to be sent to each connection at %data_by_fh.
  105
+	# For each connection also collect matched IDs, so each client
  106
+	# receives only the list of IDs which is matched by his request
  107
+	# (client does not see IDs of other clients).
  108
+	my %data_by_fh = ();
  109
+	my %fh_by_fh = ();
  110
+	my %seen_ids = ();
  111
+	foreach my $id (@$ids) {
  112
+		# All data items for this ID.
  113
+		my $data = $data_to_send->get_data_by_id($id) or next;
  114
+		# Who listen this ID.
  115
+		my $fhs_hash = $connected_fhs->get_hash_by_id($id) or next;
  116
+		while (my ($dummy, $cursor_and_fh) = each %$fhs_hash) {
  117
+			# Process a single FH which listens this ID at $cursor.
  118
+			my ($listen_cursor, $fh) = @$cursor_and_fh;
  119
+			# What other IDs listens this FH.
  120
+			my $what_listens_this_fh = [ $pairs_by_fhs->get_pairs_by_fh($fh) ];
  121
+			$fh_by_fh{$fh} = $fh;
  122
+			# Iterate over data items.
  123
+			ONE_ITEM:
  124
+			foreach my $item (@$data) {
  125
+				# Process a single data item in context of this FH.
  126
+				my ($cursor, $rdata, $limit_ids) = @$item;
  127
+				# Filter data invisible to this client.
  128
+				foreach my $func (@visibility_checkers) {
  129
+					next ONE_ITEM if !$func->(
  130
+						id           => $id,
  131
+						cursor        => $cursor,
  132
+						rdata        => $rdata,
  133
+						limit_ids    => $limit_ids,
  134
+						listen_cursor => $listen_cursor,
  135
+						listen_pairs => $what_listens_this_fh,
  136
+					);
  137
+				}
  138
+				# Hash by dataref to avoid to send the same data 
  139
+				# twice if it is appeared in multiple IDs.
  140
+				if (!$data_by_fh{$fh}{$rdata}) {
  141
+					$data_by_fh{$fh}{$rdata} = {
  142
+						cursor => $cursor, 
  143
+						rdata => $rdata, 
  144
+						ids   => { $id => $cursor }
  145
+					};
  146
+				} else {
  147
+					# Add new ID to the list of IDs for this data.
  148
+					$data_by_fh{$fh}{$rdata}{ids}{$id} = $cursor;
  149
+				}
  150
+				$seen_ids{$id} = 1;
  151
+			}
  152
+		}
  153
+	}
  154
+	
  155
+	# Send data to each connection (json array format).
  156
+	# Response format is:
  157
+	# [
  158
+	#   {
  159
+	#     "ids": { "id1": cursor1, "id2": cursor2, ... },
  160
+	#     "data": <data from server without headers>
  161
+	#   },
  162
+	#   {
  163
+	#     "ids": { "id3": cursor3, "id4": cursor4, ... },
  164
+	#     "data": <data from server without headers>
  165
+	#   },
  166
+	#   ...
  167
+	# }
  168
+	my @seen_ids = sort keys %seen_ids;
  169
+	while (my ($fh, $triples) = each %data_by_fh) {
  170
+		my @out = ();
  171
+		# Ordering is for better determinism in tests.
  172
+		foreach my $triple (sort { $a->{cursor} <=> $b->{cursor} or ${$a->{rdata}} cmp ${$b->{rdata}} } values %$triples) {
  173
+			# Build one response block.
  174
+			# It's very to send cursors as string to avoid rounding.
  175
+			my @ids = 
  176
+				map { '"' . $_ . '": "' . $triple->{ids}{$_} . '"' } 
  177
+				sort keys %{$triple->{ids}};
  178
+			push @out, join "\n",
  179
+				'  {',
  180
+				'    "ids": { ' . join(", ", @ids) . ' },',
  181
+				'    "data":' . (${$triple->{rdata}} =~ /\n/? "\n" : " ") . ${$triple->{rdata}},
  182
+				'  }';
  183
+		}
  184
+		# Join response blocks into one "multipart".
  185
+		my $out = "[\n" . join(",\n", @out) . "\n]";
  186
+		my $fh = $fh_by_fh{$fh};
  187
+		my $r1 = print $fh $out;
  188
+		my $r2 = shutdown_fh($fh);
  189
+		logger("<- sending " . @out . " responses (" . length($out) . " bytes) from [" . join(", ", @seen_ids) . "] (print=$r1, shutdown=$r2)");
  190
+	}
  191
+	# Remove old data.
  192
+	foreach my $id (@$ids) {
  193
+		$data_to_send->clean_old_data_for_id($id, $CONFIG{MAX_DATA_FOR_ID});
  194
+	}
  195
+}
  196
+
  197
+# Called to check visibility of a data block.
  198
+sub hook_check_visibility {
  199
+	my (%a) = @_;
  200
+
  201
+#	use Data::Dumper; print Dumper(\%a);
  202
+	
  203
+	# 1. Filter old data.
  204
+	return 0 if $a{cursor} <= $a{listen_cursor};
  205
+		
  206
+	# 2. If this data block has limited visibility, check that
  207
+	#    current client listens at least one ID in the associated
  208
+	#    limiter list.
  209
+	return 0 if $a{limit_ids} && !grep { $a{limit_ids}{$_->[1]} } @{$a{listen_pairs}};
  210
+				
  211
+	# OK.
  212
+	return 1;
  213
+}
  214
+
  215
+# Send IFRAME content.
  216
+sub send_static {
  217
+	my ($fh, $param, $type) = @_;
  218
+	print $fh "HTTP/1.1 200 OK\r\n";
  219
+	print $fh "Connection: close\r\n";
  220
+	print $fh "Content-Type: $type\r\n";
  221
+	print $fh "Last-Modified: " . $CONFIG{"${param}_TIME"} . "\r\n";
  222
+	print $fh "Expires: Wed, 08 Jul 2037 22:53:52 GMT\r\n";
  223
+	print $fh "Cache-Control: public\r\n";
  224
+	print $fh "\r\n";
  225
+	print $fh $CONFIG{"${param}_CONTENT"};
  226
+	shutdown($fh, 2); # don't use close, it breaks event machine!
  227
+}
  228
+
  229
+# Logger routine.
  230
+sub logger {
  231
+	my ($msg, $nostat) = @_;
  232
+	my $verb = defined $CONFIG{VERBOSITY}? $CONFIG{VERBOSITY} : 100;
  233
+	return if $verb == 0;
  234
+	$msg = $msg . "\n  " . sprintf(
  235
+		"[pairs_by_fhs=%d data_to_send=%d connected_fhs=%d online_timers=%d cleanup_timers=%d events=%d]", 
  236
+		$pairs_by_fhs->get_num_items(),
  237
+		$data_to_send->get_num_items(), 
  238
+		$connected_fhs->get_num_items(), 
  239
+		$online_timers->get_num_items(),
  240
+		$cleanup_timers->get_num_items(),
  241
+		$events->get_num_items()
  242
+	) if !$nostat && $verb > 1;
  243
+	print "[" . localtime(time) . "] $msg\n";
  244
+}
  245
+
  246
+return 1;
104  Realplexor/Config.pm
... ...
@@ -0,0 +1,104 @@
  1
+##
  2
+## Realplexor configuration.
  3
+##
  4
+package Realplexor::Config;
  5
+use strict;
  6
+use base 'Exporter';
  7
+use Event::Lib;
  8
+use File::Basename;
  9
+use Cwd 'abs_path';
  10
+use POSIX 'strftime';
  11
+our @EXPORT = qw(%CONFIG);
  12
+our %CONFIG;
  13
+
  14
+my $root = dirname(dirname(abs_path(__FILE__)));
  15
+
  16
+#
  17
+# Additional auto-generated parameters:
  18
+# - IFRAME_CONTENT
  19
+# - IFRAME_TIME
  20
+#
  21
+
  22
+# Load config.
  23
+sub load {
  24
+	my ($add) = @_;
  25
+	# Reset config.
  26
+	%CONFIG = ();
  27
+	# Read default config.
  28
+	do($root . "/dklab_realplexor.conf"); die $@ if $@;
  29
+	# Read custom config.
  30
+	if ($add) {
  31
+		if (-f $add) {
  32
+			Realplexor::Common::logger("CONFIG: appending configuration from $add");
  33
+			do($add); die $@ if $@;
  34
+		} else {
  35
+			Realplexor::Common::logger("CONFIG: file $add does not exist, skipping");
  36
+		}
  37
+	}
  38
+	# Create custom properties.
  39
+	foreach my $param ('IFRAME', 'SCRIPT') {
  40
+		# Build IFRAME data.
  41
+		my $fname = $CONFIG{"${param}_FILE"};
  42
+		$fname = $root . "/" . $fname if $fname !~ m{^/}s;
  43
+		open(local *F, $fname) or die "Cannot read $fname: $!\n";
  44
+		local $/;
  45
+		my $content = <F>;
  46
+		close(F);
  47
+		$content =~ s{\$([a-z]\w*)}{defined $CONFIG{$1}? $CONFIG{$1} : "undefined-$1"}sgei;
  48
+		# Assign additional parameters.
  49
+		$CONFIG{"${param}_CONTENT"} = $content;
  50
+		$CONFIG{"${param}_TIME"} = strftime("%a, %e %b %Y %H:%M:%S GMT", gmtime((stat $fname)[9]));
  51
+	}
  52
+	$CONFIG{USERS} = read_users($CONFIG{USERS_FILE});
  53
+	
  54
+}
  55
+
  56
+# Read htpasswd-style users list.
  57
+sub read_users {
  58
+	my ($file) = @_;
  59
+	$file = $root . '/' . $file if $file !~ m{^/}s;
  60
+	open(local *F, $file) or die "Cannot open $file: $!\n";
  61
+	my %users = ();
  62
+	while (<F>) {
  63
+		s/#.*//sg;
  64
+		s/^\s+|\s+$//sg;
  65
+		next if !$_;
  66
+		my ($login, $pass) = split ":", $_, 2;
  67
+		next if !defined $pass;
  68
+		if (length($login) && $login !~ /^[a-z0-9]+$/is) {
  69
+			# Must not contain special characters like "_" and others.
  70
+			Realplexor::Common::logger("Warning: login \"$login\" is not alphanumeric, skipped.");
  71
+			next;
  72
+		}
  73
+		$users{$login} = $pass;
  74
+	}
  75
+	return \%users;
  76
+}
  77
+
  78
+# Return 1 if we need hard restart.
  79
+sub reload {
  80
+	my ($add) = @_;
  81
+	my $lowlevel = qr/^(WAIT_ADDR|WAIT_TIMEOUT|IN_ADDIN_TIMEOUT|SU_.*)$/s;
  82
+	my $ignore = qr/^(HOOK_|.*_CONTENT)$/s;
  83
+	# Load new config.
  84
+	my %old = %CONFIG;
  85
+	if (!eval { load($add); return 1 }) {
  86
+		Realplexor::Common::logger("Error reloading config, continue with old settings: $@");
  87
+		%CONFIG = %old;
  88
+		return;
  89
+	}
  90
+	# Check which options are changed.
  91
+	while (my ($opt, $v) = each %CONFIG) {
  92
+		my $o = $old{$opt};
  93
+		my $v_old = join(", ", @{ref $o eq 'ARRAY' && $o  or  ref $o eq 'HASH' && [map { "\"$_=>$o->{$_}\"" } keys %$o]  or  [$o||""]});
  94
+		my $v_new = join(", ", @{ref $v eq 'ARRAY' && $v  or  ref $v eq 'HASH' && [map { "\"$_=>$v->{$_}\"" } keys %$v]  or  [$v||""]});
  95
+		if ($v_old ne $v_new) {
  96
+			return $opt if $opt =~ $lowlevel;
  97
+			next if $opt =~ $ignore || ref $v eq "CODE";
  98
+			Realplexor::Common::logger("Option $opt is changed: $v_old -> $v_new");
  99
+		}
  100
+	}
  101
+	return;
  102
+}
  103
+
  104
+return 1;
38  Realplexor/Tools.pm
... ...
@@ -0,0 +1,38 @@
  1
+##
  2
+## Realplexor tools.
  3
+##
  4
+package Realplexor::Tools;
  5
+use strict;
  6
+use Time::HiRes;
  7
+use Math::BigFloat;
  8
+
  9
+# Counter to make the time unique.
  10
+my $time_counter = 0;
  11
+
  12
+# Return HiRes time. It is guaranteed that two sequencial calls
  13
+# of this function always return different time, second > first.
  14
+#
  15
+# ATTENTION! This function returns Math::BigFloat value, because
  16
+# standard double is not enough to differ sequential calls of 
  17
+# this function.
  18
+sub time_hi_res {
  19
+	my $time = new Math::BigFloat(Time::HiRes::time());
  20
+	$time->precision(-14); # number of digits after "."
  21
+	my $cycle = 1000;
  22
+	$time_counter++;
  23
+	$time_counter = 0 if $time_counter > $cycle;
  24
+	my $add = (1.0 / $cycle) * $time_counter * 0.000001;
  25
+	return $time + $add;
  26
+}
  27
+