process.pm

source of perl for linux application,

}

sub OS2::localClipbrd::new {
  my ($c) = shift;
  my $morph = [];
  push @$morph, OS2::localMorphPM->new(0) unless shift;
  &OpenClipbrd;
  # print STDERR ">>>>>\n";
  bless $morph, $c
}
sub OS2::localClipbrd::DESTROY {
  # print STDERR "<<<<<\n";
  CloseClipbrd();
}

sub OS2::localFlashWindow::new ($$) {
  my ($c, $w) = (shift, shift);
  my $morph = OS2::localMorphPM->new(0);
  FlashWindow($w, 1);
  # print STDERR ">>>>>\n";
  bless [$w, $morph], $c
}
sub OS2::localFlashWindow::DESTROY {
  # print STDERR "<<<<<\n";
  FlashWindow(shift->[0], 0);
}

# Good for \0-terminated text (not "text/unicode" and other Firefox stuff)
sub ClipbrdText (@) {
  my $h = OS2::localClipbrd->new;
  my $data = ClipbrdData @_;
  return unless $data;
  my $lim = MemoryRegionSize($data);
  $lim = StrLen($data, $lim);			# Look for 1-byte 0
  return unpack "P$lim", pack 'L', $data;
}

sub ClipbrdText_2byte (@) {
  my $h = OS2::localClipbrd->new;
  my $data = ClipbrdData @_;
  return unless $data;
  my $lim = MemoryRegionSize($data);
  $lim = StrLen($data, $lim, 2);		# Look for 2-byte 0
  return unpack "P$lim", pack 'L', $data;
}

sub ClipbrdTextUCS2le (@) {
  my $txt = ClipbrdText_2byte @_;		# little-endian shorts
  #require Unicode::String;
  pack "U*", unpack "v*", $txt;
}

sub ClipbrdText_set ($;@) {
  my $h = OS2::localClipbrd->new;
  EmptyClipbrd();				# It may contain other types
  my ($txt, $no_convert_nl) = (shift, shift);
  ClipbrdData_set($txt, !$no_convert_nl, @_);
}

sub ClipbrdFmtAtoms {
  my $h = OS2::localClipbrd->new('nomorph');
  my $fmt = 0;
  my @formats;
  push @formats, $fmt while eval {$fmt = EnumClipbrdFmts $fmt};
  die $@ if $@ and $^E == 0x1001 and $fmt = 0;	# Croaks on empty list?
  @formats;
}

sub ClipbrdFmtNames {
  map AtomName($_), ClipbrdFmtAtoms(@_);
}

sub MessageBox ($;$$$$$) {
  my $morph = OS2::localMorphPM->new(0);
  die "MessageBox needs text" unless @_;
  push @_ , ($0 eq '-e' ? "Perl one-liner's message" : "$0 message") if @_ == 1;
  &_MessageBox;
}

my %pointers;

sub get_pointer ($;$$) {
  my $id = $_[0];
  return $pointers{$id} if exists $pointers{$id};
  $pointers{$id} = &SysPointer;
}

# $button needs to be of the form 'String', ['String'] or ['String', flag].
# If ['String'], it is assumed the default button; same for 'String' if $only
# is set.
sub process_MB2 ($$;$) {
  die "process_MB2() needs 2 arguments, got '@_'" unless @_ == 2 or @_ == 3;
  my ($button, $ret, $only) = @_;
  # default is BS_PUSHBUTTON, add BS_DEFAULT if $only is set
  $button = [$button, $only ? 0x400 : 0] unless ref $button eq 'ARRAY';
  push @$button, 0x400 if @$button == 1; # BS_PUSHBUTTON|BS_DEFAULT
  die "Button needs to be of the form 'String', ['String'] or ['String', flag]"
    unless @$button == 2;
  pack "Z71 x L l", $button->[0], $ret, $button->[1]; # name, retval, flag
}

