/**************************************************************************/
/*                                                                        */
/* Utility to set RexxMail folder attributes for current user             */
/*                                                                        */
/**************************************************************************/
/*                                                                        */
/* This program forms part of the RexxMail package, and may not be        */
/* distributed separately.                                                */
/*                                                                        */
/**************************************************************************/
/*                                                                        */
/* The latest version of RexxMail can be found at                         */
/*               www.degeus.com/rexx                                      */
/*                                                                        */
/**************************************************************************/
/*                                                                        */
/* This program is released under the terms of the GNU license, see       */
/*               www.gnu.org/copyleft/gpl.html                            */
/*                                                                        */
/**************************************************************************/
/*                                                                        */
/* (c) 2000-2006 Marcus de Geus                                           */
/*               marcus@degeus.com                                        */
/*               www.degeus.com                                           */
/*                                                                        */
/**************************************************************************/
/*                                                                        */
/* Use it if you like it. Don't if you don't. No legalese.                */
/*                                                                        */
/**************************************************************************/

signal on halt  /* handle halt condition */

if (\LoadRexxUtils()) then  /* if we cannot load the REXX utilities lib */
do
 call Halt  /* quit */
end

/**************************************************************************/
/* See if we can find and open the location.txt file                      */
/**************************************************************************/

parse source . . ProgSpec  /* get the program name */
ProgDir = filespec('D',ProgSpec)||filespec('P',ProgSpec)  /* get the program directory */

LocFile = ProgDir||'location.txt'  /* the name of the locations file */

if (stream(LocFile,'C','QUERY EXISTS') = '') then  /* if we cannot find the location file */
do
 call beep 333,333  /* signal */
 call lineout StdOut,'Could not find "'||LocFile||'"'  /* report */
 call Halt  /* and abort */
end

if (stream(LocFile,'C','OPEN READ') >< 'READY:') then  /* if we cannot open the location file */
do
 call beep 333,333  /* signal */
 call lineout StdOut,'Could not open "'||LocFile||'"'  /* report */
 call Halt  /* and abort */
end

/**************************************************************************/
/* Retrieve the main folder location for the current user                 */
/**************************************************************************/

parse upper arg UserName  /* get any argument */

if (UserName = '') then  /* if we have no user name */
do

 UserName = translate(value('USER',,'OS2ENVIRONMENT'))  /* get the user from the OS/2 environemnt, in upper case */

 if (UserName = '') then  /* if we still have no user name */
 do
  UserName = 'DEFAULT'  /* use the default */
 end

end

Location = ''  /* start with nothing */

do while ((Location = '') & (lines(LocFile)))  /* as long as we have no location, and there are lines left */

 NextLine = linein(LocFile)  /* get the next line */

 if (NextLine >< '') then  /* if the line is not empty */
 do

  if (substr(NextLine,1,1) >< '#') then  /* if it is not a comment */
  do

   parse upper var NextLine NextUser ' = ' Location  /* get the bits we want */

   if (strip(NextUser) >< UserName) then  /* if this is not the right user */
   do
    Location = ''  /* clear the location variable to continue the loop */
   end

  end

 end

end

call stream LocFile,'C','CLOSE'  /* close the locations file */
Location = strip(Location)  /* remove excess whitespace */

if (Location = '') then  /* if we found no location */
do
 call lineout StdOut,'No location found for user "'||UserName||'"'  /* report */
 call Usage  /* and tell 'em how to do it */
end

/**************************************************************************/
/* Get user input                                                         */
/**************************************************************************/

GoBack = 0  /* no need to go back yet */

do until (GoBack)  /* go on until the user quits */

 call ClearScreen  /* clear the screen */
 call lineout StdOut,'  Main RexxMail folder for user "'||UserName||'" = "'||Location||'"'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'  Select one of the following for more information:'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'    1  Lock/unlock'  /* info */
 call lineout StdOut,'    2  Hide/show'  /* info */
 call lineout StdOut,'    3  Background'  /* info */
 call lineout StdOut,'    4  Font'  /* info */
 call lineout StdOut,'    5  Icons'  /* info */
 call lineout StdOut,'    6  Sort class'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'    0  Quit'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,''  /* empty line */
 call charout StdOut,'  Action [1/L/2/H/3/B/4/F/5/I/6/S/0/Q] : Q'||d2c(8)  /* user prompt */
 Reply = sysgetkey('ECHO')  /* get the user's reply */

 select  /* do one of the following */

  when (pos(Reply,'1Ll') > 0) then  /* if the reply is one of these */
  do
   call DoLockUnlock Location  /* tell the user how */
  end

  when (pos(Reply,'2Hh') > 0) then  /* if the reply is one of these */
  do
   call DoHideShow Location  /* tell the user how */
  end

  when (pos(Reply,'3Bb') > 0) then  /* if the reply is one of these */
  do
   call DoBackground Location,ProgDir  /* tell the user how */
  end

  when (pos(Reply,'4Ff') > 0) then  /* if the reply is one of these */
  do
   call DoFont Location  /* tell the user how */
  end

  when (pos(Reply,'5Ii') > 0) then  /* if the reply is one of these */
  do
   call DoIcons Location,ProgDir  /* tell the user how */
  end

  when (pos(Reply,'6Ss') > 0) then  /* if the reply is one of these */
  do
   call DoSort Location  /* tell the user how */
  end

  when (pos(Reply,'0Qq'||d2c(13)||d2c(27)) > 0) then  /* if the reply is one of these */
  do
   GoBack = 1  /* go back, i.e. quit */
  end

  otherwise  /* if the reply is none of the above */
  do
   nop  /* do nothing */
  end

 end

