REM file: Newvol.bas - Public Domain DOS Utility
REM Version 1.0a created 02/12/1995
REM Version 1.1a created 03/26/2001
REM Version 1.2a created 12/10/2005

' default integer variables
DEFINT A-Z
REM $DYNAMIC

' define boolean values
CONST True = -1
CONST False = NOT True
CONST TrueD = -1#
CONST FalseD = NOT TrueD
CONST NUL = ""

' define color values
CONST Black = 0
CONST Cyan = 11
CONST Green = 10
CONST Plain = 7
CONST Red = 12
CONST White = 15
CONST Yellow = 14

' get include files
REM $INCLUDE: 'qbx.bi'
REM $INCLUDE: 'fcb.bi'
REM $INCLUDE: 'dta.bi'

' declare functions
DECLARE FUNCTION ParseLine (S$)
DECLARE FUNCTION BreakIS()
DECLARE FUNCTION ClearBreak()
DECLARE FUNCTION KeyIS()

' initialize filename buffer
DIM ASCIIZ AS STRING * 260, Drive.Search AS STRING * 1

' declare program dta
DIM BASIC.DTA.SEG AS INTEGER, BASIC.DTA.OFF AS INTEGER

' declare structures
DIM FCBfile AS FCBtype, DTAfile AS DTAtype

' declare registers
COMMON SHARED InregsX AS RegTypeX, OutregsX AS RegTypeX
COMMON SHARED InregsX2 AS RegtypeX, InregsX3 AS RegtypeX

' declare work variables
COMMON SHARED Continuous.Display AS INTEGER, Display.Errors AS INTEGER
COMMON SHARED Update.Volume AS INTEGER

' declare command line work variables
COMMON SHARED Command.Line AS STRING, Command.Line.Redirect AS STRING
COMMON SHARED Command.Work AS STRING, Control.Break AS INTEGER
COMMON SHARED Last.Switch AS INTEGER, Display.Drive AS INTEGER
COMMON SHARED Display.Volume AS INTEGER, Pipe.Buffer AS STRING * 1
COMMON SHARED Redirected.Input AS INTEGER

' declare external procedures
DECLARE SUB SetInt
DECLARE SUB RestInt

' backwards compatible for bc 7.1
REM $INCLUDE: 'bc7.inc'

' increase stack size
STACK STACK

' install new interrupt service routine
CALL SetInt

' declare standard error trap
ON ERROR GOTO Error.Routine

' command line parser
FUNCTION ParseLine (X$)
 Imbedded = INSTR(Command.Line, LCASE$(X$))
 IF Imbedded THEN
    Command.Line = LEFT$(Command.Line, Imbedded - 1) + MID$(Command.Line, Imbedded + LEN(X$))
    Last.Switch = Imbedded - 1
    ParseLine = True
 ELSE
    Imbedded = INSTR(Command.Line, UCASE$(X$))
    IF Imbedded THEN
       Command.Line = LEFT$(Command.Line, Imbedded - 1) + MID$(Command.Line, Imbedded + LEN(X$))
       Last.Switch = Imbedded - 1
       ParseLine = True
    ELSE
       ParseLine = False
    END IF
 END IF
END FUNCTION 

' store basic dta
InregsX.AX = &H2F00
CALL InterruptX(&H21, InregsX, OutregsX)
BASIC.DTA.SEG = OutregsX.ES
BASIC.DTA.OFF = OutregsX.BX

' restore directory search dta
InregsX.AX = &H1A00
InregsX.DS = VARSEG(DTAfile)
InregsX.DX = VARPTR(DTAfile)
CALL InterruptX(&H21, InregsX, OutregsX)

' get current drive
InregsX.AX = &H1900
CALL InterruptX(&H21, InregsX, OutregsX)
Current.Drive$ = CHR$((OutregsX.AX AND &HFF) + 65)

' check command line
SELECT CASE COMMAND$
CASE "/?"
   GOTO Boot.Usage
END SELECT

