小物ソフト

/* NetNews Title set */
/* 99.5.11 ori      *//*
   葉山さんのプログラムのパクリ (^^;
original: http://hp.vector.co.jp/authors/VA009797/rexx/index.html

ホントは, 行区切りは RFC では 0x0d0a のはず
*/
options 'ETmode'
True = 1; False = 0;
nl = '0d0a'x

call RxFuncAdd 'SysLoadFuncs', 'rexxutil', 'SysLoadFuncs'
call SysLoadFuncs
call rxfuncadd 'RxJisLoadFuncs', 'RXJIS', 'RxJisLoadFuncs'
call RxJisLoadFuncs

parse value 'ffdf'x 'fffd'x with EAT_MVMT EAT_Asc
eaname = '.Comments'

parse arg Args
if left(Args, 1) == '"'
   then parse var Args ch +1 fname(ch)
   else parse var Args fname .

if fname = '' then Rc = ErrExit('ファイル名を指定して下さい。')
text = charin(fname,, chars(fname))
call stream fname, 'c', 'close'
text = ChangeStr(   nl, text, '0a'x)
text = ChangeStr('0d'x, text, '0a'x)
text = '0a'x''RxJisMimeJisTo(text)

p = pos('0a'x'SUBJECT:', translate(text))
if p == 0 then Rc = ErrExit('Subject が見つからない。('fname', Len='length(text)')')
parse var text =(p)':'str '0a'x res '0a0a'x
str = strip(str)
do while length(res) > 0 & pos(left(res, 1), '09'x' ') > 0
   parse var res txt '0a'x res
   str = str''strip(translate(txt,, '09'x))
end

val = reverse(EAT_Asc)d2li(length(str))str
Rc = SysGetEA(fname, eaname, 'org')
if org \= '' then do
   parse var org chk +4 cnt +2 org
   if chk \== reverse(EAT_MVMT)'0000'x then Rc = ErrExit('対応していない形式です。')
   if pos(val, org) > 0 then Rc = ErrExit('すでに設定されています。')
   cnt = li2d(cnt)
end
else cnt = 0
val = reverse(EAT_MVMT)x2c('0000')d2li(cnt +1)val''org
Rc = SysPutEA(fname, eaname, val)
if Rc == 0 then say fname'の' eaname'に "'str'"を設定しました。'
exit

ErrExit: say arg(1)
exit

d2li: d2ii: return reverse(d2c(arg(1), word(arg(2) 2, 1)));
li2d: ii2d: return c2d(reverse(arg(1)), word(arg(2) 4, 1));

ChangeStr:procedure   /* from ORexx */
   parse arg needle,haystack,newneedle
   result=''
   tempx=1
   do forever
      tempy=pos(needle,haystack,tempx)
      if tempy=0 then leave
      result=result||substr(haystack,tempx,tempy-tempx)||newneedle
      tempx=tempy+length(needle)
   end
   result=result||substr(haystack,tempx)
return result

/*   =================================
 *      Base64 デコード
 *      (参考元は generic.erx)
 *       99.12.28 by ori
 *   =================================
 */
options 'etmode'
call rxfuncadd 'RxJisLoadFuncs', 'RXJIS', 'RxJisLoadFuncs'
call RxJisLoadFuncs

'extract /getmark/filename'
if getmark.0 > 0 then 'dokey a+Y'   /* Move to beginning of mark, even if in a different file. */
oldfilename = filename.1
'extract /last/autosave/line/filename'
call etksetfilefield 'autosave', 0   /* Turn off autosaving... */
if getmark.0 > 0 then do
   firstline = getmark.1
   lastline = getmark.2
   marked = 'marked lines'
   if filename.1 \= oldfilename then
      'sayerror Working on marked area in' filename.1 '...'
   else
      'sayerror Working on marked area...'
end
else do
   firstline = 1
   lastline = last.1
   marked = ''
   'sayerror Working on file...'
end
limit = lastline -firstline +1

tpath = value('TEMP',, 'OS2ENVIRONMENT')
if tpath == '' then tpath = value('TMP',, 'OS2ENVIRONMENT')
if DBRight(tpath, 1) \== '\' then tpath = tpath'\'

