      PROGRAM Email
C----------------------------------------------------------------------
C!  -
C!
C!   Author   :- Julian J. Bunn        25-APR-1997
C!
C! The purpose of this program is to extract all messages in each
C! folder in MAIL.MAI into individual Eudora .mbx file
C?
C!======================================================================
      implicit integer (a-z)
      include '($ssdef)'
c
      mfcontext = 0
      mcontext = 0
c
c Begin mail file and open
c
      call begin_mail_file(mfcontext)
c
c Read all folders
c
      call read_folders(mfcontext)
c
c Close the mail file
c
      call close_mail_file(mfcontext)
c
c
c
      end

      subroutine read_folders(mfcontext)
      implicit integer (a-z)
      parameter (lmailfile=255,lfoldername=15,maxfolder=200)
      include '($ssdef)'
      include '($maildef)'
      common /folders/ nfolder,folder,nmess
      character*(lmailfile) mailfile
      character*(lfoldername) foldername,folder(maxfolder)
      character*255 crecord,cfrom,cto,ccc,cdate,csend,csubject
      integer nmess(maxfolder)
      external handle_folder
c
      structure /itemlist/
        integer*2 bufflen
        integer*2 itemcode
        integer*4 buffadd
        integer*4 retladd
      end structure
      record /itemlist/ in_item(4),out_item(20)
c
c get the folder names
c
      nfolder = 0
      userword = 77
      in_item(1).bufflen  = 4
      in_item(1).itemcode = mail$_mailfile_folder_routine
      in_item(1).buffadd  = %loc(handle_folder)
      in_item(1).retladd  = %loc(dummy)
      in_item(2).bufflen  = 4
      in_item(2).itemcode = mail$_mailfile_user_data
      in_item(2).buffadd  = %loc(userword)
      in_item(2).retladd  = %loc(dummy)
      in_item(3).bufflen  = 0
      in_item(3).itemcode = 0
      out_item(1).bufflen  = 0
      out_item(1).itemcode = 0
      status = mail$mailfile_info_file(mfcontext,in_item,out_item)
      if(.not.status) status=lib$signal(%val(status))
c
c Get number of messages in each folder
c
      do 1 ifold=1,nfolder
c
c set up the message context
c
         mcontext = 0
         in_item(1).bufflen  = 4
         in_item(1).itemcode = mail$_message_file_ctx
         in_item(1).buffadd  = %loc(mfcontext)
         in_item(1).retladd  = %loc(dummy)
         in_item(2).bufflen  = 0
         in_item(2).itemcode = 0
         out_item(1).bufflen  = 0
         out_item(1).itemcode = 0
         status = mail$message_begin(mcontext,in_item,out_item)
         if(.not.status) status=lib$signal(%val(status))
         foldername = folder(ifold)
         lfold = index(foldername,' ')-1
         if(lfold.eq.-1) lfold = lfoldername
         in_item(1).bufflen  = lfold
         in_item(1).itemcode = mail$_message_folder
         in_item(1).buffadd  = %loc(foldername)
         in_item(1).retladd  = %loc(dummy)
         in_item(2).bufflen  = 0
         in_item(2).itemcode = 0
         out_item(1).bufflen  = 4
         out_item(1).itemcode = mail$_message_selected
         out_item(1).buffadd = %loc(num_mess)
         out_item(1).retladd = %loc(dummy)
         out_item(2).bufflen  = 0
         out_item(2).itemcode = 0
         status = mail$message_select(mcontext,in_item,out_item)
         if(.not.status) status=lib$signal(%val(status))
         nmess(ifold) = num_mess
         write(6,*) num_mess,' Messages in ',foldername
         write(6,*) 'Creating file '//foldername(:lfold)//'.mbx'
         if(foldername(:3).eq.'c++') foldername='cpp'
         open(1,file=foldername(:lfold)//'.mbx',status='new',
     &        carriagecontrol='list',err=999)
         do imess = 1,num_mess
            in_item(1).bufflen  = 0
            in_item(1).itemcode = mail$_message_next
            in_item(1).buffadd  = 0
            in_item(1).retladd  = %loc(dummy)
            in_item(2).bufflen  = 0
            in_item(2).itemcode = 0
            out_item(1).bufflen  = 255
            out_item(1).itemcode = mail$_message_from
            out_item(1).buffadd = %loc(cfrom)
            out_item(1).retladd = %loc(lcfrom)
            out_item(2).bufflen  = 255
            out_item(2).itemcode = mail$_message_to
            out_item(2).buffadd = %loc(cto)
            out_item(2).retladd = %loc(lcto)
            out_item(3).bufflen  = 255
            out_item(3).itemcode = mail$_message_cc
            out_item(3).buffadd = %loc(ccc)
            out_item(3).retladd = %loc(lccc)
            out_item(4).bufflen  = 255
            out_item(4).itemcode = mail$_message_subject
            out_item(4).buffadd = %loc(csubject)
            out_item(4).retladd = %loc(lcsubject)
            out_item(5).bufflen  = 255
            out_item(5).itemcode = mail$_message_date
            out_item(5).buffadd = %loc(cdate)
            out_item(5).retladd = %loc(lcdate)
            out_item(6).bufflen  = 255
            out_item(6).itemcode = mail$_message_sender
            out_item(6).buffadd = %loc(csend)
            out_item(6).retladd = %loc(lcsend)
            out_item(7).bufflen  = 0
            out_item(7).itemcode = 0
            status = mail$message_get(mcontext,in_item,out_item)
            if(.not.status) status=lib$signal(%val(status))
