File Coverage

blib/lib/Authen/Perl/NTLM.pm
Criterion Covered Total %
statement 273 290 94.1
branch 32 58 55.1
condition 2 6 33.3
subroutine 52 53 98.1
pod 0 20 0.0
total 359 427 84.0


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             # NTLM.pm - An implementation of NTLM. In this version, I only
3             # implemented the client side functions that calculates the NTLM response.
4             # I will add the corresponding server side functions in the next version.
5             #
6            
7             package Authen::Perl::NTLM;
8            
9 1     1   858 use strict;
  1         2  
  1         42  
10 1     1   1557 use POSIX;
  1         9558  
  1         10  
11 1     1   3533 use Carp;
  1         9  
  1         241  
12             $Authen::Perl::NTLM::PurePerl = undef; # a flag to see if we load pure perl
13             # DES and MD4 modules
14             eval "require Crypt::DES && require Digest::MD4";
15             if ($@) {
16             eval "require Crypt::DES_PP && require Digest::Perl::MD4";
17             if ($@) {
18             die "Required DES and/or MD4 module doesn't exist!\n";
19             }
20             else {
21             $Authen::Perl::NTLM::PurePerl = 1;
22             }
23             }
24             else {
25             $Authen::Perl::NTLM::PurePerl = 0;
26             }
27            
28             if ($Authen::Perl::NTLM::PurePerl == 1) {
29             require Crypt::DES_PP;
30             Crypt::DES_PP->import;
31             require Digest::Perl::MD4;
32             import Digest::Perl::MD4 qw(md4);
33             }
34             else {
35             require Crypt::DES;
36             Crypt::DES->import;
37             require Digest::MD4;
38             import Digest::MD4;
39             }
40 1     1   5 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  1         1  
  1         290  
41            
42             require Exporter;
43             require DynaLoader;
44            
45             *import = \&Exporter::import;
46            
47             @ISA = qw (Exporter DynaLoader);
48             @EXPORT = qw ();
49             @EXPORT_OK = qw (nt_hash lm_hash calc_resp);
50             $VERSION = '0.12';
51            
52             # Stolen from Crypt::DES.
53             sub usage {
54 0     0 0 0 my ($package, $filename, $line, $subr) = caller (1);
55 0         0 $Carp::CarpLevel = 2;
56 0         0 croak "Usage: $subr (@_)";
57             }
58            
59             # These constants are stolen from samba-2.2.4 and other sources
60 1     1   6 use constant NTLMSSP_SIGNATURE => 'NTLMSSP';
  1         2  
  1         93  
61            
62             # NTLMSSP Message Types
63 1     1   5 use constant NTLMSSP_NEGOTIATE => 1;
  1         2  
  1         52  
64 1     1   4 use constant NTLMSSP_CHALLENGE => 2;
  1         1  
  1         40  
65 1     1   5 use constant NTLMSSP_AUTH => 3;
  1         2  
  1         42  
66 1     1   5 use constant NTLMSSP_UNKNOWN => 4;
  1         7  
  1         51  
67            
68             # NTLMSSP Flags
69            
70             # Text strings are in unicode
71 1     1   5 use constant NTLMSSP_NEGOTIATE_UNICODE => 0x00000001;
  1         2  
  1         51  
72             # Text strings are in OEM
73 1     1   5 use constant NTLMSSP_NEGOTIATE_OEM => 0x00000002;
  1         2  
  1         38  
74             # Server should return its authentication realm
75 1     1   6 use constant NTLMSSP_REQUEST_TARGET => 0x00000004;
  1         1  
  1         47  
76             # Request signature capability
77 1     1   5 use constant NTLMSSP_NEGOTIATE_SIGN => 0x00000010;
  1         2  
  1         46  
78             # Request confidentiality
79 1     1   11 use constant NTLMSSP_NEGOTIATE_SEAL => 0x00000020;
  1         2  
  1         49  
80             # Use datagram style authentication
81 1     1   5 use constant NTLMSSP_NEGOTIATE_DATAGRAM => 0x00000040;
  1         2  
  1         42  
