process.pm

source of perl for linux application,

package OS2::localMorphPM;
# use strict;

sub new {
  my ($c,$f) = @_;
  OS2::MorphPM($f);
  # print STDERR ">>>>>\n";
  bless [$f], $c
}
sub DESTROY {
  # print STDERR "<<<<<\n";
  OS2::UnMorphPM(shift->[0])
}

package OS2::Process;

BEGIN {
  require Exporter;
  require XSLoader;
  #require AutoLoader;

  our @ISA = qw(Exporter);
  our $VERSION = "1.02";
  XSLoader::load('OS2::Process', $VERSION);
}

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
our @EXPORT = qw(
	P_BACKGROUND
	P_DEBUG
	P_DEFAULT
	P_DETACH
	P_FOREGROUND
	P_FULLSCREEN
	P_MAXIMIZE
	P_MINIMIZE
	P_NOCLOSE
	P_NOSESSION
	P_NOWAIT
	P_OVERLAY
	P_PM
	P_QUOTE
	P_SESSION
	P_TILDE
	P_UNRELATED
	P_WAIT
	P_WINDOWED
	my_type
	file_type
	T_NOTSPEC
	T_NOTWINDOWCOMPAT
	T_WINDOWCOMPAT
	T_WINDOWAPI
	T_BOUND
	T_DLL
	T_DOS
	T_PHYSDRV
	T_VIRTDRV
	T_PROTDLL
	T_32BIT

	os2constant

	ppid
	ppidOf
	sidOf
	scrsize
	scrsize_set
	kbdChar
	kbdhChar
	kbdStatus
	_kbdStatus_set
	kbdhStatus
	kbdhStatus_set
	vioConfig
	viohConfig
	vioMode
	viohMode
	viohMode_set
	_vioMode_set
	_vioState
	_vioState_set
	vioFont
	vioFont_set
	process_entry
	process_entries
	process_hentry
	process_hentries
	change_entry
	change_entryh
	process_hwnd
	Title_set
	Title
	winTitle_set
	winTitle
	swTitle_set
	bothTitle_set
	WindowText
	WindowText_set
	WindowPos
	WindowPos_set
	hWindowPos
	hWindowPos_set
	WindowProcess
	SwitchToProgram
	DesktopWindow
	ActiveWindow
	ActiveWindow_set
	ClassName
	FocusWindow
	FocusWindow_set
	ShowWindow
	PostMsg
	BeginEnumWindows
	EndEnumWindows
	GetNextWindow
	IsWindow
	ChildWindows
	out_codepage
	out_codepage_set
	process_codepage_set
	in_codepage
	in_codepage_set
	cursor
	cursor_set
	screen
	screen_set
	process_codepages
	QueryWindow
	WindowFromId
	WindowFromPoint
	EnumDlgItem
        EnableWindow
        EnableWindowUpdate
        IsWindowEnabled
        IsWindowVisible
        IsWindowShowing
        WindowPtr
        WindowULong
        WindowUShort
	WindowStyle
        SetWindowBits
        SetWindowPtr
        SetWindowULong
        SetWindowUShort
        WindowBits_set
        WindowPtr_set
        WindowULong_set
        WindowUShort_set
	TopLevel
	FocusWindow_set_keep_Zorder

	ActiveDesktopPathname
	InvalidateRect
	CreateFrameControls

	ClipbrdFmtInfo
	ClipbrdOwner
	ClipbrdViewer
	ClipbrdData
	OpenClipbrd
	CloseClipbrd
	ClipbrdData_set
	ClipbrdOwner_set
	ClipbrdViewer_set
	EnumClipbrdFmts
	EmptyClipbrd
	ClipbrdFmtNames
	ClipbrdFmtAtoms
	AddAtom
	FindAtom
	DeleteAtom
	AtomUsage
	AtomName
	AtomLength
	SystemAtomTable
	CreateAtomTable
	DestroyAtomTable

	_ClipbrdData_set
	ClipbrdText
	ClipbrdText_set
	ClipbrdText_2byte
	ClipbrdTextUCS2le
	MemoryRegionSize

	_MessageBox
	MessageBox
	_MessageBox2
	MessageBox2
	get_pointer
	LoadPointer
	SysPointer
	Alarm
	FlashWindow

	get_title
	set_title
	io_term
);
our @EXPORT_OK = qw(
	ResetWinError
        MPFROMSHORT
        MPVOID
        MPFROMCHAR
        MPFROM2SHORT
        MPFROMSH2CH
        MPFROMLONG
);