end

call Halt  /* that's all, folks! */

/**************************************************************************/
DoLockUnlock: procedure  /* locks or unlocks folders */
/**************************************************************************/

parse arg Location  /* get the argument */

GoBack = 0  /* do not go back yet */

do until (GoBack)  /* go on until the user quits */

 call ClearScreen  /* clear the screen */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'  Select one of the following for more information:'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'    1  Lock user folders'  /* info */
 call lineout StdOut,'    2  Unlock user folders'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'    0  Quit'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,''  /* empty line */
 call charout StdOut,'  Action [1/L/2/U/0/Q] : Q'||d2c(8)  /* user prompt */
 Reply = sysgetkey('ECHO')  /* get the user's reply */

 select  /* do one of the following */

  when (pos(Reply,'1Ll') > 0) then  /* if the reply is one of these */
  do
   call DoLock Location  /* tell the user how to */
  end

  when (pos(Reply,'2Uu') > 0) then  /* if the reply is one of these */
  do
   call DoUnlock Location  /* tell the user how to */
  end

  when (pos(Reply,'0Qq'||d2c(13)||d2c(27)) > 0) then  /* if the reply is one of these */
  do
   GoBack = 1  /* go back, i.e. quit */
  end

  otherwise  /* if the reply is none of the above */
  do
   nop  /* do nothing */
  end

 end

end

return  /* end of DoLockUnlock */

/**************************************************************************/
DoHideShow: procedure  /* hides or Shows folders */
/**************************************************************************/

parse arg Location  /* get the argument */

GoBack = 0  /* do not go back yet */

do until (GoBack)  /* go on until the user quits */

 call ClearScreen  /* clear the screen */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'  Select one of the following for more information:'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'    1  Hide user folders'  /* info */
 call lineout StdOut,'    2  Show user folders'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'    0  Quit'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,''  /* empty line */
 call charout StdOut,'  Action [1/H/2/S/0/Q] : Q'||d2c(8)  /* user prompt */
 Reply = sysgetkey('ECHO')  /* get the user's reply */

 select  /* do one of the following */

  when (pos(Reply,'1Hh') > 0) then  /* if the reply is one of these */
  do
   call DoHide Location  /* tell the user how to */
  end

  when (pos(Reply,'2Ss') > 0) then  /* if the reply is one of these */
  do
   call DoShow Location  /* tell the user how to */
  end

  when (pos(Reply,'0Qq'||d2c(13)||d2c(27)) > 0) then  /* if the reply is one of these */
  do
   GoBack = 1  /* go back, i.e. quit */
  end

  otherwise  /* if the reply is none of the above */
  do
   nop  /* do nothing */
  end

 end

end

return  /* end of DoHideShow */

/**************************************************************************/
DoBackground: procedure  /* set background */
/**************************************************************************/

parse arg Location,ProgDir  /* get the argument */

GoBack = 0  /* do not go back yet */

do until (GoBack)  /* go on until the user quits */

 call ClearScreen  /* clear the screen */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'  Select one of the following for more information:'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'    1  Bitmap background'  /* info */
 call lineout StdOut,'    2  System default background'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'    0  Quit'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,''  /* empty line */
 call charout StdOut,'  Action [1/B/2/S/0/Q] : Q'||d2c(8)  /* user prompt */
 Reply = sysgetkey('ECHO')  /* get the user's reply */

 select  /* do one of the following */

  when (pos(Reply,'1Bb') > 0) then  /* if the reply is one of these */
  do
   call DoBitmap Location,ProgDir  /* tell the user how to */
  end

  when (pos(Reply,'2Ss') > 0) then  /* if the reply is one of these */
  do
   call DoSystem Location  /* tell the user how to */
  end

  when (pos(Reply,'0Qq'||d2c(13)||d2c(27)) > 0) then  /* if the reply is one of these */
  do
   GoBack = 1  /* go back, i.e. quit */
  end

  otherwise  /* if the reply is none of the above */
  do
   nop  /* do nothing */
  end

 end