# If one button, make it the default one even if it is of 'String' => val form.
# If icon is of the form 'SP#<number>', load this via SysPointer.
sub process_MB2_INFO ($;$$$) {
  my $l = 0;
  my $out;
  die "process_MB2_INFO() needs 1..4 arguments" unless @_ and @_ < 5;
  my $buttons = shift;
  die "Buttons array should consist of pairs" if @$buttons % 2;

  push @_, 0 unless @_;		# Icon id; non-0 ignored without MB_CUSTOMICON
  # Box flags (MB_MOVABLE and MB_INFORMATION or MB_CUSTOMICON)
  push @_, ($_[0] ? 0x4080 : 0x4030) unless @_ > 1;
  push @_, 0 unless @_ > 2;	# Notify window

  my ($icon, $style, $notify) = (shift, shift, shift);
  $icon = get_pointer $1 if $icon =~ /^SP#(\d+)\z/;
  $out = pack "L L L L",	# icon, #buttons, style, notify, buttons
      $icon, @$buttons/2, $style, $notify;
  $out .= join '',
    map process_MB2($buttons->[2*$_], $buttons->[2*$_+1], @$buttons == 2),
      0..@$buttons/2-1;
  pack('L', length(pack 'L', 0) + length $out) . $out;
}

# MessageBox2 'Try this', OS2::Process::process_MB2_INFO([['Dismiss', 0] => 0x1000], OS2::Process::get_pointer(22),0x4080,0), 'me', 1, 0, 0
# or the shortcut
# MessageBox2 'Try this', [[['Dismiss', 0] => 0x1000], 'SP#22'], 'me'
# 0x80 means MB_CUSTOMICON (does not focus?!).  This focuses:
# MessageBox2 'Try this', [[['Dismiss',0x400] => 0x1000], 0, 0x4030,0]
# 0x400 means BS_DEFAULT.  This is the same as the shortcut
# MessageBox2 'Try this', [[Dismiss => 0x1000]]
sub MessageBox2 ($;$$$$$) {
  my $morph = OS2::localMorphPM->new(0);
  die "MessageBox needs text" unless @_;
  push @_ , [[Dismiss => 0x1000], # Name, retval (style BS_PUSHBUTTON|BS_DEFAULT)
	     #0,		# e.g., get_pointer(11),# SPTR_ICONINFORMATION
	     #0x4030,		# = MB_MOVEABLE | MB_INFORMATION
	     #0,		# Notify window; was 1==HWND_DESKTOP
	    ] if @_ == 1;
  push @_ , ($0 eq '-e' ? "Perl one-liner" : $0). "'s message" if @_ == 2;
  $_[1] = &process_MB2_INFO(@{$_[1]}) if ref($_[1]) eq 'ARRAY';
  &_MessageBox2;
}

my %mbH_default = (
  text => 'Something happened',
  title => ($0 eq '-e' ? "Perl one-liner" : $0). "'s message",
  parent => 1,			# HWND_DESKTOP
  owner => 0,
  helpID => 0,
  buttons => ['Dismiss' => 0x1000],
  default_button => 1,
#  icon => 0x30,		# MB_INFORMATION
#  iconID => 0,			# XXX???
  flags => 0,			# XXX???
  notifyWindow => 0,		# XXX???
);

sub MessageBoxH {
  die "MessageBoxH: even number of arguments expected" if @_ % 2;
  my %a = (%mbH_default, @_);
  die "MessageBoxH: even number of elts of button array expected"
    if @{$a{buttons}} % 2;
  if (defined $a{iconID}) {
    $a{flags} |= 0x80;		# MB_CUSTOMICON
  } else {
    $a{icon} = 0x30 unless defined $a{icon};
    $a{iconID} = 0;
    $a{flags} |= $a{icon};
  }
  # Mark default_button as MessageBox2() expects it:
  $a{buttons}[2*$a{default_button}] = [$a{buttons}[2*$a{default_button}]];

  my $use_2 = 'ARRAY' eq ref $a{buttons};
  return
    MessageBox2 $a{text}, [@a{qw(buttons iconID flags notifyWindow)}],
      $a{parent}, $a{owner}, $a{helpID}
	if $use_2;
  die "MessageBoxH: unexpected format of argument 'buttons'";
}