our $AUTOLOAD;

sub AUTOLOAD {
    # This AUTOLOAD is used to 'autoload' constants from the constant()
    # XS function.  If a constant is not found then control is passed
    # to the AUTOLOAD in AutoLoader.

    (my $constname = $AUTOLOAD) =~ s/.*:://;
    my $val = constant($constname, @_ ? $_[0] : 0);
    if ($! != 0) {
	if ($! =~ /Invalid/ || $!{EINVAL}) {
	    die "Unsupported function $AUTOLOAD"
	} else {
	    my ($pack,$file,$line) = caller;
	    die "Your vendor has not defined OS2::Process macro $constname, used at $file line $line.
";
	}
    }
    eval "sub $AUTOLOAD { $val }";
    goto &$AUTOLOAD;
}

sub os2constant {
  require OS2::Process::Const;
  my $sym = shift;
  my ($err, $val) = OS2::Process::Const::constant($sym);
  die $err if $err;
  $val;
}

sub const_import {
  require OS2::Process::Const;
  my $sym = shift;
  my $val = os2constant($sym);
  my $p = caller(1);

  # no strict;

  *{"$p\::$sym"} = sub () { $val };
  ();			# needed by import()
}

sub import {
  my $class = shift;
  my $ini = @_;
  @_ = ($class,
	map {
	  /^(HWND|WM|SC|SWP|WC|PROG|QW|EDI|WS|QWS|QWP|QWL|FF|FI|LS|FS|FCF|BS|MS|TBM|CF|CFI|FID|MB|MBID|CF|CFI|SPTR)_/ ? const_import($_) : $_
	} @_);
  goto &Exporter::import if @_ > 1 or $ini == 0;
}

# Preloaded methods go here.

sub Title () { (process_entry())[0] }

# *Title_set = \&sesmgr_title_set;

sub swTitle_set_sw {
  my ($title, @sw) = @_;
  $sw[0] = $title;
  change_entry(@sw);
}

sub swTitle_set ($) {
  my (@sw) = process_entry();
  swTitle_set_sw(shift, @sw);
}

sub winTitle_set_sw {
  my ($title, @sw) = @_;
  my $h = OS2::localMorphPM->new(0);
  WindowText_set $sw[1], $title;
}

sub winTitle_set ($) {
  my (@sw) = process_entry();
  winTitle_set_sw(shift, @sw);
}

sub winTitle () {
  my (@sw) = process_entry();
  my $h = OS2::localMorphPM->new(0);
  WindowText $sw[1];
}

sub bothTitle_set ($) {
  my (@sw) = process_entry();
  my $t = shift;
  winTitle_set_sw($t, @sw);
  swTitle_set_sw($t, @sw);
}

sub Title_set ($) {
  my $t = shift;
  return 1 if sesmgr_title_set($t);
  return 0 unless $^E == 372;
  my (@sw) = process_entry();
  winTitle_set_sw($t, @sw);
  swTitle_set_sw($t, @sw);
}

sub process_entry { swentry_expand(process_swentry(@_)) }

our @hentry_fields = qw( title owner_hwnd icon_hwnd 
			 owner_phandle owner_pid owner_sid
			 visible nonswitchable jumpable ptype sw_entry );

sub swentry_hexpand ($) {
  my %h;
  @h{@hentry_fields} = swentry_expand(shift);
  \%h;
}