end

return  /* end of DoBackground */

/**************************************************************************/
DoFont: procedure  /* set font */
/**************************************************************************/

parse arg Location  /* get the argument */

GoBack = 0  /* do not go back yet */

do until (GoBack)  /* go on until the user quits */

 call ClearScreen  /* clear the screen */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'  Select one of the following for more information:'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'    1  Warp Sans'  /* info */
 call lineout StdOut,'    2  Proportional'  /* info */
 call lineout StdOut,'    3  Monospaced'  /* info */
 call lineout StdOut,'    4  VIO'  /* info */
 call lineout StdOut,'    5  Other'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'    0  Quit'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,''  /* empty line */
 call charout StdOut,'  Action [1/W/2/V/3/P/4/M/5/O/0/Q] : Q'||d2c(8)  /* user prompt */
 Reply = sysgetkey('ECHO')  /* get the user's reply */

 select  /* do one of the following */

  when (pos(Reply,'1Ww') > 0) then  /* if the reply is one of these */
  do
   call DoWarpSans Location  /* tell the user how to */
  end

  when (pos(Reply,'2Pp') > 0) then  /* if the reply is one of these */
  do
   call DoProportional Location  /* tell the user how to */
  end

  when (pos(Reply,'3Mm') > 0) then  /* if the reply is one of these */
  do
   call DoMonospaced Location  /* tell the user how to */
  end

  when (pos(Reply,'4Vv') > 0) then  /* if the reply is one of these */
  do
   call DoVIO Location  /* tell the user how to */
  end

  when (pos(Reply,'5Oo') > 0) then  /* if the reply is one of these */
  do
   call DoOther Location  /* tell the user how to */
  end

  when (pos(Reply,'0Qq'||d2c(13)||d2c(27)) > 0) then  /* if the reply is one of these */
  do
   GoBack = 1  /* go back, i.e. quit */
  end

  otherwise  /* if the reply is none of the above */
  do
   nop  /* do nothing */
  end

 end

end

return  /* end of DoFont */

/**************************************************************************/
DoSort: procedure  /* sets the sort class */
/**************************************************************************/

parse arg Location  /* get the argument */

GoBack = 0  /* do not go back yet */

do until (GoBack)  /* go on until the user quits */

 call ClearScreen  /* clear the screen */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'  Select one of the following for more information:'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'    1  Extended sort class (CWMailFile)'  /* info */
 call lineout StdOut,'    2  Default sort class (WPFileSystem)'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'    0  Quit'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,''  /* empty line */
 call charout StdOut,'  Action [1/L/2/U/0/Q] : Q'||d2c(8)  /* user prompt */
 Reply = sysgetkey('ECHO')  /* get the user's reply */

 select  /* do one of the following */

  when (pos(Reply,'1Ee') > 0) then  /* if the reply is one of these */
  do
   call DoExtendedSort Location  /* tell the user how to */
  end

  when (pos(Reply,'2Dd') > 0) then  /* if the reply is one of these */
  do
   call DoDefaultSort Location  /* tell the user how to */
  end

  when (pos(Reply,'0Qq'||d2c(13)||d2c(27)) > 0) then  /* if the reply is one of these */
  do
   GoBack = 1  /* go back, i.e. quit */
  end

  otherwise  /* if the reply is none of the above */
  do
   nop  /* do nothing */
  end

 end

end

return  /* end of DoSort */

/**************************************************************************/
DoLock: procedure  /* locks folders */
/**************************************************************************/

parse arg Location  /* get the argument */

call ClearScreen  /* clear the screen */
call lineout StdOut,'  This option will set the attributes of the main folder and its subfolders'  /* report */
call lineout StdOut,'  to prevent their being copied, deleted, dragged, moved, or shadowed.'  /* report */
call lineout StdOut,'  Also, folder properties notebooks will become inaccessible, and objects'  /* report */
call lineout StdOut,'  cannot be dropped on these folders, with the exception of mail folders.'  /* report */
call lineout StdOut,''  /* report */
call lineout StdOut,'  Note that this applies only to WPS operations; command-line operations are'  /* report */
call lineout StdOut,'  not affected.'  /* report */

if (\UserQuery('Lock main folder and subfolders?')) then  /* if we do not get the go-ahead */
do
 return 0  /* quit */
