ここから G.711 のエンコーダである． G.711 のあつかいについては 「Perl による G.711 の処理」 において，よりくわしくあつかっている．

#=============================================================================
# ulaw -> linear conversion table generator
#=============================================================================

my $QUANT_MASK = 0xf;
my $BIAS = 0x84;
my $SEG_MASK = 0x70;
my $SEG_SHIFT = 4;
my $SIGN_BIT = 0x80;

my @u2l;

sub u2l($) {
    my ($uval) = @_;
    $uval = ~$uval;
    my $t = (($uval & $QUANT_MASK) << 3) + $BIAS;
    $t <<= ($uval & $SEG_MASK) >> $SEG_SHIFT;
    return ($uval & $SIGN_BIT) ? ($BIAS - $t) : ($t - $BIAS);
}

### gen_u2l()
#   generate ulaw-to-linear conversion table (@u2l)
#
sub gen_u2l() {
    for (my $i = 0; $i < 256; $i++) {
        $u2l[$i] = u2l($i);
    };
}

ここから音声出力のための初期化をおこなう部分である．

#=============================================================================
# Open sound output
#=============================================================================

my $BUF_SIZE = 2000;

sub open_sound_output() {
    my $status;
    my $parameter;

    open(SOUND_OUT, ">/dev/audio") || die "Sound output open failed!\n";

    # 16 bit sampling for output
    my $bits = pack("L", 16);
    $status = ioctl(SOUND_OUT, SOUND_PCM_WRITE_BITS(), $bits);
    if ($status < 0) {
        print stderr "8 bit sampling setting failed!\n";
    };

    # 2-channel (binaural)
    # $parameter = pack("L", 1);
    # $status = ioctl(SOUND_OUT, SNDCTL_DSP_STEREO(), $parameter);
    # if ($status < 0) {
    #     print stderr "Stereo setting failed!\n";
    # };

    # Number of channels = 2
    $parameter = pack("L", 2);
    $status = ioctl(SOUND_OUT, SNDCTL_DSP_CHANNELS(), $parameter);
    # $status = ioctl(SOUND_OUT, SOUND_PCM_WRITE_CHANNELS(), $parameter);
    if ($status < 0) {
	print stderr "#Channels setting failed!\n";
    };

    # 8000 Hz sampling rate for output
    my $sampling = pack("L", 8000);
    $status = ioctl(SOUND_OUT, SNDCTL_DSP_SPEED(), $sampling);
    # $status = ioctl(SOUND_OUT, SOUND_PCM_WRITE_RATE(), $sampling);
    if ($status < 0) {
        print stderr "8000 Hz sampling rate setting failed!\n";
    };

    # Buffer underrun may be cause by network
    $parameter = APF_NETWORK();
    $status = ioctl(SOUND_OUT, SNDCTL_DSP_PROFILE(), $parameter);
    if ($status < 0) {
        print stderr "ioctl(SNDCTL_DSP_PROFILE) failed!\n";
    };

    # Block size
    $parameter = pack("L", $BUF_SIZE);
    $status = ioctl(SOUND_OUT, SNDCTL_DSP_GETBLKSIZE(), $parameter);
    if ($status < 0) {
        print stderr "ioctl(SNDCTL_DSP_GETBLKSIZE) failed!\n";
    };
}


#=============================================================================
# Playout (deciding timing for output)
#=============================================================================

my ($left_ssrc, $right_ssrc);

my %repeat_count;