82             # Use LM session key for sign/seal
83 1     1   5 use constant NTLMSSP_NEGOTIATE_LM_KEY => 0x00000080;
  1         1  
  1         46  
84             # NetWare authentication
85 1     1   6 use constant NTLMSSP_NEGOTIATE_NETWARE => 0x00000100;
  1         1  
  1         342  
86             # NTLM authentication
87 1     1   7 use constant NTLMSSP_NEGOTIATE_NTLM => 0x00000200;
  1         1  
  1         58  
88             # Domain Name supplied on negotiate
89 1     1   71 use constant NTLMSSP_NEGOTIATE_OEM_DOMAIN_SUPPLIED => 0x00001000;
  1         2  
  1         51  
90             # Workstation Name supplied on negotiate
91 1     1   6 use constant NTLMSSP_NEGOTIATE_OEM_WORKSTATION_SUPPLIED => 0x00002000;
  1         2  
  1         41  
92             # Indicates client/server are same machine
93 1     1   4 use constant NTLMSSP_NEGOTIATE_LOCAL_CALL => 0x00004000;
  1         2  
  1         166  
94             # Sign for all security levels
95 1     1   6 use constant NTLMSSP_NEGOTIATE_ALWAYS_SIGN => 0x00008000;
  1         2  
  1         47  
96             # TargetName is a domain name
97 1     1   5 use constant NTLMSSP_TARGET_TYPE_DOMAIN => 0x00010000;
  1         2  
  1         123  
98             # TargetName is a server name
99 1     1   7 use constant NTLMSSP_TARGET_TYPE_SERVER => 0x00020000;
  1         2  
  1         49  
100             # TargetName is a share name
101 1     1   5 use constant NTLMSSP_TARGET_TYPE_SHARE => 0x00040000;
  1         2  
  1         46  
102             # TargetName is a share name
103 1     1   5 use constant NTLMSSP_NEGOTIATE_NTLM2 => 0x00080000;
  1         2  
  1         56  
104             # get back session keys
105 1     1   5 use constant NTLMSSP_REQUEST_INIT_RESPONSE => 0x00100000;
  1         2  
  1         51  
106             # get back session key, LUID
107 1     1   5 use constant NTLMSSP_REQUEST_ACCEPT_RESPONSE => 0x00200000;
  1         9  
  1         46  
108             # request non-ntsession key
109 1     1   6 use constant NTLMSSP_REQUEST_NON_NT_SESSION_KEY => 0x00400000;
  1         3  
  1         542  
110 1     1   8 use constant NTLMSSP_NEGOTIATE_TARGET_INFO => 0x00800000;
  1         2  
  1         57  
111 1     1   6 use constant NTLMSSP_NEGOTIATE_128 => 0x20000000;
  1         2  
  1         46  
112 1     1   7 use constant NTLMSSP_NEGOTIATE_KEY_EXCH => 0x40000000;
  1         2  
  1         53  
113 1     1   7 use constant NTLMSSP_NEGOTIATE_80000000 => 0x80000000;
  1         2  
  1         3879  