end

BaseSettings = 'NODELETE=YES;'||,  /* include the NoDelete setting */
               'NOSETTINGS=YES;'||,  /* and NoSettings */
               'NOSHADOW=YES;'||,  /* and NoShadow */
               'NOCOPY=YES;'||,  /* and NoCopy */
               'NOMOVE=YES;'  /* and NoMove */

call sysfiletree Location||'\*','Folders.','DO'  /* look for folders in the main folder */

do Number = 1 to Folders.0  /* take each one we find */

 RxMlDirName = translate(getRxMlName(Folders.Number))  /* get the RexxMail dir name, if any, and make it upper case */
 
 select  /* do one of the following */

  when (wordpos(RxMlDirName,'DRAFTS IN IN_ARCHIVE OUT OUT_ARCHIVE') > 0) then  /* if it is one of these */
  do
   call syssetobjectdata Folders.Number,BaseSettings||'NODRAG=YES;'  /* process it */
  end

  when (wordpos(RxMlDirName,'ACCESSORIES ADDRESSES CONFIGURATION TEMP') > 0) then  /* if it is one of these */
  do
   call syssetobjectdata Folders.Number,BaseSettings||'NODRAG=YES;'||'NODROP=YES;'  /* process it */
  end

  otherwise  /* if it is none of the above */
  do
   call syssetobjectdata Folders.Number,BaseSettings  /* process it */
  end

 end

end

call syssetobjectdata Location,BaseSettings||'NODRAG=YES;'||'NODROP=YES;'  /* process the main folder */

return 1  /* end of DoLock */

/**************************************************************************/
DoUnlock: procedure  /* unlocks folders */
/**************************************************************************/

parse arg Location  /* get the argument */

call ClearScreen  /* clear the screen */
call lineout StdOut,'  This option will set the attributes of the main folder and its subfolders'  /* report */
call lineout StdOut,'  to allow their being copied, deleted, dragged, moved, or shadowed.'  /* report */
call lineout StdOut,'  Also, folder properties notebooks will become accessible, and objects'  /* report */
call lineout StdOut,'  can be dropped into these folders.'  /* report */
call lineout StdOut,''  /* report */
call lineout StdOut,'  Note that this applies only to WPS operations; command-line operations are'  /* report */
call lineout StdOut,'  not affected.'  /* report */

if (\UserQuery('Unlock main folder and subfolders?')) then  /* if we do not get the go-ahead */
do
 return 0  /* quit */
end

Settings = 'NODELETE=NO;'||,  /* include the NoDelete setting for the next bunch of folders */
           'NOSETTINGS=NO;'||,  /* and NoSettings */
           'NORENAME=NO;'||,  /* and NoRename */
           'NOSHADOW=NO;'||,  /* and NoShadow */
           'NOCOPY=NO;'||,  /* and NoCopy */
           'NOMOVE=NO;'||,  /* and NoMove */
           'NODRAG=NO;'||,  /* and NoDrag */
           'NODROP=NO;'  /* and NoDrop */

call syssetobjectdata Location,Settings  /* process the main folder */
call sysfiletree Location||'\*','Folders.','DOS'  /* look for (sub)folders in the main folder */

do Number = 1 to Folders.0  /* take each one we find */
 call syssetobjectdata Folders.Number,Settings  /* and process it */
end

return 1  /* end of DoUnlock */

/**************************************************************************/
DoHide: procedure  /* makes folders invisible */
/**************************************************************************/

parse arg Location  /* get the argument */

call ClearScreen  /* clear the screen */
call lineout StdOut,'  This option will make the folder objects in the main user folder invisible,'  /* report */
call lineout StdOut,'  with the exception of the Accessories folder.'  /* report */
call lineout StdOut,''  /* report */
call lineout StdOut,'  Note that this applies only to WPS operations; command-line operations are'  /* report */
call lineout StdOut,'  not affected.'  /* report */
call lineout StdOut,''  /* report */
call lineout StdOut,'  If you have not already done so, you may first want to create a shadow of'  /* report */
call lineout StdOut,'  the Configuration folder in the Accessories folder for easier access.'  /* report */

if (\UserQuery('Make folder objects in main folder invisible?')) then  /* if we do not get the go-ahead */
do
 return 0  /* quit */
end

call ShowHide Location,'YES'  /* hide them */

return 1  /* end of DoHide */

/**************************************************************************/
DoShow: procedure  /* makes folders visible */
/**************************************************************************/

parse arg Location  /* get the argument */

