Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/PRMASTR3.ZIP/PRMASTER.PAS

Pascal/Delphi Source File | 1990-01-23 | 6.3 KB | 273 lines

{$F+}
Program PRMASTER;

Uses dos,crt,spooler,search,io;

var
  prevx,prevy:byte;
  global_filename:string;
  print_status: byte;
  res:integer;
  title_attribute,
  foreground_attribute,
  background_attribute:word;

procedure get_legal;
begin
  writeln('PRMASTER Print Spooler Utility.');
  writeln('Written by John Gatewood Ham               01/19/90');
  writeln('Created using Turbo Pascal, copyright (c) Borland International 1987, 1988.');
end;

procedure show_error(msgtitle,msgtxt:string);
var popscreen:popptr;
begin
  alert:=true;
  new(popscreen,init(2,11,79,11,msgtitle,msgtxt,
                     title_attribute,
                     foreground_attribute,
                     background_attribute));
  popscreen^.showit;
  dispose(popscreen,done);
  alert:=false;
end;

procedure spoolit(fname:string);
begin
  if not spool_a_file(fname) then
     show_error('Error','Unable to add "'+fname+'" to queue.');
end;

procedure unspoolit(fname:string);
begin
  if not unspool_a_file(fname) then
     show_error('Error','Unable to delete "'+fname+'" from queue.');
end;

{This must be a top level procedure to be a procedural parameter}
procedure fetch_file_name;
var fmenu:popfetchptr;
    hold:string;
begin
  new(fmenu,init(2,11,79,11,'Current='+global_filename,'Filename=',
                 title_attribute,
                 foreground_attribute,
                 background_attribute));
  hold:=fmenu^.fetchit;
  if hold <> '' then
     global_filename:=fexpand(hold);
  dispose(fmenu,done);
end;

procedure unspoolallfiles;
begin
  if not unspool_all_files then
     show_error('Error','Unable to delete all files from queue.')
  else
     show_error('Warning','All files cancelled by operator.');
end;

procedure getchoice;
begin
  up1level:=true;
end;

procedure showset(var fileset:string;flag:integer);
{flag = 1, spoolem}
{flag = 0, showem}
var
    tnode:flistptr;
    res:integer;
    submenu:menuptr2;
    maxwidth:integer;

begin
   getfilelist(fileset,(readonly+hidden+sysfile+archive));
   if filelist = nil then
     begin
       show_error('Error','No files in fileset "'+fileset+'"');
       exit;
     end;
   tnode:=filelist;
   new(submenu,init(2,2,79,24,'',
                   title_attribute,
                   foreground_attribute,
                   background_attribute));

   maxwidth:=0;
   while (tnode <> nil) do
     begin
       submenu^.add2menu(tnode^.fname,getchoice);
       if length(tnode^.fname) > maxwidth then
          maxwidth:=length(tnode^.fname);
       tnode:=tnode^.next;
     end;
   if flag = 1 then
      submenu^.title:='Files to spool'
   else
      submenu^.title:='Disk fileset '+fileset;
   deletefilelist;
   submenu^.pickmenu;
   res:=global_choice;
   if (res > 0) and (flag=1) then
      spoolit(submenu^.current^.itemlabel);
   dispose(submenu,done);
end;

{This must be a top level procedure to be a procedural parameter}
procedure spoolem;
begin
  if global_filename = '' then
     exit;
  if not match(global_filename) then
     begin
       show_error('Error','No files in fileset "'+global_filename+'" on disk.');
       exit;
     end;
  showset(global_filename,1);
end;

procedure showemdisk;
begin
  if global_filename = '' then
     exit;
  if not match(global_filename) then
     begin
       show_error('Error','No files in fileset "'+global_filename+'" on disk.');
       exit;
     end;
  showset(global_filename,0);
end;

procedure showset2(var fileset:string;flag:integer);
{flag = 1, unspoolem}
{flag = 0, showem}
var
    res:integer;
    submenu:menuptr2;
    maxwidth:integer;
    tnode:slistptr;
begin
  getspoolfilelist(global_filename);
  new(submenu,init(2,2,79,24,'',
                   title_attribute,
                   foreground_attribute,
                   background_attribute));

  maxwidth:=0;
  submenu^.itemcount:=0;
  tnode:=sfilelist;
  while (tnode <> nil) do
    begin
      submenu^.add2menu(tnode^.fname,getchoice);
      if length(tnode^.fname) > maxwidth then
         maxwidth:=length(tnode^.fname);
      tnode:=tnode^.next;
    end;
  if flag = 1 then
    submenu^.title:='Unspool file list'
  else
    submenu^.title:='Files on spooler';
  deletesfilelist;
  submenu^.pickmenu;
  res:=global_choice;
  if (res > 0) and (flag=1) then
    unspoolit(submenu^.current^.itemlabel);
  dispose(submenu,done);
end;

procedure unspoolem;
begin
  if queue_empty then
    begin
      show_error('Error','No files on spooler.');
      exit;
    end;
  showset2(global_filename,1);
end;

procedure showem;
begin
  if queue_empty then
    begin
      show_error('Error','No files on spooler.');
      exit;
    end;
  showset2(global_filename,0);
end;

procedure unspoolemall;
begin
  if queue_empty then
    begin
      show_error('Error','No files on spooler.');
      exit;
    end;
  unspoolallfiles;
end;

procedure changefileset;
begin
   fetch_file_name;
end;

procedure main;
var mainmenu:menuptr2;
begin
  new(mainmenu,init(21,5,40,10,'Main Menu',
                    title_attribute,
                    foreground_attribute,
                    background_attribute));
  mainmenu^.add2menu('Spool a file       ',spoolem);
  mainmenu^.add2menu('Unspool a file     ',unspoolem);
  mainmenu^.add2menu('Unspool all files  ',unspoolemall);
  mainmenu^.add2menu('Show spoolfiles    ',showem);
  mainmenu^.add2menu('Show disk files    ',showemdisk);
  mainmenu^.add2menu('Change fileset     ',changefileset);
  mainmenu^.pickmenu;
  dispose(mainmenu,done);
end;

Procedure Mypoprtn;
var
    prevx,prevy:byte;
begin
  prevx:=wherex;
  prevy:=wherey;

  cursoroff;
  global_filename:=fexpand('*.*');
  main;
  cursoron;

  gotoxy(prevx,prevy);
end;

begin
  if monochrome then
    begin
      foreground_attribute:=lightgray;
      background_attribute:=black+lightgray*16;
      title_attribute:=white;
    end
  else
    begin
      foreground_attribute:=white+blue*16;
      background_attribute:=blue+lightgray*16;
      title_attribute:=yellow;
    end;
stimulus:=false;
if paramcount > 0 then
   if (paramstr(1) = '/s') or
      (paramstr(1) = '/S') then
       stimulus:=true;
clrscr;
get_legal;
if not print_installed then
  begin
    writeln('PRINT.COM not installed');
    exit;
  end;
  mypoprtn;
end.