For starters,

use strict;
use warnings;

sub _unsigned_to_signed {
   return unpack('i', pack('I', $_[0]));
}

sub binsearch(&$\@) {
   my ($compare, $value, $array) = @_;

   #
   # If the $value is not found in @array,
   # the 1s complement of where the $value
   # should be inserted is returned. So,
   # $value is found if the return value >= 0.
   #
   # When compare is called, $a is an alias for $value,
   # and $b is an alias for the element of the array
   # against which $a which be compared.
   #
   # Example:
   #    # Add $value to sorted @array, if it's not already there.
   #    $idx = binsearch { $a <=> $b } $value, @array;
   #    splice(@array, ~$idx, 0, $value) if $idx < 0;
   #

   my $i = 0;
   my $j = $#$array;

   return $j if $j == -1;

   my $ap = do { no strict 'refs'; \*{caller().'::a'} };
   my $bp = do { no strict 'refs'; \*{caller().'::b'} };
   my $kp = do { no strict 'refs'; \*{caller().'::k'} };

   local *$ap;
   local *$bp;
   local *$kp;

   *$ap = \$value;

   for (;;) {
      my $k = int(($j-$i)/2) + $i;
      *$kp = \$k;
      *$bp = \($array->[$k]);

      my $cmp = &$compare();
      return $k if $cmp == 0;

      if ($cmp < 0) {
         $j = $k-1;
         return _unsigned_to_signed(~$k) if $i > $j;
      } else {
         $i = $k+1;
         return _unsigned_to_signed(~$i) if $i > $j;
      }
   }
}

our $k;

for (
   #      0 1 2 3 4 5 6 7 8
   [ [qw( a b c p q r x w z )], 'p', 'r',  3,  5,  3 ],
   [ [qw( a b c p q r x w z )], 'd', 'w',  3,  5,  3 ],
   [ [qw( q q q q q q q q q )], 'p', 'z',  0,  8,  9 ],
   [ [qw( q q q q q q q q q )], 'q', 'z',  0,  8,  9 ],
   [ [qw( q q q q q q q q q )], 'r', 'z',  9,  8,  0 ],
   [ [qw( q q q q q q q q q )], 'a', 'p',  0, -1,  0 ],
   [ [qw( q q q q q q q q q )], 'a', 'q',  0,  8,  9 ],
   [ [qw( q q q q q q q q q )], 'a', 'r',  0,  8,  9 ],
) {
   my ( $array, $beg, $end,
      $expect_beg_idx, $expect_end_idx, $expect_count ) = @$_;

   my $beg_idx = binsearch {
      $a cmp $b || ( $k > 0 && $a eq $array->[$k-1] ? -1 : 0 )
   } $beg, @$array;

   $beg_idx = ~$beg_idx if $beg_idx < 0;

   my $end_idx = binsearch {
      $a cmp $b || ( $k < $#$array && $a eq $array->[$k+1] ? +1 : 0 )
   } $end, @$array;

   $end_idx = ~$end_idx - 1 if $end_idx < 0;

   my $count = $end_idx - $beg_idx + 1;

   printf("%2d %-5s  %2d %-5s  %2d %-5s\n",
      $beg_idx,
      $beg_idx == $expect_beg_idx ? "(ok)" : "(bad)",
      $end_idx,
      $end_idx == $expect_end_idx ? "(ok)" : "(bad)",
      $count,
      $count == $expect_count ? "(ok)" : "(bad)",
   );
}
[download]

 3 (ok)    5 (ok)    3 (ok)
 3 (ok)    5 (ok)    3 (ok)
 0 (ok)    8 (ok)    9 (ok)
 0 (ok)    8 (ok)    9 (ok)
 9 (ok)    8 (ok)    0 (ok)
 0 (ok)   -1 (ok)    0 (ok)
 0 (ok)    8 (ok)    9 (ok)
 0 (ok)    8 (ok)    9 (ok)
[download]

It can be optimised, of course. In particular, the negating can be removed, the callback can be inlined, and the initial cuts can be used for both searches.

---

---

Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!

Titles consisting of a single word are discouraged, and in most cases are disallowed outright.

Read Where should I post X? if you're not absolutely sure you're posting in the right place.

Please read these before you post! —

• How do I compose an effective node title?
• How do I post a question effectively?
• Markup in the Monastery

Posts may use any of the Perl Monks Approved HTML tags:

a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr

You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)

	For:		Use:
	&		&
	<		&lt;
	>		&gt;
	[		&#91;
	]		&#93;

Link using PerlMonks shortcuts! What shortcuts can I use for linking?

See Writeup Formatting Tips and other pages linked from there for more info.