# backward compatibility
*set_title = \&Title_set;
*get_title = \&Title;

# New (logical) names
*WindowBits_set = \&SetWindowBits;
*WindowPtr_set = \&SetWindowPtr;
*WindowULong_set = \&SetWindowULong;
*WindowUShort_set = \&SetWindowUShort;

# adapter; display; cbMemory; Configuration; VDHVersion; Flags; HWBufferSize;
# FullSaveSize; PartSaveSize; EMAdaptersOFF; EMDisplaysOFF;
sub vioConfig (;$$) {
  my $data = &_vioConfig;
  my @out = unpack 'x[S]SSLSSSLLLSS', $data;
  # If present, offset points to S/S (with only the first work making sense)
  my (@adaptersEMU, @displayEMU);
  @displaysEMU = unpack("x[$out[10]]S/S", $data), pop @out if @out > 10;
  @adaptersEMU = unpack("x[$out[ 9]]S/S", $data), pop @out if @out > 9;
  $out[9] = $adaptersEMU[0] if @adaptersEMU;
  $out[10] = $displaysEMU[0] if @displaysEMU;
  @out;
}

my @vioConfig = qw(adapter display cbMemory Configuration VDHVersion Flags
		   HWBufferSize FullSaveSize PartSaveSize EMAdapters EMDisplays);

sub viohConfig (;$$) {
  my %h;
  @h{@vioConfig} = &vioConfig;
  %h;
}

# fbType; color; col; row; hres; vres; fmt_ID; attrib; buf_addr; buf_length;
# full_length; partial_length; ext_data_addr;
sub vioMode() {unpack 'x[S]CCSSSSCCLLLLL', _vioMode}

my @vioMode = qw( fbType color col row hres vres fmt_ID attrib buf_addr
		  buf_length full_length partial_length ext_data_addr);

sub viohMode() {
  my %h;
  @h{@vioMode} = vioMode;
  %h;
}

sub viohMode_set {
  my %h = (viohMode, @_);
  my $o = pack 'x[S]CCSSSSCCLLLLL', @h{@vioMode};
  $o = pack 'SCCSSSSCCLLLLL', length $o, @h{@vioMode};
  _vioMode_set($o);
}

sub kbdChar (;$$) {unpack 'CCCCSL', &_kbdChar}

my @kbdChar = qw(ascii scancode status nlsstate shifts time);
sub kbdhChar (;$$) {
  my %h;
  @h{@kbdChar} = &kbdChar;
  %h
}

sub kbdStatus (;$) {unpack 'x[S]SSSS', &_kbdStatus}
my @kbdStatus = qw(state turnChar intCharFlags shifts);
sub kbdhStatus (;$) {
  my %h;
  @h{@kbdStatus} = &kbdStatus;
  %h
}
sub kbdhStatus_set {
  my $h = (@_ % 2 ? shift @_ : 0);
  my %h = (kbdhStatus($h), @_);
  my $o = pack 'x[S]SSSS', @h{@kbdStatus};
  $o = pack 'SSSSS', length $o, @h{@kbdStatus};
  _kbdStatus_set($o,$h);
}

#sub DeleteAtom		{ !WinDeleteAtom(@_) }
sub DeleteAtom		{ !_DeleteAtom(@_) }
sub DestroyAtomTable    { !_DestroyAtomTable(@_) }

# XXXX This is a wrong order: we start keyreader, then screenwriter; so it is
# the writer who gets signals.