### playout()
#   make the first element of each buffer the playout data.
#
sub playout() {
    if ($left_ssrc eq '') {
        my @ssrcs = keys %buf_rtp;
        if (@ssrcs >= 2) {  # already received two streams (SSRCs)
            if ($ssrcs[0] > $ssrcs[1]) {
                $left_ssrc = $ssrcs[1];
                $right_ssrc = $ssrcs[0];
            } else {
                $left_ssrc = $ssrcs[0];
                $right_ssrc = $ssrcs[1];
            };
        }
    } else {
        my $left_buf = ${$buf_rtp{$left_ssrc}}[0];
        my $right_buf = ${$buf_rtp{$right_ssrc}}[0];
        if ($repeat_count{$left_ssrc} == 0 && $repeat_count{$right_ssrc} == 0 ||
            @{$buf_rtp{$left_ssrc}} > 2 && @{$buf_rtp{$right_ssrc}} > 2) {
            if ($inspection_switch) {
                my ($left_seq, $right_seq, $left_ts, $right_ts);
                ($_, $left_seq, $left_ts) = unpack('nnNN', $left_buf);
                ($_, $right_seq, $right_ts) = unpack('nnNN', $right_buf);
                if ($left_seq != $right_seq) {
		    print stderr "Seq num mismatched! $left_seq $right_seq\n";
		};
                if ($left_ts != $right_ts) {
                    print stderr "Timestamp mismatch! $left_ts $right_ts\n";
                };
            };
            shift @{$buf_rtp{$left_ssrc}};	# discard an old packet
            shift @{$buf_rtp{$right_ssrc}};	# discard an old packet
            if (${$buf_rtp{$left_ssrc}}[0] eq '') {
					# no data in the L-ch buffer head
                ${$buf_rtp{$left_ssrc}}[0] = $left_buf;   # repeat the data
                $repeat_count{$left_ssrc}++;
            } else {
                $repeat_count{$left_ssrc} = 0;
            };
            if (${$buf_rtp{$right_ssrc}}[0] eq '') {
					# no data in the R-ch buffer head
                ${$buf_rtp{$right_ssrc}}[0] = $right_buf; # repeat the data
                $repeat_count{$right_ssrc}++;
            } else {
                $repeat_count{$right_ssrc} = 0;
            };
            $buf_displ++;

            my (@left_data, @right_data);
            ($_, $_, $_, @left_data) = unpack('LLLC*', $left_buf);
            ($_, $_, $_, @right_data) = unpack('LLLC*', $right_buf);
            if ($#left_data != $#right_data) {
                print stderr "Numbers of left/right data different!\n";
            };

            # decode @left_data and @right_data
	    my $outbuf;
            for (my $i = 0; $i <= $#left_data; $i++) {
                $outbuf .=
		    pack("SS", $u2l[$left_data[$i]], $u2l[$right_data[$i]]);
            };

	    syswrite(SOUND_OUT, $outbuf);
        };
    };
}

このプログラムの主要部分である．

#=============================================================================
# main
#=============================================================================

open_sound_output();

$fd_in_rtp =  open_socket($IN_PORT_RTP);
$fd_in_rtcp = open_socket($IN_PORT_RTCP);

gen_u2l();

for (;;) {
    ## Test non-blocking I/O possibilities ##
    # $rin = file descriptor set [$fd_in_rtp, $fd_in_rtcp]
    my $rin = '';
    vec($rin, fileno($fd_in_rtcp), 1) = 1;
    vec($rin, fileno($fd_in_rtp), 1) = 1;

    my $rout;
    my $nfound = select($rout = $rin, undef, undef, 0);

    if ($nfound > 0) {			# Non-blocking I/O possible
        ## Accept packets ##
        if (vec($rout, fileno($fd_in_rtcp), 1)) {	# RTCP data readable
        					# (Control data prioritized)
            receive_rtcp_packet();
        };
        if (vec($rout, fileno($fd_in_rtp), 1)) {	# RTP data readable
            receive_rtp_packet($curr_time);
        };
    };

    playout();
}

Audio::Wav は wave ファイルをあつかうためのパッケージである．

use Time::HiRes qw(time sleep);	# for exact time measurements and sleep

ここで Time::HiRes というパッケージは時刻を正確に計測するためのものである．

my $CODEC = 'linear16';		# 'ulaw', 'ulaw16', 'linear16' or 'linear32'

my $CHANNELS = $CODEC eq 'ulaw16' || $CODEC eq 'linear32' ? 2 : 1;

1 チャンネルまたは 2 チャンネル (ステレオ) の信号をあつかう． $CODEC が 'ulaw', 'linear16' のときは 1 チャンネル，'ulaw16', 'linear32' のときは 2 チャンネルである．