call ClearScreen  /* clear the screen */
call lineout StdOut,'  This option will make the folder objects in the main user folder visible.'  /* report */
call lineout StdOut,''  /* report */
call lineout StdOut,'  Note that this applies only to WPS operations; command-line operations are'  /* report */
call lineout StdOut,'  not affected.'  /* report */

if (\UserQuery('Make folder objects in main folder visible?')) then  /* if we do not get the go-ahead */
do
 return 0  /* quit */
end

call ShowHide Location,'NO'  /* show them */

return 1  /* end of DoShow */

/**************************************************************************/
DoBitmap: procedure  /* sets bitmap background */
/**************************************************************************/

parse arg Location,ProgDir  /* get the argument */

GoBack = 0  /* no need to go back yet */

do until (GoBack)  /* go on until the user quits */

 call ClearScreen  /* clear the screen */
 call lineout StdOut,'  This option sets the background of the user folders to'  /* report */
 call lineout StdOut,'  '||ProgDir||'Icons\Folders\FolderBG.BMP'  /* report */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'  Select one of the following:'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'    1  Single bitmap background'  /* info */
 call lineout StdOut,'    2  Tiled bitmap background'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,'    0  Quit'  /* info */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,''  /* empty line */
 call charout StdOut,'  Action [1/S/2/T/0/Q] : Q'||d2c(8)  /* user prompt */
 Reply = sysgetkey('ECHO')  /* get the user's reply */

 select  /* do one of the following */

  when (pos(Reply,'1Ss') > 0) then  /* if the reply is one of these */
  do
   call SetBackground Location,ProgDir,'N'  /* do it */
   GoBack = 1  /* and quit */
  end

  when (pos(Reply,'2Tt') > 0) then  /* if the reply is one of these */
  do
   call SetBackground Location,ProgDir,'T'  /* do it */
   GoBack = 1  /* and quit */
  end

  when (pos(Reply,'0Qq'||d2c(13)||d2c(27)) > 0) then  /* if the reply is one of these */
  do
   GoBack = 1  /* go back, i.e. quit */
  end

  otherwise  /* if the reply is none of the above */
  do
   nop  /* do nothing */
  end

 end

end

return  /* end of DoBitmap */

/**************************************************************************/
DoSystem: procedure  /* sets system default folder background */
/**************************************************************************/

parse arg Location  /* get the argument */

call ClearScreen  /* clear the screen */
call lineout StdOut,'  This option sets the background of the user folders to the system default.'  /* report */
call SetBackground Location  /* do it */

return  /* end of DoSystem */

/**************************************************************************/
DoWarpSans: procedure  /* sets Warp Sans text font */
/**************************************************************************/

parse arg Location  /* get the argument */

call ClearScreen  /* clear the screen */
call lineout StdOut,'  This option sets the folder text font to 9 pt. Warp Sans.'  /* report */
call SetTextFont Location,'9.WarpSans'  /* do it */

return  /* end of DoWarpSans */

/**************************************************************************/
DoProportional: procedure  /* sets System Proportional text font */
/**************************************************************************/

parse arg Location  /* get the argument */

call ClearScreen  /* clear the screen */
call lineout StdOut,'  This option sets the folder text font to 10 pt. System Proportional.'  /* report */
call SetTextFont Location,'10.System Proportional'  /* do it */

return  /* end of DoProportional */

/**************************************************************************/
DoMonospaced: procedure  /* sets System Monospaced text font */
/**************************************************************************/

parse arg Location  /* get the argument */

call ClearScreen  /* clear the screen */
call lineout StdOut,'  This option sets the folder text font to 10 pt. System Monospaced.'  /* report */
call SetTextFont Location,'10.System Monospaced'  /* do it */

return  /* end of DoMonospaced */

/**************************************************************************/
DoVIO: procedure  /* sets System VIO font */
/**************************************************************************/

parse arg Location  /* get the argument */

GoBack = 0  /* no need to go back yet */

do until (GoBack)  /* go on until the user quits */

 call ClearScreen  /* clear the screen */
 call lineout StdOut,'  This option sets the folder text font to System VIO.'  /* report */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,''  /* empty line */
 call charout StdOut,'  Please enter the font size (2-18, or none to quit): '  /* info */
 parse pull FontSize  /* geth user input */

 select  /* do one of the following */

  when (datatype(FontSize,'W')) then  /* if the reply is a whole number */
  do

   if ((FontSize > 1) & (FontSize < 19)) then  /* if the reply is in the right range */
   do
    call SetTextFont Location,FontSize||'.System VIO'  /* do it */
    GoBack = 1  /* and quit */
   end

  end

  when (FontSize = '') then  /* if the reply is nothing */
  do
   GoBack = 1  /* quit */
  end

  otherwise  /* if the reply is none of the above */
  do
   nop  /* do nothing */
  end

 end