BaseChars = xrange('A', 'Z')xrange('a', 'z')xrange('0', '9')'+/='
cnt = 0
do i = firstline to lastline         /* For every line in the file or mark, */
   call etksetfilefield 'line', i    /* make that line the current line */
   'extract /getline'
   j = i -firstline +1
   if j // 50 = 0 then
      'sayerror Processed' j 'lines of' limit marked
   if verify(getline.1, BaseChars) \== 0 then iterate
   if getline.1 == '' then iterate

   text = strip(getline.1)
   do i = i +1 to lastline
      call etksetfilefield 'line', i
      'extract /getline'
      j = i -firstline +1
      if j // 50 = 0 then
         'sayerror Processed' j 'lines of' limit marked
      if verify(getline.1, BaseChars) \== 0 then leave
      if getline.1 == '' then leave
      text = text ||strip(getline.1)
   end
   cnt = cnt +1
   bin.cnt = RxJisBase64To(text)
end
do i = 1 to cnt
   fname = tpath'Base64.'right(i, 3, 0)
   call charout fname, bin.i
   call stream fname, 'c', 'close'
   /*'xcom'*/ 'e' fname
   address CMD 'erase' fname
   /*call etksetfilefield 'filename', 'xxx'*/
   /*call etkinserttext bin.i*/ /* ←異常終了してしまう */
   call etksetfilefield 'modify', 1
   call etksetfilefield 'autosave', 0
end
'sayerror 0'
'sayerror' cnt'ファイル、生成しました。'
call etksetfilefield 'autosave', autosave.1   /* Restore autosaving */
call etksetfilefield 'line', line.1           /* Restore current line */
call RxJisDropFuncs

/* file分割 99.9.14 */
options translate('ETmode')

call RxFuncAdd 'SysLoadFuncs', 'rexxutil', 'SysLoadFuncs'
call SysLoadFuncs

parse arg orgfile drv
if \datatype(left(drv, 1), 'M') then drv = 'A:'
if substr(drv, 2) \== ':' then drv = left(drv, 1)':'

bin = charin(orgfile,, chars(orgfile))
orgfile = FileSpec('N', orgfile)
p = pos('.', orgfile'.')
base = left(orgfile, p -1)
do i = 1 while bin \== ''
   fname = drv''base'.'right(i, 3, 0)
   do forever
      n = length(bin)
      say fname '... 残り:' n 'Bytes ('n%1024 'KB)'
      ch = SysGetKey()
      if ch == '!'   then call DiskUtil drv
      if ch \= '0d'x then iterate
      if stream(fname, 'c', 'query exists') == '' then leave
      say 'ファイル' fname 'は, 既に存在します。'
   end
   free = word(SysDriveInfo(drv), 2)
   n = min(length(bin), free)
   parse var bin val +(n) bin
   ln = charout(fname, val)
   call charout fname
   if ln \== 0 then say '書き出し失敗。残り' ln
end
exit

DiskUtil: procedure
   parse arg drv
   do forever
      say 'd' '09'x'ディレクトリ表示'
      say 'F' '09'x'フォーマット'
      say '?' '09'x'ディスク情報 (ドライブ 空き容量 全体容量)'
      say
      say '[ESC]' '09'x'終了'
      ch = SysGetKey()
      say
      select
         when ch == '1b'x then return
         when ch == '?' then say SysDriveInfo(drv)
         when ch == 'd' then 'dir' drv
         when ch == 'F' then 'format' drv
      otherwise
         say '07'x
      end
   end

/* EAstring    */
/* 99.5.16 ori */
options 'ETmode'
True = 1; False = 0;
nl = '0d0a'x

call RxFuncAdd 'SysLoadFuncs', 'rexxutil', 'SysLoadFuncs'
call SysLoadFuncs

parse value 'fffd'x 'ffdf'x 'ffde'x with EAT_Asc EAT_MVMT EAT_MVST

parse arg Args
if left(Args, 1) == '"'
   then parse var Args ch +1 fname(ch)
   else parse var Args fname .