my $SAMPLING_RATE = 8000;

標本化レートは 8000 Hz である． 他の値にかえても動作するはずである．

my $volume = 0.45;

この値をかえれば音量をかえることができる．

my $wav_file = "WaveFile.wav";

ファイル名はここであたえている．

my $FRAME_LENGTH = $SAMPLING_RATE / 50;	# number of samples in a packet

my $PACKET_SIZE = 1500;	# Assumed max UDP packet size

my $REMOTE_PORT_RTP = 10000;
my $REMOTE_PORT_RTCP = 10001;

my $LOCAL_PORT_RTP = 8000;
my $LOCAL_PORT_RTCP = 8001;	# local ports for output (UDP)
        # input and output local ports must be different.
        # (implementation restriction)

my $ip = '192.168.1.33';

IP アドレスとポート番号はここできめている．

my $rtp_addr = pack_sockaddr_in($REMOTE_PORT_RTP, inet_aton($ip));
my $rtcp_addr = pack_sockaddr_in($REMOTE_PORT_RTCP, inet_aton($ip));

my ($fd_out_rtp, $fd_out_rtcp, $fd_in_rtcp);

my (@out_ip_rtp, @out_buf_rtp);
my (@out_ip_rtcp, @out_buf_rtcp);

my $debug_switch = 0;
my $inspection_switch = 0;

$inspection_switch |= $debug_switch;


#=============================================================================
# Utility function
#=============================================================================

my $power32 = 4294967296;
my $power16 = 65536;

### current_npt_time()
#   return exact current time
#
sub current_npt_time() {
    my $time = time;
    my $lower = ($time - int($time)) * 4294967296.0;
    my $upper = int($time) + 2208988800;
    return ($upper, $lower);
}

### decode_sockaddr($sockaddr)
#   decode sockaddr_in structure to "$IP:$port" format.
#
sub decode_sockaddr($) {
    my ($sockaddr) = @_;
    if (length($sockaddr) != 16) {
        return '';
    };
    my ($port, $ip) = unpack_sockaddr_in($sockaddr);
    return inet_ntoa($ip) . ":$port";
}

### check_codec($codec)
#   check whether the specified CODEC is appropriate
#
sub check_codec($) {
    my ($codec) = @_;
    if ($codec ne 'ulaw' && $codec ne 'ulaw16' &&
        $codec ne 'linear16' && $codec ne 'linear32') {
	print STDERR "Unknown CODEC: $codec\n";
    };
}

### check_wav($details)
#   check whether the wave file format is appropriate
#
sub check_wav($) {
    my ($details) = @_;
    my $error = 0;
    # my $channels = $$details{channels};
    my $bits_sample = $$details{bits_sample};
    if ($bits_sample != 16) {
	$error = 1;
	print STDERR "#bits in sample ($bits_sample) must be 16\n";
    };
    # my $sample_rate = $$details{sample_rate};
    # if ($sample_rate != 8000) {
    #	$error = 1;
    #	print STDERR "Sample rate ($sample_rate) must be 8000\n";
    # };
    if ($error) {
	exit 1;
    };
}


#=============================================================================
# Network Output functions
#=============================================================================

### open_socket($proto)
#   open a UDP port of the local host (both for input and output),
#   and return the file descriptor.
#
sub open_socket($) {
    my ($port) = @_;
    my $fd;
    socket($fd, AF_INET, SOCK_DGRAM, getprotobyname('udp')) ||
        die "socket($fd)$!\n";
    setsockopt($fd, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) ||
        die "setsockopt()$!\n";
    bind($fd, pack_sockaddr_in($port, INADDR_ANY)) ||
        die "bind($fd)$!\n";
    return $fd;
}

my %packet_count;
my %octet_count;