end

return  /* end of DoVIO */

/**************************************************************************/
DoOther: procedure  /* sets user-defined text font */
/**************************************************************************/

parse arg Location  /* get the argument */

GoBack = 0  /* no need to go back yet */

do until (GoBack)  /* go on until the user quits */

 call ClearScreen  /* clear the screen */
 call lineout StdOut,'  This option sets the folder text font to a user-defined value.'  /* report */
 call lineout StdOut,''  /* empty line */
 call lineout StdOut,''  /* empty line */
 call charout StdOut,'  Please enter the font definition (e.g. "10. Helvetica"): '  /* info */
 parse pull FontSize  /* get user input */
 parse var FontSize FontSize '.' FontName  /* get the components */

 select  /* do one of the following */

  when (datatype(FontSize,'W')) then  /* if the font size at least is a whole number, we have a chance of success */
  do
   call SetTextFont Location,FontSize||'.'||strip(FontName)  /* do it */
   GoBack = 1  /* and quit */
  end

  when (FontSize = '') then  /* if the reply is nothing, we want the system default font */
  do
   GoBack = 1  /* quit */
  end

  otherwise  /* if the reply is none of the above */
  do
   nop  /* do nothing */
  end

 end

end

return  /* end of DoOther */

/**************************************************************************/
DoIcons: procedure  /* sets folder icons */
/**************************************************************************/

parse arg Location,ProgDir  /* get the arguments */

call ClearScreen  /* clear the screen */
call lineout StdOut,'  This option sets the mail folders to use the icon files in'  /* report */
call lineout StdOut,'  '||ProgDir||'Icons\Folders'  /* report */
call lineout StdOut,'  Note that any unread mail folder icons will be reset.'  /* report */

if (\UserQuery('Set mail folder icons?')) then  /* if we do not get the user's permission */
do
 return 0  /* quit */
end

call syssetobjectdata Location,'ICONFILE='||ProgDir||'Icons\Folders\Main_0.ICO'  /* set the closed icon */
call syssetobjectdata Location,'ICONNFILE=1,'||ProgDir||'Icons\Folders\Main_1.ICO'  /* set the open icon */
call sysfiletree Location||'\*','Folders.','DO'  /* look for the main subfolders */

do Index = 1 to Folders.0  /* for each one we found */

 RxMlDirName = translate(GetRxMlName(Folders.Index))  /* get the RexxMail dir name in upper case */
 call syssetobjectdata Folders.Index,'ICONFILE='||ProgDir||'Icons\Folders\'||RxMlDirName||'_0.ICO'  /* set the closed icon */
 call syssetobjectdata Folders.Index,'ICONNFILE=1,'||ProgDir||'Icons\Folders\'||RxMlDirName||'_1.ICO'  /* set the open icon */

 select  /* do one of the following */

  when (RxMlDirName = 'CONFIGURATION') then  /* if it is this one */
  do
   call syssetobjectdata Folders.Index||'\lists','ICONFILE='||ProgDir||'Icons\Folders\Lists_0.ICO'  /* set the closed icon */
   call syssetobjectdata Folders.Index||'\lists','ICONNFILE=1,'||ProgDir||'Icons\Folders\Lists_1.ICO'  /* set the open icon */
  end

  when (wordpos(RxMlDirName,'IN_ARCHIVE OUT_ARCHIVE') > 0) then  /* if it is one of these */
  do

   call sysfiletree Folders.Index||'\*','Subfolders.','DOS'  /* look for subfolders */

   do SubIndex = 1 to Subfolders.0  /* for each one we found */
    call syssetobjectdata Subfolders.SubIndex,'ICONFILE='||ProgDir||'Icons\Folders\Normal_0.ICO'  /* set the closed icon */
    call syssetobjectdata Subfolders.SubIndex,'ICONNFILE=1,'||ProgDir||'Icons\Folders\Normal_1.ICO'  /* set the open icon */
   end

  end

  otherwise  /* if none of the above */
  do
   call syssetobjectdata Folders.Index,'ICONFILE='  /* reset the closed icon */
   call syssetobjectdata Folders.Index,'ICONNFILE=1,'  /* reset the open icon */
  end

 end

end

return 1  /* end of DoIcons */

/**************************************************************************/
DoExtendedSort: procedure  /* sets CWMailFile sort class */
/**************************************************************************/

parse arg Location  /* get the argument */

call ClearScreen  /* clear the screen */
call lineout StdOut,'  This option sets the folder sort class to CWMailFile.'  /* report */