sub process_hentry { swentry_hexpand(process_swentry(@_)) }
sub process_hwnd { process_hentry()->{owner_hwnd} }

my $swentry_size = swentry_size();

sub sw_entries () {
  my $s = swentries_list();
  my ($c, $s1) = unpack 'La*', $s;
  die "Unconsistent size in swentries_list()" unless 4+$c*$swentry_size == length $s;
  my (@l, $e);
  push @l, $e while $e = substr $s1, 0, $swentry_size, '';
  @l;
}

sub process_entries () {
  map [swentry_expand($_)], sw_entries;
}

sub process_hentries () {
  map swentry_hexpand($_), sw_entries;
}

sub change_entry {
  change_swentry(create_swentry(@_));
}

sub create_swentryh ($) {
  my $h = shift;
  create_swentry(@$h{@hentry_fields});
}

sub change_entryh ($) {
  change_swentry(create_swentryh(shift));
}

# Massage entries into the same order as WindowPos_set:
sub WindowPos ($) {
  my ($fl, $h, $w, $y, $x, $behind, $hwnd, @rest)
	= unpack 'L l4 L4', WindowSWP(shift);
  ($x, $y, $fl, $w, $h, $behind, @rest);
}

# Put them into a hash
sub hWindowPos ($) {
  my %h;
  @h{ qw(flags height width y x behind hwnd reserved1 reserved2) }
	= unpack 'L l4 L4', WindowSWP(shift);
  \%h;
}

my @SWP_keys = ( [qw(width height)],	# SWP_SIZE=1
		 [qw(x y)],		# SWP_MOVE=2
		 [qw(behind)] );	# SWP_ZORDER=3
my %SWP_def;
@SWP_def{ map @$_, @SWP_keys }  = (0) x 20;

# Get them from a hash
sub hWindowPos_set ($$) {
  my $hash = shift;
  my $hwnd = (@_ ? shift : $hash->{hwnd} );
  my $flags;
  if (exists $hash->{flags}) {
    $flags = $hash->{flags};
  } else {			# Set flags according to existing keys in $hash
    $flags = 0;
    for my $bit (0..2) {
      exists $hash->{$_} and $flags |= (1<<$bit) for @{$SWP_keys[$bit]};
    }
  }
  for my $bit (0..2) {		# Check for required keys
    next unless $flags & (1<<$bit);
    exists $hash->{$_}
      or die sprintf "key $_ required for flags=%#x", $flags
	for @{$SWP_keys[$bit]};
  }
  my %h = (%SWP_def, flags => $flags, %$hash);		# Avoid warnings
  my ($x, $y, $fl, $w, $h, $behind) = @h{ qw(x y flags width height behind) };
  WindowPos_set($hwnd, $x, $y, $fl, $w, $h, $behind);
}

sub ChildWindows (;$) {
  my $hm = OS2::localMorphPM->new(0);
  my @kids;
  my $h = BeginEnumWindows(@_ ? shift : 1);	# HWND_DESKTOP
  my $w;
  push @kids, $w while $w = GetNextWindow $h;
  EndEnumWindows $h;
  @kids;
}

sub TopLevel ($) {
  my $d = DesktopWindow;
  my $w = shift;
  while (1) {
    my $p = QueryWindow $w, 5;	# QW_PARENT;
    return $w if not $p or $p == $d;
    $w = $p;
  }
}

sub FocusWindow_set_keep_Zorder ($) {
  my $w = shift;
  my $t = TopLevel $w;
  my $b = hWindowPos($t)->{behind}; # we are behind this
  EnableWindowUpdate($t, 0);
  FocusWindow_set($w);
# sleep 1;    # Make flicker stronger when present
  hWindowPos_set {behind => $b}, $t;
  EnableWindowUpdate($t, 1);
}

sub WindowStyle ($) {
  WindowULong(shift,-2);	# QWL_STYLE