/* $Header: /cvsroot/macperl/perl/macos/ext/MacPerl/MacPerl.xs,v 1.8 2006/07/07 06:40:50 pudge Exp $
*
* Copyright (c) 1995 Matthias Neeracher
*
* You may distribute under the terms of the Perl Artistic License,
* as specified in the README file.
*
* $Log: MacPerl.xs,v $
* Revision 1.8 2006/07/07 06:40:50 pudge
* More endian fixes
*
* Revision 1.7 2006/06/20 01:39:18 pudge
* Loads of fixes, mostly for Intel port
*
* Revision 1.6 2005/02/20 05:57:13 pudge
* GUSI* memory leaks
*
* Revision 1.5 2002/12/13 18:26:42 pudge
* Fix header name for UFS
*
* Revision 1.4 2002/11/13 02:04:53 pudge
* Aieeeeee! Big ol' Carbon update.
*
* Revision 1.3 2001/09/02 00:38:40 pudge
* Sync with perforce
*
* Revision 1.2 2001/04/17 03:53:44 pudge
* Minor version/config changes, plus sync with maint-5.6/perl
*
* Revision 1.1 2000/08/14 03:39:34 neeri
* Checked into Sourceforge
*
* Revision 1.1 2000/05/14 21:45:04 neeri
* First build released to public
*
* Revision 1.3 1998/04/07 01:47:30 neeri
* MacPerl 5.2.0r4b1
*
* Revision 1.2 1997/11/18 00:53:29 neeri
* MacPerl 5.1.5
*
* Revision 1.1 1997/04/07 20:51:05 neeri
* Synchronized with MacPerl 5.1.4a1
*
*/
#define MAC_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifndef MACOS_TRADITIONAL
#include "../Carbon.h"
#endif
#include <Types.h>
#include <Quickdraw.h>
#include <Dialogs.h>
#include <Lists.h>
#ifdef MACOS_TRADITIONAL
#include <GUSIFileSpec.h>
#endif
#include <PLStringFuncs.h>
#include <Files.h>
#include <Fonts.h>
#include <Resources.h>
#include <LowMem.h>
/* Shamelessly borrowed from Apple's includes. Sorry */
/*
* faccess() commands; for general use
*/
/* 'd' => "directory" ops */
#define F_DELETE (('d'<<8)|0x01)
#define F_RENAME (('d'<<8)|0x02)
/*
* more faccess() commands; for use only by MPW tools
*/
#define F_OPEN (('d'<<8)|0x00) /* reserved for operating system use */
/* 'e' => "editor" ops */
#define F_GTABINFO (('e'<<8)|0x00) /* get tab offset for file */
#define F_STABINFO (('e'<<8)|0x01) /* set " " " " */
#define F_GFONTINFO (('e'<<8)|0x02) /* get font number and size for file */
#define F_SFONTINFO (('e'<<8)|0x03) /* set " " " " " " */
#define F_GPRINTREC (('e'<<8)|0x04) /* get print record for file */
#define F_SPRINTREC (('e'<<8)|0x05) /* set " " " " */
#define F_GSELINFO (('e'<<8)|0x06) /* get selection information for file */
#define F_SSELINFO (('e'<<8)|0x07) /* set " " " " */
#define F_GWININFO (('e'<<8)|0x08) /* get current window position */
#define F_SWININFO (('e'<<8)|0x09) /* set " " " */
#define F_GSCROLLINFO (('e'<<8)|0x0A) /* get scroll information */
#define F_SSCROLLINFO (('e'<<8)|0x0B) /* set " " */
#define F_GMARKER (('e'<<8)|0x0D) /* Get Marker */
#define F_SMARKER (('e'<<8)|0x0C) /* Set " */
#define F_GSAVEONCLOSE (('e'<<8)|0x0F) /* Get Save on close */
#define F_SSAVEONCLOSE (('e'<<8)|0x0E) /* Set " " " */
/*
* argument structure for use with F_SMARKER command
*/
#ifdef powerc
#pragma options align=mac68k
#endif
struct MarkElement {
int start; /* start position of mark */
int end; /* end position */
unsigned char charCount; /* number of chars in mark name */
char name[64]; /* marker name */
}; /* note: marker may be up to 64 chars long */
#ifdef powerc
#pragma options align=reset
#endif
#ifndef __cplusplus
typedef struct MarkElement MarkElement;
#endif
#ifdef powerc
#pragma options align=mac68k
#endif
struct SelectionRecord {
long startingPos;
long endingPos;
long displayTop;
};
#ifdef powerc
#pragma options align=reset
#endif
#ifndef __cplusplus
typedef struct SelectionRecord SelectionRecord;
#endif
static char gMacPerlScratch[256];
#define gMacPerlScratchString ((StringPtr) gMacPerlScratch)
#ifdef MACOS_TRADITIONAL
static ControlHandle GetDlgCtrl(DialogPtr dlg, short item)
{
short kind;
Handle hdl;
Rect box;
GetDialogItem(dlg, item, &kind, &hdl, &box);
return (ControlHandle) hdl;
}
static void GetDlgText(DialogPtr dlg, short item, StringPtr text)
{
GetDialogItemText((Handle) GetDlgCtrl(dlg, item), text);
}
static void SetDlgText(DialogPtr dlg, short item, char * text)
{
setdialogitemtext((Handle) GetDlgCtrl(dlg, item), text);
}
static void GetDlgRect(DialogPtr dlg, short item, Rect * r)
{
short kind;
Handle hdl;
GetDialogItem(dlg, item, &kind, &hdl, r);
}
static void FrameDlgRect(DialogPtr dlg, short item)
{
Rect r;
GetDlgRect(dlg, item, &r);
InsetRect(&r, -4, -4);
PenSize(3, 3);
FrameRoundRect(&r, 16, 16);
PenSize(1,1);
}
ListHandle gPickList = NULL;
Boolean gPickScalar = false;
#define SetCell(cell, row, column) { (cell).h = column; (cell).v = row; }
#define ROW(cell) (cell).v
pascal void
MacListUpdate(myDialog, myItem)
DialogPtr myDialog;
short myItem;
{
Rect myrect;
LUpdate(myDialog->visRgn, gPickList);
myrect = (**(gPickList)).rView;
InsetRect(&myrect, -1, -1);
FrameRect(&myrect);
}
static void HandleArrowInList(
ListHandle list, Boolean down, Boolean extend, Boolean extreme)
{
Cell cell;
Cell cur;
if (!list) /* How did we get here, anyway? */
return;
if (list[0]->selFlags & lOnlyOne)
extend = false;
SetPt(&cell, 0, 0);
if (!LGetSelect(true, &cell, list))
SetPt(&cur, 0, down ? -1 : 0);
else if (down) {
do {
if (!extend)
LSetSelect(false, cell, list);
cur = cell;
++cell.v;
} while (LGetSelect(true, &cell, list));
} else {
cur = cell;
if (!extend)
do {
LSetSelect(false, cell, list);
++cell.v;
} while (LGetSelect(true, &cell, list));
}
if (down) {
if (++cur.v >= list[0]->dataBounds.bottom)
cur.v = 0;
} else {
if (--cur.v < 0)
cur.v = list[0]->dataBounds.bottom-1;
}
if (extend && extreme)
if (down)
do {
LSetSelect(true, cur, list);
} while (++cur.v < list[0]->dataBounds.bottom);
else
do {
LSetSelect(true, cur, list);
} while (--cur.v >= 0);
else {
if (extreme)
cur.v = down ? list[0]->dataBounds.bottom-1 : 0;
LSetSelect(true, cur, list);
}
}
#if TARGET_RT_MAC_CFM
RoutineDescriptor uMacListUpdate =
BUILD_ROUTINE_DESCRIPTOR(uppUserItemProcInfo, MacListUpdate);
#else
#define uMacListUpdate MacListUpdate
#endif
pascal Boolean
MacListFilter(myDialog, myEvent, myItem)
DialogPtr myDialog;
EventRecord *myEvent;
short *myItem;
{
Rect listrect;
short myascii;
Handle myhandle;
Point mypoint;
short mytype;
int activate;
SetPort(myDialog);
if (myEvent->what == keyDown)
switch (myascii = myEvent->message & 0x0FF) {
case 015:
case 003: /* This is return or enter... */
*myItem = 1;
return true;
case '.':
if (!(myEvent->modifiers & cmdKey))
break;
/* Fall through */
case 033: /* Cancel */
*myItem = 2;
return true;
case 036: /* UpArrow */
case 037: /* DownArrow */
HandleArrowInList(
gPickList, myascii==037,
(myEvent->modifiers & shiftKey) != 0,
(myEvent->modifiers & cmdKey) != 0);
myEvent->what = nullEvent;
}
else if (myEvent->what == mouseDown) {
mypoint = myEvent->where;
GlobalToLocal(&mypoint);
GetDialogItem(myDialog, 4, &mytype, &myhandle, &listrect);
if (PtInRect(mypoint, &listrect) && gPickList != NULL) {
if (!gPickScalar && myEvent->when - gPickList[0]->clikTime < LMGetDoubleTime()) {
LRect(&listrect, gPickList[0]->lastClick, gPickList);
if (PtInRect(mypoint, &listrect))
LSetSelect(true, gPickList[0]->lastClick, gPickList);
}
if (LClick(mypoint, (short)myEvent->modifiers, gPickList)) {
/* User double-clicked in cell... */
LSetSelect(true, gPickList[0]->lastClick, gPickList);
*myItem = 1;
return true;
}
}
} else if (myEvent->what == activateEvt && gPickList != NULL) {
activate = (myEvent->modifiers & 0x01) != 0;
LActivate((Boolean) activate, gPickList);
}
return false;
}
#if TARGET_RT_MAC_CFM
RoutineDescriptor uMacListFilter =
BUILD_ROUTINE_DESCRIPTOR(uppModalFilterProcInfo, MacListFilter);
#else
#define uMacListFilter MacListFilter
#endif
#endif /* MACOS_TRADITIONAL */
static OSErr GetVolInfo(short volume, Boolean indexed, FSSpec * spec)
{
OSErr err;
HParamBlockRec pb;
pb.volumeParam.ioNamePtr = spec->name;
pb.volumeParam.ioVRefNum = indexed ? 0 : volume;
pb.volumeParam.ioVolIndex = indexed ? volume : 0;
if (err = PBHGetVInfoSync(&pb))
return err;
spec->vRefNum = pb.volumeParam.ioVRefNum;
spec->parID = 1;
return noErr;
}
int choose()
{
croak("choose not implemented at the moment");
return -1;
}
MODULE = MacPerl PACKAGE = MacPerl PREFIX = MP_
void
MP_SetFileInfo(creator, type, path, ...)
OSType creator
OSType type
char * path
CODE:
{
int i;
for (i=2; i<items; i++)
fsetfileinfo((char *) SvPV_nolen(ST(i)), creator, type);
}
void
MP_GetFileInfo(path)
char * path
PPCODE:
{
OSType creator;
OSType type;
errno = 0;
fgetfileinfo(path, &creator, &type);
if (errno) {
if (GIMME != G_ARRAY)
XPUSHs(&PL_sv_undef);
/* Else return empty list */
} else if (GIMME != G_ARRAY) {
OSType ntype = htonl(type);
XPUSHs(sv_2mortal(newSVpv((char *) &ntype, 4)));
} else {
OSType ntype = htonl(type);
OSType ncreator = htonl(creator);
XPUSHs(sv_2mortal(newSVpv((char *) &ncreator, 4)));
XPUSHs(sv_2mortal(newSVpv((char *) &ntype, 4)));
}
}
void
MP_Ask(prompt, ...)
char * prompt
CODE:
#ifndef MACOS_TRADITIONAL
croak("Usage: MacPerl::Ask unsupported in Carbon");
#else
{
short item;
DialogPtr dlg;
dlg = GetNewDialog(2010, NULL, (WindowPtr)-1);
InitCursor();
SetDlgText(dlg, 3, prompt);
if (items > 1)
SetDlgText(dlg, 4, (char *) SvPV_nolen(ST(1)));
SelectDialogItemText(dlg, 4, 0, 1024);
ShowWindow(dlg);
SetPort(dlg);
FrameDlgRect(dlg, ok);
ModalDialog((ModalFilterUPP)0, &item);
switch (item) {
case ok:
GetDlgText(dlg, 4, gMacPerlScratchString);
ST(0) = sv_2mortal(newSVpv(gMacPerlScratch+!!*gMacPerlScratch, gMacPerlScratch[0]));
break;
case cancel:
ST(0) = &PL_sv_undef;
break;
}
DisposeDialog(dlg);
}
#endif
int
MP_Answer(prompt, ...)
char * prompt
CODE:
#ifndef MACOS_TRADITIONAL
croak("Usage: MacPerl::Answer unsupported in Carbon");
#else
{
short item;
DialogPtr dlg;
if (items > 4)
items = 4;
dlg = GetNewDialog((items>1) ? 1999+items : 2001, NULL, (WindowPtr)-1);
InitCursor();
SetDlgText(dlg, 5, prompt);
if (items > 1)
for (item = 1; item < items; item++) {
strcpy(gMacPerlScratch+1, (char *) SvPV_nolen(ST(item)));
*gMacPerlScratchString = strlen(gMacPerlScratch+1);
SetControlTitle(GetDlgCtrl(dlg, item), gMacPerlScratchString);
}
else
SetControlTitle(GetDlgCtrl(dlg, 1), "\pOK");
ShowWindow(dlg);
SetPort(dlg);
FrameDlgRect(dlg, ok);
ModalDialog((ModalFilterUPP)0, &item);
DisposeDialog(dlg);
RETVAL = (items > 1) ? items - item - 1 : 0;
}
#endif
OUTPUT:
RETVAL
void
MP_Choose(domain, type, prompt, ...)
int domain
int type
char * prompt
CODE:
#ifndef MACOS_TRADITIONAL
croak("Usage: MacPerl::Choose unsupported in Carbon");
#else
{
int flags;
STRLEN len;
char * constraint;
char * def_addr;
constraint = (items>=4) ? ((char *) SvPV(ST(3), len)) : nil;
constraint = constraint && len ? constraint : nil;
flags = (items>=5) ? ((int) SvIV(ST(4))) : 0;
def_addr = (items>=6) ? ((char *) SvPV(ST(5), len)) : nil;
def_addr = def_addr && len ? def_addr : nil;
gMacPerlScratch[0] = 0;
if (def_addr) {
memcpy(gMacPerlScratch, def_addr, len);
gMacPerlScratch[len] = 0; /* Some types require this */
}
len = 256; /* Len is output only! */
if (choose(domain, type, prompt, constraint, flags, gMacPerlScratch, &len) < 0 || !len)
ST(0) = &PL_sv_undef;
else
ST(0) = sv_2mortal(newSVpv(gMacPerlScratch, len));
}
#endif
void
MP_Pick(prompt, ...)
char * prompt
PPCODE:
#ifndef MACOS_TRADITIONAL
croak("Usage: MacPerl::Pick unsupported in Carbon");
#else
{
short itemHit;
STRLEN len;
Boolean done;
DialogPtr dlg;
Cell mycell;
short mytype;
Handle myhandle;
Point cellsize;
Rect listrect, dbounds;
char * item;
InitCursor();
dlg = GetNewDialog(2020, NULL, (WindowPtr)-1);
SetDlgText(dlg, 3, prompt);
GetDialogItem(dlg, 4, &mytype, &myhandle, &listrect);
SetDialogItem(dlg, 4, mytype, (Handle)&uMacListUpdate, &listrect);
SetPort(dlg);
InsetRect(&listrect, 1, 1);
SetRect(&dbounds, 0, 0, 1, items-1);
cellsize.h = (listrect.right - listrect.left);
cellsize.v = 17;
listrect.right -= 15;
gPickList = LNew(&listrect, &dbounds, cellsize, 0,
dlg, true, false, false, true);
gPickScalar = GIMME != G_ARRAY;
gPickList[0]->selFlags = !gPickScalar ? lExtendDrag+lUseSense : lOnlyOne;
LSetDrawingMode(false, gPickList);
SetCell(mycell, 0, 0);
for (; mycell.v<items-1; ++mycell.v) {
item = (char *) SvPV(ST(mycell.v+1), len);
LSetCell(item, len, mycell, gPickList);
}
LSetDrawingMode(true, gPickList);
ShowWindow(dlg);
for (done=false; !done; ) {
SetPort(dlg);
FrameDlgRect(dlg, ok);
ModalDialog((ModalFilterUPP) &uMacListFilter, &itemHit);
switch (itemHit) {
case ok:
SetCell(mycell, 0, 0);
done = true;
while (LGetSelect(true, &mycell, gPickList)) {
XPUSHs(sv_mortalcopy(ST(mycell.v+1)));
++mycell.v;
}
break;
case cancel:
done = true;
break;
}
} /* Modal Loop */
SetPort(dlg);
LDispose(gPickList);
gPickList = nil;
DisposeDialog(dlg);
}
#endif
int
MP_Quit(...)
CODE:
#ifndef MACOS_TRADITIONAL
croak("Usage: MacPerl::Quit unsupported in Carbon");
#else
if (items > 0)
gMacPerl_Quit = SvIV(ST(0));
RETVAL = gMacPerl_Quit;
#endif
OUTPUT:
RETVAL
int
MP_ErrorFormat(...)
CODE:
#ifndef MACOS_TRADITIONAL
croak("Usage: MacPerl::ErrorFormat unsupported in Carbon");
#else
if (items > 0)
gMacPerl_ErrorFormat = SvIV(ST(0));
RETVAL = gMacPerl_ErrorFormat;
#endif
OUTPUT:
RETVAL
void
MP_FAccess(file, cmd, ...)
char * file
unsigned cmd
PPCODE:
{
#ifndef MACOS_TRADITIONAL
croak("Usage: MacPerl::FAccess unsupported in Carbon");
#else
unsigned uarg;
Rect rarg;
SelectionRecord sarg;
char * name;
switch (cmd) {
case F_GFONTINFO:
if (faccess(file, cmd, (long *)&uarg) < 0)
XPUSHs(&PL_sv_undef);
else if (GIMME != G_ARRAY)
XPUSHs(sv_2mortal(newSViv(uarg >> 16)));
else {
GetFontName(uarg >> 16, gMacPerlScratchString);
XPUSHs(sv_2mortal(newSVpv(gMacPerlScratch+!!*gMacPerlScratch, *gMacPerlScratch)));
XPUSHs(sv_2mortal(newSViv(uarg & 0xFFFF)));
}
break;
case F_GSELINFO:
if (faccess(file, cmd, (long *)&sarg) < 0)
XPUSHs(&PL_sv_undef);
else if (GIMME != G_ARRAY)
XPUSHs(sv_2mortal(newSViv(sarg.startingPos)));
else {
XPUSHs(sv_2mortal(newSViv(sarg.startingPos)));
XPUSHs(sv_2mortal(newSViv(sarg.endingPos)));
XPUSHs(sv_2mortal(newSViv(sarg.displayTop)));
}
break;
case F_GTABINFO:
if (faccess(file, cmd, (long *)&uarg) < 0)
XPUSHs(&PL_sv_undef);
else
XPUSHs(sv_2mortal(newSViv(uarg)));
break;
case F_GWININFO:
if (faccess(file, cmd, (long *)&rarg) < 0)
XPUSHs(&PL_sv_undef);
else if (GIMME != G_ARRAY)
XPUSHs(sv_2mortal(newSViv(rarg.top)));
else {
XPUSHs(sv_2mortal(newSViv(rarg.left)));
XPUSHs(sv_2mortal(newSViv(rarg.top)));
XPUSHs(sv_2mortal(newSViv(rarg.right)));
XPUSHs(sv_2mortal(newSViv(rarg.bottom)));
}
break;
case F_SFONTINFO:
if (items < 3)
croak("Usage: MacPerl::FAccess(file, F_SFONTINFO, font [, size])");
name = SvPV_nolen(ST(2));
if (items == 3) {
if (faccess(file, F_GFONTINFO, (long *)&uarg) < 0)
uarg = 9;
} else
uarg = (unsigned) SvIV(ST(3));
if (isalpha(*name)) {
short family;
getfnum(name, &family);
uarg = (uarg & 0xFFFF) | ((unsigned) family) << 16;
} else
uarg = (uarg & 0xFFFF) | ((unsigned) SvIV(ST(2))) << 16;
if (faccess(file, cmd, (long *)uarg) < 0)
XPUSHs(&PL_sv_undef);
else
XPUSHs(sv_2mortal(newSViv(1)));
break;
case F_SSELINFO:
if (items < 4)
croak("Usage: MacPerl::FAccess(file, F_SSELINFO, start, end [, top])");
if (items == 4) {
if (faccess(file, F_GSELINFO, (long *) &sarg) < 0)
sarg.displayTop = SvIV(ST(2));
} else
sarg.displayTop = SvIV(ST(4));
sarg.startingPos = SvIV(ST(2));
sarg.endingPos = SvIV(ST(3));
if (faccess(file, cmd, (long *)&sarg) < 0)
XPUSHs(&PL_sv_undef);
else
XPUSHs(sv_2mortal(newSViv(1)));
break;
case F_STABINFO:
if (items < 3)
croak("Usage: MacPerl::FAccess(file, F_STABINFO, tab)");
uarg = SvIV(ST(2));
if (faccess(file, cmd, (long *)uarg) < 0)
XPUSHs(&PL_sv_undef);
else
XPUSHs(sv_2mortal(newSViv(1)));
break;
case F_SWININFO:
if (items < 4 )
croak("Usage: MacPerl::FAccess(file, F_SWININFO, left, top [, right [, bottom]])");
if (items < 6) {
if (faccess(file, F_GWININFO, (long *)&rarg) < 0)
rarg.bottom = rarg.right = 400;
else {
rarg.bottom = rarg.bottom - rarg.top + (short) SvIV(ST(3));
if (items == 4)
rarg.right = rarg.right - rarg.left + (short) SvIV(ST(2));
}
} else {
rarg.right = (short) SvIV(ST(4));
rarg.bottom = (short) SvIV(ST(5));
}
rarg.left = (short) SvIV(ST(2));
rarg.top = (short) SvIV(ST(3));
if (faccess(file, cmd, (long *)&rarg) < 0)
XPUSHs(&PL_sv_undef);
else
XPUSHs(sv_2mortal(newSViv(1)));
break;
default:
croak("MacPerl::FAccess() can't handle this command");
}
#endif
}
void
MP_MakeFSSpec(path)
char * path
CODE:
{
FSSpec spec;
if (GUSIPath2FSp(path, &spec))
ST(0) = &PL_sv_undef;
else
ST(0) = sv_2mortal(MP_GUSIFSp2Encoding(&spec, newSVpvn("", 0)));
}
void
MP_MakePath(path)
char * path
CODE:
{
FSSpec spec;
if (GUSIPath2FSp(path, &spec))
ST(0) = &PL_sv_undef;
else
ST(0) = sv_2mortal(MP_GUSIFSp2FullPath(&spec, newSVpvn("", 0)));
}
void
MP_Volumes()
PPCODE:
{
FSSpec spec;
if (GIMME != G_ARRAY) {
GUSISpecial2FSp('macs', kOnSystemDisk, &spec);
GetVolInfo(spec.vRefNum, false, &spec);
XPUSHs(sv_2mortal(MP_GUSIFSp2Encoding(&spec, newSVpvn("", 0))));
} else {
short index;
for (index = 0; !GetVolInfo(index+1, true, &spec); ++index)
XPUSHs(sv_2mortal(MP_GUSIFSp2Encoding(&spec, newSVpvn("", 0))));
}
}
BOOT:
{
/* This is all MacPerl-specific stuff */
#ifdef MACOS_TRADITIONAL
extern int StandAlone;
VersRecHndl vers = (VersRecHndl) GetResource('vers', 1);
int versLen = *(*vers)->shortVersion;
SV * version = get_sv("MacPerl::Version", TRUE | GV_ADDMULTI);
SV * arch = get_sv("MacPerl::Architecture", TRUE | GV_ADDMULTI);
SV * cc = get_sv("MacPerl::Compiler", TRUE | GV_ADDMULTI);
HLock((Handle) vers);
memcpy(gMacPerlScratch, (char *)(*vers)->shortVersion+1, versLen);
if (StandAlone)
strcpy(gMacPerlScratch+versLen, " Application");
else
strcpy(gMacPerlScratch+versLen, " MPW");
sv_setpv(version, gMacPerlScratch);
SvREADONLY_on(version);
sv_setpv(arch, ARCHNAME);
SvREADONLY_on(arch);
sv_setpv(cc, CC);
SvREADONLY_on(cc);
#endif
}