if (\UserQuery('Set folder sort class to CWMailFile?')) then  /* if we do not get the user's permission */
do
 return 0  /* quit */
end

GotCWMFC = 0  /* we have no CWMailFile class yet */
call sysqueryclasslist('ClassList.')  /* get the class list */

do Index = 1 to ClassList.0  /* look at each entry */

 if (word(ClassList.Index,1) = 'CWMailFile') then  /* if it is what we want */
 do
  GotCWMFC = 1  /* we have a CWMailFile class */
 end

end

if (\GotCWMFC) then  /* if the CWMailFile class is not registered */
do
 call beep 333,333  /* signal */
 call lineout StdOut,'  Please register the CWMailFile class before using this option.'  /* report */
 call lineout StdOut,'  Press [Enter] to continue'  /* report */
 pull  /* wait for [Enter] */
end
else  /* if all is well */
do

 call sysfiletree Location||'\*','Folders.','DOS'  /* look for the mail folder(s) */

 do Index = 1 to Folders.0  /* for each one we found */

  if (\syssetobjectdata(Folders.Index,'DETAILSCLASS=CWMailFile;SORTCLASS=CWMailFile')) then  /* if we cannot set the class */
  do
   call lineout StdOut,'  Error processing "'||Folders.Index||'"'  /* report failure */
   call lineout StdOut,'  Press [Enter] to continue'  /* report */
   pull  /* wait for [Enter] */
  end

 end

end

return 1  /* end of DoExtendedSort */

/**************************************************************************/
DoDefaultSort: procedure  /* sets CWMailFile sort */
/**************************************************************************/

parse arg Location  /* get the argument */

call ClearScreen  /* clear the screen */
call lineout StdOut,'  This option sets folder sort class to WPFileSystem.'  /* report */

if (\UserQuery('Set folder sort class to WPFileSystem?')) then  /* if we do not get the user's permission */
do
 return 0  /* quit */
end

call sysfiletree Location||'\*','Folders.','DOS'  /* look for the folder(s) */

do Index = 1 to Folders.0  /* for each one we found */

 if (\syssetobjectdata(Folders.Index,'DETAILSCLASS=WPFileSystem;SORTCLASS=WPFileSystem;DEFAULTSORT=0')) then  /* if we cannot set the class */
 do
  call lineout StdOut,'  Error processing "'||Folders.Index||'"'  /* report failure */
  call lineout StdOut,'  Press [Enter] to continue'  /* report */
  pull  /* wait for [Enter] */
 end

end

return 1  /* end of DoDefaultSort */

/**************************************************************************/
SetTextFont: procedure  /* sets the mail folder text font */
/**************************************************************************/

parse arg Location,FontSize  /* get the arguments */

if (\UserQuery('Set folder text font to '||FontSize||'?')) then  /* if we do not get the user's permission */
do
 return 0  /* quit */
end

call ProcessFolders Location,'ICONFONT='||FontSize||';TREEFONT='||FontSize||';DETAILSFONT='||FontSize  /* do it */

return 1  /* end of SetTextFont */

/**************************************************************************/
SetBackGround: procedure  /* sets the user folder background */
/**************************************************************************/

parse arg Location,ProgDir,Action  /* get the arguments */

if (Action = '') then  /* if we have no action parameter */
do
 Settings = 'BACKGROUND=,,,,'  /* no background parameters */
 Message = 'Set user folder background to system default?'  /* what to show */
end
else  /* if we have an action parameter */
do
 Settings = 'BACKGROUND='||ProgDir||'icons\folders\mail_background.bmp,'||Action||',,I,255 255 255'  /* use these parameters */
 BMType = word('single tiled',pos(Action,'NT'))  /* get the right bitmap type message string */
 Message = 'Set user folder background to '||BMType||' bitmap?'  /* what to show */
end

if (\UserQuery(Message)) then  /* if we do not get the user's permission */
do
 return 0  /* quit */
end

call ProcessFolders Location,Settings  /* do it */

return 1  /* end of SetBackGround */

/**************************************************************************/
ShowHide: procedure  /* does the actual hiding/showing */
/**************************************************************************/

parse arg Location,Action  /* get the arguments */

Settings = 'NOTVISIBLE='||Action||';'  /* the setting to use */
call sysfiletree Location||'\*','Folders.','DO'  /* look for folders in the main folder */

do Number = 1 to Folders.0  /* take each one we find */

 if (GetRxMlName(Folders.Number) >< 'ACCESSORIES') then  /* unless it is the Accessories folder */
 do
  call syssetobjectdata Folders.Number,Settings  /* process it */
 end

end