### send_rtp($destination_addr, $buf)
#   send an RTP packet which is stored in the ring buffer.
#
sub send_rtp($$) {
    my ($destination_addr, $buf) = @_;
    send($fd_out_rtp, $buf, 0, $destination_addr) || die "send()$!";
    $packet_count{$destination_addr}++;
    $octet_count{$destination_addr} += length($buf);
    if ($inspection_switch) {
        my ($d1, $d2, $seq_no, $timestamp, $ssrc, $a1, $a2, $a3, $a4) =
            unpack('CCnNNCCCC', $buf);
        print decode_sockaddr($destination_addr),
	" out: $a1 $a2 $a3 $a4 seq=$seq_no ssrc=$ssrc\n";
	if ($debug_switch) {
	    print "RTP timestamp=$timestamp length=", length($buf), "\n";
	};
    };
}

### send_rtcp($destination_addr, $buf)
#   send an RTCP packet.
#
sub send_rtcp($$) {
    my ($destination_addr, $buf) = @_;
    send($fd_out_rtcp, $buf, 0, $destination_addr) || die "send()$!";
    if ($inspection_switch) {
	my ($d1, $d2, $seq_no, $timestamp, $ssrc, $a1, $a2, $a3, $a4) =
	    unpack('CCnNNCCCC', $buf);
        print decode_sockaddr($destination_addr),
	" out: $a1 $a2 $a3 $a4 seq=$seq_no ssrc=$ssrc\n";
	if ($debug_switch) {
	    print "RTCP timestamp=$timestamp length=", length($buf), "\n";
	};
    };
}

### receive_rtcp()
#   receive an RTCP packet and reply to the sender.
#
sub receive_rtcp() {
    my $buf;
    my $source_addr = recv($fd_in_rtcp, $buf, $PACKET_SIZE, 0);
    defined($source_addr) || die "recv()$!";
    my ($dummy, $ip) = unpack_sockaddr_in($source_addr);
    my ($first_byte, $payload_type, $length, $ssrc) = unpack('CCnN', $buf);
    my $version = $first_byte >> 6;		# must be 2
    unless ($version == 2) {
        print STDERR "Invalid RTCP packet header: version=$version\n";
    };

    # if ($inspection_switch) {
        my $report_count = $first_byte & 31;
        print "RTCP payload_type=$payload_type rerport_count=$report_count\n";
        print "Control data received from ", inet_ntoa($ip),
        ", length=", length($buf), "\n";
    # };

    ### to analyze the packet here ###

    if ($payload_type == 201) {	# if Receiver Report
        analyze_receiver_report($buf);
    };
}

### analyze_receiver_report()
#
sub analyze_receiver_report($) {
    my ($message) = @_;
    my $jitter = 0;
    my ($time_upper, $time_lower) = current_npt_time();
    my $curr_time = ($time_upper << 16) + ($time_lower >> 16);
    my $delay_since_last_SR = 0;
    my ($ssrc, $frac_lost, $highest_seq_no, $jitter);
    my ($last_SR, $delay_since_last_SR);
    ($_, $_, $ssrc, $frac_lost, $highest_seq_no, $jitter,
     $last_SR, $delay_since_last_SR) =
        unpack('NNNNNNNN', $message);	# 2B rtp header + 6B report block 1
    my $fraction_lost = $frac_lost >> 24;
    my $cumulative_packets_lost = $frac_lost & 0xFFFFFF;
    printf "Round trip time: %5.6f S\n", ($curr_time - $last_SR) / 65536.0;
}

ここから RTCP メッセージを生成するための部分である．

#=============================================================================
# RTCP Message Generator
#=============================================================================

my $CNAME = 1;

my $RTCP_INTERVAL = 5; # sec

my %rtcp_next_time;