' read command line from PSP
Command.line = NUL
InregsX.AX = &H6200
CALL InterruptX(&H21, InregsX, OutregsX)
PSPsegment = OutregsX.BX
PSPoffset = 128
DEF SEG = PSPsegment
FOR Count = 1 TO 127
   Command.Char = PEEK(PSPoffset + Count)
   SELECT CASE Command.Char
   CASE 0, 10, 13
      EXIT FOR
   CASE ELSE
      Command.line = Command.line + CHR$(Command.Char)
   END SELECT
NEXT
DEF SEG
IF Command.Line = NUL THEN
   Command.Line = ENVIRON$("NEWVOL")
END IF
Command.Line = RTRIM$(Command.Line)

' get switches from command line
Continuous.Display = ParseLine ("/C")
Display.Drive = ParseLine("/D")
Update.Volume = ParseLine ("/V")
Display.Volume = ParseLine("/X")
Display.Errors = ParseLine ("/Z")
Control.Break = ParseLine ("/~")
Var = ParseLine("/_")

' recheck command line
IF INSTR(Command.Line, "/") THEN
   GOTO Boot.Error
END IF
Command.Line = RTRIM$(Command.Line)
IF Last.Switch THEN
   IF LEN(Command.Line) > Last.Switch THEN
      GOTO Boot.Error
   END IF
END IF

' remove blanks from command line
Command.Line = RTRIM$(Command.Line)
Command.Line = LTRIM$(Command.Line)
Command.Line = UCASE$(Command.Line)
Command.Line.Redirect = Command.Line

' check break flag override
IF Control.Break THEN
   Var = ClearBreak
END IF

' search through all input filenames
Redirected.Input = False

' check pipe length
InregsX.AX = &H4202 ' eof
InregsX.BX = 0 ' stdin
InregsX.CX = 0
InregsX.DX = 0
Call InterruptX(&H21, InregsX, OutregsX)
If OutregsX.AX > 0 Then
   Pipe.Redirect = True
   InregsX.AX = &H4200
   InregsX.BX = 0 ' stdin
   InregsX.CX = 0
   InregsX.DX = 0
   Call InterruptX(&H21, InregsX, OutregsX)
Endif
If Pipe.Redirect = False Then
   DEF SEG = &H40
   X = PEEK(&H71)
   DEF SEG
   IF X = 64 THEN
      DEF SEG = &H40
      POKE &H71, 0
      DEF SEG
   END IF