c
c Insert the Eudora delimiter. The date doesn't matter
c
            write(1,'(a)') 'From ???@??? Tue Jan 23 18:04:27 1996'
c
c Massage the date to a form like Tue, 29 Oct 1996 14:16:20 +0100
c (call all days monday: it doesn't matter!)
c
            cdate = 'Mon, '//cdate(1:2)//' '//cdate(4:6)//' '//
     &              cdate(8:20)//' +0100'
            lcdate = 31
            
            write(1,'(a)') 'Received: ; '//cdate(:lcdate)
            write(1,'(a)') 'To: '//cto(:min(127,lcto))
            write(1,'(a)') 'Cc: '//ccc(:min(127,lccc))
c
c Massage the sender name from various VMS specific formats
c Don't bother massaging the other addresses
c
            if(csend(:6).eq.'SMTP%"') then
               csend = csend(7:)
               lcsend = index(csend,'"')-1
            else if(csend(:9).eq.'DXMINT::"') then
               csend = csend(10:)
               lcsend = index(csend,'"')-1
            else if(index(csend,'::').ne.0) then
               idp = index(csend,'::')
               csend = csend(idp+2:lcsend)//'@'//csend(:idp-1)//
     &                 '.cern.ch '
               lcsend = index(csend,' ')-1
            else if(index(csend,'@').eq.0) then
               csend = csend(:lcsend)//'@vxcern.cern.ch '
               lcsend = index(csend,' ')-1
            endif
            write(1,'(a)') 'From: '//csend(:min(125,lcsend))
            write(1,'(a)') 'Subject: '//csubject(:min(122,lcsubject))
c
c Get the records
c
            in_item(1).bufflen  = 0
            in_item(1).itemcode = mail$_message_continue
            in_item(1).buffadd  = 0
            in_item(1).retladd  = %loc(dummy)
            in_item(2).bufflen  = 0
            in_item(2).itemcode = 0
            out_item(1).bufflen  = 255
            out_item(1).itemcode = mail$_message_record
            out_item(1).buffadd = %loc(crecord)
            out_item(1).retladd = %loc(lcrecord)
            out_item(2).bufflen  = 0
            out_item(2).itemcode = 0
            nrec = 0
    2       status = mail$message_get(mcontext,in_item,out_item)
            if(status) then
               if(index(crecord(:lcrecord),':'//char(9)).ne.0) goto 2
               nrec = nrec + 1
               write(1,'(a)') crecord(:min(131,lcrecord))
               goto 2
            endif
            write(6,*) 'Mail message containing ',nrec,' records'
         end do
c
c End the message context
c
         in_item(1).bufflen  = 0
         in_item(1).itemcode = 0
         out_item(1).bufflen  = 0
         out_item(1).itemcode = 0
         status = mail$message_end(mcontext,in_item,out_item)
         if(.not.status) status=lib$signal(%val(status))
         close(1)
    1 continue
 1000 write(6,100)
      write(6,101) (nmess(i),folder(i),i=1,nfolder)
      write(6,102)
  100 format(///,26x,'Mails in Folders',26x,/,75('='))
  101 format(1x,i4,' in ',a,
     &          i4,' in ',a,
     &          i4,' in ',a)
  102 format(75('='),//)
      stop
  999 write(6,*) 'Error creating folder file'
      end

      integer function lenocc(char)
      character*(*) char
      do lenocc=len(char),1,-1
         if(char(lenocc:lenocc).ne.' ') return
      end do
      lenocc = 0
      end

      integer function handle_folder(userword,struct)
      parameter (lfoldername=15,maxfolder=200)
      include '($ssdef)'
      common /folders/ nfolder,folder,nmess
      character*(lfoldername) folder(maxfolder)
      character*1024 fname
      integer nmess(maxfolder)
      structure /descriptor/
        integer*2 length
        byte dtype
        byte dclass
        integer*4 p_data
      end structure
      record /descriptor/ struct
c
      handle_folder = ss$_normal
      len = struct.length
      if(len.le.0) return
      if(nfolder.ge.maxfolder) then
        status = lib$put_output('Maximum number of Folders exceeded')
        handle_folder = ss$_accvio
        return
      endif
      call add2val(%val(struct.p_data),fname,len)
      nfolder = nfolder + 1
      folder(nfolder) = fname(:len)
      nmess(nfolder) = 0
      end
      subroutine add2val(input,output,len)
      character*(*) output
      byte input(1024)
      do 1 i=1,len
         output(i:i) = char(input(i))
    1 continue
      end
      subroutine begin_mail_file(mfcontext)
C----------------------------------------------------------------------
C!  -
C!
C!   Author   :- Julian J. Bunn        10-APR-1991
C!
C?
C!======================================================================
      implicit integer (a-z)
      parameter (lmailfile=255)
      include '($ssdef)'
      include '($maildef)'
      character*(lmailfile) mailfile
c
      structure /itemlist/
        integer*2 bufflen
        integer*2 itemcode
        integer*4 buffadd
        integer*4 retladd
      end structure
      record /itemlist/ in_item(4),out_item(4)
c
      in_item(1).bufflen  = 0
      in_item(1).itemcode = 0
      out_item(1).bufflen  = lmailfile
      out_item(1).itemcode = mail$_mailfile_mail_directory
      out_item(1).buffadd = %loc(mailfile)
      out_item(1).retladd = %loc(lm)
      out_item(2).bufflen  = 0
      out_item(2).itemcode = 0
      status = mail$mailfile_begin(mfcontext,in_item,out_item)
      if(.not.status) status=lib$signal(%val(status))
      write(6,*) ' Mail directory ',mailfile(:lm)
c
c Open the mail file
c
      mailfile = mailfile(:lm)//'MAIL.MAI'
      lm = lm + 8
      in_item(1).bufflen  = lm
      in_item(1).itemcode = mail$_mailfile_name
      in_item(1).buffadd  = %loc(mailfile)
      in_item(1).retladd  = %loc(dummy)
      in_item(2).bufflen  = 0
      in_item(2).itemcode = 0
      out_item(1).bufflen  = 0
      out_item(1).itemcode = 0
      status = mail$mailfile_open(mfcontext,in_item,out_item)
      if(.not.status) status=lib$signal(%val(status))
      write(6,*) ' Mail file '//mailfile(:lm)//' opened'
c
      end
      subroutine close_mail_file(mfcontext)
C----------------------------------------------------------------------
C!  -
C!
C!   Author   :- Julian J. Bunn        10-APR-1991
C!
C?
C!======================================================================
      implicit integer (a-z)
      include '($ssdef)'
      include '($maildef)'
c
      structure /itemlist/
        integer*2 bufflen
        integer*2 itemcode
        integer*4 buffadd
        integer*4 retladd
      end structure
      record /itemlist/ in_item(4),out_item(4)
c
      in_item(1).bufflen  = 0
      in_item(1).itemcode = 0
      out_item(1).bufflen  = 0
      out_item(1).itemcode = 0
      status = mail$mailfile_close(mfcontext,in_item,out_item)
      if(.not.status) status=lib$signal(%val(status))
      end