return  /* end of ShowHide */

/**************************************************************************/
ProcessFolders: procedure  /* processes folder settings */
/**************************************************************************/

parse arg Location,Settings  /* get the arguments */

call syssetobjectdata Location,Settings  /* process the main folder */
call sysfiletree Location||'\*','Folders.','DOS'  /* look for (sub)folders in the main folder */

do Number = 1 to Folders.0  /* take each one we find */
 call syssetobjectdata Folders.Number,Settings  /* process the folder */
end

return  /* end of ProcessFolders */

/**************************************************************************/
UserQuery: procedure expose Global.  /* get a reply from the user */
/**************************************************************************/

parse arg Prompt  /* get the argument */

call lineout StdOut,''  /* start a new line */
call lineout StdOut,''  /* start a new line */
call charout StdOut,'  '||Prompt||' [Y/N] Y'||d2c(8)  /* user prompt */
Reply = (pos(sysgetkey('ECHO'),'Yy+'||d2c(13)) > 0)  /* affirmative = 1 */

return Reply  /* end of UserQuery */

/**************************************************************************/
ClearScreen: procedure expose Global.  /* clears the screen ("syscls" does not preserve screen colours) */
/**************************************************************************/

ScreenSize = systextscreensize()  /* get the screen dimensions */
ScreenRows = word(ScreenSize,1)  /* the screen height */
ScreenCols = word(ScreenSize,2)  /* the screen width */

do Index = 1 to ScreenRows  /* for each row on the screen */
 call syscurpos Index,0  /* move to the row start */
 call charout StdOut,copies(' ',ScreenCols)  /* clear the line */
end

call syscurpos 0,0  /* move to the top left-hand corner of the screen */
call charout StdOut,copies('_',ScreenCols)  /* low line */
call lineout StdOut,'  RexxMail User Folders Utility'  /* screen info */
call charout StdOut,copies('î',ScreenCols)  /* high line */
call lineout StdOut,''  /* empty line */

return 1  /* end of ClearScreen */

/**************************************************************************/
LoadRexxUtils: procedure expose Global.  /* loads REXX utility functions if necessary */
/**************************************************************************/

if (rxfuncquery('SysLoadFuncs') >< 0) then  /* if we have to load the REXX utility functions */
do

 if (rxfuncadd('SysLoadFuncs','RexxUtil','SysLoadFuncs') = 0) then  /* if we can register the general loading function */
 do
  call sysloadfuncs  /* call the general loading function */
 end
 else  /* if we cannot register the general loading function */
 do
  Message = '  ERROR: Cannot load Rexx utility functions.'  /* report */
  call WriteLog Global.LogFile,Message  /* report */
  return 0  /* no success */
 end

end

return 1  /* end of LoadRexxUtils */

/**************************************************************************/
GetRxMlName: procedure expose Global.  /* gets the rxmldirname extended attribute from an object */
/**************************************************************************/

parse arg Object  /* get the argument */

call sysgetea Object,'RXMLDIRNAME','EAString'  /* get the EA */
OutText = ''  /* nothing yet */

if (EAString >< '') then  /* if we actually found something */
do

 parse var EAString EAType 3 EARest  /* get the bits we want */

 if (EAType = 'DFFF'x) then  /* if it is a multiple value, multiple type entry */
 do
  parse var EARest . 3 Lines 5 EAString  /* get the stuff we want */
  Lines = c2d(reverse(Lines))  /* extract the number of comment lines */
 end
 else  /* if not, it must be simple ASCII */
 do
  Lines = 1  /* we have just one line to extract */
 end

 do Lines  /* take each line entry */

  parse var EAString EAType 3 EALength 5 EAString  /* get the bits we want */

  if (EAType = 'FDFF'x) then  /* if it is ASCII text (which it should be) */
  do

   EALength = c2d(reverse(EALength))  /* get the length of the next line */
   parse var EAString EAText +(EALength) EAString  /* get the bits we want */
   OutText = OutText||EAText  /* add the text to what we have */

   if (EAString >< '') then  /* if there is more */
   do
    OutText = OutText||Global.!CRLF  /* add a CRLF */
   end

  end
  else  /* if it is not ASCII */
  do
   say 'Invalid extended attribute '||EAType||' from "'||Object||'"'  /* report */
   return ''  /* return no success */
  end

 end

end

return OutText  /* end of GetRxMlName */

/**************************************************************************/
Usage:  /* we end up here */
/**************************************************************************/

call lineout StdOut,'Usage : MailLock [username]'  /* show them how to do it */

/**************************************************************************/
Halt:  /* we end up here */
/**************************************************************************/

exit  /* and exit */