Endif
DO
   ' check control break
   IF BreakIS THEN
      EXIT DO
   END IF

   ' get standard input
   Standard.Input$ = NUL

   If Pipe.Redirect Then
      DO

         ' read from device
         InregsX.AX = &H3F00
         InregsX.BX = 0 ' stdin
         InregsX.CX = 1 ' char
         InregsX.DS = VARSEG(Pipe.Buffer)
         InregsX.DX = VARPTR(Pipe.Buffer)
         Call InterruptX(&H21, InregsX, OutregsX)
         If (OutregsX.Flags AND &H1) = &H1 Then
            Exit Do
         Endif
         If (OutregsX.Flags AND &H1) = &H0 Then
            If OutregsX.AX = 0 Then
               Exit Do
            Endif

            ' store input
            Redirected.Input = True

            ' store character
            Char$ = Pipe.Buffer

            ' check input character
            SELECT CASE ASC(Char$)
            CASE 10, 26
            CASE 13
               EXIT DO
            CASE ELSE
               Standard.Input$ = Standard.Input$ + Char$
            END SELECT
         END IF
      LOOP
   END IF

   ' clear break flag
   IF Redirected.Input = False THEN
      IF Cleared = False THEN
         Cleared = True
         Var = ClearBreak
      END IF
   END IF

   ' check control break
   IF BreakIS THEN
      EXIT DO
   END IF

   ' check nul filename input
   IF Redirected.Input = False THEN
      IF Standard.Input$ = NUL THEN
         CALL RestInt ' restore Control-Break
         X$ = Inkey$ ' quits here
         CALL SetInt ' reset Control-Break
         IF X$ = CHR$(0) + CHR$(0) THEN
            EXIT DO
         END IF
      END IF
   END IF

   ' check standard input
   IF Redirected.Input THEN
      IF Standard.Input$ = NUL THEN
	 EXIT DO
      END IF
   END IF

   ' display header
   GOSUB Header

   ' store entire command
   Command.Work = Command.Line.Redirect

   DO
      ' store entire command
      Imbedded = INSTR(Command.Line, " ")
      IF Imbedded THEN
         Command.Work = Standard.Input$ + LEFT$(Command.Line, Imbedded - 1)
         Command.Line = MID$(Command.Line, Imbedded + 1)
      ELSE
         Command.Work = Standard.Input$ + Command.Line
         Command.Line = NUL
      END IF

      ' store current drive
      IF MID$(Command.Work, 2, 1) = ":" THEN
         Drive.Search = LEFT$(Command.Work, 1)
         Command.Work = MID$(Command.Work, 3)
      ELSE
	 Drive.Search = Current.Drive$
      END IF

      ' change to drive
      InregsX.AX = &HE00
      InregsX.DX = ASC(Drive.Search) - 65
      CALL InterruptX(&H21, InregsX, OutregsX)
   
      ' find volume label
      ASCIIZ = "\*.*" + CHR$(0)
      InregsX.AX = &H4E00
      InregsX.CX = &H08
      InregsX.DS = VARSEG(ASCIIZ)
      InregsX.DX = VARPTR(ASCIIZ)
      CALL InterruptX(&H21, InregsX, OutregsX)

      ' store current volume label
      Volume.Label$ = RTRIM$(DTAfile.ASCIIZfilename)
      WHILE RIGHT$(Volume.Label$, 1) = CHR$(0)
	 Volume.Label$ = LEFT$(Volume.Label$, LEN(Volume.Label$) - 1)
	 Volume.Label$ = RTRIM$(Volume.Label$)
      WEND

      ' check update volume variable
      IF Update.Volume THEN
         GOSUB Print.Label
      END IF

      ' check update volume variable
      IF Update.Volume = False THEN

	 ' check delete volume label
         IF Command.Work = NUL THEN

	    ' check volume label name
            Imbedded = INSTR(Volume.Label$, ".")
            IF Imbedded THEN
               Volume.Label$ = LEFT$(Volume.Label$, Imbedded - 1) +_
               MID$(Volume.Label$, Imbedded + 1)
	    END IF

	    ' trim volume label
	    Volume.Filename$ = MID$(Volume.Label$, 1, 8)
	    Volume.Extension$ = MID$(Volume.Label$, 9, 3)
	    Volume.Filename$ = RTRIM$(Volume.Filename$)
	    Volume.Extension$ = RTRIM$(Volume.Extension$)

	    ' store volume label
	    FCBfile.ExtendedFCB = CHR$(255)
            FCBfile.FileAttribute = CHR$(&H08)
	    FCBfile.Filename = Volume.Filename$
	    FCBfile.Extension = Volume.Extension$
	    FCBfile.DriveNumber = CHR$(ASC(Drive.Search$) - 64)

	    ' delete volume label
	    InregsX.AX = &H1300
	    InregsX.DS = VARSEG(FCBfile)
	    InregsX.DX = VARPTR(FCBfile)
	    CALL InterruptX(&H21, InregsX, OutregsX)

	    ' check volume flag
	    IF (OutregsX.AX AND &HFF) = &HFF THEN
               IF Display.Errors = False THEN
                  COLOR Red, Black
                  PRINT "Error deleting volume."
	       END IF
	    ELSE
               GOSUB Print.Label
	    END IF
	 ELSE

	    ' check volume label name
            Imbedded = INSTR(Volume.Label$, ".")
            IF Imbedded THEN
               Volume.Label$ = LEFT$(Volume.Label$, Imbedded - 1) +_
               MID$(Volume.Label$, Imbedded + 1)
	    END IF

	    ' trim volume label
	    Volume.Filename$ = MID$(Volume.Label$, 1, 8)
	    Volume.Extension$ = MID$(Volume.Label$, 9, 3)
	    Volume.Filename$ = RTRIM$(Volume.Filename$)
	    Volume.Extension$ = RTRIM$(Volume.Extension$)

	    ' store volume label
	    FCBfile.ExtendedFCB = CHR$(255)
            FCBfile.FileAttribute = CHR$(&H08)
	    FCBfile.Filename = Volume.Filename$
	    FCBfile.Extension = Volume.Extension$
	    FCBfile.DriveNumber = CHR$(ASC(Drive.Search$) - 64)

	    ' delete volume label
	    InregsX.AX = &H1300
	    InregsX.DS = VARSEG(FCBfile)
	    InregsX.DX = VARPTR(FCBfile)
	    CALL InterruptX(&H21, InregsX, OutregsX)

	    ' store new volume label
            Volume.Label$ = Command.Work

	    ' check volume label name
            Imbedded = INSTR(Volume.Label$, ".")
            IF Imbedded THEN
               Volume.Label$ = LEFT$(Volume.Label$, Imbedded - 1) +_
               MID$(Volume.Label$, Imbedded + 1)
	    END IF

	    ' trim volume label
	    Volume.Filename$ = MID$(Volume.Label$, 1, 8)
	    Volume.Extension$ = MID$(Volume.Label$, 9, 3)
	    Volume.Filename$ = RTRIM$(Volume.Filename$)
	    Volume.Extension$ = RTRIM$(Volume.Extension$)

	    ' store volume label
	    FCBfile.ExtendedFCB = CHR$(255)
            FCBfile.FileAttribute = CHR$(&H08)
	    FCBfile.Filename = Volume.Filename$
	    FCBfile.Extension = Volume.Extension$
	    FCBfile.DriveNumber = CHR$(ASC(Drive.Search$) - 64)

	    ' store volume label
	    Volume.Filename$ = Volume.Filename$ + SPACE$(8 - LEN(Volume.Filename$))
	    Volume.Extension$ = Volume.Extension$ + SPACE$(3 - LEN(Volume.Extension$))
	    Volume.Label$ = Volume.Filename$ + Volume.Extension$

	    ' create volume label
	    InregsX.AX = &H1600
	    InregsX.DS = VARSEG(FCBfile)
	    InregsX.DX = VARPTR(FCBfile)
	    CALL InterruptX(&H21, InregsX, OutregsX)

	    ' check volume flag
	    IF (OutregsX.AX AND &HFF) = &HFF THEN
               IF Display.Errors = False THEN
                  COLOR Red, Black
		  PRINT "Error creating volume."
	       END IF
	    ELSE
               GOSUB Print.Label
	    END IF
	 END IF
      END IF

      ' check search filename
      IF Command.Line = NUL THEN
	 EXIT DO
      END IF
   LOOP

   ' check search filename
   IF Standard.Input$ = NUL THEN
      EXIT DO
   END IF