### generate_outgoing_rtcp($out_addr, $ssrc, $cname, $timestamp)
#   generate Source Description and Sender Report messages of RTCP
#
sub generate_outgoing_rtcp($$$$) {
    my ($out_addr, $ssrc, $cname, $timestamp) = @_;
    my $current_time = time;
    if ($current_time >= $rtcp_next_time{$out_addr}) {
	if ($rtcp_next_time{$out_addr} == 0) {	# first time
	    $rtcp_next_time{$out_addr} = rand ($RTCP_INTERVAL / 2);
	    # Compute initial sending time
        # } elsif ($rtcp_next_time{$out_addr} == 0) {
	# 			# first time (SDES only)
        #     send_rtcp($out_addr, source_description($ssrc, $cname));
        #         # send a Source Description message of RTCP
        } else {		# not first time (SR and SDES)
            send_rtcp($out_addr,
                      sender_report($out_addr, $ssrc, $timestamp) .
                      source_description($ssrc, $cname));
                # send SR and SDES messages of RTCP
            print "Sending SR and SDES to ", decode_sockaddr($out_addr), "\n";

	    $rtcp_next_time{$out_addr} = $current_time +
		$RTCP_INTERVAL / 2 + rand ($RTCP_INTERVAL);
	};
    };
}

### source_description($ssrc, $my_cname)
#   Return a Source Description of RTCP
#
sub source_description($$) {
    my ($ssrc, $my_cname) = @_;
    my $cname_length = length($my_cname);
    return pack("nnNCCC*",
                0x81ca,	# V=2, PT=202 (SDES), SourceCount=1 (single chunk)
                1 + ($cname_length + 2 + 3) / 4, # length in words
		$ssrc, $CNAME, $cname_length) .
          $my_cname;
}

### sender_report($ssrc, $timestamp)
#   return a Sender Report of RTCP
#
sub sender_report($$$) {
    my ($out_addr, $ssrc, $timestamp) = @_;
    my ($curr_time_upper, $curr_time_lower) = current_npt_time();
    my $packet_count = $packet_count{$out_addr};
    my $octet_count = $octet_count{$out_addr};
    $packet_count{$out_addr} = 0;
    $octet_count{$out_addr} = 0;
    my $sender_info = pack("NNNNN", $curr_time_upper, $curr_time_lower,
                           $timestamp, $packet_count, $octet_count);
    my $header = pack("nnN", 
                      0x81c8, # V=2, PT=200(SR), ReportCount=1 (single chunk)
                      1 + length($sender_info) / 4,	# length in words
                      $ssrc);
    return $header . $sender_info;
}

ここから G.711 のデコーダである． G.711 のあつかいについては 「Perl による G.711 の処理」 において，よりくわしくあつかっている．

#=============================================================================
# Linear to ulaw conversion table generator
#=============================================================================

my $QUANT_MASK = 0xf;
my $BIAS = 0x84;
my $SEG_MASK = 0x70;
my $SEG_SHIFT = 4;
my $SIGN_BIT = 0x80;

my (@u2l, @l2u);

sub u2l($) {
    my ($uval) = @_;
    $uval = ~$uval;
    my $t = (($uval & $QUANT_MASK) << 3) + $BIAS;
    $t <<= ($uval & $SEG_MASK) >> $SEG_SHIFT;
    return ($uval & $SIGN_BIT) ? ($BIAS - $t) : ($t - $BIAS);
}

### gen_u2l()
#   generate ulaw-to-linear conversion table (@u2l)
#
sub gen_u2l() {
    for (my $i = 0; $i < 256; $i++) {
        $u2l[$i] = u2l($i);
    };
}

### gen_l2u()
#   generate linear-to-ulaw conversion table (@l2u)
#   (This method might not generate an optimum converter.)
#
sub gen_l2u() {
    for (my $i = 0; $i < 256; $i++) {
        my $j = $u2l[$i];
        if ($j < 0) {
            $j += 65536;
        };
        $l2u[$j] = $i;
    };
    for (my $i = 1; $i < 65536; $i++) {
        if ($l2u[$i] == 0) {
            $l2u[$i] = $l2u[$i-1];
        };
    };
}

### gen_ul_conv()
#   generate ulaw <-> linear conversion tables
#
sub gen_ul_conv() {
    gen_u2l();
    gen_l2u();
}

ここから主要部分である．

#=============================================================================
# main
#=============================================================================

if ($ARGV[0] ne '') {
    $wav_file = "$SAMPLING_RATE/$ARGV[0]";
    print "Playing file $wav_file\n";
};
if ($ARGV[1] ne '') {
    $volume = $ARGV[1];
    print "Volume=$volume\n";
};
my $loop = 1;
if ($ARGV[2] eq 'noloop') {
    $loop = 0;
}

