view release on metacpan or  search on metacpan

lib/Image/Base/X11/Protocol/Drawable.pm  view on Meta::CPAN

    ### reply: $X->unpack_reply($elem->{'request_type'}, $elem->{'reply'})

    my ($pixel) = $X->unpack_reply ($elem->{'request_type'}, $elem->{'reply'});
    $colour_to_pixel->{$colour} = $pixel;
    if ($pixel_to_colour) {
      $pixel_to_colour->{$pixel} = $colour;
    }
  };

  while (@_) {
    my $colour = shift;
    next if defined $colour_to_pixel->{$colour};  # already known
    delete $self->{'-pixel_to_colour'};

    # black_pixel or white_pixel of a default colormap
    if (my $field = $colour_to_screen_field{$colour}) { # "black" or "white"
      if (my $screen_info = X11::Protocol::Other::default_colormap_to_screen_info($X,$colormap)) {
        my $pixel = $colour_to_pixel->{$colour} = $screen_info->{$field};
        if ($pixel_to_colour) {
          $pixel_to_colour->{$pixel} = $colour;
        }
        next;
      }
    }

    my $elem = { colour => $colour };
    my @req;
    # Crib: [:xdigit:] new in 5.6, so only 0-9A-F, and in any case as of
    # perl 5.12.4 [:xdigit:] matches some wide chars but hex() doesn't
    # accept them
    if (my @rgb = X11::Protocol::Other::hexstr_to_rgb($colour)) {
      @req = ('AllocColor', $colormap, map {hex} @rgb);
    } else {
      @req = ('AllocNamedColor', $colormap, $colour);
    }
    $elem->{'request_type'} = $req[0];
    my $seq = $elem->{'seq'} = $X->send(@req);
    $X->add_reply ($seq, \$elem->{'reply'});

    ### $elem
    push @queued, $elem;
    if (@queued > 256) {
      &$wait_queue();
    }
  }
  while (@queued) {
    &$wait_queue();
  }

  if (@failed_colours) {
    die "Unknown colour(s): ",join(', ', @failed_colours);
  }
}

#------------------------------------------------------------------------------
# clipping to signed 16-bit parameters

use constant _LO => -0x8000;  # -32768
use constant _HI =>  0x7FFF;  # +32767

# $x1,$y1, $x2,$y2 are the endpoints of a line.
# Return new endpoints which are clipped to within -0x8000 to +0x7FFF which is
# signed 16-bits for X protocol.
# If given line is entirely outside the signed 16-bit rectangle then return
# an empty list.
#
sub _line_clip {
  my ($x1,$y1, $x2,$y2) = @_;
  ### _line_clip_16bit(): "$x1,$y1, $x2,$y2"

  unless (_line_any_positive($x1,$y1, $x2,$y2)) {
    ### nothing positive ...
    return;
  }

  my ($x1new,$y1new) = _line_end_clip($x1,$y1, $x2,$y2)
    or do {
      ### x1,y1 end nothing in range ...
      return;
    };
  ($x2,$y2) = _line_end_clip($x2,$y2, $x1,$y1)
    or return;
  return ($x1new,$y1new, $x2,$y2);
}

# $x1,$y1, $x2,$y2 are the endpoints of a line.
# Return new values for the $x2,$y2 end which clips it to within
#     LO <= x2 <= HI
#     LO <= y2 <= HI
#
# If the line is entirely outside LO to HI then return an empty list.
# If x2,y2 is already within LO to HI then return them unchanged.
#
#                     x1,y1
#                    /
#                +--------       if x2 outside
#                | /             then
#                |/              move it to x2new=LO
#    x2new,y2new *               and y2new=corresponding pos on line
#               /|
#              / |
#        x2,y2   +--------
#               LO
#
#                +---------
#                |               if y2 outside,
#                |    x1,y1      including moved y2new outside
#                |   /           then
#                +--*-----       move it to y2new=LO
#                  /x2new,       and x2new=corresponding pos on line
#                 / y2new       
#    first y2new *
#               / 
#              /  
#        x2,y2              
#
sub _line_end_clip {
  my ($x1,$y1, $x2,$y2) = @_;
  ### _line_end_clip(): "$x1,$y1, $x2,$y2"

  my ($x2new, $y2new);
  if ($x2 < _LO || $x2 > _HI) {
    # x2 is outside LO to HI, clip to x2=LOorHI and y2 set to corresponding
    my $xlen = $x2 - $x1
      or return;   # xlen==0 means x1==x2 so entirely outside LO to HI
    $x2new = ($x2 < _LO ? _LO : _HI);
    $y2new = floor(($y2*($x2new-$x1) + $y1*($x2-$x2new)) / $xlen + 0.5);

    ### x clip: "to $x2new,$y2new   frac ".($y2*($x2new-$x1) + $y1*($x2-$x2new))." / $xlen"
  } else {
    $x2new = $x2;
    $y2new = $y2;
  }

  if ($y2new < _LO || $y2new > _HI) {
    my $ylen = $y2 - $y1
      or return;   # ylen==0 means y1==y2 so entirely outside LO to HI
    $y2new = ($y2 < _LO ? _LO : _HI);
    $x2new = floor(($x2*($y2new-$y1) + $x1*($y2-$y2new)) / $ylen + 0.5);
    ### y clip: "to $x2new,$y2new   left ".($y2new-$y1)." right ".($y2-$y2new)
    if ($x2new < _LO || $x2new > _HI) {
      ### x2new outside ...
      return;
    }
  }