# XXXX Do we ever get a message "screenwriter killed"???  If reader HUPs us...
# Large buffer works at least for read from pipes; should we binmode???
sub __term_mirror_screen {   # Read from fd=$in and write to the console
  local $SIG{TERM} = $SIG{HUP} = $SIG{BREAK} = $SIG{INT} = # die() can stop END
    sub { my $s = shift; warn "screenwriter killed ($s)...\n";};
  my $in = shift;
  open IN, "<&=$in" or die "open <&=$in: $!";
  # Attempt to redirect to STDERR/OUT is not very useful, but try this anyway...
  open OUT, '>', '/dev/con' or open OUT, '>&STDERR' or open OUT, '>&STDOUT'
	and select OUT or die "Can't open /dev/con or STDERR/STDOUT for write";
  $| = 1; local $SIG{TERM} = sub { die "screenwriter exits...\n"};
  binmode IN; binmode OUT;
  eval { print $_ while sysread IN, $_, 1<<16; };	# print to OUT...
  warn $@ if $@;
  warn "Screenwriter can't read any more ($!, $^E), terminating...\n";
}

# Does not automatically ends when the parent exits if related => 0
# copy from fd=$in to screen ; same for $out; or $in may be a named pipe
sub __term_mirror {
  my $pid;
  ### If related => 1, we get TERM when our parent exits...
  local $SIG{TERM} = sub { my $s = shift;
			   die "keyreader exits in a few secs ($s)...\n" };
  my ($in, $out) = (shift, shift);
  if (defined $out and length $out) {	# Allow '' for ease of @ARGV
    open OUT, ">&=$out" or die "Cannot open &=$out for write: $!";
    fcntl(OUT, 4, 1);		# F_SETFD, NOINHERIT
    open IN, "<&=$in" or die "Cannot open &=$in for read/ioctl: $!";
    fcntl(IN,  4, 0);		# F_SETFD, INHERIT
  } else {
    warn "Unexpected i/o pipe name: `$in'" unless $in =~ m,^[\\/]pipe[\\/],i;
    OS2::pipe $in, 'wait';
    open OUT, '+<', $in or die "Can't open `$in' for r/w: $!";
    fcntl(OUT,  4, 0);		# F_SETFD, INHERIT
    $in = fileno OUT;
    undef $out;
  }
  my %opt = @_;
  Title_set $opt{title}				if exists $opt{title};
  &scrsize_set(split /,/, $opt{scrsize})	if exists $opt{scrsize};

  my @i = map +('-I', $_), @INC;	# Propagate @INC

  # Careful unless PERL_SIGNALS=unsafe: SIGCHLD does not work...
  $SIG{CHLD} = sub {wait; die "Keyreader follows screenwriter...\n"}
	unless defined $out;

  $pid = system 1, $^X, @i, '-MOS2::Process',
	 '-we', 'END {sleep 2} OS2::Process::__term_mirror_screen shift', $in;
  close IN if defined $out;
  $pid > 0 or die "Cannot start a grandkid";

  open STDIN, '</dev/con' or warn "reopen stdin: $!";
  select OUT;    $| = 1;  binmode OUT;	# need binmode: sysread() may be bin
  $SIG{PIPE} = sub { die "writing to a closed pipe" };
  $SIG{HUP} = $SIG{BREAK} = $SIG{INT} = $SIG{TERM};
  # Workaround: EMX v61 won't return pid on SESSION|UNRELATED after fork()...
  syswrite OUT, pack 'L', $$ or die "syswrite failed: $!" if $opt{writepid};
  # Turn Nodelay on kbd.  Pipe is automatically nodelay...
  if ($opt{read_by_key}) {
    if (eval {require Term::ReadKey; 1}) {
      Term::ReadKey::ReadMode(4);
    } else { warn "can't load Term::ReadKey; input by lines..." }
  }
  print while sysread STDIN, $_, 1<<($opt{smallbuffer} ? 0 : 16); # to OUT
}

