line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# -*- perl -*-
|
2
|
|
|
|
|
|
|
# RPC.pm - An implementation of a DCE RPC Composer/Parser. It is expected
|
3
|
|
|
|
|
|
|
# to cover all the connection oriented PDUs.
|
4
|
|
|
|
|
|
|
# implemented the client side functions that calculates the NTLM response.
|
5
|
|
|
|
|
|
|
# I will add the corresponding server side functions in the next version.
|
6
|
|
|
|
|
|
|
#
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
package DCE::Perl::RPC;
|
9
|
|
|
|
|
|
|
|
10
|
1
|
|
|
1
|
|
603
|
use strict;
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
32
|
|
11
|
1
|
|
|
1
|
|
5
|
use Carp;
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
85
|
|
12
|
1
|
|
|
1
|
|
4
|
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
|
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
200
|
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
require Exporter;
|
15
|
|
|
|
|
|
|
require DynaLoader;
|
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
*import = \&Exporter::import;
|
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
@ISA = qw (Exporter DynaLoader);
|
20
|
|
|
|
|
|
|
@EXPORT = qw ();
|
21
|
|
|
|
|
|
|
@EXPORT_OK = qw ();
|
22
|
|
|
|
|
|
|
$VERSION = '0.01';
|
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
# Stolen from Crypt::DES.
|
25
|
|
|
|
|
|
|
sub usage {
|
26
|
0
|
|
|
0
|
0
|
0
|
my ($package, $filename, $line, $subr) = caller (1);
|
27
|
0
|
|
|
|
|
0
|
$Carp::CarpLevel = 2;
|
28
|
0
|
|
|
|
|
0
|
croak "Usage: $subr (@_)";
|
29
|
|
|
|
|
|
|
}
|
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
# DCE RPC PDU Types
|
32
|
1
|
|
|
1
|
|
6
|
use constant RPC_REQUEST => 0x00;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
96
|
|
33
|
1
|
|
|
1
|
|
5
|
use constant RPC_PING => 0x01;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
42
|
|
34
|
1
|
|
|
1
|
|
5
|
use constant RPC_RESPONSE => 0x02;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
41
|
|
35
|
1
|
|
|
1
|
|
5
|
use constant RPC_FAULT => 0x03;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
36
|
|
36
|
1
|
|
|
1
|
|
16
|
use constant RPC_WORKING => 0x04;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
40
|
|
37
|
1
|
|
|
1
|
|
5
|
use constant RPC_NOCALL => 0x05;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
46
|
|
38
|
1
|
|
|
1
|
|
4
|
use constant RPC_REJECT => 0x06;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
31
|
|
39
|
1
|
|
|
1
|
|
4
|
use constant RPC_ACK => 0x07;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
34
|
|
40
|
1
|
|
|
1
|
|
4
|
use constant RPC_CL_CANCEL => 0x08;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
29
|
|
41
|
1
|
|
|
1
|
|
3
|
use constant RPC_FACK => 0x09;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
33
|
|
42
|
1
|
|
|
1
|
|
8
|
use constant RPC_CANCEL_ACK => 0x0a;
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
32
|
|
43
|
1
|
|
|
1
|
|
8
|
use constant RPC_BIND => 0x0b;
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
27
|
|
44
|
1
|
|
|
1
|
|
4
|
use constant RPC_BIND_ACK => 0x0c;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
32
|
|
45
|
1
|
|
|
1
|
|
3
|
use constant RPC_BIND_NACK => 0x0d;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
31
|
|
46
|
1
|
|
|
1
|
|
4
|
use constant RPC_ALTER_CONTEXT => 0x0e;
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
26
|
|
47
|
1
|
|
|
1
|
|
4
|
use constant RPC_ALTER_CONTEXT_RESP => 0x0f;
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
31
|
|
48
|
1
|
|
|
1
|
|
4
|
use constant RPC_BIND_RESP => 0x10;
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
27
|
|
49
|
1
|
|
|
1
|
|
3
|
use constant RPC_SHUTDOWN => 0x11;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
43
|
|
50
|
1
|
|
|
1
|
|
4
|
use constant RPC_CO_CANCEL => 0x12;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
45
|
|
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
# DCE RPC PFC Flags
|
53
|
|
|
|
|
|
|
# First Fragment
|
54
|
1
|
|
|
1
|
|
4
|
use constant PFC_FIRST_FRAG => 0x01;
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
27
|
|
55
|
|
|
|
|
|
|
# Last Fragment
|
56
|
1
|
|
|
1
|
|
3
|
use constant PFC_LAST_FRAG => 0x02;
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
31
|
|
57
|
|
|
|
|
|
|
# Cancel was pending at sender
|
58
|
1
|
|
|
1
|
|
4
|
use constant PFC_PENDING_CANCEL => 0x04;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
40
|
|
59
|
|
|
|
|
|
|
# Reserved
|
60
|
1
|
|
|
1
|
|
3
|
use constant PFC_RESERVED_1 => 0x08;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
35
|
|
61
|
|
|
|
|
|
|
# supports concurrent multiplexing of a single connection
|
62
|
1
|
|
|
1
|
|
4
|
use constant PFC_CONC_MPX => 0x10;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
33
|
|
63
|
|
|
|
|
|
|
# only meaningful on 'fault' packet; if true, guaranteed call
|
64
|
|
|
|
|
|
|
# did not execute
|
65
|
1
|
|
|
1
|
|
4
|
use constant PFC_DID_NOT_EXECUTE => 0x20;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
28
|
|
66
|
|
|
|
|
|
|
# 'maybe' call semantics requested
|
67
|
1
|
|
|
1
|
|
3
|
use constant PFC_MAYBE => 0x40;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
35
|
|
68
|
|
|
|
|
|
|
# if true, a non-nul object UUID was specified in the handle,
|
69
|
|
|
|
|
|
|
# and is present in the optional object field. If false, the
|
70
|
|
|
|
|
|
|
# object field is omitted.
|
71
|
1
|
|
|
1
|
|
5
|
use constant PFC_OBJECT_UUID => 0x80;
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
51
|
|
72
|
|
|
|
|
|
|
|
73
|
1
|
|
|
1
|
|
4
|
use constant RPC_MAJOR_VERSION => 5;
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
29
|
|
74
|
1
|
|
|
1
|
|
4
|
use constant RPC_MINOR_VERSION => 0;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
35
|
|
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
# Connection Oriented PDU common header size
|
77
|
1
|
|
|
1
|
|
4
|
use constant RPC_CO_HDR_SZ => 16;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
27
|
|
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
# Fragment Size
|
80
|
1
|
|
|
1
|
|
4
|
use constant RPC_FRAG_SZ => 5840;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
39
|
|
81
|
|
|
|
|
|
|
|
82
|
1
|
|
|
1
|
|
4
|
use constant RPC_AUTH_NTLM => 0x0a;
|
|
1
|
|
|
|
|
16
|
|
|
1
|
|
|
|
|
36
|
|
83
|
1
|
|
|
1
|
|
4
|
use constant RPC_AUTH_LEVEL_CONNECT => 0x02;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
1101
|
|
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
#########################################################################
|
86
|
|
|
|
|
|
|
# Constructor to initialize authentication related information. In this #
|
87
|
|
|
|
|
|
|
# version, we assume NTLM as the authentication scheme of choice. #
|
88
|
|
|
|
|
|
|
# The constructor only takes the class name as an argument. #
|
89
|
|
|
|
|
|
|
#########################################################################
|
90
|
|
|
|
|
|
|
sub new {
|
91
|
1
|
50
|
|
1
|
0
|
615
|
usage("new DCE::Perl::RPC") unless @_ == 1;
|
92
|
1
|
|
|
|
|
2
|
my ($package) = @_;
|
93
|
1
|
|
|
|
|
8
|
srand time;
|
94
|
1
|
|
|
|
|
4
|
my $ctx_id = pack("V", rand 2**32);
|
95
|
1
|
|
|
|
|
8
|
bless {'auth_type' => RPC_AUTH_NTLM,
|
96
|
|
|
|
|
|
|
'auth_level' => RPC_AUTH_LEVEL_CONNECT,
|
97
|
|
|
|
|
|
|
'auth_ctx_id' => $ctx_id}, $package;
|
98
|
|
|
|
|
|
|
}
|
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
############################################################################
|
101
|
|
|
|
|
|
|
# rpc_co_hdr composes the 16-bytes common DCE RPC header that must present #
|
102
|
|
|
|
|
|
|
# in all conection oriented DCE RPC messages. It takes four arguments: #
|
103
|
|
|
|
|
|
|
# 1) PDU type; 2) PDU flags; 3) size of the PDU part that is specific to #
|
104
|
|
|
|
|
|
|
# the PDU type; 4) size of the authentication credentials. #
|
105
|
|
|
|
|
|
|
# This function is an internal function. It is not supposed to be called #
|
106
|
|
|
|
|
|
|
# from the outside world. #
|
107
|
|
|
|
|
|
|
############################################################################
|
108
|
|
|
|
|
|
|
sub rpc_co_hdr($$$$)
|
109
|
|
|
|
|
|
|
{
|
110
|
4
|
|
|
4
|
0
|
7
|
my ($type, $flags, $size, $auth_size) = @_;
|
111
|
4
|
|
|
|
|
5
|
my $msg = chr(RPC_MAJOR_VERSION) . chr(RPC_MINOR_VERSION);
|
112
|
4
|
|
|
|
|
6
|
$msg .= chr($type);
|
113
|
4
|
|
|
|
|
5
|
$msg .= chr($flags);
|
114
|
4
|
|
|
|
|
4
|
$msg .= pack("H8", "10000000"); # assume little endian
|
115
|
4
|
|
|
|
|
10
|
$msg .= pack("v", RPC_CO_HDR_SZ+$size+$auth_size);
|
116
|
4
|
|
|
|
|
5
|
$msg .= pack("v", $auth_size);
|
117
|
4
|
|
|
|
|
5
|
$msg .= pack("V", 0x00); # always 0 for call_id for now
|
118
|
4
|
|
|
|
|
11
|
return $msg;
|
119
|
|
|
|
|
|
|
}
|
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
############################################################################
|
122
|
|
|
|
|
|
|
# rpc_auth_hdr composes the 8-bytes authentication header. It takes four #
|
123
|
|
|
|
|
|
|
# arguments: 1) Authentication Type; 2) Authentication Level; 3) length of #
|
124
|
|
|
|
|
|
|
# padding; 4) context id of this session. #
|
125
|
|
|
|
|
|
|
############################################################################
|
126
|
|
|
|
|
|
|
sub rpc_auth_hdr($$$$)
|
127
|
|
|
|
|
|
|
{
|
128
|
3
|
|
|
3
|
0
|
9
|
my ($auth_type, $auth_level, $pad_len, $ctx_id) = @_;
|
129
|
3
|
|
|
|
|
6
|
my $msg = chr($auth_type);
|
130
|
3
|
|
|
|
|
5
|
$msg .= chr($auth_level);
|
131
|
3
|
|
|
|
|
4
|
$msg .= chr($pad_len);
|
132
|
3
|
|
|
|
|
4
|
$msg .= chr(0);
|
133
|
3
|
|
|
|
|
4
|
$msg .= $ctx_id;
|
134
|
3
|
|
|
|
|
6
|
return $msg;
|
135
|
|
|
|
|
|
|
}
|
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
#####################################################################
|
138
|
|
|
|
|
|
|
# rpc_bind composes the DCE RPC bind PDU. To make things simple, it #
|
139
|
|
|
|
|
|
|
# assumes the PDU context list only has one element. It takes four #
|
140
|
|
|
|
|
|
|
# arguments: 1) Presentation Context Id; 2) Abstract Syntax #
|
141
|
|
|
|
|
|
|
# concatenated with interface version; 3) list of transfer syntax #
|
142
|
|
|
|
|
|
|
# concatenated with interface version; 4) authentication #
|
143
|
|
|
|
|
|
|
# credentials. #
|
144
|
|
|
|
|
|
|
#####################################################################
|
145
|
|
|
|
|
|
|
sub rpc_bind($$$@$)
|
146
|
|
|
|
|
|
|
{
|
147
|
1
|
|
|
1
|
0
|
11
|
my $self = shift;
|
148
|
1
|
|
|
|
|
2
|
my $ctx_id = shift;
|
149
|
1
|
|
|
|
|
3
|
my $abs_syntax = shift;
|
150
|
1
|
|
|
|
|
3
|
my @xfer_syntax = shift;
|
151
|
1
|
|
|
|
|
3
|
my $auth_value = shift;
|
152
|
1
|
|
|
|
|
2
|
my $msg = "";
|
153
|
1
|
|
|
|
|
2
|
my $auth_pad = 0;
|
154
|
1
|
|
|
|
|
2
|
my $i;
|
155
|
1
|
|
|
|
|
2
|
my $bind_msg = pack("v", RPC_FRAG_SZ) . pack("v", RPC_FRAG_SZ);
|
156
|
1
|
|
|
|
|
3
|
$bind_msg .= pack("V", 0); # ask for new association group id
|
157
|
1
|
|
|
|
|
2
|
$bind_msg .= chr(1) . chr(0) . pack("v", 0);
|
158
|
1
|
|
|
|
|
4
|
$bind_msg .= pack("v", $ctx_id); # ctx id
|
159
|
1
|
|
|
|
|
4
|
$bind_msg .= chr(@xfer_syntax);
|
160
|
1
|
|
|
|
|
2
|
$bind_msg .= chr(0);
|
161
|
1
|
|
|
|
|
2
|
$bind_msg .= $abs_syntax;
|
162
|
1
|
|
|
|
|
5
|
for ($i = 0; $i < @xfer_syntax; ++$i) {
|
163
|
1
|
|
|
|
|
4
|
$bind_msg .= $xfer_syntax[$i];
|
164
|
|
|
|
|
|
|
}
|
165
|
1
|
|
|
|
|
6
|
while (length($bind_msg) % 4 != 0) {
|
166
|
0
|
|
|
|
|
0
|
$bind_msg .= chr(0);
|
167
|
0
|
|
|
|
|
0
|
$auth_pad++;
|
168
|
|
|
|
|
|
|
}
|
169
|
1
|
|
|
|
|
22
|
$bind_msg .= rpc_auth_hdr($self->{'auth_type'}, $self->{'auth_level'}, $auth_pad, $self->{'auth_ctx_id'});
|
170
|
1
|
|
|
|
|
5
|
$msg = rpc_co_hdr(RPC_BIND, PFC_FIRST_FRAG | PFC_LAST_FRAG,
|
171
|
|
|
|
|
|
|
length($bind_msg), length($auth_value)) . $bind_msg . $auth_value;
|
172
|
1
|
|
|
|
|
3
|
return $msg;
|
173
|
|
|
|
|
|
|
}
|
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
##############################################################################
|
176
|
|
|
|
|
|
|
# rpc_bind_resp composes the DCE RPC bind_resp PDU. This PDU is undocumented #
|
177
|
|
|
|
|
|
|
# in the OpenGroup's specification but it is used by DCOM. It's main #
|
178
|
|
|
|
|
|
|
# responsibility is to respond to the NTLM challenge posted by the bind_ack #
|
179
|
|
|
|
|
|
|
# PDU from the server. Its lone argument is the NTLM response. #
|
180
|
|
|
|
|
|
|
##############################################################################
|
181
|
|
|
|
|
|
|
sub rpc_bind_resp($$)
|
182
|
|
|
|
|
|
|
{
|
183
|
1
|
|
|
1
|
0
|
52
|
my $self = shift;
|
184
|
1
|
|
|
|
|
2
|
my $auth_value = shift;
|
185
|
1
|
|
|
|
|
2
|
my $msg = "";
|
186
|
1
|
|
|
|
|
2
|
my $auth_pad = 0;
|
187
|
1
|
|
|
|
|
2
|
my $i;
|
188
|
1
|
|
|
|
|
2
|
my $bind_resp_msg = pack("v", RPC_FRAG_SZ) . pack("v", RPC_FRAG_SZ);
|
189
|
1
|
|
|
|
|
5
|
while (length($bind_resp_msg) % 4 != 0) {
|
190
|
0
|
|
|
|
|
0
|
$bind_resp_msg .= chr(0);
|
191
|
0
|
|
|
|
|
0
|
$auth_pad++;
|
192
|
|
|
|
|
|
|
}
|
193
|
1
|
|
|
|
|
528
|
$bind_resp_msg .= rpc_auth_hdr($self->{'auth_type'}, $self->{'auth_level'}, $auth_pad, $self->{'auth_ctx_id'});
|
194
|
1
|
|
|
|
|
4
|
$msg = rpc_co_hdr(RPC_BIND_RESP, PFC_FIRST_FRAG | PFC_LAST_FRAG,
|
195
|
|
|
|
|
|
|
length($bind_resp_msg), length($auth_value)) . $bind_resp_msg . $auth_value;
|
196
|
1
|
|
|
|
|
4
|
return $msg;
|
197
|
|
|
|
|
|
|
}
|
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
###########################################################################
|
200
|
|
|
|
|
|
|
# rpc_co_request composes the connection-oriented DCE RPC Request PDU. It #
|
201
|
|
|
|
|
|
|
# takes five arguments: 1) the stub; 2) the presentation context id; #
|
202
|
|
|
|
|
|
|
# 3) operation # within the interface; 4) object UUID; 5) authetication #
|
203
|
|
|
|
|
|
|
# credentials. The fourth argument can be "" if there is no UUID #
|
204
|
|
|
|
|
|
|
# associate with this request PDU. #
|
205
|
|
|
|
|
|
|
###########################################################################
|
206
|
|
|
|
|
|
|
sub rpc_co_request($$$$$$)
|
207
|
|
|
|
|
|
|
{
|
208
|
1
|
|
|
1
|
0
|
41
|
my ($self, $body, $ctx_id, $op_num, $uuid, $auth_value) = @_;
|
209
|
1
|
|
|
|
|
2
|
my $msg = "";
|
210
|
1
|
|
|
|
|
2
|
my $auth_pad = 0;
|
211
|
1
|
|
|
|
|
1
|
my $i;
|
212
|
1
|
|
|
|
|
2
|
my $flags = PFC_FIRST_FRAG | PFC_LAST_FRAG;
|
213
|
1
|
|
|
|
|
2
|
my $req_msg = pack("V", length($body));
|
214
|
1
|
|
|
|
|
2
|
$req_msg .= pack("v", $ctx_id);
|
215
|
1
|
|
|
|
|
2
|
$req_msg .= pack("v", $op_num);
|
216
|
1
|
50
|
33
|
|
|
8
|
if (defined($uuid) and length($uuid) == 16) {
|
217
|
1
|
|
|
|
|
1
|
$flags |= PFC_OBJECT_UUID;
|
218
|
1
|
|
|
|
|
2
|
$req_msg .= $uuid;
|
219
|
|
|
|
|
|
|
}
|
220
|
1
|
|
|
|
|
1
|
$req_msg .= $body;
|
221
|
1
|
|
|
|
|
4
|
while (length($req_msg) % 4 != 0) {
|
222
|
2
|
|
|
|
|
2
|
$req_msg .= chr(0);
|
223
|
2
|
|
|
|
|
4
|
$auth_pad++;
|
224
|
|
|
|
|
|
|
}
|
225
|
1
|
|
|
|
|
3
|
$req_msg .= rpc_auth_hdr($self->{'auth_type'}, $self->{'auth_level'}, $auth_pad, $self->{'auth_ctx_id'});
|
226
|
1
|
|
|
|
|
3
|
$msg = rpc_co_hdr(RPC_REQUEST, $flags,
|
227
|
|
|
|
|
|
|
length($req_msg), length($auth_value)) . $req_msg . $auth_value;
|
228
|
1
|
|
|
|
|
3
|
return $msg;
|
229
|
|
|
|
|
|
|
}
|
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
##########################################################################
|
232
|
|
|
|
|
|
|
# rpc_alt_ctx composes a DCE RPC alter_context PDU. alter_context PDU is #
|
233
|
|
|
|
|
|
|
# used to change the presentation syntax established by the earlier bind #
|
234
|
|
|
|
|
|
|
# PDU. Therefore it has similar format. However, there is no need for #
|
235
|
|
|
|
|
|
|
# authentication credentials. Like rpc_bind, we also assume the #
|
236
|
|
|
|
|
|
|
# presentation context list only has one element. #
|
237
|
|
|
|
|
|
|
##########################################################################
|
238
|
|
|
|
|
|
|
sub rpc_alt_ctx($$$@)
|
239
|
|
|
|
|
|
|
{
|
240
|
1
|
|
|
1
|
0
|
35
|
my $self = shift;
|
241
|
1
|
|
|
|
|
2
|
my $ctx_id = shift;
|
242
|
1
|
|
|
|
|
2
|
my $abs_syntax = shift;
|
243
|
1
|
50
|
|
|
|
6
|
usage("Abstract Syntax plus interface version must be 20-bytes long!") unless length($abs_syntax) == 20;
|
244
|
1
|
|
|
|
|
3
|
my @xfer_syntax = shift;
|
245
|
1
|
|
|
|
|
1
|
my $msg = "";
|
246
|
1
|
|
|
|
|
2
|
my $i;
|
247
|
1
|
|
|
|
|
2
|
my $alt_ctx_msg = pack("v", RPC_FRAG_SZ) . pack("v", RPC_FRAG_SZ);
|
248
|
1
|
|
|
|
|
1
|
$alt_ctx_msg .= pack("V", 0); # ask for new association group id
|
249
|
1
|
|
|
|
|
1
|
$alt_ctx_msg .= chr(1) . chr(0) . pack("v", 0);
|
250
|
1
|
|
|
|
|
3
|
$alt_ctx_msg .= pack("v", $ctx_id); # ctx id
|
251
|
1
|
|
|
|
|
2
|
$alt_ctx_msg .= chr(@xfer_syntax);
|
252
|
1
|
|
|
|
|
22
|
$alt_ctx_msg .= chr(0);
|
253
|
1
|
|
|
|
|
2
|
$alt_ctx_msg .= $abs_syntax;
|
254
|
1
|
|
|
|
|
4
|
for ($i = 0; $i < @xfer_syntax; ++$i) {
|
255
|
1
|
|
|
|
|
4
|
$alt_ctx_msg .= $xfer_syntax[$i];
|
256
|
|
|
|
|
|
|
}
|
257
|
1
|
|
|
|
|
4
|
$msg = rpc_co_hdr(RPC_ALTER_CONTEXT, PFC_FIRST_FRAG | PFC_LAST_FRAG,
|
258
|
|
|
|
|
|
|
length($alt_ctx_msg), 0) . $alt_ctx_msg;
|
259
|
1
|
|
|
|
|
3
|
return $msg;
|
260
|
|
|
|
|
|
|
}
|
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
1;
|
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
__END__
|