Package list libcryptx-perl / 96f8bd1
Math::BigInt::LTM - proper fix for #46 Karel Miko 2 years ago
2 changed file(s) with 728 addition(s) and 207 deletion(s). Raw diff Collapse all Expand all
5959 Newz(0, RETVAL, 1, mp_int);
6060 mp_init(RETVAL);
6161 mp_read_radix(RETVAL, SvPV_nolen(x), 8);
62 OUTPUT:
63 RETVAL
64
65 ##############################################################################
66 # _from_base()
67
68 Math::BigInt::LTM
69 _from_base(Class, SV *x, int base)
70 CODE:
71 Newz(0, RETVAL, 1, mp_int);
72 mp_init(RETVAL);
73 mp_read_radix(RETVAL, SvPV_nolen(x), base);
74 OUTPUT:
75 RETVAL
76
77 ##############################################################################
78 # _from_bytes()
79
80 Math::BigInt::LTM
81 _from_bytes(Class, SV *x)
82 PREINIT:
83 STRLEN buf_len;
84 unsigned char *buf_ptr;
85 CODE:
86 Newz(0, RETVAL, 1, mp_int);
87 mp_init(RETVAL);
88 buf_ptr = (unsigned char *)SvPVbyte(x, buf_len);
89 mp_read_unsigned_bin(RETVAL, buf_ptr, buf_len);
6290 OUTPUT:
6391 RETVAL
6492
189217 ##############################################################################
190218 # _alen() - return the approx. length of the number in base 10 (fast)
191219 # _alen() might underestimate, but never overestimate the true value
220
192221 int
193222 _alen(Class, Math::BigInt::LTM n)
194223 PREINIT:
233262 RETVAL
234263
235264 ##############################################################################
236 # _as_hex() - return ref to hexadecimal string (prefixed with 0x)
265 # _to_hex() - return ref to hexadecimal string (no prefix)
237266
238267 SV *
239 _as_hex(Class, Math::BigInt::LTM n)
268 _to_hex(Class, Math::BigInt::LTM n)
240269 PREINIT:
241270 int i, len;
242271 char *buf;
243272 CODE:
244 len = mp_unsigned_bin_size(n) * 2 + 3;
245 RETVAL = newSV(len);
246 SvPOK_on(RETVAL);
247 buf = SvPVX(RETVAL); /* get ptr to storage */
248 *buf++ = '0'; *buf++ = 'x'; /* prepend '0x' */
249 mp_tohex(n, buf);
250 for (i=0; i<len && buf[i]>0; i++) buf[i] = toLOWER(buf[i]);
251 SvCUR_set(RETVAL, strlen(buf)+2); /* set real length */
252 OUTPUT:
253 RETVAL
254
255 ##############################################################################
256 # _as_bin() - return ref to binary string (prefixed with 0b)
257
258 SV *
259 _as_bin(Class, Math::BigInt::LTM n)
260 PREINIT:
261 int len;
262 char *buf;
263 CODE:
264 len = mp_unsigned_bin_size(n) * 8 + 3;
265 RETVAL = newSV(len);
266 SvPOK_on(RETVAL);
267 buf = SvPVX(RETVAL); /* get ptr to storage */
268 *buf++ = '0'; *buf++ = 'b'; /* prepend '0b' */
269 mp_tobinary(n, buf);
270 SvCUR_set(RETVAL, strlen(buf)+2); /* set real length */
271 OUTPUT:
272 RETVAL
273
274 ##############################################################################
275 # _as_oct() - return ref to octal string (prefixed with 0)
276
277 SV *
278 _as_oct(Class, Math::BigInt::LTM n)
279 PREINIT:
280 int len;
281 char *buf;
282 CODE:
283 len = mp_unsigned_bin_size(n) * 3 + 3;
273 len = mp_unsigned_bin_size(n) * 2 + 1;
284274 RETVAL = newSV(len);
285275 SvPOK_on(RETVAL);
286276 buf = SvPVX(RETVAL);
287 *buf++ = '0'; /* prepend '0' */
277 mp_tohex(n, buf);
278 for (i=0; i<len && buf[i]>0; i++) buf[i] = toLOWER(buf[i]);
279 SvCUR_set(RETVAL, strlen(buf));
280 OUTPUT:
281 RETVAL
282
283 ##############################################################################
284 # _to_bin() - return ref to binary string (no prefix)
285
286 SV *
287 _to_bin(Class, Math::BigInt::LTM n)
288 PREINIT:
289 int len;
290 char *buf;
291 CODE:
292 len = mp_unsigned_bin_size(n) * 8 + 1;
293 RETVAL = newSV(len);
294 SvPOK_on(RETVAL);
295 buf = SvPVX(RETVAL);
296 mp_tobinary(n, buf);
297 SvCUR_set(RETVAL, strlen(buf));
298 OUTPUT:
299 RETVAL
300
301 ##############################################################################
302 # _to_oct() - return ref to octal string (no prefix)
303
304 SV *
305 _to_oct(Class, Math::BigInt::LTM n)
306 PREINIT:
307 int len;
308 char *buf;
309 CODE:
310 len = mp_unsigned_bin_size(n) * 3 + 1;
311 RETVAL = newSV(len);
312 SvPOK_on(RETVAL);
313 buf = SvPVX(RETVAL);
288314 mp_tooctal(n, buf);
289 SvCUR_set(RETVAL, strlen(buf)+1); /* set real length */
315 SvCUR_set(RETVAL, strlen(buf));
316 OUTPUT:
317 RETVAL
318
319 ##############################################################################
320 # _to_base() - raw bytes
321
322 SV *
323 _to_base(Class, Math::BigInt::LTM n, int base)
324 PREINIT:
325 int len;
326 char *buf;
327 CODE:
328 len = mp_unsigned_bin_size(n) * 8; /* the worst case for base == 2 */
329 RETVAL = newSV(len + 1);
330 SvPOK_on(RETVAL);
331 buf = SvPVX(RETVAL);
332 if (len > 0) {
333 mp_toradix_n(n, buf, base, len);
334 SvCUR_set(RETVAL, strlen(buf));
335 }
336 else {
337 buf[0] = '0';
338 SvCUR_set(RETVAL, 1);
339 }
340 OUTPUT:
341 RETVAL
342
343 ##############################################################################
344 # _to_bytes() - raw bytes
345 # _as_bytes() - raw bytes
346
347 SV *
348 _to_bytes(Class, Math::BigInt::LTM n)
349 ALIAS:
350 _as_bytes = 1
351 PREINIT:
352 int len;
353 unsigned char *buf;
354 CODE:
355 PERL_UNUSED_VAR(ix);
356 len = mp_unsigned_bin_size(n);
357 RETVAL = newSV(len + 1);
358 SvPOK_on(RETVAL);
359 buf = (unsigned char*)SvPVX(RETVAL);
360 if (len > 0) {
361 mp_to_unsigned_bin(n, buf);
362 SvCUR_set(RETVAL, len);
363 }
364 else {
365 buf[0] = 0;
366 SvCUR_set(RETVAL, 1);
367 }
290368 OUTPUT:
291369 RETVAL
292370
44 our $VERSION = '0.062_001';
55
66 use CryptX;
7
8 sub api_version() { 2 }
7 use Carp;
98
109 sub CLONE_SKIP { 1 } # prevent cloning
10
11 sub api_version() { 2 } # compatible with Math::BigInt v1.83+
12
13 sub import { }
14
15 ### the following functions are implemented in XS
16 # _1ex()
17 # _acmp()
18 # _add()
19 # _alen()
20 # _alen()
21 # _and()
22 # _as_bytes()
23 # _copy()
24 # _dec()
25 # _div()
26 # _from_base()
27 # _from_bin()
28 # _from_bytes()
29 # _from_hex()
30 # _from_oct()
31 # _gcd()
32 # _inc()
33 # _is_even()
34 # _is_odd()
35 # _is_one()
36 # _is_ten()
37 # _is_two()
38 # _is_zero()
39 # _lcm()
40 # _len()
41 # _lsft()
42 # _mod()
43 # _modinv()
44 # _modpow()
45 # _mul()
46 # _new()
47 # _one()
48 # _or()
49 # _pow()
50 # _root()
51 # _rsft()
52 # _set()
53 # _sqrt()
54 # _str()
55 # _sub()
56 # _ten()
57 # _to_base()
58 # _to_bin()
59 # _to_bytes()
60 # _to_hex()
61 # _to_oct()
62 # _two()
63 # _xor()
64 # _zero()
65 # _zeros()
66
1167
1268 ### same as overloading in Math::BigInt::Lib
1369 use overload
70
1471 # overload key: with_assign
1572
1673 '+' => sub {
238295 return $class -> _sqrt($class -> _copy($_[0]));
239296 },
240297
241 'int' => sub { $_[0] -> copy() -> bint(); },
298 'int' => sub { $_[0] },
242299
243300 # overload key: conversion
244301
251308 '=' => sub { ref($_[0]) -> _copy($_[0]); },
252309
253310 ;
254
255 ### same as import() in Math::BigInt::Lib
256 sub import { }
257311
258312 ### same as _check() in Math::BigInt::Lib
259313 sub _check {
260 # used by the test suite
261 my ($class, $x) = @_;
262 return "Input is undefined" unless defined $x;
263 return "$x is not a reference" unless ref($x);
264 return 0;
314 # used by the test suite
315 my ($class, $x) = @_;
316 return "Input is undefined" unless defined $x;
317 return "$x is not a reference" unless ref($x);
318 return 0;
265319 }
266320
267321 ### same as _digit() in Math::BigInt::Lib
268322 sub _digit {
269 my ($class, $x, $n) = @_;
270 substr($class ->_str($x), -($n+1), 1);
323 my ($class, $x, $n) = @_;
324 substr($class ->_str($x), -($n+1), 1);
271325 }
272326
273327 ### same as _num() in Math::BigInt::Lib
274328 sub _num {
275 my ($class, $x) = @_;
276 0 + $class -> _str($x);
277 }
278
279 ### BEWARE!!! NOT THE SAME as _fac() in Math::BigInt::Lib
329 my ($class, $x) = @_;
330 0 + $class -> _str($x);
331 }
332
333 ### same as _fac() in Math::BigInt::Lib
280334 sub _fac {
281 # factorial
282 my ($class, $x) = @_;
283
284 my $two = $class -> _two();
285
286 if ($class -> _acmp($x, $two) < 0) {
287 $class->_set($x, 1);
288 return $x;
289 }
290
291 my $i = $class -> _copy($x);
292 while ($class -> _acmp($i, $two) > 0) {
293 $i = $class -> _dec($i);
294 $x = $class -> _mul($x, $i);
295 }
296
297 return $x;
335 # factorial
336 my ($class, $x) = @_;
337
338 my $two = $class -> _two();
339
340 if ($class -> _acmp($x, $two) < 0) {
341 return $class -> _one();
342 }
343
344 my $i = $class -> _copy($x);
345 while ($class -> _acmp($i, $two) > 0) {
346 $i = $class -> _dec($i);
347 $x = $class -> _mul($x, $i);
348 }
349
350 return $x;
351 }
352
353 ### same as _dfac() in Math::BigInt::Lib
354 sub _dfac {
355 # double factorial
356 my ($class, $x) = @_;
357
358 my $two = $class -> _two();
359
360 if ($class -> _acmp($x, $two) < 0) {
361 return $class -> _one();
362 }
363
364 my $i = $class -> _copy($x);
365 while ($class -> _acmp($i, $two) > 0) {
366 $i = $class -> _sub($i, $two);
367 $x = $class -> _mul($x, $i);
368 }
369
370 return $x;
298371 }
299372
300373 ### same as _nok() in Math::BigInt::Lib
301374 sub _nok {
302 # Return binomial coefficient (n over k).
303 # Given refs to arrays, return ref to array.
304 # First input argument is modified.
305
306 my ($class, $n, $k) = @_;
307
308 # If k > n/2, or, equivalently, 2*k > n, compute nok(n, k) as
309 # nok(n, n-k), to minimize the number if iterations in the loop.
310
311 {
312 my $twok = $class -> _mul($class -> _two(), $class -> _copy($k));
313 if ($class -> _acmp($twok, $n) > 0) {
314 $k = $class -> _sub($class -> _copy($n), $k);
315 }
316 }
317
318 # Example:
319 #
320 # / 7 \ 7! 1*2*3*4 * 5*6*7 5 * 6 * 7 6 7
321 # | | = --------- = --------------- = --------- = 5 * - * -
322 # \ 3 / (7-3)! 3! 1*2*3*4 * 1*2*3 1 * 2 * 3 2 3
323
324 if ($class -> _is_zero($k)) {
325 return $class -> _one();
326 }
327
328 # Make a copy of the original n, since we'll be modifying n in-place.
329
330 my $n_orig = $class -> _copy($n);
331
332 # n = 5, f = 6, d = 2 (cf. example above)
333
334 $n = $class -> _sub($n, $k);
335 $n = $class -> _inc($n);
336
337 my $f = $class -> _copy($n);
338 $class -> _inc($f);
339
340 my $d = $class -> _two();
341
342 # while f <= n (the original n, that is) ...
343
344 while ($class -> _acmp($f, $n_orig) <= 0) {
345
346 # n = (n * f / d) == 5 * 6 / 2 (cf. example above)
347
348 $n = $class -> _mul($n, $f);
349 $n = $class -> _div($n, $d);
350
351 # f = 7, d = 3 (cf. example above)
352
353 $f = $class -> _inc($f);
354 $d = $class -> _inc($d);
355 }
356
357 return $n;
375 # Return binomial coefficient (n over k).
376 my ($class, $n, $k) = @_;
377
378 # If k > n/2, or, equivalently, 2*k > n, compute nok(n, k) as
379 # nok(n, n-k), to minimize the number if iterations in the loop.
380
381 {
382 my $twok = $class -> _mul($class -> _two(), $class -> _copy($k));
383 if ($class -> _acmp($twok, $n) > 0) {
384 $k = $class -> _sub($class -> _copy($n), $k);
385 }
386 }
387
388 # Example:
389 #
390 # / 7 \ 7! 1*2*3*4 * 5*6*7 5 * 6 * 7
391 # | | = --------- = --------------- = --------- = ((5 * 6) / 2 * 7) / 3
392 # \ 3 / (7-3)! 3! 1*2*3*4 * 1*2*3 1 * 2 * 3
393 #
394 # Equivalently, _nok(11, 5) is computed as
395 #
396 # (((((((7 * 8) / 2) * 9) / 3) * 10) / 4) * 11) / 5
397
398 if ($class -> _is_zero($k)) {
399 return $class -> _one();
400 }
401
402 # Make a copy of the original n, in case the subclass modifies n in-place.
403
404 my $n_orig = $class -> _copy($n);
405
406 # n = 5, f = 6, d = 2 (cf. example above)
407
408 $n = $class -> _sub($n, $k);
409 $n = $class -> _inc($n);
410
411 my $f = $class -> _copy($n);
412 $f = $class -> _inc($f);
413
414 my $d = $class -> _two();
415
416 # while f <= n (the original n, that is) ...
417
418 while ($class -> _acmp($f, $n_orig) <= 0) {
419 $n = $class -> _mul($n, $f);
420 $n = $class -> _div($n, $d);
421 $f = $class -> _inc($f);
422 $d = $class -> _inc($d);
423 }
424
425 return $n;
358426 }
359427
360428 ### same as _log_int() in Math::BigInt::Lib
361429 sub _log_int {
362 # calculate integer log of $x to base $base
363 # ref to array, ref to array - return ref to array
364 my ($class, $x, $base) = @_;
365
366 # X == 0 => NaN
367 return if $class -> _is_zero($x);
368
369 $base = $class -> _new(2) unless defined($base);
370 $base = $class -> _new($base) unless ref($base);
371
372 # BASE 0 or 1 => NaN
373 return if $class -> _is_zero($base) || $class -> _is_one($base);
374
375 # X == 1 => 0 (is exact)
376 if ($class -> _is_one($x)) {
377 return $class -> _zero(), 1;
378 }
379
380 my $cmp = $class -> _acmp($x, $base);
381
382 # X == BASE => 1 (is exact)
383 if ($cmp == 0) {
384 return $class -> _one(), 1;
385 }
386
387 # 1 < X < BASE => 0 (is truncated)
388 if ($cmp < 0) {
389 return $class -> _zero(), 0;
390 }
391
392 my $y;
393
394 # log(x) / log(b) = log(xm * 10^xe) / log(bm * 10^be)
395 # = (log(xm) + xe*(log(10))) / (log(bm) + be*log(10))
396
397 {
398 my $x_str = $class -> _str($x);
399 my $b_str = $class -> _str($base);
400 my $xm = "." . $x_str;
401 my $bm = "." . $b_str;
402 my $xe = length($x_str);
403 my $be = length($b_str);
404 my $log10 = log(10);
405 my $guess = int((log($xm) + $xe * $log10) / (log($bm) + $be * $log10));
406 $y = $class -> _new($guess);
407 }
408
409 my $trial = $class -> _pow($class -> _copy($base), $y);
410 my $acmp = $class -> _acmp($trial, $x);
411
412 # Did we get the exact result?
413
414 return $y, 1 if $acmp == 0;
415
416 # Too small?
417
418 while ($acmp < 0) {
419 $trial = $class -> _mul($trial, $base);
420 $y = $class -> _inc($y);
421 $acmp = $class -> _acmp($trial, $x);
422 }
423
424 # Too big?
425
426 while ($acmp > 0) {
427 $trial = $class -> _div($trial, $base);
428 $y = $class -> _dec($y);
429 $acmp = $class -> _acmp($trial, $x);
430 }
431
432 return $y, 1 if $acmp == 0; # result is exact
433 return $y, 0; # result is too small
430 # calculate integer log of $x to base $base
431 # ref to array, ref to array - return ref to array
432 my ($class, $x, $base) = @_;
433
434 # X == 0 => NaN
435 return if $class -> _is_zero($x);
436
437 $base = $class -> _new(2) unless defined($base);
438 $base = $class -> _new($base) unless ref($base);
439
440 # BASE 0 or 1 => NaN
441 return if $class -> _is_zero($base) || $class -> _is_one($base);
442
443 # X == 1 => 0 (is exact)
444 if ($class -> _is_one($x)) {
445 return $class -> _zero(), 1;
446 }
447
448 my $cmp = $class -> _acmp($x, $base);
449
450 # X == BASE => 1 (is exact)
451 if ($cmp == 0) {
452 return $class -> _one(), 1;
453 }
454
455 # 1 < X < BASE => 0 (is truncated)
456 if ($cmp < 0) {
457 return $class -> _zero(), 0;
458 }
459
460 my $y;
461
462 # log(x) / log(b) = log(xm * 10^xe) / log(bm * 10^be)
463 # = (log(xm) + xe*(log(10))) / (log(bm) + be*log(10))
464
465 {
466 my $x_str = $class -> _str($x);
467 my $b_str = $class -> _str($base);
468 my $xm = "." . $x_str;
469 my $bm = "." . $b_str;
470 my $xe = length($x_str);
471 my $be = length($b_str);
472 my $log10 = log(10);
473 my $guess = int((log($xm) + $xe * $log10) / (log($bm) + $be * $log10));
474 $y = $class -> _new($guess);
475 }
476
477 my $trial = $class -> _pow($class -> _copy($base), $y);
478 my $acmp = $class -> _acmp($trial, $x);
479
480 # Did we get the exact result?
481
482 return $y, 1 if $acmp == 0;
483
484 # Too small?
485
486 while ($acmp < 0) {
487 $trial = $class -> _mul($trial, $base);
488 $y = $class -> _inc($y);
489 $acmp = $class -> _acmp($trial, $x);
490 }
491
492 # Too big?
493
494 while ($acmp > 0) {
495 $trial = $class -> _div($trial, $base);
496 $y = $class -> _dec($y);
497 $acmp = $class -> _acmp($trial, $x);
498 }
499
500 return $y, 1 if $acmp == 0; # result is exact
501 return $y, 0; # result is too small
502 }
503
504 ### same as _lucas() in Math::BigInt::Lib
505 sub _lucas {
506 my ($class, $n) = @_;
507
508 $n = $class -> _num($n) if ref $n;
509
510 # In list context, use lucas(n) = lucas(n-1) + lucas(n-2)
511
512 if (wantarray) {
513 my @y;
514
515 push @y, $class -> _two();
516 return @y if $n == 0;
517
518 push @y, $class -> _one();
519 return @y if $n == 1;
520
521 for (my $i = 2 ; $i <= $n ; ++ $i) {
522 $y[$i] = $class -> _add($class -> _copy($y[$i - 1]), $y[$i - 2]);
523 }
524
525 return @y;
526 }
527
528 require Scalar::Util;
529
530 # In scalar context use that lucas(n) = fib(n-1) + fib(n+1).
531 #
532 # Remember that _fib() behaves differently in scalar context and list
533 # context, so we must add scalar() to get the desired behaviour.
534
535 return $class -> _two() if $n == 0;
536
537 return $class -> _add(scalar $class -> _fib($n - 1),
538 scalar $class -> _fib($n + 1));
539 }
540
541 ### same as _fib() in Math::BigInt::Lib
542 sub _fib {
543 my ($class, $n) = @_;
544
545 $n = $class -> _num($n) if ref $n;
546
547 # In list context, use fib(n) = fib(n-1) + fib(n-2)
548
549 if (wantarray) {
550 my @y;
551
552 push @y, $class -> _zero();
553 return @y if $n == 0;
554
555 push @y, $class -> _one();
556 return @y if $n == 1;
557
558 for (my $i = 2 ; $i <= $n ; ++ $i) {
559 $y[$i] = $class -> _add($class -> _copy($y[$i - 1]), $y[$i - 2]);
560 }
561
562 return @y;
563 }
564
565 # In scalar context use a fast algorithm that is much faster than the
566 # recursive algorith used in list context.
567
568 my $cache = {};
569 my $two = $class -> _two();
570 my $fib;
571
572 $fib = sub {
573 my $n = shift;
574 return $class -> _zero() if $n <= 0;
575 return $class -> _one() if $n <= 2;
576 return $cache -> {$n} if exists $cache -> {$n};
577
578 my $k = int($n / 2);
579 my $a = $fib -> ($k + 1);
580 my $b = $fib -> ($k);
581 my $y;
582
583 if ($n % 2 == 1) {
584 # a*a + b*b
585 $y = $class -> _add($class -> _mul($class -> _copy($a), $a),
586 $class -> _mul($class -> _copy($b), $b));
587 } else {
588 # (2*a - b)*b
589 $y = $class -> _mul($class -> _sub($class -> _mul(
590 $class -> _copy($two), $a), $b), $b);
591 }
592
593 $cache -> {$n} = $y;
594 return $y;
595 };
596
597 return $fib -> ($n);
598 }
599
600 ### same as _sand() in Math::BigInt::Lib
601 sub _sand {
602 my ($class, $x, $sx, $y, $sy) = @_;
603
604 return ($class -> _zero(), '+')
605 if $class -> _is_zero($x) || $class -> _is_zero($y);
606
607 my $sign = $sx eq '-' && $sy eq '-' ? '-' : '+';
608
609 my ($bx, $by);
610
611 if ($sx eq '-') { # if x is negative
612 # two's complement: inc (dec unsigned value) and flip all "bits" in $bx
613 $bx = $class -> _copy($x);
614 $bx = $class -> _dec($bx);
615 $bx = $class -> _as_hex($bx);
616 $bx =~ s/^-?0x//;
617 $bx =~ tr<0123456789abcdef>
618 <\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00>;
619 } else { # if x is positive
620 $bx = $class -> _as_hex($x); # get binary representation
621 $bx =~ s/^-?0x//;
622 $bx =~ tr<fedcba9876543210>
623 <\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00>;
624 }
625
626 if ($sy eq '-') { # if y is negative
627 # two's complement: inc (dec unsigned value) and flip all "bits" in $by
628 $by = $class -> _copy($y);
629 $by = $class -> _dec($by);
630 $by = $class -> _as_hex($by);
631 $by =~ s/^-?0x//;
632 $by =~ tr<0123456789abcdef>
633 <\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00>;
634 } else {
635 $by = $class -> _as_hex($y); # get binary representation
636 $by =~ s/^-?0x//;
637 $by =~ tr<fedcba9876543210>
638 <\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00>;
639 }
640
641 # now we have bit-strings from X and Y, reverse them for padding
642 $bx = reverse $bx;
643 $by = reverse $by;
644
645 # padd the shorter string
646 my $xx = "\x00"; $xx = "\x0f" if $sx eq '-';
647 my $yy = "\x00"; $yy = "\x0f" if $sy eq '-';
648 my $diff = CORE::length($bx) - CORE::length($by);
649 if ($diff > 0) {
650 # if $yy eq "\x00", we can cut $bx, otherwise we need to padd $by
651 $by .= $yy x $diff;
652 } elsif ($diff < 0) {
653 # if $xx eq "\x00", we can cut $by, otherwise we need to padd $bx
654 $bx .= $xx x abs($diff);
655 }
656
657 # and the strings together
658 my $r = $bx & $by;
659
660 # and reverse the result again
661 $bx = reverse $r;
662
663 # One of $bx or $by was negative, so need to flip bits in the result. In both
664 # cases (one or two of them negative, or both positive) we need to get the
665 # characters back.
666 if ($sign eq '-') {
667 $bx =~ tr<\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00>
668 <0123456789abcdef>;
669 } else {
670 $bx =~ tr<\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00>
671 <fedcba9876543210>;
672 }
673
674 # leading zeros will be stripped by _from_hex()
675 $bx = '0x' . $bx;
676 $bx = $class -> _from_hex($bx);
677
678 $bx = $class -> _inc($bx) if $sign eq '-';
679
680 # avoid negative zero
681 $sign = '+' if $class -> _is_zero($bx);
682
683 return $bx, $sign;
684 }
685
686 ### same as _sxor() in Math::BigInt::Lib
687 sub _sxor {
688 my ($class, $x, $sx, $y, $sy) = @_;
689
690 return ($class -> _zero(), '+')
691 if $class -> _is_zero($x) && $class -> _is_zero($y);
692
693 my $sign = $sx ne $sy ? '-' : '+';
694
695 my ($bx, $by);
696
697 if ($sx eq '-') { # if x is negative
698 # two's complement: inc (dec unsigned value) and flip all "bits" in $bx
699 $bx = $class -> _copy($x);
700 $bx = $class -> _dec($bx);
701 $bx = $class -> _as_hex($bx);
702 $bx =~ s/^-?0x//;
703 $bx =~ tr<0123456789abcdef>
704 <\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00>;
705 } else { # if x is positive
706 $bx = $class -> _as_hex($x); # get binary representation
707 $bx =~ s/^-?0x//;
708 $bx =~ tr<fedcba9876543210>
709 <\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00>;
710 }
711
712 if ($sy eq '-') { # if y is negative
713 # two's complement: inc (dec unsigned value) and flip all "bits" in $by
714 $by = $class -> _copy($y);
715 $by = $class -> _dec($by);
716 $by = $class -> _as_hex($by);
717 $by =~ s/^-?0x//;
718 $by =~ tr<0123456789abcdef>
719 <\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00>;
720 } else {
721 $by = $class -> _as_hex($y); # get binary representation
722 $by =~ s/^-?0x//;
723 $by =~ tr<fedcba9876543210>
724 <\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00>;
725 }
726
727 # now we have bit-strings from X and Y, reverse them for padding
728 $bx = reverse $bx;
729 $by = reverse $by;
730
731 # padd the shorter string
732 my $xx = "\x00"; $xx = "\x0f" if $sx eq '-';
733 my $yy = "\x00"; $yy = "\x0f" if $sy eq '-';
734 my $diff = CORE::length($bx) - CORE::length($by);
735 if ($diff > 0) {
736 # if $yy eq "\x00", we can cut $bx, otherwise we need to padd $by
737 $by .= $yy x $diff;
738 } elsif ($diff < 0) {
739 # if $xx eq "\x00", we can cut $by, otherwise we need to padd $bx
740 $bx .= $xx x abs($diff);
741 }
742
743 # xor the strings together
744 my $r = $bx ^ $by;
745
746 # and reverse the result again
747 $bx = reverse $r;
748
749 # One of $bx or $by was negative, so need to flip bits in the result. In both
750 # cases (one or two of them negative, or both positive) we need to get the
751 # characters back.
752 if ($sign eq '-') {
753 $bx =~ tr<\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00>
754 <0123456789abcdef>;
755 } else {
756 $bx =~ tr<\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00>
757 <fedcba9876543210>;
758 }
759
760 # leading zeros will be stripped by _from_hex()
761 $bx = '0x' . $bx;
762 $bx = $class -> _from_hex($bx);
763
764 $bx = $class -> _inc($bx) if $sign eq '-';
765
766 # avoid negative zero
767 $sign = '+' if $class -> _is_zero($bx);
768
769 return $bx, $sign;
770 }
771
772 ### same as _sor() in Math::BigInt::Lib
773 sub _sor {
774 my ($class, $x, $sx, $y, $sy) = @_;
775
776 return ($class -> _zero(), '+')
777 if $class -> _is_zero($x) && $class -> _is_zero($y);
778
779 my $sign = $sx eq '-' || $sy eq '-' ? '-' : '+';
780
781 my ($bx, $by);
782
783 if ($sx eq '-') { # if x is negative
784 # two's complement: inc (dec unsigned value) and flip all "bits" in $bx
785 $bx = $class -> _copy($x);
786 $bx = $class -> _dec($bx);
787 $bx = $class -> _as_hex($bx);
788 $bx =~ s/^-?0x//;
789 $bx =~ tr<0123456789abcdef>
790 <\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00>;
791 } else { # if x is positive
792 $bx = $class -> _as_hex($x); # get binary representation
793 $bx =~ s/^-?0x//;
794 $bx =~ tr<fedcba9876543210>
795 <\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00>;
796 }
797
798 if ($sy eq '-') { # if y is negative
799 # two's complement: inc (dec unsigned value) and flip all "bits" in $by
800 $by = $class -> _copy($y);
801 $by = $class -> _dec($by);
802 $by = $class -> _as_hex($by);
803 $by =~ s/^-?0x//;
804 $by =~ tr<0123456789abcdef>
805 <\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00>;
806 } else {
807 $by = $class -> _as_hex($y); # get binary representation
808 $by =~ s/^-?0x//;
809 $by =~ tr<fedcba9876543210>
810 <\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00>;
811 }
812
813 # now we have bit-strings from X and Y, reverse them for padding
814 $bx = reverse $bx;
815 $by = reverse $by;
816
817 # padd the shorter string
818 my $xx = "\x00"; $xx = "\x0f" if $sx eq '-';
819 my $yy = "\x00"; $yy = "\x0f" if $sy eq '-';
820 my $diff = CORE::length($bx) - CORE::length($by);
821 if ($diff > 0) {
822 # if $yy eq "\x00", we can cut $bx, otherwise we need to padd $by
823 $by .= $yy x $diff;
824 } elsif ($diff < 0) {
825 # if $xx eq "\x00", we can cut $by, otherwise we need to padd $bx
826 $bx .= $xx x abs($diff);
827 }
828
829 # or the strings together
830 my $r = $bx | $by;
831
832 # and reverse the result again
833 $bx = reverse $r;
834
835 # One of $bx or $by was negative, so need to flip bits in the result. In both
836 # cases (one or two of them negative, or both positive) we need to get the
837 # characters back.
838 if ($sign eq '-') {
839 $bx =~ tr<\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00>
840 <0123456789abcdef>;
841 } else {
842 $bx =~ tr<\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00>
843 <fedcba9876543210>;
844 }
845
846 # leading zeros will be stripped by _from_hex()
847 $bx = '0x' . $bx;
848 $bx = $class -> _from_hex($bx);
849
850 $bx = $class -> _inc($bx) if $sign eq '-';
851
852 # avoid negative zero
853 $sign = '+' if $class -> _is_zero($bx);
854
855 return $bx, $sign;
856 }
857
858 ### same as _as_bin() in Math::BigInt::Lib
859 sub _as_bin {
860 # convert the number to a string of binary digits with prefix
861 my ($class, $x) = @_;
862 return '0b' . $class -> _to_bin($x);
863 }
864
865 ### same as _as_oct() in Math::BigInt::Lib
866 sub _as_oct {
867 # convert the number to a string of octal digits with prefix
868 my ($class, $x) = @_;
869 return '0' . $class -> _to_oct($x); # yes, 0 becomes "00"
870 }
871
872 ### same as _as_hex() in Math::BigInt::Lib
873 sub _as_hex {
874 # convert the number to a string of hexadecimal digits with prefix
875 my ($class, $x) = @_;
876 return '0x' . $class -> _to_hex($x);
434877 }
435878
436879 1;