if fname = '' then exit
eanames = '.Longname .Subject .Comments .Keyphrases .History'
say 'FileName:' fname
do i = 1 to words(eanames)
   eaname = word(eanames, i)
   Rc = SysGetEA(fname, eaname, 'val')
   txt = EAtoString(val, nl'0909'x)
   say eaname':' '09'x''txt
end
pull .
exit

StringtoEA: procedure expose EAT_MVST EAT_MVMT EAT_Asc
parse arg str, eol, m +1 /* Single-V, Multi-V */
res = ''
do cnt = 1 while str \= ''
   parse var str txt(eol) str
   res = res''reverse(EAT_Asc)d2li(length(txt))txt
end
if translate(m) == 'S' then return res
return reverse(EAT_MVMT)x2c('0000')d2li(cnt -1)res

EAtoString: procedure expose EAT_MVST EAT_MVMT EAT_Asc
parse arg val, eol
if val == '' then return ''
p = 1; res = EAstrs(StrP2(val, 'p'));
if p < 0 then return 'ERROR:'
return res

EAstrs: procedure expose val p eol EAT_MVST EAT_MVMT EAT_Asc
parse arg eat
eat = reverse(eat)
if eat == EAT_MVST | eat == EAT_MVMT then do
   cp = li2d(StrP2(val, 'p'))
   cnt = li2d(StrP2(val, 'p'))
   res = ''
   if eat == EAT_MVST then tp = StrP2(val, 'p')
   do cnt
      if eat == EAT_MVMT then tp = StrP2(val, 'p')
      res = res''EAstrs(tp)eol
      if p < 0 then leave
   end
end
else if eat == EAT_Asc then do
   ln = li2d(StrP2(val, 'p'))
   res = substr(val, p, ln)
   p = p +ln
end
else do
   p = -1
end
return res

StrP2: return substr(arg(1), value(arg(2), value(arg(2)) +2), 2);

d2li: d2ii: return reverse(d2c(arg(1), word(arg(2) 2, 1)));
li2d: ii2d: return c2d(reverse(arg(1)), word(arg(2) 4, 1));

/* RxCalendar  */
/* 98.8.17 ori */
options 'ETmode'
nl = '0d0a'x

parse arg args
n = verify(args, '/-. ', 'M')
if n == 0 then parse var args m
else parse var args y =(n)+1 m
now = right(date('S'), 8)
if \datatype(y, 'W') then parse var now y +4
if \datatype(m, 'W') then parse var now +4 m +2
if y < 1000 then y = y +word(1900 2000, (y <= 50) +1)

base = BaseDay(y, m, 1)
n = BaseDay(y, m +1, 1) -base
sDays = copies('0'x, (base +1)//7)xrange('1'x, d2c(n))
sWeek = /*'Sun Mon Tue Wed Thu Fri Sat'*/ '日 月 火 水 木 金 土'
ww = 3   /* ←表示幅 */
say center(y'/'m, ww *7)
say strWeek(sWeek, ww)
do while length(sDays) > 0
   parse var sDays val +7 sDays
   say strDay(val, ww)
end
exit

strWeek: procedure expose nl
parse arg val, ln
res = ''
if ln > length(word(val, 1)) then
   do i = 1 to 7; res = res''right(word(val, i), ln); end;
else do
   res = right(word(val, 1), ln)
   do i = 3 to 7 by 2; res = res''right(word(val, i), ln*2); end; res = res nl;
   do i = 2 to 7 by 2; res = res''right(word(val, i), ln*2); end;
end
return res

strDay: procedure
parse arg val, ln
if \datatype(ln, 'W') then ln = 3
res = ''
do i = 1 to length(val)
   n = c2d(substr(val, i, 1))
   res = res''right(word(n, (n == 0) +1), ln)
end
return res

BaseDay: procedure
   parse arg y, m, d
   m = m -2 -1
   if m < 0 then do; m = m +12; y = y -1; end;
return y*365 +y%4 -y%100 +y%400 +format(m*30.6,, 0) +d -307