$fd_out_rtp =  open_socket($LOCAL_PORT_RTP);
$fd_out_rtcp = open_socket($LOCAL_PORT_RTCP);
$fd_in_rtcp = $fd_out_rtcp;

gen_ul_conv();

check_codec($CODEC);

my $wav = new Audio::Wav;
my $wav_reader = $wav->read($wav_file);

check_wav($wav_reader->details());

my $ssrc = $ARGV[3] | int(rand 0x80000000);
my $seq_no = 0;

my $time_interval = 1000 * $FRAME_LENGTH / $SAMPLING_RATE;
my $timestamp = 0;
my $real_time = time;
my $playout_time = 1000 * $real_time;

for (;;) {
    my @buf;
    for (my $i = 0; $i < $FRAME_LENGTH; $i++) {
        my @data = $wav_reader->read();
        if (!defined($data[0])) {
            if (!$loop) {
                exit 0;
            };
            $wav_reader = $wav->read($wav_file);	# read the file again
            @data = $wav_reader->read();
            print "Repeating...\n";
        };
        $data[0] = $volume * $data[0];
        if ($CODEC eq 'ulaw') {
            $buf[$i] = $l2u[$data[0]];	# only the first channel data is used
        } elsif ($CODEC eq 'linear16') {
            $buf[$i] = $data[0];	# only the first channel data is used
        } elsif ($CODEC eq 'linear32') {
            if (@data >= 2) {		# use two-channel data
                $buf[2*$i] = $data[0];
                $data[1] = $volume * $data[1];
                $buf[2*$i+1] = $data[1];
            } else {			# duplicate single-channel data
                $buf[2*$i] = $data[0];
                $buf[2*$i+1] = $data[0];
            };
        } elsif ($CODEC eq 'ulaw16') {
            if (@data >= 2) {		# use two-channel data
                $buf[2*$i] = $l2u[$data[0]];
                $data[1] = $volume * $data[1];
                $buf[2*$i+1] = $l2u[$data[1]];
            } else {			# duplicate single-channel data
        	my $data = $l2u[$data[0]];
                $buf[2*$i] = $data;
                $buf[2*$i+1] = $data;
            };
        };
    };
    my $buf;
    if ($CODEC eq 'ulaw') {
        $buf = pack('NNNC*', 0x80000000 + $seq_no, $timestamp, $ssrc, @buf);
    } elsif ($CODEC eq 'ulaw16') {
        $buf = pack('NNNC*', 0x80600000 + $seq_no, $timestamp, $ssrc, @buf);
    } else { # linear16 or linear32
        $buf = pack('NNNn*',
        	    ($CODEC eq 'linear16' ? 0x80610000 : 0x80620000) + $seq_no,
        	    $timestamp, $ssrc, @buf);
    };

    send_rtp($rtp_addr, $buf);
    my $cname = getlogin() . ":$LOCAL_PORT_RTP";
    generate_outgoing_rtcp($rtcp_addr, $ssrc, $cname, $timestamp);

    my $rin = '';
    vec($rin, fileno($fd_in_rtcp), 1) = 1;
    my $rout;
    my $nfound = select($rout = $rin, undef, undef, 0);
    if ($nfound > 0) {			# Non-blocking I/O possible
        if (vec($rout, fileno($fd_in_rtcp), 1)) {	# RTCP data readable
            receive_rtcp();
        };
    };

    if ($debug_switch) {
        print "$real_time $playout_time ", decode_sockaddr($rtp_addr), "\n";
    };

    $seq_no++;
    if ($seq_no >= 65536) {
        $seq_no = 0;
    };
    $timestamp += @buf / $CHANNELS;
    $real_time = time;
    $playout_time += $time_interval;
    my $sleep_time = $playout_time / 1000 - $real_time;
    if ($sleep_time > 0) {
        sleep($sleep_time);
    };
    # printf "%f %f\n", $real_time, $sleep_time;
}