114            
115             sub lm_hash($);
116             sub nt_hash($);
117             sub calc_resp($$);
118            
119             #########################################################################
120             # Constructor to initialize authentication related information. In this #
121             # version, we assume NTLM as the authentication scheme of choice. #
122             # The constructor takes the class name, LM hash of the client password #
123             # and the LM hash of the client password as arguments. #
124             #########################################################################
125             sub new_client {
126 1 50 33 1 0 9 usage("new_client Authen::Perl::NTLM(\$lm_hpw, \$nt_hpw\) or\nnew_client Authen::Perl::NTLM\(\$lm_hpw, \$nt_hpw, \$user, \$user_domain, \$domain, \$machine\)") unless @_ == 3 or @_ == 7;
127 1         3 my ($package, $lm_hpw, $nt_hpw, $user, $user_domain, $domain, $machine) = @_;
128 1         8 srand time;
129 1 50       3 if (not defined($user)) {$user = $ENV{'USERNAME'};}
  0         0  
130 1 50       8 if (not defined($user_domain)) {$user_domain = $ENV{'USERDOMAIN'};}
  0         0  
131 1 50       3 if (not defined($domain)) {$domain = Win32::DomainName();}
  0         0  
132 1 50       4 if (not defined($machine)) {$machine = $ENV{'COMPUTERNAME'};}
  0         0  
133 1 50       3 usage("LM hash must be 21-bytes long") unless length($lm_hpw) == 21;
134 1 50       4 usage("NT hash must be 21-bytes long") unless length($nt_hpw) == 21;
135 1 50       4 defined($user) or usage "Undefined User Name!\n";
136 1 50       4 defined($user_domain) or usage "Undefined User Domain!\n";
137 1 50       3 defined($domain) or usage "Undefined Network Domain!\n";
138 1 50       4 defined($machine) or usage "Undefined Computer Name!\n";
139 1         4 my $ctx_id = pack("V", rand 2**32);
140 1         10 bless {
141             'user' => $user,
142             'user_domain' => $user_domain,
143             'domain' => $domain,
144             'machine' => $machine,
145             'lm_hpw' => $lm_hpw,
146             'nt_hpw' => $nt_hpw
147             }, $package;
148             }
149            
150             ###########################################################################
151             # new_server instantiate a NTLM server that composes an NTLM challenge #
152             # It can take one argument for the server network domain. If the argument #
153             # is not supplied, it will call Win32::DomainName to obtain it. #
154             ###########################################################################
155             sub new_server {
156 1 50 33 1 0 62 usage("new_server Authen::Perl::NTLM or\nnew_server Authen::Perl::NTLM(\$domain\)") unless @_ == 1 or @_ == 2;
157 1         2 my ($package, $domain) = @_;
158 1 50       4 if (not defined($domain)) {$domain = Win32::DomainName();}
  0         0  
159 1 50       3 defined($domain) or usage "Undefined Network Domain!\n";
160 1         6 bless {
161             'domain' => $domain,
162             'cChallenge' => 0 # a counter to stir the seed to generate random
163             }, $package; # number for the nonce
164             }
165            
166             ##########################################################################
167             # lm_hash calculates the LM hash to be used to calculate the LM response #
168             # It takes a password and return the 21 bytes LM password hash. #
169             ##########################################################################
170             sub lm_hash($)
171             {
172 1     1 0 519 my ($passwd) = @_;
173 1         2 my $cipher1;
174             my $cipher2;
175 1         3 my $magic = pack("H16", "4B47532140232425"); # magical string to be encrypted for the LM password hash
176 1         5 while (length($passwd) < 14) {
177 4         9 $passwd .= chr(0);
178             }
179 1         3 my $lm_pw = substr($passwd, 0, 14);
180 1         3 $lm_pw = uc($lm_pw); # change the password to upper case
181 1         6 my $key = convert_key(substr($lm_pw, 0, 7)) . convert_key(substr($lm_pw, 7, 7));
182 1 50       5 if ($Authen::Perl::NTLM::PurePerl) {
183 1         11 $cipher1 = Crypt::DES_PP->new(substr($key, 0, 8));
184 1         230 $cipher2 = Crypt::DES_PP->new(substr($key, 8, 8));
185             }
186             else {
187 0         0 $cipher1 = Crypt::DES->new(substr($key, 0, 8));
188 0         0 $cipher2 = Crypt::DES->new(substr($key, 8, 8));
189             }
190 1         174 return $cipher1->encrypt($magic) . $cipher2->encrypt($magic) . pack("H10", "0000000000");
191             }
192            
193             ##########################################################################
194             # nt_hash calculates the NT hash to be used to calculate the NT response #
195             # It takes a password and return the 21 bytes NT password hash. #
196             ##########################################################################
197             sub nt_hash($)
198             {
199 1     1 0 257 my ($passwd) = @_;
200 1         5 my $nt_pw = unicodify($passwd);
201 1         2 my $nt_hpw;
202 1 50       4 if ($Authen::Perl::NTLM::PurePerl == 1) {
203 1         6 $nt_hpw = md4($nt_pw) . pack("H10", "0000000000");
204             }
205             else {
206 0         0 my $md4 = new Digest::MD4;
207 0         0 $md4->add($nt_pw);
208 0         0 $nt_hpw = $md4->digest() . pack("H10", "0000000000");
209             }
210 1         1020 return $nt_hpw;
211             }
212            
213             ####################################################################
214             # negotiate_msg creates the NTLM negotiate packet given the domain #
215             # (from Win32::DomainName()) and the workstation name (from #
216             # $ENV{'COMPUTERNAME'} or Win32::NodeName()) and the negotiation #
217             # flags. #
218             ####################################################################
219             sub negotiate_msg($$)
220             {
221 1     1 0 26 my $self = $_[0];
222 1         2 my $flags = pack("V", $_[1]);
223 1         11 my $domain = $self->{'domain'};
224 1         2 my $machine = $self->{'machine'};
225 1         3 my $msg = NTLMSSP_SIGNATURE . chr(0);
226 1         2 $msg .= pack("V", NTLMSSP_NEGOTIATE);
227 1         2 $msg .= $flags;
228 1         2 my $offset = length($msg) + 8*2;
229 1         43 $msg .= pack("v", length($domain)) . pack("v", length($domain)) . pack("V", $offset + length($machine));
230 1         5 $msg .= pack("v", length($machine)) . pack("v", length($machine)) . pack("V", $offset);
231 1         7 $msg .= $machine . $domain;
232 1         4 return $msg;
233             }
234            
235             ####################################################################
236             # challenge_msg composes the NTLM challenge message. It takes NTLM #
237             # Negotiation Flags as an argument. #
238             ####################################################################
239             sub challenge_msg($)
240             {
241 1     1 0 13 my ($self) = @_;
242 1         3 my $flags = pack("V", $_[1]);
243 1         2 my $domain = $self->{'domain'};
244 1         2 my $msg = NTLMSSP_SIGNATURE . chr(0);
245 1         2 $self->{'cChallenge'} += 0x100;
246 1         2 $msg .= pack("V", NTLMSSP_CHALLENGE);
247 1         4 $msg .= pack("v", length($domain)) . pack("v", length($domain)) . pack("V", 48);
248 1         2 $msg .= $flags;
249 1         4 $msg .= compute_nonce($self->{'cChallenge'});
250 1         2 $msg .= pack("VV", 0, 0); # 8 bytes of reserved 0s
251 1         2 $msg .= pack("V", 0); # ServerContextHandleLower
252 1         2 $msg .= pack("V", 0x3c); # ServerContextHandleUpper
253 1         3 $msg .= unicodify($domain);
254 1         4 return $msg;
255             }
256            
257             ###########################################################################
258             # parse_challenge parses the NTLM challenge and return a list of server #
259             # network domain, NTLM Negotiation Flags, Nonce, ServerContextHandleUpper #
260             # and ServerContextHandleLower. #
261             ###########################################################################
262             sub parse_challenge
263             {
264 1     1 0 37 my ($self, $pkt) = @_;
265 1 50       11 substr($pkt, 0, 8) eq (NTLMSSP_SIGNATURE . chr(0)) or usage "NTLM Challenge doesn't contain NTLMSSP_SIGNATURE!\n";
266 1         11 my $type = GetInt32(substr($pkt, 8));
267 1 50       5 $type == NTLMSSP_CHALLENGE or usage "Not an NTLM Challenge!\n";
268 1         3 my $target = GetString($pkt, 12);
269 1         4 $target = un_unicodify($target);
270 1         4 my $flags = GetInt32(substr($pkt, 20));
271 1         3 my $nonce = substr($pkt, 24, 8);
272 1         3 my $ctx_lower = GetInt32(substr($pkt, 40));
273 1         4 my $ctx_upper = GetInt32(substr($pkt, 44));
274 1         5 return ($target, $flags, $nonce, $ctx_lower, $ctx_upper);
275             }
276            
277             ############################################################################
278             # GetString is called internally to get a UNICODE string in a NTLM message #
279             ############################################################################
280             sub GetString
281             {
282 1     1 0 2 my ($str, $loc) = @_;
283 1         4 my $len = GetInt16(substr($str, $loc));
284 1         3 my $max_len = GetInt16(substr($str, $loc+2));
285 1         4 my $offset = GetInt32(substr($str, $loc+4));
286 1         3 return substr($str, $offset, 2*$max_len);
287             }
288            
289             ############################################################################
290             # GetInt32 is called internally to get a 32-bit integer in an NTLM message #
291             ############################################################################
292             sub GetInt32
293             {
294 5     5 0 9 my ($str) = @_;
295 5         11 return unpack("V", substr($str, 0, 4));
296             }
297            
298             ############################################################################
299             # GetInt16 is called internally to get a 16-bit integer in an NTLM message #
300             ############################################################################
301             sub GetInt16
302             {
303 2     2 0 4 my ($str) = @_;
304 2         5 return unpack("v", substr($str, 0, 2));
305             }
306            
307             ###########################################################################
308             # auth_msg creates the NTLM response to an NTLM challenge from the #
309             # server. It takes 2 arguments: $nonce obtained from parse_challenge and #
310             # NTLM Negotiation Flags. #
311             # This function ASSUMEs the input of user domain, user name and #
312             # workstation name are in ASCII format and not in UNICODE format. #
313             ###########################################################################
314             sub auth_msg($$$)
315             {
316 1     1 0 62 my ($self, $nonce) = @_;
317 1         3 my $session_key = session_key();
318 1         2 my $user_domain = $self->{'user_domain'};
319 1         3 my $username = $self->{'user'};
320 1         2 my $machine = $self->{'machine'};
321 1         4 my $lm_resp = calc_resp($self->{'lm_hpw'}, $nonce);
322 1         301 my $nt_resp = calc_resp($self->{'nt_hpw'}, $nonce);
323 1         303 my $flags = pack("V", $_[2]);
324 1         3 my $msg = NTLMSSP_SIGNATURE . chr(0);
325 1         2 $msg .= pack("V", NTLMSSP_AUTH);
326 1         3 my $offset = length($msg) + 8*6 + 4;
327 1         6 $msg .= pack("v", length($lm_resp)) . pack("v", length($lm_resp)) . pack("V", $offset + 2*length($user_domain) + 2*length($username) + 2*length($machine) + length($session_key));
328 1         6 $msg .= pack("v", length($nt_resp)) . pack("v", length($nt_resp)) . pack("V", $offset + 2*length($user_domain) + 2*length($username) + 2*length($machine) + length($session_key) + length($lm_resp));
329 1         5 $msg .= pack("v", 2*length($user_domain)) . pack("v", 2*length($user_domain)) . pack("V", $offset);
330 1         4 $msg .= pack("v", 2*length($username)) . pack("v", 2*length($username)) . pack("V", $offset + 2*length($user_domain));
331 1         6 $msg .= pack("v", 2*length($machine)) . pack("v", 2*length($machine)) . pack("V", $offset + 2*length($user_domain) + 2*length($username));
332 1         5 $msg .= pack("v", length($session_key)) . pack("v", length($session_key)) . pack("V", $offset + 2*length($user_domain) + 2*length($username) + 2*length($machine)+ 48);
333 1         3 $msg .= $flags . unicodify($user_domain) . unicodify($username) . unicodify($machine) . $lm_resp . $nt_resp . $session_key;
334 1         4 return $msg;
335             }
336            
337             #####################################################################
338             # session_key computes a session key for an NTLM session. Currently #
339             # it is not implemented. #
340             #####################################################################
341             sub session_key
342             {
343 1     1 0 3 return "";
344             }
345            
346             #######################################################################
347             # compute_nonce computes the 8-bytes nonce to be included in server's
348             # NTLM challenge packet.
349             #######################################################################
350             sub compute_nonce($)
351             {
352 1     1 0 1 my ($cChallenge) = @_;
353 1         4 my @SysTime = UNIXTimeToFILETIME($cChallenge, time);
354 1         4 my $Seed = (($SysTime[1] + 1) << 0) |
355             (($SysTime[2] + 0) << 8) |
356             (($SysTime[3] - 1) << 16) |
357             (($SysTime[4] + 0) << 24);
358 1         2 srand $Seed;
359 1         4 my $ulChallenge0 = rand(2**16)+rand(2**32);
360 1         2 my $ulChallenge1 = rand(2**16)+rand(2**32);
361 1         2 my $ulNegate = rand(2**16)+rand(2**32);
362 1 50       3 if ($ulNegate & 0x1) {$ulChallenge0 |= 0x80000000;}
  1         2  
363 1 50       3 if ($ulNegate & 0x2) {$ulChallenge1 |= 0x80000000;}
  1         1  
364 1         10 return pack("V", $ulChallenge0) . pack("V", $ulChallenge1);
365             }
366            
367             #########################################################################
368             # convert_key converts a 7-bytes key to an 8-bytes key based on an
369             # algorithm.
370             #########################################################################
371             sub convert_key($) {
372 8     8 0 14 my ($in_key) = @_;
373 8         9 my @byte;
374 8         9 my $result = "";
375 8 50       17 usage("exactly 7-bytes key") unless length($in_key) == 7;
376 8         11 $byte[0] = substr($in_key, 0, 1);
377 8         22 $byte[1] = chr(((ord(substr($in_key, 0, 1)) << 7) & 0xFF) | (ord(substr($in_key, 1, 1)) >> 1));
378 8         17 $byte[2] = chr(((ord(substr($in_key, 1, 1)) << 6) & 0xFF) | (ord(substr($in_key, 2, 1)) >> 2));
379 8         18 $byte[3] = chr(((ord(substr($in_key, 2, 1)) << 5) & 0xFF) | (ord(substr($in_key, 3, 1)) >> 3));
380 8         16 $byte[4] = chr(((ord(substr($in_key, 3, 1)) << 4) & 0xFF) | (ord(substr($in_key, 4, 1)) >> 4));
381 8         16 $byte[5] = chr(((ord(substr($in_key, 4, 1)) << 3) & 0xFF) | (ord(substr($in_key, 5, 1)) >> 5));
382 8         16 $byte[6] = chr(((ord(substr($in_key, 5, 1)) << 2) & 0xFF) | (ord(substr($in_key, 6, 1)) >> 6));
383 8         13 $byte[7] = chr((ord(substr($in_key, 6, 1)) << 1) & 0xFF);
384 8         19 for (my $i = 0; $i < 8; ++$i) {
385 64         93 $byte[$i] = set_odd_parity($byte[$i]);
386 64         137 $result .= $byte[$i];
387             }
388 8         34 return $result;
389             }
390            
391             ##########################################################################
392             # set_odd_parity turns one-byte into odd parity. Odd parity means that
393             # a number in binary has odd number of 1's.
394             ##########################################################################
395             sub set_odd_parity($)
396             {
397 64     64 0 67 my ($byte) = @_;
398 64         60 my $parity = 0;
399 64         54 my $ordbyte;
400 64 50       96 usage("single byte input only") unless length($byte) == 1;
401 64         62 $ordbyte = ord($byte);
402 64         118 for (my $i = 0; $i < 8; ++$i) {
403 512 100       737 if ($ordbyte & 0x01) {++$parity;}
  171         154  
404 512         883 $ordbyte >>= 1;
405             }
406 64         55 $ordbyte = ord($byte);
407 64 100       109 if ($parity % 2 == 0) {
408 35 100       48 if ($ordbyte & 0x01) {
409 7         8 $ordbyte &= 0xFE;
410             }
411             else {
412 28         30 $ordbyte |= 0x01;
413             }
414             }
415 64         117 return chr($ordbyte);
416             }
417            
418             ###########################################################################
419             # calc_resp computes the 24-bytes NTLM response based on the password hash
420             # and the nonce.
421             ###########################################################################
422             sub calc_resp($$)
423             {
424 2     2 0 3 my ($key, $nonce) = @_;
425 2         2 my $cipher1;
426             my $cipher2;
427 0         0 my $cipher3;
428 2 50       6 usage("key must be 21-bytes long") unless length($key) == 21;
429 2 50       5 usage("nonce must be 8-bytes long") unless length($nonce) == 8;
430 2 50       5 if ($Authen::Perl::NTLM::PurePerl) {
431 2         12 $cipher1 = Crypt::DES_PP->new(convert_key(substr($key, 0, 7)));
432 2         353 $cipher2 = Crypt::DES_PP->new(convert_key(substr($key, 7, 7)));
433 2         785 $cipher3 = Crypt::DES_PP->new(convert_key(substr($key, 14, 7)));
434             }
435             else {
436 0         0 $cipher1 = Crypt::DES->new(convert_key(substr($key, 0, 7)));
437 0         0 $cipher2 = Crypt::DES->new(convert_key(substr($key, 7, 7)));
438 0         0 $cipher3 = Crypt::DES->new(convert_key(substr($key, 14, 7)));
439             }
440 2         427 return $cipher1->encrypt($nonce) . $cipher2->encrypt($nonce) . $cipher3->encrypt($nonce);
441             }
442            
443             #########################################################################
444             # un_unicodify takes a unicode string and turns it into an ASCII string.
445             # CAUTION: This function is intended to be used with unicodified ASCII
446             # strings.
447             #########################################################################
448             sub un_unicodify
449             {
450 1     1 0 2 my ($str) = @_;
451 1         1 my $newstr = "";
452 1         2 my $i;
453            
454 1 50       4 usage("$str must be a string of even length to be un_unicodify!: $!\n") if length($str) % 2;
455            
456 1         24 for ($i = 0; $i < length($str) / 2; ++$i) {
457 3         9 $newstr .= substr($str, 2*$i, 1);
458             }
459 1         3 return $newstr;
460             }
461            
462             #########################################################################
463             # unicodify takes an ASCII string and turns it into a unicode string.
464             #########################################################################
465             sub unicodify($)
466             {
467 5     5 0 14 my ($str) = @_;
468 5         6 my $newstr = "";
469 5         5 my $i;
470            
471 5         14 for ($i = 0; $i < length($str); ++$i) {
472 26         55 $newstr .= substr($str, $i, 1) . chr(0);
473             }
474 5         13 return $newstr;
475             }
476            
477             ##########################################################################
478             # UNIXTimeToFILETIME converts UNIX time_t to 64-bit FILETIME format used
479             # in win32 platforms. It returns two 32-bit integer. The first one is
480             # the upper 32-bit and the second one is the lower 32-bit. The result is
481             # adjusted by cChallenge as in NTLM spec. For those of you who want to
482             # use this function for actual use, please remove the cChallenge variable.
483             ##########################################################################
484             sub UNIXTimeToFILETIME($$)
485             {
486 1     1 0 2 my ($cChallenge, $time) = @_;
487 1         7 $time = $time * 10000000 + 11644473600000000 + $cChallenge;
488 1         3 my $uppertime = $time / (2**32);
489 1         13 my $lowertime = $time - floor($uppertime) * 2**32;
490 1         6 return ($lowertime & 0x000000ff,
491             $lowertime & 0x0000ff00,
492             $lowertime & 0x00ff0000,
493             $lowertime & 0xff000000,
494             $uppertime & 0x000000ff,
495             $uppertime & 0x0000ff00,
496             $uppertime & 0x00ff0000,
497             $uppertime & 0xff000000);
498             }
499            
500             1;
501            
502             __END__