LOOP

End.Newvol:

' restore basic dta
InregsX.AX = &H1A00
InregsX.DS = BASIC.DTA.SEG
InregsX.DX = BASIC.DTA.OFF
CALL InterruptX(&H21, InregsX, OutregsX)

' restore current drive
InregsX.AX = &HE00
InregsX.DX = ASC(Current.Drive$) - 65
CALL InterruptX(&H21, InregsX, OutregsX)

' display end program
IF Continuous.Display = False THEN
   Prompt$ = "Press <enter> to exit to DOS:"
   CALL MorePrompt(Prompt$, CHR$(13), Outpt$)
END IF
COLOR Plain, Black

' restore key trapping
CALL RestInt
END

' display vaolume label
Print.Label:
 ' display drive letter
 IF Display.Drive THEN
    COLOR Yellow, Black
    PRINT Drive.Search; ":";
 END IF
 ' display volume label
 IF Display.Volume = False THEN
    COLOR Yellow, Black
    PRINT Volume.Label$
 END IF
 IF Display.Drive AND Display.Volume THEN
    PRINT
 END IF
 RETURN

' display program usage
Boot.Usage:
 ' restore key trapping
 CALL RestInt
 Var$=Inkey$
 ' make header
 COLOR White, Black
 PRINT "Newvol v1.2a: Volume update utility; "
 COLOR Yellow, Black
 PRINT "Usage:"
 PRINT "   Newvol [d:][volumename][/cdvz]"
 PRINT "Where:"
 PRINT "   /c  continuous display"
 PRINT "   /d  display drive letter"
 PRINT "   /v  leave volume label unchanged"
 PRINT "   /z  suppress errors"
 COLOR Plain, Black
 END

