NetNews Usenet Archive 1993 #1/NN_1993_1.iso/spool/comp/lang/tcl/2353

Internet Message Format | 1993-01-12 | 27.2 KB

Path: sparky!uunet!olivea!spool.mu.edu!agate!boulder!csn!cherokee!durian
From: [e-mail] (Mike Durian)
Newsgroups: comp.lang.tcl
Subject: tclm0.1 - tcl with MIDI extensions (1/7)
Message-ID: <[e-mail]>
Date: 12 Jan 93 20:27:09 GMT
Sender: [e-mail] (Radio Free Boulder)
Organization: U S WEST Advanced Technologies
Lines: 990
Nntp-Posting-Host: mongo.advtech.uswest.com

# This is a shell archive.  Save it in a file, remove anything before
# this line, and then unpack it by entering "sh file".  Note, it may
# create directories; files and directories will be owned by you and
# have default permissions.
#
# This archive contains:
#
#    tclm0.1
#    tclm0.1/README
#    tclm0.1/tclm.h
#    tclm0.1/tclmCmd.c
#
echo c - tclm0.1
mkdir tclm0.1 > /dev/null 2>&1
echo x - tclm0.1/README
sed 's/^X//' >tclm0.1/README << 'END-of-tclm0.1/README'
X1/11/93
X  This is the first release, 0.1, of tclm.  Tclm is simply a
Xtcl interpreter with extensions for the manipulation of
XStandard MIDI Files.  In the most basic form tclm allows
Xyou to read, write and create SMFs as well as get and put events.
XThere are also additional commands that help manipulate
Xindividual events.
X  As a special bonus tclm contains a command to play
XSMFs.  Unfortunately, this is only available on BSD/386
Xsystems equiped with a MPU-401 compatible MIDI card
Xas it uses the MPU-401 MIDI device driver.
X  Compilation should be fairly straight forward.  Just
Xedit the Makefile and adjust TCLSRCDIR, DEFS, RANLIB
Xand BINDIR as appropriate for your system.  A 'make'
Xand a 'make install' should do it then.  Be sure
Xto change the first line on mplay and minfo to point
Xto the correct location of your tclm.
X  I have included a small patch for BSD/386 systems.  There
Xare conflicts between the tcl setenv command and the
Xsystem setenv command.  The patch merely changes the tcl
Xsetenv and unsetenv to be called Setenv and Unsetenv
Xrespectively.  The patch was made from the tk3.0 directory,
Xbut you should be able to wing it if you need to.
X'patch -p < bsdi.patch' worked for me.
X  If you do build on a BSD/386 system with MPU defined,
Xbe sure you have set up a symbolic link between
X/usr/src/sys/i386 and /usr/include/i386.
X  Besides the tclm interpreter there are also two sample
Xscripts.  One, minfo, dumps SMFs to a human readable form
Xand should works on all systems.  The other, mplay, plays
XSMFs and will only work on systems with the MPU-401 routines,
Xname BSD/386 machines.
X  I imagine people won't like me for it, but I've written
Xthe man pages with the mdoc routines.  Because of this I'm
Xincluding preformatted man pages and do not install them
Xin the Makefile.
X  Keep in mind that this is the first release; I'm sure
Xthere are numerous bugs.  Please send me all ideas, fixes,
Xbugs and interesting scripts.
X
XMike Durian - [e-mail]
END-of-tclm0.1/README
echo x - tclm0.1/tclm.h
sed 's/^X//' >tclm0.1/tclm.h << 'END-of-tclm0.1/tclm.h'
X/* tclm.h,v 1.3 1993/01/12 19:23:04 durian Exp */
X/*
X * Copyright (c) 1993 Michael B. Durian.  All rights reserved.
X *
X * Redistribution and use in source and binary forms, with or without
X * modification, are permitted provided that the following conditions
X * are met:
X * 1. Redistributions of source code must retain the above copyright
X *    notice, this list of conditions and the following disclaimer.
X * 2. Redistributions in binary form must reproduce the above copyright
X *    notice, this list of conditions and the following disclaimer in the
X *    documentation and/or other materials provided with the distribution.
X * 3. All advertising materials mentioning features or use of this software
X *    must display the following acknowledgement:
X *    This product includes software developed by Michael B. Durian.
X * 4. The name of the the Author may be used to endorse or promote
X *    products derived from this software without specific prior written
X *    permission.
X *
X * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED
X * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
X * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
X * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
X * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
X * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
X * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
X * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
X * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
X * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
X * SUCH DAMAGE.
X */
X#ifndef TCLM_H
X#define TCLM_H
Xtypedef struct {
X    HCHUNK    hchunk;
X    TCHUNK    *tchunks;
X} MIDI_FILE;
X
X#define MAX_EVENT_SIZE 256
X
Xextern int Tclm_MidiConfig _ANSI_ARGS_((ClientData, Tcl_Interp *, int,
X    char **));
Xextern int Tclm_ConvertBytes _ANSI_ARGS_((Tcl_Interp *, char *,
X    unsigned char *, int *));
Xextern int Tclm_Division _ANSI_ARGS_((Tcl_Interp *, int, char **));
Xextern int Tclm_MidiFixToVar _ANSI_ARGS_((ClientData, Tcl_Interp *, int,
X    char **));
Xextern int Tclm_Format _ANSI_ARGS_((Tcl_Interp *, int, char **));
Xextern int Tclm_MidiFree _ANSI_ARGS_((ClientData, Tcl_Interp *, int, char **));
Xextern int Tclm_MidiGet _ANSI_ARGS_((ClientData, Tcl_Interp *, int, char **));
Xextern int Tclm_MidiPut _ANSI_ARGS_((ClientData, Tcl_Interp *, int, char **));
Xextern int Tclm_GetMFile _ANSI_ARGS_((Tcl_Interp *, char *, MIDI_FILE **));
Xextern void Tclm_InitMidi _ANSI_ARGS_((Tcl_Interp *));
Xextern int Tclm_MidiMake _ANSI_ARGS_((ClientData, Tcl_Interp *, int, char **));
Xextern int Tclm_NumTracks _ANSI_ARGS_((Tcl_Interp *, int, char **));
Xextern int Tclm_MidiRead _ANSI_ARGS_((ClientData, Tcl_Interp *, int, char **));
Xextern int Tclm_MidiRewind _ANSI_ARGS_((ClientData, Tcl_Interp *, int,
X    char **));
Xextern int Tclm_SetMFile _ANSI_ARGS_((Tcl_Interp *, char *, MIDI_FILE *));
Xextern int Tclm_MidiTiming _ANSI_ARGS_((ClientData, Tcl_Interp *, int,
X    char **));
Xextern int Tclm_MidiVarToFix _ANSI_ARGS_((ClientData, Tcl_Interp *, int,
X    char **));
Xextern int Tclm_MidiWrite _ANSI_ARGS_((ClientData, Tcl_Interp *, int,
X    char **));
Xextern int Tclm_MidiMPU _ANSI_ARGS_((ClientData, Tcl_Interp *, int, char **));
X#endif
END-of-tclm0.1/tclm.h
echo x - tclm0.1/tclmCmd.c
sed 's/^X//' >tclm0.1/tclmCmd.c << 'END-of-tclm0.1/tclmCmd.c'
X/* tclmCmd.c,v 1.3 1993/01/12 19:23:08 durian Exp */
X/*
X * Copyright (c) 1993 Michael B. Durian.  All rights reserved.
X *
X * Redistribution and use in source and binary forms, with or without
X * modification, are permitted provided that the following conditions
X * are met:
X * 1. Redistributions of source code must retain the above copyright
X *    notice, this list of conditions and the following disclaimer.
X * 2. Redistributions in binary form must reproduce the above copyright
X *    notice, this list of conditions and the following disclaimer in the
X *    documentation and/or other materials provided with the distribution.
X * 3. All advertising materials mentioning features or use of this software
X *    must display the following acknowledgement:
X *    This product includes software developed by Michael B. Durian.
X * 4. The name of the the Author may be used to endorse or promote
X *    products derived from this software without specific prior written
X *    permission.
X *
X * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED
X * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
X * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
X * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
X * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
X * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
X * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
X * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
X * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
X * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
X * SUCH DAMAGE.
X */
X#include "tclInt.h"
X#include "tclUnix.h"
X#include "mutil.h"
X#include "tclm.h"
X
X
XTcl_HashTable MidiFileHash;
Xstatic int mfileId = 0;
X
Xvoid
XTclm_InitMidi(interp)
X    Tcl_Interp *interp;
X{
X
X    Tcl_CreateCommand(interp, "midiconfig", Tclm_MidiConfig, NULL, NULL);
X    Tcl_CreateCommand(interp, "midiread", Tclm_MidiRead, NULL, NULL);
X    Tcl_CreateCommand(interp, "midiwrite", Tclm_MidiWrite, NULL, NULL);
X    Tcl_CreateCommand(interp, "midimake", Tclm_MidiMake, NULL, NULL);
X    Tcl_CreateCommand(interp, "midifree", Tclm_MidiFree, NULL, NULL);
X    Tcl_CreateCommand(interp, "midirewind", Tclm_MidiRewind, NULL, NULL);
X
X    Tcl_CreateCommand(interp, "midifixtovar", Tclm_MidiFixToVar, NULL,
X        NULL);
X    Tcl_CreateCommand(interp, "midivartofix", Tclm_MidiVarToFix, NULL,
X        NULL);
X    Tcl_CreateCommand(interp, "midiget", Tclm_MidiGet, NULL, NULL);
X    Tcl_CreateCommand(interp, "midiput", Tclm_MidiPut, NULL, NULL);
X    Tcl_CreateCommand(interp, "miditiming", Tclm_MidiTiming, NULL, NULL);
X    Tcl_CreateCommand(interp, "midimpu", Tclm_MidiMPU, NULL, NULL);
X    Tcl_InitHashTable(&MidiFileHash, TCL_ONE_WORD_KEYS);
X}
X
X
Xint
XTclm_MidiConfig(dummy, interp, argc, argv)
X    ClientData dummy;
X    Tcl_Interp *interp;
X    int argc;
X    char **argv;
X{
X    int length;
X    int result;
X
X    /*
X     * argv[0] - midiconfig
X     * argv[1] - mfileID
X     * argv[2] - format | division | tracks
X     * argv[3] - optional arg
X     */
X    result = TCL_OK;
X    if (argc < 3 || argc > 4) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"",
X            argv[0], "mfileId {format | division | tracks} ?arg?\"",
X            (char *)NULL);
X        return (TCL_ERROR);
X    }
X
X    length = strlen(argv[2]);
X    switch(argv[2][0]) {
X    case 'd':
X        if (strncmp(argv[2], "division", length) == 0)
X            result = Tclm_Division(interp, argc, argv);
X        else {
X            Tcl_AppendResult(interp, "bad option, ", argv[2],
X                ", must be one of format, division or tracks",
X                (char *)NULL);
X            return (TCL_ERROR);
X        }
X        break;
X    case 'f':
X        if (strncmp(argv[2], "format", length) == 0)
X            result = Tclm_Format(interp, argc, argv);
X        else {
X            Tcl_AppendResult(interp, "bad option, ", argv[2],
X                ", must be one of format, division or tracks",
X                (char *)NULL);
X            return (TCL_ERROR);
X        }
X        break;
X    case 't':
X        if (strncmp(argv[2], "tracks", length) == 0)
X            result = Tclm_NumTracks(interp, argc, argv);
X        else {
X            Tcl_AppendResult(interp, "bad option, ", argv[2],
X                ", must be one of format, division or tracks",
X                (char *)NULL);
X            return (TCL_ERROR);
X        }
X        break;
X    default:
X        Tcl_AppendResult(interp, "bad option, ", argv[2],
X            ", must be one of format, division or tracks",
X            (char *)NULL);
X        return (TCL_ERROR);
X    }
X
X    return (result);
X}
X
Xint
XTclm_MidiMake(dummy, interp, argc, argv)
X    ClientData dummy;
X    Tcl_Interp *interp;
X    int argc;
X    char **argv;
X{
X    MIDI_FILE *mfile;
X    Tcl_HashEntry *hash_entry;
X    int fd;
X    int i;
X    int created_hash;
X    char num_str[20];
X
X    /*
X     * argv[0] - midimake
X     */
X    if (argc != 1) {
X        Tcl_AppendResult(interp, "bad # args: should be \"",
X            argv[0], "\"", (char *)NULL);
X        return (TCL_ERROR);
X    }
X    if ((mfile = (MIDI_FILE *)malloc(sizeof(MIDI_FILE))) == NULL) {
X        Tcl_AppendResult(interp, "Not enough memory for MIDI file",
X            (char *)NULL);
X        return (TCL_ERROR);
X    }
X    strncpy(mfile->hchunk.str, "MThd", 4);
X    mfile->hchunk.length = 6;
X    mfile->hchunk.format = 1;
X    mfile->hchunk.division = 120;
X    mfile->hchunk.num_trks = 0;
X    mfile->tchunks = NULL;
X
X    hash_entry = Tcl_CreateHashEntry(&MidiFileHash, (char *)mfileId,
X        &created_hash);
X    if (!created_hash) {
X        Tcl_AppendResult(interp, "Hash bucket for file alread ",
X            "exists", (char *)NULL);
X        return (TCL_ERROR);
X    }
X    Tcl_SetHashValue(hash_entry, mfile);
X
X    sprintf(interp->result, "mfile%d", mfileId++);
X    return (TCL_OK);
X}
X
Xint
XTclm_MidiRead(dummy, interp, argc, argv)
X    ClientData dummy;
X    Tcl_Interp *interp;
X    int argc;
X    char **argv;
X{
X    MIDI_FILE *mfile;
X    OpenFile *filePtr;
X    Tcl_HashEntry *hash_entry;
X    int created_hash;
X    int fd;
X    int i;
X    int result;
X    char num_str[20];
X
X    /*
X     * argv[0] - midiread
X     * argv[1] - open file descriptor
X     */
X    if (argc != 2) {
X        Tcl_AppendResult(interp, "bad # args: should be \"",
X            argv[0], " fileId\"", (char *)NULL);
X        return (TCL_ERROR);
X    }
X    if ((result = TclGetOpenFile(interp, argv[1], &filePtr)) != TCL_OK)
X        return (result);
X
X    fd = fileno(filePtr->f);
X    if ((mfile = (MIDI_FILE *)malloc(sizeof(MIDI_FILE))) == NULL) {
X        Tcl_AppendResult(interp, "Not enough memory for MIDI file",
X            (char *)NULL);
X        return (TCL_ERROR);
X    }
X    if (!read_header_chunk(fd, &mfile->hchunk)) {
X        if (MidiEof)
X            Tcl_AppendResult(interp, "EOF");
X        else
X            Tcl_AppendResult(interp,
X                "Couldn't read header chunk\n", MidiError,
X                (char *)NULL);
X        return (TCL_ERROR);
X    }
X    if ((mfile->tchunks = (TCHUNK *)malloc(mfile->hchunk.num_trks *
X        sizeof(TCHUNK))) == NULL) {
X        Tcl_AppendResult(interp, "Not enough memory for track ",
X            "chunks", (char *)NULL);
X        return (TCL_ERROR);
X    }
X
X    for (i = 0;  i < mfile->hchunk.num_trks; i++) {
X        if (!read_track_chunk(fd, &(mfile->tchunks[i]))) {
X            sprintf(num_str, "%d", i);
X            Tcl_AppendResult(interp, "Couldn't read track ",
X                "number ",  num_str, "\n", MidiError,
X                (char *)NULL);
X            return (TCL_ERROR);
X        }
X    }
X    hash_entry = Tcl_CreateHashEntry(&MidiFileHash, (char *)mfileId,
X        &created_hash);
X    if (!created_hash) {
X        Tcl_AppendResult(interp, "Hash bucket for file alread ",
X            "exists", (char *)NULL);
X        return (TCL_ERROR);
X    }
X    Tcl_SetHashValue(hash_entry, mfile);
X
X    sprintf(interp->result, "mfile%d", mfileId++);
X    return (TCL_OK);
X}
X
Xint
XTclm_MidiWrite(dummy, interp, argc, argv)
X    ClientData dummy;
X    Tcl_Interp *interp;
X    int argc;
X    char **argv;
X{
X    MIDI_FILE *mfile;
X    OpenFile *filePtr;
X    Tcl_HashEntry *hash_entry;
X    int fd;
X    int i;
X    int result;
X    char num_str[20];
X
X    /*
X     * argv[0] - midiwrite
X     * argv[1] - mfileId
X     * argv[2] - fileId
X     */
X    if (argc != 3) {
X        Tcl_AppendResult(interp, "bad # args: shoudl be \"",
X            argv[0], " mfileId fileId\"", (char *)NULL);
X        return (TCL_ERROR);
X    }
X    if ((result = TclGetOpenFile(interp, argv[2], &filePtr)) != TCL_OK)
X        return (result);
X
X    if ((result = Tclm_GetMFile(interp, argv[1], &mfile)) != TCL_OK)
X        return (result);
X
X    fd = fileno(filePtr->f);
X
X    if (!write_header_chunk(fd, &mfile->hchunk)) {
X        Tcl_AppendResult(interp, "Couldn't write header chunk\n",
X            MidiError, (char *)NULL);
X        return (TCL_ERROR);
X    }
X    for (i = 0; i < mfile->hchunk.num_trks; i++) {
X        if (!write_track_chunk(fd, &(mfile->tchunks[i]))) {
X            sprintf(interp->result,
X                "Coudln't write track chunk %d\n%s", i,
X                MidiError);
X            return (TCL_ERROR);
X        }
X    }
X    return (TCL_OK);
X}
X
Xint
XTclm_MidiFree(dummy, interp, argc, argv)
X    ClientData dummy;
X    Tcl_Interp *interp;
X    int argc;
X    char **argv;
X{
X    MIDI_FILE *mfile;
X    int mfileId;
X    int result;
X
X    /*
X     * argv[0] - midifree
X     * argv[1] - mfileId
X     */
X    if (argc != 2) {
X        Tcl_AppendResult(interp, "bad # args: should be \"",
X            argv[0], " mfileId\"", (char *)NULL);
X        return (TCL_ERROR);
X    }
X
X    if ((result = Tclm_GetMFile(interp, argv[1], &mfile)) != TCL_OK)
X        return (result);
X
X    mfileId = (int)strtol(argv[1] + 5, NULL, 0);
X    Tcl_DeleteHashEntry(Tcl_FindHashEntry(&MidiFileHash, (char *)mfileId));
X
X    free(mfile->tchunks);
X    free(mfile);
X    return (TCL_OK);
X}
X
Xint
XTclm_GetMFile(interp, FileId, mfile)
X    Tcl_Interp *interp;
X    char *FileId;
X    MIDI_FILE **mfile;
X{
X    Tcl_HashEntry *hash_entry;
X    char *chk_ptr;
X    int mfileId;
X
X    if (strncmp(FileId, "mfile", 5) != 0) {
X        Tcl_AppendResult(interp, "Bad MIDI file identifier \"",
X            FileId, "\"", (char *)NULL);
X        return (TCL_ERROR);
X    }
X
X    mfileId = (int)strtol(FileId + 5, &chk_ptr, 0);
X    if (chk_ptr == FileId + 5) {
X        Tcl_AppendResult(interp, "Bad MIDI file identifier \"",
X            FileId, "\"", (char *)NULL);
X        return (TCL_ERROR);
X    }
X    if ((hash_entry = Tcl_FindHashEntry(&MidiFileHash, (char *)mfileId))
X        == NULL) {
X        Tcl_AppendResult(interp, FileId, " doesn't exist",
X            (char *)NULL);
X        return (TCL_ERROR);
X    }
X    *mfile = (MIDI_FILE *)Tcl_GetHashValue(hash_entry);
X    return (TCL_OK);
X}
X
Xint
XTclm_SetMFile(interp, FileId, mfile)
X    Tcl_Interp *interp;
X    char *FileId;
X    MIDI_FILE *mfile;
X{
X    Tcl_HashEntry *hash_entry;
X    char *chk_ptr;
X    int mfileId;
X
X    if (strncmp(FileId, "mfile", 5) != 0) {
X        Tcl_AppendResult(interp, "Bad MIDI file identifier \"",
X            FileId, "\"", (char *)NULL);
X        return (TCL_ERROR);
X    }
X
X    mfileId = (int)strtol(FileId + 5, &chk_ptr, 0);
X    if (chk_ptr == FileId + 5) {
X        Tcl_AppendResult(interp, "Bad MIDI file identifier \"",
X            FileId, "\"", (char *)NULL);
X        return (TCL_ERROR);
X    }
X    if ((hash_entry = Tcl_FindHashEntry(&MidiFileHash, (char *)mfileId))
X        == NULL) {
X        Tcl_AppendResult(interp, FileId, " doesn't exist",
X            (char *)NULL);
X        return (TCL_ERROR);
X    }
X    Tcl_SetHashValue(hash_entry, (char *)mfile);
X    return (TCL_OK);
X}
X
Xint
XTclm_NumTracks(interp, argc, argv)
X    Tcl_Interp *interp;
X    int argc;
X    char **argv;
X{
X    MIDI_FILE *mfile;
X    char *chk_ptr;
X    int i;
X    int result;
X    int num_trks;
X
X    /*
X     * argv[0] - midiconfig
X     * argv[1] - mfileId
X     * argv[2] - tracks
X     * argv[3] - optional number of tracks
X     */
X    if ((result = Tclm_GetMFile(interp, argv[1], &mfile)) != TCL_OK)
X        return (result);
X
X    if (argc == 3)
X        sprintf(interp->result, "%d", mfile->hchunk.num_trks);
X    else {
X        num_trks = (int)strtol(argv[3], &chk_ptr, 0);
X        if (chk_ptr == argv[3]) {
X            Tcl_AppendResult(interp, "Bad number of tracks ",
X                argv[3], (char *)NULL);
X            return (TCL_ERROR);
X        }
X        if (mfile->hchunk.format == 0 && num_trks != 1) {
X            Tcl_AppendResult(interp, "Format 0 files can only ",
X                "have one track, not ", argv[3], (char *)NULL);
X            return (TCL_ERROR);
X        }
X        if (mfile->tchunks == NULL) {
X            if (num_trks != 0) {
X                if ((mfile->tchunks = (TCHUNK *)malloc(
X                    sizeof(TCHUNK) * num_trks)) == NULL) {
X                    Tcl_AppendResult(interp,
X                        "Not enough memory for ", argv[3],
X                        " tracks", (char *)NULL);
X                }
X            }
X        } else {
X            if (num_trks == 0) {
X                free((char *)mfile->tchunks);
X                mfile->tchunks = NULL;
X            } else {
X                if ((mfile->tchunks = (TCHUNK *)realloc(
X                    mfile->tchunks, sizeof(TCHUNK) * num_trks))
X                    == NULL) {
X                    Tcl_AppendResult(interp,
X                        "Not enough memory for ", argv[3],
X                        " tracks", (char *)NULL);
X                }
X            }
X        }
X
X        for (i = mfile->hchunk.num_trks; i < num_trks; i++) {
X            mfile->tchunks[i].event_start = NULL;
X            mfile->tchunks[i].events = NULL;
X            mfile->tchunks[i].msize = 0;
X            mfile->tchunks[i].length = 0;
X            mfile->tchunks[i].pos = 0;
X            strncpy(mfile->tchunks[i].str, "MTrk", 4);
X        }
X
X        mfile->hchunk.num_trks = num_trks;
X        if ((result = Tclm_SetMFile(interp, argv[1], mfile)) !=
X            TCL_OK)
X            return (result);
X    }
X    return (TCL_OK);
X}
X
Xint
XTclm_Format(interp, argc, argv)
X    Tcl_Interp *interp;
X    int argc;
X    char **argv;
X{
X    MIDI_FILE *mfile;
X    char *chk_ptr;
X    int result;
X    int format;
X
X    /*
X     * argv[0] - midiconfig
X     * argv[1] - mfileId
X     * argv[2] - format
X     * argv[3] - optional arg
X     */
X
X    if ((result = Tclm_GetMFile(interp, argv[1], &mfile)) != TCL_OK)
X        return (result);
X
X    if (argc == 3)
X        sprintf(interp->result, "%d", mfile->hchunk.format);
X    else {
X        format = (int)strtol(argv[3], &chk_ptr, 0);
X        if (chk_ptr == argv[3] || format < 0 || format > 2) {
X            Tcl_AppendResult(interp, "Bad format",
X                argv[2], (char *)NULL);
X            return (TCL_ERROR);
X        }
X        mfile->hchunk.format = format;
X        if ((result = Tclm_SetMFile(interp, argv[1], mfile)) !=
X            TCL_OK)
X            return (result);
X    }
X    return (TCL_OK);
X}
X
Xint
XTclm_Division(interp, argc, argv)
X    Tcl_Interp *interp;
X    int argc;
X    char **argv;
X{
X    MIDI_FILE *mfile;
X    char *chk_ptr;
X    int division;
X    int result;
X
X    /*
X     * argv[0] - midiconfig
X     * argv[1] - mfileId
X     * argv[2] - division
X     * argv[3] - optional arg
X     */
X
X    if ((result = Tclm_GetMFile(interp, argv[1], &mfile)) != TCL_OK)
X        return (result);
X
X    if (argc == 3)
X        sprintf(interp->result, "%d", mfile->hchunk.division);
X    else {
X        division = (int)strtol(argv[3], &chk_ptr, 0);
X        if (chk_ptr == argv[3]) {
X            Tcl_AppendResult(interp, "bad division value ",
X                argv[3], (char *)NULL);
X            return (TCL_ERROR);
X        }
X        mfile->hchunk.division = division;
X        if ((result = Tclm_SetMFile(interp, argv[1], mfile)) !=
X            TCL_OK)
X            return (result);
X    }
X    return (TCL_OK);
X}
X
Xint
XTclm_MidiGet(dummy, interp, argc, argv)
X    ClientData dummy;
X    Tcl_Interp *interp;
X    int argc;
X    char **argv;
X{
X    MIDI_FILE *mfile;
X    char *chk_ptr;
X    int event_size;
X    int i;
X    int result;
X    int track_num;
X    EVENT_TYPE event_type;
X    char number[10];
X    unsigned char event[MAX_EVENT_SIZE];
X
X    /*
X     * argv[0] - midiget
X     * argv[1] - mfileId
X     * argv[2] - track number
X     */
X
X    if (argc != 3) {
X        Tcl_AppendResult(interp, "bad # args: should be \"",
X            argv[0], " mfileId track_num\"", (char *)NULL);
X        return (TCL_ERROR);
X    }
X
X    if ((result = Tclm_GetMFile(interp, argv[1], &mfile)) != TCL_OK)
X        return (result);
X
X    track_num = (int)strtol(argv[2], &chk_ptr, 0);
X    if (chk_ptr == argv[2] || track_num < 0 ||
X        track_num > mfile->hchunk.num_trks - 1) {
X        Tcl_AppendResult(interp, "Bad track number ", argv[2],
X            (char *)NULL);
X        return (TCL_ERROR);
X    }
X    if ((event_size = get_smf_event(&(mfile->tchunks[track_num]), event,
X        &event_type)) == -1) {
X        Tcl_AppendResult(interp, "Couldn't get event from ", argv[1],
X            " track ", argv[2], "\n", MidiError, (char *)NULL);
X        return (TCL_ERROR);
X    }
X
X    /* convert event to numbers in hex */
X    for (i = 0; i < event_size; i++) {
X        sprintf(number, "0x%02x", event[i]);
X        Tcl_AppendElement(interp, number, 0);
X    }
X
X    return (TCL_OK);
X}
X
Xint
XTclm_ConvertBytes(interp, str, bytes, num_bytes)
X    Tcl_Interp *interp;
X    char *str;
X    unsigned char *bytes;
X    int *num_bytes;
X{
X    int i;
X    int result;
X    char *chk_ptr;
X    char **bytes_str;
X
X    if ((result = Tcl_SplitList(interp, str, num_bytes, &bytes_str)) !=
X        TCL_OK)
X        return (result);
X
X    for (i = 0; i < *num_bytes; i++) {
X        *bytes++ = (unsigned char)strtol(bytes_str[i], &chk_ptr, 0);
X        if (chk_ptr == bytes_str[i]) {
X            Tcl_AppendResult(interp, "Bad event data ",
X                bytes_str[i], (char *)NULL);
X            free((char *)bytes_str);
X            return (TCL_ERROR);
X        }
X    }
X    free((char *)bytes_str);
X    return (TCL_OK);
X}
X
Xint
XTclm_MidiPut(dummy, interp, argc, argv)
X    ClientData dummy;
X    Tcl_Interp *interp;
X    int argc;
X    char **argv;
X{
X    MIDI_FILE *mfile;
X    char *chk_ptr;
X    int num_bytes;
X    int result;
X    int track_num;
X    unsigned char event[MAX_EVENT_SIZE];
X
X    /*
X     * argv[0] - midiput
X     * argv[1] - mfileId
X     * argv[2] - track number
X     * argv[3] - event
X     */
X    if (argc != 4) {
X        Tcl_AppendResult(interp, "bad # args: should be \"",
X            argv[0], " mfileId track_num event\"", (char *)NULL);
X        return (TCL_ERROR);
X    }
X    if ((result = Tclm_GetMFile(interp, argv[1], &mfile)) != TCL_OK)
X        return (result);
X
X    track_num = (int)strtol(argv[2], &chk_ptr, 0);
X    if (chk_ptr == argv[2] || track_num < 0 ||
X        track_num > mfile->hchunk.num_trks - 1) {
X        Tcl_AppendResult(interp, "Bad track number ", argv[2],
X            (char *)NULL);
X        return (TCL_ERROR);
X    }
X
X    if ((result = Tclm_ConvertBytes(interp, argv[3], event, &num_bytes))
X        != TCL_OK)
X        return (result);
X
X    if (!put_smf_event(&(mfile->tchunks[track_num]), event, num_bytes)) {
X        Tcl_AppendResult(interp, "Couldn't put event\n",
X            MidiError, (char *)NULL);
X        return (TCL_ERROR);
X    }
X
X    return (TCL_OK);
X}
X
Xint
XTclm_MidiRewind(dummy, interp, argc, argv)
X    ClientData dummy;
X    Tcl_Interp *interp;
X    int argc;
X    char **argv;
X{
X    MIDI_FILE *mfile;
X    char *chk_ptr;
X    char **track_list;
X    int i;
X    int num_tracks;
X    int result;
X    int track;
X    char number[10];
X
X    /*
X     * argv[0] - midirewind
X     * argv[1] = mfileId
X     * argv[2] = optional track list
X     */
X    if (argc < 2 || argc > 3) {
X        Tcl_AppendResult(interp, "bad # args: should be \"",
X            argv[0], " mfileId ?track list?\"", (char *)NULL);
X        return (TCL_ERROR);
X    }
X
X    if ((result = Tclm_GetMFile(interp, argv[1], &mfile)) != TCL_OK)
X        return (result);
X
X    if (argc == 2)
X        for (i = 0; i < mfile->hchunk.num_trks; i++)
X            rewind_track(&(mfile->tchunks[i]));
X    else {
X        if ((result = Tcl_SplitList(interp, argv[2], &num_tracks,
X            &track_list)) != TCL_OK)
X            return (result);
X        for (i = 0; i < num_tracks; i++) {
X            track = (int)strtol(track_list[i], &chk_ptr, 0);
X            if (chk_ptr == track_list[i] || track < 0 ||
X                track >= mfile->hchunk.num_trks) {
X                Tcl_AppendResult(interp, "Bad track value ",
X                    track_list[i], (char *)NULL);
X                free ((char *)track_list);
X                return (TCL_ERROR);
X            }
X            rewind_track(&(mfile->tchunks[track]));
X        }
X        free((char *)track_list);
X    }
X
X    return (TCL_OK);
X}
X
Xint
XTclm_MidiVarToFix(dummy, interp, argc, argv)
X    ClientData dummy;
X    Tcl_Interp *interp;
X    int argc;
X    char **argv;
X{
X    long fix;
X    int delta;
X    int num_bytes;
X    int result;
X    unsigned char bytes[MAX_EVENT_SIZE];
X
X    /*
X     * argv[0] - midivartofix
X     * argv[1] - midi event
X     */
X    if (argc != 2) {
X        Tcl_AppendResult(interp, "bad # args: should be\"",
X            argv[0], " midi_event\"", (char *)NULL);
X        return (TCL_ERROR);
X    }
X    if ((result = Tclm_ConvertBytes(interp, argv[1], bytes, &num_bytes))
X        != TCL_OK)
X        return (result);
X
X    fix = var2fix(bytes, &delta);
X    sprintf(interp->result, "%ld", fix);
X    return (TCL_OK);
X}
X
Xint
XTclm_MidiFixToVar(dummy, interp, argc, argv)
X    ClientData dummy;
X    Tcl_Interp *interp;
X    int argc;
X    char **argv;
X{
X    long fix;
X    char *chk_ptr;
X    int i;
X    int num_bytes;
X    unsigned char bytes[4];
X    char byte_str[10];
X
X    /*
X     * argv[0] - midifixtovar
X     * argv[1] - fixed length value
X     */
X    if (argc != 2) {
X        Tcl_AppendResult(interp, "bad # args: should be \"",
X            argv[0], " fixval\"", (char *)NULL);
X        return (TCL_ERROR);
X    }
X
X    fix = strtol(argv[1], &chk_ptr, 0);
X    if (chk_ptr == argv[1]) {
X        Tcl_AppendResult(interp, "Bad fixed length value ", argv[1],
X            (char *)NULL);
X        return (TCL_ERROR);
X    }
X    num_bytes = fix2var(fix, bytes);
X    for (i = 0; i < num_bytes; i++) {
X        sprintf(byte_str, "0x%02x", bytes[i]);
X        Tcl_AppendElement(interp, byte_str, 0);
X    }
X    return (TCL_OK);
X}
X
Xint
XTclm_MidiTiming(dummy, interp, argc, argv)
X    ClientData dummy;
X    Tcl_Interp *interp;
X    int argc;
X    char **argv;
X{
X    int delta;
X    int i;
X    int num_bytes;
X    int result;
X    unsigned char bytes[MAX_EVENT_SIZE];
X    char str[10];
X
X    /*
X     * argv[0] - miditiming
X     * argv[1] - event
X     */
X
X    if ((result = Tclm_ConvertBytes(interp, argv[1], bytes, &num_bytes))
X        != TCL_OK)
X        return (result);
X
X    (void)var2fix(bytes, &delta);
X
X    for (i = 0; i < delta; i++) {
X        sprintf(str, "0x%02x", bytes[i]);
X        Tcl_AppendElement(interp, str, 0);
X    }
X    return (TCL_OK);
X}
X
Xint
XTclm_MidiMPU(dummy, interp, argc, argv)
X    ClientData dummy;
X    Tcl_Interp *interp;
X    int argc;
X    char **argv;
X{
X
X    /*
X     * argv[0] - midimpu
X     */
X    if (argc != 1) {
X        Tcl_AppendResult(interp, "wrong # args: should be\"",
X            argv[0], "\"", (char *)NULL);
X        return (TCL_ERROR);
X    }
X
X#ifdef MPU
X    Tcl_AppendResult(interp, "1", (char *)NULL);
X#else
X    Tcl_AppendResult(interp, "0", (char *)NULL);
X#endif
X    return (TCL_OK);
X}
END-of-tclm0.1/tclmCmd.c
exit