File Coverage

blib/lib/X11/Protocol/Ext/MIT_SHM.pm

Criterion	Covered	Total	%
statement	13	36	36.1
branch	0	4	0.0
condition	0	3	0.0
subroutine	5	10	50.0
pod	0	1	0.0
total	18	54	33.3

# Copyright 2011, 2012, 2013, 2014 Kevin Ryde

# This file is part of X11-Protocol-Other.
#
# X11-Protocol-Other is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as published
# by the Free Software Foundation; either version 3, or (at your option) any
# later version.
#
# X11-Protocol-Other is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General
# Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with X11-Protocol-Other.  If not, see .

BEGIN { require 5 }
package X11::Protocol::Ext::MIT_SHM;
use strict;
use Carp;
use X11::Protocol;

use vars '$VERSION', '@CARP_NOT';
$VERSION = 30;
@CARP_NOT = ('X11::Protocol');

# uncomment this to run the ### lines
#use Smart::Comments;

# /usr/share/doc/x11proto-xext-dev/shm.txt.gz
# /usr/share/doc/x11proto-core-dev/x11protocol.txt.gz
#
# /usr/include/X11/extensions/shm.h
# /usr/include/X11/extensions/shmproto.h
# /usr/include/X11/extensions/shmstr.h
#
# /usr/share/doc/libxext-dev/
# /usr/include/X11/extensions/Xshm.h
#     Xlib
#

### MIT_SHM.pm loads

#------------------------------------------------------------------------------
# events

# "major_opcode", "minor_opcode" names as per GraphicsExposure and NoExpose
my $MitShmCompletion_event = [ 'xxxxLSCxLLx12',
                               'drawable',
                               'minor_opcode',
                               'major_opcode',
                               'shmseg',
                               'offset',
                             ];

#------------------------------------------------------------------------------

my $reqs =
  [
   [ 'MitShmQueryVersion',  # 0
     \&_request_empty,
     sub {
       my ($X, $data) = @_;
       my ($shared_pixmaps, $major, $minor, $uid, $gid, $pixmap_format)
         = unpack 'xCx6SSSSC', $data;
       return ($major, $minor, $uid, $gid,
               $shared_pixmaps,
               $X->interp('ImageFormat', $pixmap_format));
     }],

   [ 'MitShmAttach',  # 1
     sub {
       my ($X, $shmseg, $shmid, $readonly) = @_;
       return pack 'LLCxxx', $shmseg, $shmid, $readonly;
     } ],

   [ 'MitShmDetach',  # 2
     \&_request_card32s ],  # ($X, $shmseg)

   [ 'MitShmPutImage',  # 3
     sub {
       my $self = shift;
       my ($drawable, $gc, $depth,
           $total_width, $total_height,
           $src_x, $src_y,
           $src_width, $src_height,
           $dst_x, $dst_y,
           $format,
           $send_event,
           $shmseg, $offset) = @_;
       return pack("LLSSssSSssCCCxLL",
                   $drawable, $gc,
                   $total_width, $total_height,
                   $src_x, $src_y,
                   $src_width, $src_height,
                   $dst_x, $dst_y,
                   $depth,
                   $self->num('ImageFormat',$format),
                   $send_event,
                   $shmseg, $offset);
     }],

   [ 'MitShmGetImage',     # 4
     sub {
       my $self = shift;
       my ($drawable, $x, $y, $width, $height,
           $planemask, $format,
           $shmseg, $offset) = @_;
       $format = $self->num('ImageFormat', $format);
       return pack ('LssSSLCxxxLL',
                    $drawable, $x, $y, $width, $height,
                    $planemask, $format,
                    $shmseg, $offset);
     }, sub {
       my ($X, $data) = @_;
       ### $data
       my ($depth, $visual, $size) = unpack 'xCx6LL', $data;
       return ($depth, _interp_none($X,$visual), $size);
     } ],

   [ 'MitShmCreatePixmap',       # 5
     sub {
       my ($X, $pixmap, $drawable, $depth, $width, $height, $shmseg, $offset)
         = @_;
       return pack ('LLSSCxxxLL',
                    $pixmap, $drawable,
                    $width, $height, $depth,
                    $shmseg, $offset);
     } ],

  ];

sub new {
  my ($class, $X, $request_num, $event_num, $error_num) = @_;
  ### MIT_SHM new() ...

  # Errors
  $X->{'ext_const'}->{'Error'}->[$error_num] = 'ShmSeg';
  $X->{'ext_const_num'}->{'Error'}->{'ShmSeg'} = $error_num;
  $X->{'ext_error_type'}->[$error_num] = 1; # bad resource

  # Requests
  _ext_requests_install ($X, $request_num, $reqs);

  # Events
  $X->{'ext_const'}{'Events'}[$event_num] = 'MitShmCompletion';
  $X->{'ext_events'}[$event_num] = $MitShmCompletion_event;

  return bless { }, $class;
}

sub _ext_requests_install {
  my ($X, $request_num, $reqs) = @_;

  $X->{'ext_request'}->{$request_num} = $reqs;
  my $href = $X->{'ext_request_num'};
  my $i;
  foreach $i (0 .. $#$reqs) {
    $href->{$reqs->[$i]->[0]} = [$request_num, $i];
  }
}

sub _request_empty {
  # ($X)
  if (@_ > 1) {
    croak "No parameters in this request";
  }
  return '';
}

sub _request_card32s {
  shift;  # ($X, $card32...)
  ### _request_card32s(): @_
  return pack 'L*', @_;
}

sub _interp_none {
  my ($X, $id) = @_;
  if ($X->{'do_interp'} && $id == 0) {
    return 'None';
  } else {
    return $id;
  }
}

1;
__END__