languages/tcl/runtime/builtin/file.pir

   1 .HLL 'Tcl', ''
   2 .namespace []
   3
   4 .sub '&file'
   5   .param pmc argv :slurpy
   6
   7   .local int argc
   8   argc = elements argv
   9
  10   if argc == 0 goto few_args
  11
  12   .local string subcommand_name
  13   subcommand_name = shift argv
  14
  15   .local pmc options
  16   options = get_root_global ['_tcl'; 'helpers'; 'file'], 'options'
  17
  18   .local pmc select_option
  19   select_option  = get_root_global ['_tcl'], 'select_option'
  20
  21   .local string canonical_subcommand
  22   canonical_subcommand = select_option(options, subcommand_name)
  23
  24   .local pmc subcommand_proc
  25
  26   subcommand_proc = get_root_global ['_tcl';'helpers';'file'], canonical_subcommand
  27   if_null subcommand_proc, bad_args
  28
  29   .return subcommand_proc(argv)
  30
  31 bad_args:
  32   .return ('') # once all commands are implemented, remove this...
  33
  34 few_args:
  35   die 'wrong # args: should be "file option ?arg ...?"'
  36
  37 .end
  38
  39 .HLL '_Tcl', ''
  40 .namespace [ 'helpers'; 'file' ]
  41
  42 .sub 'normalize' # RT#40721: Stub for testing
  43   .param pmc argv
  44   $P0 = argv[0]
  45   .return ($P0)
  46 .end
  47
  48 .sub 'join'
  49   .param pmc argv
  50
  51   .local int argc
  52   argc = elements argv
  53   if argc == 0 goto bad_args
  54
  55   .local string dirsep
  56   $P1 = get_root_global ['_tcl'], 'slash'
  57   dirsep = $P1
  58
  59   .local string result
  60   result = ''
  61   .local int ii
  62   ii = 0
  63
  64 name_loop:
  65   if ii == argc goto name_loop_done
  66
  67   .local string name,char
  68   name = argv[ii]
  69
  70   char = substr name, 0, 1
  71   if char == dirsep goto absolute
  72   result .= name
  73   goto name_loop_next
  74
  75 absolute:
  76   result = name
  77
  78 name_loop_next:
  79   inc ii
  80   if ii == argc goto name_loop_done
  81   result .= dirsep
  82   goto name_loop
  83
  84 name_loop_done:
  85   .return(result)
  86
  87 bad_args:
  88   die 'wrong # args: should be "file join name ?name ...?"'
  89 .end
  90
  91 .sub 'stat'
  92   .param pmc argv
  93
  94   .local int argc
  95   argc = elements argv
  96
  97   if argc != 2 goto bad_args
  98
  99   .local string file,varname
 100   file = shift argv
 101   varname = shift argv
 102
 103   $P1 = new 'OS'
 104   push_eh no_file
 105     $P2 = $P1.'stat'(file)
 106   pop_eh
 107
 108   .local pmc setVar
 109   setVar = find_global 'setVar'
 110
 111   $P3 = new 'TclArray'
 112   $P1 = $P2[8]
 113   $P3['atime'] = $P1
 114   $P1 = $P2[10]
 115   $P3['ctime'] = $P1
 116   $P1 = $P2[0]
 117   $P3['dev'] = $P1
 118   $P1 = $P2[5]
 119   $P3['gid'] = $P1
 120   $P1 = $P2[1]
 121   $P3['ino'] = $P1
 122   $P1 = $P2[2]
 123   $P3['mode'] = $P1
 124   $P1 = $P2[9]
 125   $P3['mtime'] = $P1
 126   $P1 = $P2[3]
 127   $P3['nlink'] = $P1
 128   $P1 = $P2[7]
 129   $P3['size'] = $P1
 130
 131   $I1 = $P2[2]
 132   $I2 = 0o170000   #S_IFMT
 133   $I3 = $I1 & $I2
 134
 135   $P4 = find_global 'filetypes'
 136   $S1 = $P4[$I3]
 137   $P3['type'] = $S1
 138
 139
 140   $P1 = $P2[4]
 141   $P3['uid'] = $P1
 142
 143   setVar(varname, $P3)
 144
 145   .return('')
 146
 147 # RT#40731: should be more discriminating about the error messages .OS generates
 148 no_file:
 149   $S0  = 'could not read "'
 150   $S0 .= file
 151   $S0 .= '": no such file or directory'
 152   die $S0
 153 bad_args:
 154   die 'wrong # args: should be "file stat name varName"'
 155 .end
 156
 157 .sub 'isdirectory'
 158   .param pmc argv
 159
 160   .local int argc
 161   argc = elements argv
 162
 163   if argc != 1 goto bad_args
 164
 165   .local string file
 166   file = shift argv
 167
 168   $P1 = new 'OS'
 169   push_eh no_file
 170     $P2 = $P1.'stat'(file)
 171   pop_eh
 172
 173   $I1 = $P2[2]
 174   $I3 = $I1 & 0o170000 #S_IFMT
 175
 176   if $I3 == 0o040000 goto true # directory mask
 177
 178   .return(0)
 179
 180 true:
 181   .return(1)
 182
 183 # RT#40732: should be more discriminating about the error messages .OS generates
 184 no_file:
 185   $S0  = 'could not read "'
 186   $S0 .= file
 187   $S0 .= '": no such file or directory'
 188   die $S0
 189 bad_args:
 190   die 'wrong # args: should be "file isdirectory name"'
 191
 192 .end
 193
 194 .sub 'isfile'
 195   .param pmc argv
 196
 197   .local int argc
 198   argc = elements argv
 199
 200   if argc != 1 goto bad_args
 201
 202   .local string file
 203   file = shift argv
 204
 205   $P1 = new 'OS'
 206   push_eh no_file
 207     $P2 = $P1.'stat'(file)
 208   pop_eh
 209
 210   $I1 = $P2[2]
 211   $I3 = $I1 & 0o170000   #S_IFMT
 212
 213   if $I3 == 0o100000 goto true # file mask
 214
 215   .return(0)
 216
 217 true:
 218   .return(1)
 219
 220 # RT#40733: should be more discriminating about the error messages .OS generates
 221 no_file:
 222   $S0  = 'could not read "'
 223   $S0 .= file
 224   $S0 .= '": no such file or directory'
 225   die $S0
 226 bad_args:
 227   die 'wrong # args: should be "file isfile name"'
 228
 229 .end
 230
 231 .sub 'type'
 232   .param pmc argv
 233
 234   .local int argc
 235   argc = elements argv
 236
 237   if argc != 1 goto bad_args
 238
 239   .local string file
 240   file = shift argv
 241
 242   $P1 = new 'OS'
 243   push_eh no_file
 244     $P2 = $P1.'stat'(file)
 245   pop_eh
 246
 247   $I1 = $P2[2]
 248   $I2 = 0o170000   #S_IFMT
 249   $I3 = $I1 & $I2
 250
 251   $P4 = find_global 'filetypes'
 252   $S1 = $P4[$I3]
 253   .return ($S1)
 254
 255 # RT#40734: should be more discriminating about the error messages .OS generates
 256 no_file:
 257   $S0  = 'could not read "'
 258   $S0 .= file
 259   $S0 .= '": no such file or directory'
 260   die $S0
 261 bad_args:
 262   die 'wrong # args: should be "file type name"'
 263 .end
 264
 265 .sub 'size'
 266   .param pmc argv
 267
 268   .local int argc
 269   argc = elements argv
 270
 271   if argc != 1 goto bad_args
 272
 273   .local string file
 274   file = shift argv
 275
 276   $P1 = new 'OS'
 277   push_eh no_file
 278     $P2 = $P1.'stat'(file)
 279   pop_eh
 280   $I1 = $P2[7]
 281   .return ($I1)
 282
 283 # RT#40735: should be more discriminating about the error messages .OS generates
 284 no_file:
 285   $S0  = 'could not read "'
 286   $S0 .= file
 287   $S0 .= '": no such file or directory'
 288   die $S0
 289 bad_args:
 290   die 'wrong # args: should be "file size name"'
 291 .end
 292
 293 .sub 'atime'
 294   .param pmc argv
 295
 296   .local int argc
 297   argc = elements argv
 298
 299   if argc != 1 goto bad_args
 300
 301   .local string file
 302   file = shift argv
 303
 304   $P1 = new 'OS'
 305   push_eh no_file
 306     $P2 = $P1.'stat'(file)
 307   pop_eh
 308   $I1 = $P2[8]
 309   .return ($I1)
 310
 311 # RT#40736: should be more discriminating about the error messages .OS generates
 312 no_file:
 313   $S0  = 'could not read "'
 314   $S0 .= file
 315   $S0 .= '": no such file or directory'
 316   die $S0
 317 bad_args:
 318   die 'wrong # args: should be "file atime name ?time?"'
 319 .end
 320
 321 .sub 'mtime'
 322   .param pmc argv
 323
 324   .local int argc
 325   argc = elements argv
 326
 327   if argc != 1 goto bad_args
 328
 329   .local string file
 330   file = shift argv
 331
 332   $P1 = new 'OS'
 333   push_eh no_file
 334     $P2 = $P1.'stat'(file)
 335   pop_eh
 336   $I1 = $P2[9]
 337   .return ($I1)
 338
 339 # RT#40737: should be more discriminating about the error messages .OS generates
 340 no_file:
 341   $S0  = 'could not read "'
 342   $S0 .= file
 343   $S0 .= '": no such file or directory'
 344   die $S0
 345 bad_args:
 346   die 'wrong # args: should be "file mtime name ?time?"'
 347 .end
 348
 349 # RT#40722: needs windows OS testing
 350 .sub 'dirname'
 351     .param pmc argv
 352
 353     .local int argc
 354     argc = elements argv
 355     if argc != 1 goto bad_args
 356
 357     .local string filename
 358     filename = argv[0]
 359
 360     .local string separator
 361     $P0 = get_root_global ['_tcl'], 'slash'
 362     separator = $P0
 363
 364     $S0 = substr filename, -1, 1
 365     if $S0 != separator goto continue
 366     chopn filename, 1
 367
 368   continue:
 369     .local pmc array
 370     array = split separator, filename
 371     $S0 = pop array
 372     unless $S0 == '' goto skip
 373     push array, $S0
 374
 375   skip:
 376     $I0 = elements array
 377     if $I0 == 0 goto empty
 378
 379     $P1 = new 'ResizableStringArray'
 380   loop:
 381     unless array goto done
 382     $S0 = shift array
 383     if $S0 == '' goto loop
 384     push $P1, $S0
 385     goto loop
 386
 387   done:
 388     $S0 = join separator, $P1
 389     $S1 = concat separator, $S0 # guessing that this won't be needed in win
 390     .return($S1)
 391
 392   empty:
 393     .return('.')
 394
 395   bad_args:
 396     die 'wrong # args: should be "file dirname name"'
 397 .end
 398
 399 # RT#40723: Stub (unixy)
 400 .sub 'tail'
 401   .param pmc argv
 402   .local int argc
 403   argc = elements argv
 404   if argc != 1 goto bad_args
 405   $S0 = argv[0]
 406   if $S0 == '' goto whole
 407   $S1 = substr $S0, -1, 1
 408
 409   # Trailing dirsep is removed.
 410   if $S1 != "/" goto continue
 411   chopn $S0, 1
 412
 413 continue:
 414   .local int pos, idx, last_idx
 415   pos = 0
 416   idx = -1
 417   last_idx = -1
 418 get_last_index:
 419   idx = index $S0, '/', pos
 420   if idx == -1 goto done
 421
 422   pos = idx + 1
 423   last_idx = idx
 424   goto get_last_index
 425
 426 done:
 427   if last_idx == -1 goto whole
 428   inc last_idx
 429   substr $S0, 0, last_idx, ''
 430
 431 whole:
 432   .return($S0)
 433
 434 bad_args:
 435   die 'wrong # args: should be "file tail name"'
 436 .end
 437
 438 # RT#40724: Stub for test parsing
 439 .sub 'readable'
 440   .param pmc argv
 441   .return(1)
 442 .end
 443
 444 # RT#40725: Stub for test parsing
 445 .sub 'delete'
 446   .param pmc argv
 447   .return(0)
 448 .end
 449
 450 .sub 'exists'
 451     .param pmc argv
 452
 453     .local int argc
 454     argc = elements argv
 455     if argc != 1 goto badargs
 456
 457     .local pmc os
 458     os = new 'OS'
 459     $S0 = argv[0]
 460     push_eh false
 461       $P0 = os.'stat'($S0)
 462     pop_eh
 463
 464     .return(1)
 465
 466 false:
 467     .return(0)
 468
 469 badargs:
 470     die 'wrong # args: should be "file exists name"'
 471 .end
 472
 473 # RT#40727: Stub for test parsing
 474 .sub 'copy'
 475   .param pmc argv
 476   .return(0)
 477 .end
 478
 479 .sub 'rootname'
 480     .param pmc argv
 481     .local int argc
 482
 483     argc = elements argv
 484     if argc != 1 goto bad_args
 485
 486     .local string filename
 487     filename = argv[0]
 488
 489     $P0 = split '.', filename
 490     $I0 = elements $P0
 491     if $I0 == 1 goto done
 492     $S0 = pop $P0
 493
 494     .local string separator
 495     $P1 = get_root_global ['_tcl'], 'slash'
 496     separator = $P1
 497
 498     $I0 = index $S0, separator
 499     if $I0 != -1 goto done
 500
 501     join $S0, '.', $P0
 502     .return($S0)
 503
 504 done:
 505     .return(filename)
 506
 507   bad_args:
 508     die 'wrong # args: should be "file rootname name"'
 509 .end
 510
 511 .sub 'extension'
 512     .param pmc argv
 513     .local int argc
 514
 515     # check if filename arg exists
 516     argc = elements argv
 517     if argc != 1 goto bad_args
 518
 519     # get our filename
 520     $S0 = argv[0]
 521
 522     # test if filename has dots
 523     $I0 = index $S0, '.'
 524     if $I0 == -1 goto no_dot
 525
 526     # calculate file extension
 527     $P0 = split '.', $S0
 528     $S1 = pop $P0
 529     # include dot
 530     $S1 = '.' . $S1
 531
 532     .return($S1)
 533
 534   no_dot:
 535     .return('')
 536
 537   bad_args:
 538     die 'wrong # args: should be "file extension name"'
 539 .end
 540
 541 # XXX: Stub
 542 .sub 'owned'
 543   .param pmc argv
 544   .local int argc
 545   argc = elements argv
 546   if argc != 1 goto bad_args
 547   .return(0)
 548 bad_args:
 549   die 'wrong # args: should be "file owned name"'
 550 .end
 551
 552 # XXX: Stub for test parsing
 553 .sub 'writable'
 554   .param pmc argv
 555   .return(1)
 556 .end
 557
 558 # XXX: Stub
 559 .sub 'volumes'
 560   .param pmc argv
 561   .local int argc
 562   argc = elements argv
 563   if argc != 0 goto bad_args
 564
 565   .return('/')
 566
 567 bad_args:
 568   die 'wrong # args: should be "file volumes"'
 569 .end
 570
 571 .sub 'anon' :anon :load
 572   .local pmc options
 573   options = new 'TclList'
 574   push options, 'atime'
 575   push options, 'attributes'
 576   push options, 'channels'
 577   push options, 'copy'
 578   push options, 'delete'
 579   push options, 'dirname'
 580   push options, 'executable'
 581   push options, 'exists'
 582   push options, 'extension'
 583   push options, 'isdirectory'
 584   push options, 'isfile'
 585   push options, 'join'
 586   push options, 'link'
 587   push options, 'lstat'
 588   push options, 'mtime'
 589   push options, 'mkdir'
 590   push options, 'nativename'
 591   push options, 'normalize'
 592   push options, 'owned'
 593   push options, 'pathtype'
 594   push options, 'readable'
 595   push options, 'readlink'
 596   push options, 'rename'
 597   push options, 'rootname'
 598   push options, 'separator'
 599   push options, 'size'
 600   push options, 'split'
 601   push options, 'stat'
 602   push options, 'system'
 603   push options, 'tail'
 604   push options, 'type'
 605   push options, 'volumes'
 606   push options, 'writable'
 607
 608   set_root_global ['_tcl'; 'helpers'; 'file'], 'options', options
 609 .end
 610
 611 # Local Variables:
 612 #   mode: pir
 613 #   fill-column: 100
 614 # End:
 615 # vim: expandtab shiftwidth=4 ft=pir: