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
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
#!/usr/bin/perl -w
=head1 NAME
screen-server-backend - TODO
=head1 SYNOPSIS
screen-server-backend [options]
--help TODO
--debug
--name <screen name> TODO
--daemonize (Default)
--no-daemonize
=head1 DESCRIPTION
TODO
=cut
use strict;
# Seemingly socat doesn't seem to transmit STDERR automatically so
# re-route it myself.
#
*STDERR = *STDOUT;
# Option handling
#
use Getopt::Long ();
Getopt::Long::GetOptions(
help => \&pod2usage,
debug => \ my $debug,
name => \ my $screen_name,
'daemonize!' => \ my $daemonize,
)
or pod2usage();
# Daemonization by default
#
if ( $daemonize ) {
fork && exit;
fork && exit;
umask 0;
chdir '/';
}
# Automatically clean up zombie children
#
$SIG{CHLD} = 'IGNORE';
require File::Temp;
my ( $log_fh, $log_fn ) = File::Temp::tempfile();
my $top_pid = $$;
my $child_pid = fork;
if ( ! defined $child_pid ) {
# Oops, failure. Is there a fork bomb going on?
#
die "Can't fork: $!";
}
elsif ( 0 == $child_pid ) {
# Double-fork so our parent can reap us immediately and the
# exec() below will be reaped by init.
#
fork && exit;
fork && exit;
# Wait until either the parent socat has exited or it has logged
# the right thing.
#
require Time::HiRes;
Time::HiRes::sleep( 0.05 )
while ! -s $log_fh
|| kill 0, $top_pid;
# Read the PTY from the socat logfile and have /usr/bin/screen
# start a window against it. If all goes well, we'll exec() right
# out of this loop and never finish it.
#
while ( my $l = <$log_fh> ) {
# socat under `-d -d' flags will print a line like the
# following. In the parent, socat is configured to write its
# debugging log to a $log_fn which we have a handle to in
# $log_fh.
#
# PTY is /dev/pts/4
#
if ( $l =~ m{PTY is (/dev/pts/\d+)} ) {
my $pty = $1;
# Clean up the log file. We don't need it anymore. socat
# itself may keep it open however. This is unfortunate.
#
truncate $log_fh, 0;
close $log_fh;
unlink $log_fn;
# exec screen to open a new window using the PTY allocated
# by socat.
#
my @screen_opts;
if ( $screen_name ) {
push @screen_opts, '-S' => $screen_name;
}
my @cmd = (
'screen',
@screen_opts,
'-X' => 'screen', $pty
);
if ( $debug ) {
print STDERR "exec( @cmd )\n";
}
exec @cmd;
}
}
# This is an error condition.
#
# I was unable to read any "PTY is /dev/pts/#" lines in the
# socat log so something has gone wrong. Kill off the socat if
# it's still present.
#
# TODO: check for actual death, wait between signals
close $log_fh;
unlink $log_fn;
kill -2, $top_pid; # SIGINT
kill -15, $top_pid; # SIGTERM
kill -9, $top_pid; # SIGKILL
}
elsif ( $child_pid ) {
# Tie our input to a new PTY and write the PTY's name to a log
# file so the child can pick it up.
#
# I request two levels of -d debug to get the a message "PTY is
# /dev/pts/#" in the log file at -lf. The child process is going
# to delete this log file.
#
my @cmd = (
'socat',
'-d', '-d',
"-lf$log_fn",
'-' => 'PTY',
);
if ( $debug ) {
print STDERR "exec( @cmd )\n";
}
exec @cmd;
}
sub pod2usage {
require Pod::Usage;
goto &Pod::Usage::pod2usage;
}