Boot.Error:
 CALL RestInt
 Var$=Inkey$
 COLOR White, Black
 PRINT "Command line error. Type Newvol /? for help."
 COLOR Plain, Black
 END

' make header
Header:
 IF Header.Flag THEN
    RETURN
 END IF
 Header.Flag = True
 IF Continuous.Display = False THEN
    COLOR White, Black
    PRINT "Newvol v1.2a: Volume update utility;"
 END IF
 RETURN
   
' critical error trap
Error.Routine:
 Data.Error = ERR
 IF Display.Errors THEN
    Error.Level = True
    OutregsX.Flags = &H1
    RESUME NEXT
 END IF
 SELECT CASE Data.Error
 CASE 53
    Temp.Outpt$ = "File not found."
 CASE 61
    Temp.Outpt$ = "Disk full."
 CASE 70
    Temp.Outpt$ = "Permission denied."
 CASE 71
    Temp.Outpt$ = "Disk not ready."
 CASE ELSE
    Temp.Outpt$ = "Untrapped error" + STR$(Data.Error) + "."
 END SELECT
 COLOR White, Black
 PRINT Temp.Outpt$
 Prompt$ = "Press R to retry, Q to quit, C to continue:"
 CALL MorePrompt(Prompt$, "rqc", Outpt$)
 IF BreakIS THEN
    Outpt$ = "q"
 END IF
 SELECT CASE Outpt$
 CASE "r"
    RESUME
 CASE "q"
    Error.Level = True
    RESUME End.Newvol
 CASE "c"
    OutregsX.Flags = &H1
    RESUME NEXT
 END SELECT
 COLOR Plain, Black
 ' restore key trapping
 CALL RestInt
 END 0

SUB MorePrompt (Input.String$, Input.Mask$, Output.String$)
 COLOR White, Black
 PRINT Input.String$ + " ";
 Input.Char$ = NUL
 DO
    LOCATE , , 1
    InregsX2 = InregsX
    DO
       IF BreakIS THEN
          EXIT DO
       END IF
       IF KeyIS THEN
          IF OutregsX.AX <> 0 THEN
             InregsX.AX = &H0000
             CALL InterruptX(&H16, InregsX, OutregsX)
             Input.Char$=CHR$(OutregsX.AX AND &HFF)
             EXIT DO
          END IF
       END IF
    LOOP
    InregsX = InregsX2
    IF BreakIS THEN
       EXIT DO
    END IF
    IF LEN(Input.Char$) THEN
       Input.Char$ = LCASE$(Input.Char$)
       IF INSTR(Input.Mask$, Input.Char$) THEN
	  PRINT Input.Char$
	  Output.String$ = Input.Char$
	  EXIT DO
       END IF
    END IF
 LOOP
END SUB

' clears Control-Break flag
FUNCTION ClearBreak
 DEF SEG = &H40
 POKE &H71, &H0
 DEF SEG
 ClearBreak = True
END FUNCTION

' checks Control-Break flag
FUNCTION BreakIS
 STATIC Var AS INTEGER
 IF Redirected.Input THEN
    DEF SEG = &H40
    X = PEEK(&H71)
    DEF SEG
    IF X = 64 THEN
       Var = True
    END IF
 END IF
 IF KeyIS THEN
    IF OutregsX.AX = 0 THEN
       Var = True
       DEF SEG = &H40
       POKE &H71, 64
       DEF SEG
    END IF
 END IF
 IF Var THEN
    Continuous.Display = True
 END IF
 BreakIS = Var
END FUNCTION

' checks keyboard buffer
FUNCTION KeyIS
 InregsX3 = InregsX
 InregsX.AX = &H0100
 CALL InterruptX(&H16, InregsX, OutregsX)
 InregsX = InregsX3
 IF (OutregsX.Flags AND &H40) = &H40 THEN
    KeyIS = False
 ELSE
    KeyIS = True
 END IF
END FUNCTION