my $c = 0;
sub io_term {	# arguments as hash: read_by_key/title/scrsize/related/writepid
  # read_by_key disables echo too...
  local $\  = '';
  my ($sysf, $in1, $out1, $in2, $out2, $f1, $f2, $fd) = 4;	# P_SESSION
  my %opt = @_;

  if ($opt{related}) {
    pipe $in1, $out1 or die "pipe(): $!";
    pipe $in2, $out2 or do { close($in1), close($out1), die "pipe(): $!" };
    $f1 = fileno $in1; $f2 = fileno $out2;
    fcntl($in2, 4, 1); fcntl($out1, 4, 1);		# F_SETFD, NOINHERIT
    fcntl($in1, 4, 0); fcntl($out2, 4, 0);		# F_SETFD, INHERIT
  } else {
    $f1 = "/pipe/perlmodule/OS2/Process/$$-" . $c++;
    $out1 = OS2::pipe $f1, 'rw' or die "OS2::pipe(): $^E";
    #open $out1, "+<&=$fd" or die "dup($fd): $!, $^E";
    fcntl($out1, 4, 1);		# F_SETFD, NOINHERIT
    #$in2 = $out1;
    $f2 = '';
    $sysf |= 0x40000;		# P_UNRELATED
    $opt{writepid} = 1, unless exists $opt{writepid};
  }

  # system P_SESSION will fail if there is another process
  # in the same session with a "related" asynchronous child session.
  my @i = map +('-I', $_), @INC;	# Propagate @INC
  my $krun = <<'EOS';
     END {sleep($sleep || 5)}
     use OS2::Process; $sleep = 1;
     OS2::Process::__term_mirror(@ARGV);
EOS
  my $kpid;
  if ($opt{related}) {
    $kpid = system $sysf, $^X, @i, '-we', $krun, $f1, $f2, %opt;
  } else {
    local $ENV{PERL_SIGNALS} = 'unsafe';
    $kpid = system $sysf, $^X, @i, '-we', $krun, $f1, $f2, %opt;
  }
  close $in1 or warn if defined $in1;
  close $out2 or warn if defined $out2;
  # EMX BUG with $kpid == 0 after fork()
  do { close($in2), ($out1 != $in2 and close($out1)),
       die "system $sysf, $^X: kid=$kpid, \$!=`$!', \$^E=`$^E'" }
     unless $kpid > 0 or $kpid == 0 and $opt{writepid};
  # Can't read or write until the kid opens the pipes
  OS2::pipeCntl $out1, 'connect', 'wait' unless length $f2;
  # Without duping: write after read (via termio) on the same fd dups input
  open $in2, '<&', $out1 or die "dup($out1): $^E" unless $opt{related};
  if ($opt{writepid}) {
    my $c = length pack 'L', 0;
    my $c1 = sysread $in2, (my $pid), $c;
    $c1 == $c or die "unexpected length read: $c1 vs $c";
    $kpid = unpack 'L', $pid;
  }
  return ($in2, $out1, $kpid);
}

# Autoload methods go after __END__, and are processed by the autosplit program.

1;
__END__

=head1 NAME

OS2::Process - exports constants for system() call, and process control on OS2.

=head1 SYNOPSIS

    use OS2::Process;
    $pid = system(P_PM | P_BACKGROUND, "epm.exe");

=head1 DESCRIPTION

=head2 Optional argument to system()

the builtin function system() under OS/2 allows an optional first
argument which denotes the mode of the process. Note that this argument is
recognized only if it is strictly numerical.

You can use either one of the process modes:

	P_WAIT (0)	= wait until child terminates (default)
	P_NOWAIT	= do not wait until child terminates
	P_SESSION	= new session
	P_DETACH	= detached
	P_PM		= PM program

and optionally add PM and session option bits:

	P_DEFAULT (0)	= default
	P_MINIMIZE	= minimized
	P_MAXIMIZE	= maximized
	P_FULLSCREEN	= fullscreen (session only)
	P_WINDOWED	= windowed (session only)

	P_FOREGROUND	= foreground (if running in foreground)
	P_BACKGROUND	= background

	P_NOCLOSE	= don't close window on exit (session only)

	P_QUOTE		= quote all arguments
	P_TILDE		= MKS argument passing convention
	P_UNRELATED	= do not kill child when father terminates