aboutsummaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--src/base/UBeatTimer.pas54
-rw-r--r--src/base/UNote.pas1286
-rw-r--r--src/base/UPath.pas2854
3 files changed, 2097 insertions, 2097 deletions
diff --git a/src/base/UBeatTimer.pas b/src/base/UBeatTimer.pas
index bc03de76..7f68deb6 100644
--- a/src/base/UBeatTimer.pas
+++ b/src/base/UBeatTimer.pas
@@ -170,38 +170,38 @@ var
MasterClock: real;
TimeDiff: real;
const
- AVG_HISTORY_FACTOR = 0.7;
- PAUSE_THRESHOLD = 0.010; // 10ms
- FORWARD_THRESHOLD = 0.010; // 10ms
+ AVG_HISTORY_FACTOR = 0.7;
+ PAUSE_THRESHOLD = 0.010; // 10ms
+ FORWARD_THRESHOLD = 0.010; // 10ms
begin
- MasterClock := fSyncSource.GetClock();
- Result := LyricTime;
-
- // do not sync if lyrics are paused externally or if the timestamp is old
- if (fPaused or (MasterClock = fLastClock)) then
+ MasterClock := fSyncSource.GetClock();
+ Result := LyricTime;
+
+ // do not sync if lyrics are paused externally or if the timestamp is old
+ if (fPaused or (MasterClock = fLastClock)) then
Exit;
// calculate average time difference (some sort of weighted mean).
- // The bigger AVG_HISTORY_FACTOR is, the smoother is the average diff.
- // This is done as some timestamps might be wrong or even lower
- // than their predecessor.
- TimeDiff := MasterClock - LyricTime;
- if (fAvgSyncDiff = -1) then
- fAvgSyncDiff := TimeDiff
- else
- fAvgSyncDiff := TimeDiff * (1-AVG_HISTORY_FACTOR) +
- fAvgSyncDiff * AVG_HISTORY_FACTOR;
-
- {$IFDEF LOG_SYNC}
- //Log.LogError(Format('TimeDiff: %.3f', [TimeDiff]));
- {$ENDIF}
-
+ // The bigger AVG_HISTORY_FACTOR is, the smoother is the average diff.
+ // This is done as some timestamps might be wrong or even lower
+ // than their predecessor.
+ TimeDiff := MasterClock - LyricTime;
+ if (fAvgSyncDiff = -1) then
+ fAvgSyncDiff := TimeDiff
+ else
+ fAvgSyncDiff := TimeDiff * (1-AVG_HISTORY_FACTOR) +
+ fAvgSyncDiff * AVG_HISTORY_FACTOR;
+
+ {$IFDEF LOG_SYNC}
+ //Log.LogError(Format('TimeDiff: %.3f', [TimeDiff]));
+ {$ENDIF}
+
// do not go backwards in time as this could mess up the score
if (fAvgSyncDiff > FORWARD_THRESHOLD) then
begin
{$IFDEF LOG_SYNC}
- Log.LogError('Sync: ' + floatToStr(MasterClock) + ' > ' + floatToStr(LyricTime));
- {$ENDIF}
+ Log.LogError('Sync: ' + floatToStr(MasterClock) + ' > ' + floatToStr(LyricTime));
+ {$ENDIF}
Result := LyricTime + fAvgSyncDiff;
fTimer.SetTime(Result);
@@ -219,14 +219,14 @@ begin
end
else if (fTimer.GetState = rtsPaused) and (fAvgSyncDiff >= 0) then
begin
- fTimer.Start();
+ fTimer.Start();
{$IFDEF LOG_SYNC}
Log.LogError('Unpause: ' + floatToStr(LyricTime));
{$ENDIF}
end;
fLastClock := MasterClock;
-end;
+end;
function TLyricsState.GetCurrentTime(): real;
var
@@ -241,7 +241,7 @@ end;
procedure TLyricsState.SetSyncSource(SyncSource: TSyncSource);
begin
- fSyncSource := SyncSource;
+ fSyncSource := SyncSource;
end;
(**
diff --git a/src/base/UNote.pas b/src/base/UNote.pas
index 57534030..c82cc2e3 100644
--- a/src/base/UNote.pas
+++ b/src/base/UNote.pas
@@ -1,643 +1,643 @@
-{* UltraStar Deluxe - Karaoke Game
- *
- * UltraStar Deluxe is the legal property of its developers, whose names
- * are too numerous to list here. Please refer to the COPYRIGHT
- * file distributed with this source distribution.
- *
- * This program is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this program; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
- * Boston, MA 02110-1301, USA.
- *
- * $URL$
- * $Id$
- *}
-
-unit UNote;
-
-interface
-
-{$IFDEF FPC}
- {$MODE Delphi}
-{$ENDIF}
-
-{$I switches.inc}
-
-uses
- SysUtils,
- Classes,
- SDL,
- gl,
- UDisplay,
- UIni,
- ULog,
- ULyrics,
- URecord,
- UScreenSing,
- USong,
- UTime;
-
-type
- PPLayerNote = ^TPlayerNote;
- TPlayerNote = record
- Start: integer;
- Length: integer;
- Detect: real; // accurate place, detected in the note
- Tone: real;
- Perfect: boolean; // true if the note matches the original one, light the star
- Hit: boolean; // true if the note hits the line
- end;
-
- PPLayer = ^TPlayer;
- TPlayer = record
- Name: UTF8String;
-
- // Index in Teaminfo record
- TeamID: byte;
- PlayerID: byte;
-
- // Scores
- Score: real;
- ScoreLine: real;
- ScoreGolden: real;
-
- ScoreInt: integer;
- ScoreLineInt: integer;
- ScoreGoldenInt: integer;
- ScoreTotalInt: integer;
-
- // LineBonus
- ScoreLast: real; // Last Line Score
-
- // PerfectLineTwinkle (effect)
- LastSentencePerfect: boolean;
-
- HighNote: integer; // index of last note (= High(Note)?)
- LengthNote: integer; // number of notes (= Length(Note)?).
- Note: array of TPlayerNote;
- end;
-
- TStats = record
- Player: array of TPlayer;
- SongArtist: string;
- SongTitle: string;
- end;
-
- TMedleyPlaylist = record
- Song: array of integer;
- NumMedleySongs: integer;
- CurrentMedleySong: integer;
- ApplausePlayed: boolean;
- Stats: array of TStats;
- NumPlayer: integer;
- end;
-
-{* Player and music info *}
-var
- {**
- * Player info and state for each player.
- * The amount of players is given by PlayersPlay.
- *}
- Player: array of TPlayer;
-
- {**
- * Number of players or teams playing.
- * Possible values: 1 - 6
- *}
- PlayersPlay: integer;
-
- {**
- * Selected song for singing.
- *}
- CurrentSong: TSong;
-
- PlaylistMedley: TMedleyPlaylist; // playlist medley
-
-const
- MAX_SONG_SCORE = 10000; // max. achievable points per song
- MAX_SONG_LINE_BONUS = 1000; // max. achievable line bonus per song
-
-procedure Sing(Screen: TScreenSing);
-procedure NewSentence(Screen: TScreenSing);
-procedure NewBeatClick(Screen: TScreenSing); // executed when on then new beat for click
-procedure NewBeatDetect(Screen: TScreenSing); // executed when on then new beat for detection
-procedure NewNote(Screen: TScreenSing); // detect note
-function GetMidBeat(Time: real): real;
-function GetTimeFromBeat(Beat: integer; SelfSong: TSong = nil): real;
-
-implementation
-
-uses
- Math,
- StrUtils,
- UCatCovers,
- UCommandLine,
- UCommon,
- UConfig,
- UCovers,
- UDataBase,
- UGraphic,
- UGraphicClasses,
- UJoystick,
- ULanguage,
- UMusic,
- UParty,
- UPathUtils,
- UPlatform,
- UPlaylist,
- USkins,
- USongs,
- UThemes;
-
-function GetTimeForBeats(BPM, Beats: real): real;
-begin
- Result := 60 / BPM * Beats;
-end;
-
-function GetBeats(BPM, msTime: real): real;
-begin
- Result := BPM * msTime / 60;
-end;
-
-procedure GetMidBeatSub(BPMNum: integer; var Time: real; var CurBeat: real);
-var
- NewTime: real;
-begin
- if High(CurrentSong.BPM) = BPMNum then
- begin
- // last BPM
- CurBeat := CurrentSong.BPM[BPMNum].StartBeat + GetBeats(CurrentSong.BPM[BPMNum].BPM, Time);
- Time := 0;
- end
- else
- begin
- // not last BPM
- // count how much time is it for start of the new BPM and store it in NewTime
- NewTime := GetTimeForBeats(CurrentSong.BPM[BPMNum].BPM, CurrentSong.BPM[BPMNum+1].StartBeat - CurrentSong.BPM[BPMNum].StartBeat);
-
- // compare it to remaining time
- if (Time - NewTime) > 0 then
- begin
- // there is still remaining time
- CurBeat := CurrentSong.BPM[BPMNum].StartBeat;
- Time := Time - NewTime;
- end
- else
- begin
- // there is no remaining time
- CurBeat := CurrentSong.BPM[BPMNum].StartBeat + GetBeats(CurrentSong.BPM[BPMNum].BPM, Time);
- Time := 0;
- end; // if
- end; // if
-end;
-
-function GetMidBeat(Time: real): real;
-var
- CurBeat: real;
- CurBPM: integer;
-begin
- // static BPM
- if Length(CurrentSong.BPM) = 1 then
- begin
- Result := Time * CurrentSong.BPM[0].BPM / 60;
- end
- // variable BPM
- else if Length(CurrentSong.BPM) > 1 then
- begin
- CurBeat := 0;
- CurBPM := 0;
- while (Time > 0) do
- begin
- GetMidBeatSub(CurBPM, Time, CurBeat);
- Inc(CurBPM);
- end;
-
- Result := CurBeat;
- end
- // invalid BPM
- else
- begin
- Result := 0;
- end;
-end;
-
-function GetTimeFromBeat(Beat: integer; SelfSong: TSong = nil): real;
-var
- CurBPM: integer;
- Song: TSong;
-begin
- if (SelfSong <> nil) then
- Song := SelfSong
- else
- Song := CurrentSong;
-
- // static BPM
- if Length(Song.BPM) = 1 then
- begin
- Result := Song.GAP / 1000 + Beat * 60 / Song.BPM[0].BPM;
- end
- // variable BPM
- else if Length(Song.BPM) > 1 then
- begin
- Result := Song.GAP / 1000;
- CurBPM := 0;
- while (CurBPM <= High(Song.BPM)) and
- (Beat > Song.BPM[CurBPM].StartBeat) do
- begin
- if (CurBPM < High(Song.BPM)) and
- (Beat >= Song.BPM[CurBPM+1].StartBeat) then
- begin
- // full range
- Result := Result + (60 / Song.BPM[CurBPM].BPM) *
- (Song.BPM[CurBPM+1].StartBeat - Song.BPM[CurBPM].StartBeat);
- end;
-
- if (CurBPM = High(Song.BPM)) or
- (Beat < Song.BPM[CurBPM+1].StartBeat) then
- begin
- // in the middle
- Result := Result + (60 / Song.BPM[CurBPM].BPM) *
- (Beat - Song.BPM[CurBPM].StartBeat);
- end;
- Inc(CurBPM);
- end;
-
- {
- while (Time > 0) do
- begin
- GetMidBeatSub(CurBPM, Time, CurBeat);
- Inc(CurBPM);
- end;
- }
- end
- // invalid BPM
- else
- begin
- Result := 0;
- end;
-end;
-
-procedure Sing(Screen: TScreenSing);
-var
- Count: integer;
- CountGr: integer;
- CP: integer;
-begin
- LyricsState.UpdateBeats();
-
- // sentences routines
- for CountGr := 0 to 0 do //High(Lines)
- begin;
- CP := CountGr;
- // old parts
- LyricsState.OldLine := Lines[CP].Current;
-
- // choose current parts
- for Count := 0 to Lines[CP].High do
- begin
- if LyricsState.CurrentBeat >= Lines[CP].Line[Count].Start then
- Lines[CP].Current := Count;
- end;
-
- // clean player note if there is a new line
- // (optimization on halfbeat time)
- if Lines[CP].Current <> LyricsState.OldLine then
- NewSentence(Screen);
-
- end; // for CountGr
-
- // make some operations on clicks
- if {(LyricsState.CurrentBeatC >= 0) and }(LyricsState.OldBeatC <> LyricsState.CurrentBeatC) then
- NewBeatClick(Screen);
-
- // make some operations when detecting new voice pitch
- if (LyricsState.CurrentBeatD >= 0) and (LyricsState.OldBeatD <> LyricsState.CurrentBeatD) then
- NewBeatDetect(Screen);
-end;
-
-procedure NewSentence(Screen: TScreenSing);
-var
- i: integer;
-begin
- // clean note of player
- for i := 0 to High(Player) do
- begin
- Player[i].LengthNote := 0;
- Player[i].HighNote := -1;
- SetLength(Player[i].Note, 0);
- end;
-
- // on sentence change...
- Screen.onSentenceChange(Lines[0].Current);
-end;
-
-procedure NewBeatClick;
-var
- Count: integer;
-begin
- // beat click
- if ((Ini.BeatClick = 1) and
- ((LyricsState.CurrentBeatC + Lines[0].Resolution + Lines[0].NotesGAP) mod Lines[0].Resolution = 0)) then
- begin
- AudioPlayback.PlaySound(SoundLib.Click);
- end;
-
- for Count := 0 to Lines[0].Line[Lines[0].Current].HighNote do
- begin
- if (Lines[0].Line[Lines[0].Current].Note[Count].Start = LyricsState.CurrentBeatC) then
- begin
- // click assist
- if Ini.ClickAssist = 1 then
- AudioPlayback.PlaySound(SoundLib.Click);
-
- // drum machine
- (*
- TempBeat := LyricsState.CurrentBeat; // + 2;
- if (TempBeat mod 8 = 0) then Music.PlayDrum;
- if (TempBeat mod 8 = 4) then Music.PlayClap;
- //if (TempBeat mod 4 = 2) then Music.PlayHihat;
- if (TempBeat mod 4 <> 0) then Music.PlayHihat;
- *)
- end;
- end;
-end;
-
-procedure NewBeatDetect(Screen: TScreenSing);
- var
- SentenceEnd: integer;
- I: cardinal;
-begin
- NewNote(Screen);
-
- // check for sentence end
- // we check all lines here because a new sentence may
- // have been started even before the old one finishes
- // due to corrupt lien breaks
- // checking only current line works to, but may lead to
- // weird ratings for the song files w/ the mentioned
- // errors
- // To-Do Philipp : check current and last line should
- // do it for most corrupt txt and for lines in
- // non-corrupt txts that start immediatly after the prev.
- // line ends
- if (assigned(Screen)) then
- begin
- for I := 0 to Lines[0].High do
- begin
- with Lines[0].Line[I] do
- begin
- if (HighNote >= 0) then
- begin
- SentenceEnd := Note[HighNote].Start + Note[HighNote].Length;
-
- if (LyricsState.OldBeatD < SentenceEnd) and (LyricsState.CurrentBeatD >= SentenceEnd) then
- Screen.OnSentenceEnd(I);
- end;
- end;
- end;
- end;
-end;
-
-procedure NewNote(Screen: TScreenSing);
-var
- LineFragmentIndex: integer;
- CurrentLineFragment: PLineFragment;
- PlayerIndex: integer;
- CurrentSound: TCaptureBuffer;
- CurrentPlayer: PPlayer;
- LastPlayerNote: PPlayerNote;
- Line: PLine;
- SentenceIndex: integer;
- SentenceMin: integer;
- SentenceMax: integer;
- SentenceDetected: integer; // sentence of detected note
- ActualBeat: integer;
- ActualTone: integer;
- NoteAvailable: boolean;
- NewNote: boolean;
- Range: integer;
- NoteHit: boolean;
- MaxSongPoints: integer; // max. points for the song (without line bonus)
- CurNotePoints: real; // Points for the cur. Note (PointsperNote * ScoreFactor[CurNote])
-begin
- ActualTone := 0;
- NoteHit := false;
-
- // TODO: add duet mode support
- // use Lines[LineSetIndex] with LineSetIndex depending on the current player
-
- // count min and max sentence range for checking
- // (detection is delayed to the notes we see on the screen)
- SentenceMin := Lines[0].Current-1;
- if (SentenceMin < 0) then
- SentenceMin := 0;
- SentenceMax := Lines[0].Current;
-
- for ActualBeat := LyricsState.OldBeatD+1 to LyricsState.CurrentBeatD do
- begin
- // analyze player signals
- for PlayerIndex := 0 to PlayersPlay-1 do
- begin
- // check for an active note at the current time defined in the lyrics
- NoteAvailable := false;
- SentenceDetected := SentenceMin;
- for SentenceIndex := SentenceMin to SentenceMax do
- begin
- Line := @Lines[0].Line[SentenceIndex];
- for LineFragmentIndex := 0 to Line.HighNote do
- begin
- CurrentLineFragment := @Line.Note[LineFragmentIndex];
- // check if line is active
- if ((CurrentLineFragment.Start <= ActualBeat) and
- (CurrentLineFragment.Start + CurrentLineFragment.Length-1 >= ActualBeat)) and
- (CurrentLineFragment.NoteType <> ntFreestyle) and // but ignore FreeStyle notes
- (CurrentLineFragment.Length > 0) then // and make sure the note length is at least 1
- begin
- SentenceDetected := SentenceIndex;
- NoteAvailable := true;
- Break;
- end;
- end;
- // TODO: break here, if NoteAvailable is true? We would then use the first instead
- // of the last note matching the current beat if notes overlap. But notes
- // should not overlap at all.
- // if (NoteAvailable) then
- // Break;
- end;
-
- CurrentPlayer := @Player[PlayerIndex];
- CurrentSound := AudioInputProcessor.Sound[PlayerIndex];
-
- // at the beginning of the song there is no previous note
- if (Length(CurrentPlayer.Note) > 0) then
- LastPlayerNote := @CurrentPlayer.Note[CurrentPlayer.HighNote]
- else
- LastPlayerNote := nil;
-
- // analyze buffer
- CurrentSound.AnalyzeBuffer;
-
- // add some noise
- // TODO: do we need this?
- //LyricsState.Tone := LyricsState.Tone + Round(Random(3)) - 1;
-
- // add note if possible
- if (CurrentSound.ToneValid and NoteAvailable) then
- begin
- Line := @Lines[0].Line[SentenceDetected];
- // process until last note
- for LineFragmentIndex := 0 to Line.HighNote do
- begin
- CurrentLineFragment := @Line.Note[LineFragmentIndex];
- if (CurrentLineFragment.Start <= ActualBeat) and
- (CurrentLineFragment.Start + CurrentLineFragment.Length > ActualBeat) then
- begin
- // compare notes (from song-file and from player)
-
- // move players tone to proper octave
- while (CurrentSound.Tone - CurrentLineFragment.Tone > 6) do
- CurrentSound.Tone := CurrentSound.Tone - 12;
-
- while (CurrentSound.Tone - CurrentLineFragment.Tone < -6) do
- CurrentSound.Tone := CurrentSound.Tone + 12;
-
- // half size notes patch
- NoteHit := false;
- ActualTone := CurrentSound.Tone;
- Range := 2 - Ini.Difficulty;
-
- // check if the player hit the correct tone within the tolerated range
- if (Abs(CurrentLineFragment.Tone - CurrentSound.Tone) <= Range) then
- begin
- // adjust the players tone to the correct one
- // TODO: do we need to do this?
- // Philipp: I think we do, at least when we draw the notes.
- // Otherwise the notehit thing would be shifted to the
- // correct unhit note. I think this will look kind of strange.
- ActualTone := CurrentLineFragment.Tone;
-
- // half size notes patch
- NoteHit := true;
-
- if (Ini.LineBonus > 0) then
- MaxSongPoints := MAX_SONG_SCORE - MAX_SONG_LINE_BONUS
- else
- MaxSongPoints := MAX_SONG_SCORE;
-
- // Note: ScoreValue is the sum of all note values of the song
- // (MaxSongPoints / ScoreValue) is the points that a player
- // gets for a hit of one beat of a normal note
- // CurNotePoints is the amount of points that is meassured
- // for a hit of the note per full beat
- CurNotePoints := (MaxSongPoints / Lines[0].ScoreValue) * ScoreFactor[CurrentLineFragment.NoteType];
-
- case CurrentLineFragment.NoteType of
- ntNormal: CurrentPlayer.Score := CurrentPlayer.Score + CurNotePoints;
- ntGolden: CurrentPlayer.ScoreGolden := CurrentPlayer.ScoreGolden + CurNotePoints;
- end;
-
- // a problem if we use floor instead of round is that a score of
- // 10000 points is only possible if the last digit of the total points
- // for golden and normal notes is 0.
- // if we use round, the max score is 10000 for most songs
- // but a score of 10010 is possible if the last digit of the total
- // points for golden and normal notes is 5
- // the best solution is to use round for one of these scores
- // and round the other score in the opposite direction
- // so we assure that the highest possible score is 10000 in every case.
- CurrentPlayer.ScoreInt := round(CurrentPlayer.Score / 10) * 10;
-
- if (CurrentPlayer.ScoreInt < CurrentPlayer.Score) then
- //normal score is floored so we have to ceil golden notes score
- CurrentPlayer.ScoreGoldenInt := ceil(CurrentPlayer.ScoreGolden / 10) * 10
- else
- //normal score is ceiled so we have to floor golden notes score
- CurrentPlayer.ScoreGoldenInt := floor(CurrentPlayer.ScoreGolden / 10) * 10;
-
-
- CurrentPlayer.ScoreTotalInt := CurrentPlayer.ScoreInt +
- CurrentPlayer.ScoreGoldenInt +
- CurrentPlayer.ScoreLineInt;
- end;
-
- end; // operation
- end; // for
-
- // check if we have to add a new note or extend the note's length
- if (SentenceDetected = SentenceMax) then
- begin
- // we will add a new note
- NewNote := true;
-
- // if previous note (if any) was the same, extend previous note
- if ((CurrentPlayer.LengthNote > 0) and
- (LastPlayerNote <> nil) and
- (LastPlayerNote.Tone = ActualTone) and
- ((LastPlayerNote.Start + LastPlayerNote.Length) = ActualBeat)) then
- begin
- NewNote := false;
- end;
-
- // if is not as new note to control
- for LineFragmentIndex := 0 to Line.HighNote do
- begin
- if (Line.Note[LineFragmentIndex].Start = ActualBeat) then
- NewNote := true;
- end;
-
- // add new note
- if NewNote then
- begin
- // new note
- Inc(CurrentPlayer.LengthNote);
- Inc(CurrentPlayer.HighNote);
- SetLength(CurrentPlayer.Note, CurrentPlayer.LengthNote);
-
- // update player's last note
- LastPlayerNote := @CurrentPlayer.Note[CurrentPlayer.HighNote];
- with LastPlayerNote^ do
- begin
- Start := ActualBeat;
- Length := 1;
- Tone := ActualTone; // Tone || ToneAbs
- //Detect := LyricsState.MidBeat; // Not used!
- Hit := NoteHit; // half note patch
- end;
- end
- else
- begin
- // extend note length
- if (LastPlayerNote <> nil) then
- Inc(LastPlayerNote.Length);
- end;
-
- // check for perfect note and then light the star (on Draw)
- for LineFragmentIndex := 0 to Line.HighNote do
- begin
- CurrentLineFragment := @Line.Note[LineFragmentIndex];
- if (CurrentLineFragment.Start = LastPlayerNote.Start) and
- (CurrentLineFragment.Length = LastPlayerNote.Length) and
- (CurrentLineFragment.Tone = LastPlayerNote.Tone) then
- begin
- LastPlayerNote.Perfect := true;
- end;
- end;
- end; // if SentenceDetected = SentenceMax
-
- end; // if Detected
- end; // for PlayerIndex
- end; // for ActualBeat
- //Log.LogStatus('EndBeat', 'NewBeat');
-end;
-
-end.
+{* UltraStar Deluxe - Karaoke Game
+ *
+ * UltraStar Deluxe is the legal property of its developers, whose names
+ * are too numerous to list here. Please refer to the COPYRIGHT
+ * file distributed with this source distribution.
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301, USA.
+ *
+ * $URL$
+ * $Id$
+ *}
+
+unit UNote;
+
+interface
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+{$ENDIF}
+
+{$I switches.inc}
+
+uses
+ SysUtils,
+ Classes,
+ SDL,
+ gl,
+ UDisplay,
+ UIni,
+ ULog,
+ ULyrics,
+ URecord,
+ UScreenSing,
+ USong,
+ UTime;
+
+type
+ PPLayerNote = ^TPlayerNote;
+ TPlayerNote = record
+ Start: integer;
+ Length: integer;
+ Detect: real; // accurate place, detected in the note
+ Tone: real;
+ Perfect: boolean; // true if the note matches the original one, light the star
+ Hit: boolean; // true if the note hits the line
+ end;
+
+ PPLayer = ^TPlayer;
+ TPlayer = record
+ Name: UTF8String;
+
+ // Index in Teaminfo record
+ TeamID: byte;
+ PlayerID: byte;
+
+ // Scores
+ Score: real;
+ ScoreLine: real;
+ ScoreGolden: real;
+
+ ScoreInt: integer;
+ ScoreLineInt: integer;
+ ScoreGoldenInt: integer;
+ ScoreTotalInt: integer;
+
+ // LineBonus
+ ScoreLast: real; // Last Line Score
+
+ // PerfectLineTwinkle (effect)
+ LastSentencePerfect: boolean;
+
+ HighNote: integer; // index of last note (= High(Note)?)
+ LengthNote: integer; // number of notes (= Length(Note)?).
+ Note: array of TPlayerNote;
+ end;
+
+ TStats = record
+ Player: array of TPlayer;
+ SongArtist: string;
+ SongTitle: string;
+ end;
+
+ TMedleyPlaylist = record
+ Song: array of integer;
+ NumMedleySongs: integer;
+ CurrentMedleySong: integer;
+ ApplausePlayed: boolean;
+ Stats: array of TStats;
+ NumPlayer: integer;
+ end;
+
+{* Player and music info *}
+var
+ {**
+ * Player info and state for each player.
+ * The amount of players is given by PlayersPlay.
+ *}
+ Player: array of TPlayer;
+
+ {**
+ * Number of players or teams playing.
+ * Possible values: 1 - 6
+ *}
+ PlayersPlay: integer;
+
+ {**
+ * Selected song for singing.
+ *}
+ CurrentSong: TSong;
+
+ PlaylistMedley: TMedleyPlaylist; // playlist medley
+
+const
+ MAX_SONG_SCORE = 10000; // max. achievable points per song
+ MAX_SONG_LINE_BONUS = 1000; // max. achievable line bonus per song
+
+procedure Sing(Screen: TScreenSing);
+procedure NewSentence(Screen: TScreenSing);
+procedure NewBeatClick(Screen: TScreenSing); // executed when on then new beat for click
+procedure NewBeatDetect(Screen: TScreenSing); // executed when on then new beat for detection
+procedure NewNote(Screen: TScreenSing); // detect note
+function GetMidBeat(Time: real): real;
+function GetTimeFromBeat(Beat: integer; SelfSong: TSong = nil): real;
+
+implementation
+
+uses
+ Math,
+ StrUtils,
+ UCatCovers,
+ UCommandLine,
+ UCommon,
+ UConfig,
+ UCovers,
+ UDataBase,
+ UGraphic,
+ UGraphicClasses,
+ UJoystick,
+ ULanguage,
+ UMusic,
+ UParty,
+ UPathUtils,
+ UPlatform,
+ UPlaylist,
+ USkins,
+ USongs,
+ UThemes;
+
+function GetTimeForBeats(BPM, Beats: real): real;
+begin
+ Result := 60 / BPM * Beats;
+end;
+
+function GetBeats(BPM, msTime: real): real;
+begin
+ Result := BPM * msTime / 60;
+end;
+
+procedure GetMidBeatSub(BPMNum: integer; var Time: real; var CurBeat: real);
+var
+ NewTime: real;
+begin
+ if High(CurrentSong.BPM) = BPMNum then
+ begin
+ // last BPM
+ CurBeat := CurrentSong.BPM[BPMNum].StartBeat + GetBeats(CurrentSong.BPM[BPMNum].BPM, Time);
+ Time := 0;
+ end
+ else
+ begin
+ // not last BPM
+ // count how much time is it for start of the new BPM and store it in NewTime
+ NewTime := GetTimeForBeats(CurrentSong.BPM[BPMNum].BPM, CurrentSong.BPM[BPMNum+1].StartBeat - CurrentSong.BPM[BPMNum].StartBeat);
+
+ // compare it to remaining time
+ if (Time - NewTime) > 0 then
+ begin
+ // there is still remaining time
+ CurBeat := CurrentSong.BPM[BPMNum].StartBeat;
+ Time := Time - NewTime;
+ end
+ else
+ begin
+ // there is no remaining time
+ CurBeat := CurrentSong.BPM[BPMNum].StartBeat + GetBeats(CurrentSong.BPM[BPMNum].BPM, Time);
+ Time := 0;
+ end; // if
+ end; // if
+end;
+
+function GetMidBeat(Time: real): real;
+var
+ CurBeat: real;
+ CurBPM: integer;
+begin
+ // static BPM
+ if Length(CurrentSong.BPM) = 1 then
+ begin
+ Result := Time * CurrentSong.BPM[0].BPM / 60;
+ end
+ // variable BPM
+ else if Length(CurrentSong.BPM) > 1 then
+ begin
+ CurBeat := 0;
+ CurBPM := 0;
+ while (Time > 0) do
+ begin
+ GetMidBeatSub(CurBPM, Time, CurBeat);
+ Inc(CurBPM);
+ end;
+
+ Result := CurBeat;
+ end
+ // invalid BPM
+ else
+ begin
+ Result := 0;
+ end;
+end;
+
+function GetTimeFromBeat(Beat: integer; SelfSong: TSong = nil): real;
+var
+ CurBPM: integer;
+ Song: TSong;
+begin
+ if (SelfSong <> nil) then
+ Song := SelfSong
+ else
+ Song := CurrentSong;
+
+ // static BPM
+ if Length(Song.BPM) = 1 then
+ begin
+ Result := Song.GAP / 1000 + Beat * 60 / Song.BPM[0].BPM;
+ end
+ // variable BPM
+ else if Length(Song.BPM) > 1 then
+ begin
+ Result := Song.GAP / 1000;
+ CurBPM := 0;
+ while (CurBPM <= High(Song.BPM)) and
+ (Beat > Song.BPM[CurBPM].StartBeat) do
+ begin
+ if (CurBPM < High(Song.BPM)) and
+ (Beat >= Song.BPM[CurBPM+1].StartBeat) then
+ begin
+ // full range
+ Result := Result + (60 / Song.BPM[CurBPM].BPM) *
+ (Song.BPM[CurBPM+1].StartBeat - Song.BPM[CurBPM].StartBeat);
+ end;
+
+ if (CurBPM = High(Song.BPM)) or
+ (Beat < Song.BPM[CurBPM+1].StartBeat) then
+ begin
+ // in the middle
+ Result := Result + (60 / Song.BPM[CurBPM].BPM) *
+ (Beat - Song.BPM[CurBPM].StartBeat);
+ end;
+ Inc(CurBPM);
+ end;
+
+ {
+ while (Time > 0) do
+ begin
+ GetMidBeatSub(CurBPM, Time, CurBeat);
+ Inc(CurBPM);
+ end;
+ }
+ end
+ // invalid BPM
+ else
+ begin
+ Result := 0;
+ end;
+end;
+
+procedure Sing(Screen: TScreenSing);
+var
+ Count: integer;
+ CountGr: integer;
+ CP: integer;
+begin
+ LyricsState.UpdateBeats();
+
+ // sentences routines
+ for CountGr := 0 to 0 do //High(Lines)
+ begin;
+ CP := CountGr;
+ // old parts
+ LyricsState.OldLine := Lines[CP].Current;
+
+ // choose current parts
+ for Count := 0 to Lines[CP].High do
+ begin
+ if LyricsState.CurrentBeat >= Lines[CP].Line[Count].Start then
+ Lines[CP].Current := Count;
+ end;
+
+ // clean player note if there is a new line
+ // (optimization on halfbeat time)
+ if Lines[CP].Current <> LyricsState.OldLine then
+ NewSentence(Screen);
+
+ end; // for CountGr
+
+ // make some operations on clicks
+ if {(LyricsState.CurrentBeatC >= 0) and }(LyricsState.OldBeatC <> LyricsState.CurrentBeatC) then
+ NewBeatClick(Screen);
+
+ // make some operations when detecting new voice pitch
+ if (LyricsState.CurrentBeatD >= 0) and (LyricsState.OldBeatD <> LyricsState.CurrentBeatD) then
+ NewBeatDetect(Screen);
+end;
+
+procedure NewSentence(Screen: TScreenSing);
+var
+ i: integer;
+begin
+ // clean note of player
+ for i := 0 to High(Player) do
+ begin
+ Player[i].LengthNote := 0;
+ Player[i].HighNote := -1;
+ SetLength(Player[i].Note, 0);
+ end;
+
+ // on sentence change...
+ Screen.onSentenceChange(Lines[0].Current);
+end;
+
+procedure NewBeatClick;
+var
+ Count: integer;
+begin
+ // beat click
+ if ((Ini.BeatClick = 1) and
+ ((LyricsState.CurrentBeatC + Lines[0].Resolution + Lines[0].NotesGAP) mod Lines[0].Resolution = 0)) then
+ begin
+ AudioPlayback.PlaySound(SoundLib.Click);
+ end;
+
+ for Count := 0 to Lines[0].Line[Lines[0].Current].HighNote do
+ begin
+ if (Lines[0].Line[Lines[0].Current].Note[Count].Start = LyricsState.CurrentBeatC) then
+ begin
+ // click assist
+ if Ini.ClickAssist = 1 then
+ AudioPlayback.PlaySound(SoundLib.Click);
+
+ // drum machine
+ (*
+ TempBeat := LyricsState.CurrentBeat; // + 2;
+ if (TempBeat mod 8 = 0) then Music.PlayDrum;
+ if (TempBeat mod 8 = 4) then Music.PlayClap;
+ //if (TempBeat mod 4 = 2) then Music.PlayHihat;
+ if (TempBeat mod 4 <> 0) then Music.PlayHihat;
+ *)
+ end;
+ end;
+end;
+
+procedure NewBeatDetect(Screen: TScreenSing);
+ var
+ SentenceEnd: integer;
+ I: cardinal;
+begin
+ NewNote(Screen);
+
+ // check for sentence end
+ // we check all lines here because a new sentence may
+ // have been started even before the old one finishes
+ // due to corrupt lien breaks
+ // checking only current line works to, but may lead to
+ // weird ratings for the song files w/ the mentioned
+ // errors
+ // To-Do Philipp : check current and last line should
+ // do it for most corrupt txt and for lines in
+ // non-corrupt txts that start immediatly after the prev.
+ // line ends
+ if (assigned(Screen)) then
+ begin
+ for I := 0 to Lines[0].High do
+ begin
+ with Lines[0].Line[I] do
+ begin
+ if (HighNote >= 0) then
+ begin
+ SentenceEnd := Note[HighNote].Start + Note[HighNote].Length;
+
+ if (LyricsState.OldBeatD < SentenceEnd) and (LyricsState.CurrentBeatD >= SentenceEnd) then
+ Screen.OnSentenceEnd(I);
+ end;
+ end;
+ end;
+ end;
+end;
+
+procedure NewNote(Screen: TScreenSing);
+var
+ LineFragmentIndex: integer;
+ CurrentLineFragment: PLineFragment;
+ PlayerIndex: integer;
+ CurrentSound: TCaptureBuffer;
+ CurrentPlayer: PPlayer;
+ LastPlayerNote: PPlayerNote;
+ Line: PLine;
+ SentenceIndex: integer;
+ SentenceMin: integer;
+ SentenceMax: integer;
+ SentenceDetected: integer; // sentence of detected note
+ ActualBeat: integer;
+ ActualTone: integer;
+ NoteAvailable: boolean;
+ NewNote: boolean;
+ Range: integer;
+ NoteHit: boolean;
+ MaxSongPoints: integer; // max. points for the song (without line bonus)
+ CurNotePoints: real; // Points for the cur. Note (PointsperNote * ScoreFactor[CurNote])
+begin
+ ActualTone := 0;
+ NoteHit := false;
+
+ // TODO: add duet mode support
+ // use Lines[LineSetIndex] with LineSetIndex depending on the current player
+
+ // count min and max sentence range for checking
+ // (detection is delayed to the notes we see on the screen)
+ SentenceMin := Lines[0].Current-1;
+ if (SentenceMin < 0) then
+ SentenceMin := 0;
+ SentenceMax := Lines[0].Current;
+
+ for ActualBeat := LyricsState.OldBeatD+1 to LyricsState.CurrentBeatD do
+ begin
+ // analyze player signals
+ for PlayerIndex := 0 to PlayersPlay-1 do
+ begin
+ // check for an active note at the current time defined in the lyrics
+ NoteAvailable := false;
+ SentenceDetected := SentenceMin;
+ for SentenceIndex := SentenceMin to SentenceMax do
+ begin
+ Line := @Lines[0].Line[SentenceIndex];
+ for LineFragmentIndex := 0 to Line.HighNote do
+ begin
+ CurrentLineFragment := @Line.Note[LineFragmentIndex];
+ // check if line is active
+ if ((CurrentLineFragment.Start <= ActualBeat) and
+ (CurrentLineFragment.Start + CurrentLineFragment.Length-1 >= ActualBeat)) and
+ (CurrentLineFragment.NoteType <> ntFreestyle) and // but ignore FreeStyle notes
+ (CurrentLineFragment.Length > 0) then // and make sure the note length is at least 1
+ begin
+ SentenceDetected := SentenceIndex;
+ NoteAvailable := true;
+ Break;
+ end;
+ end;
+ // TODO: break here, if NoteAvailable is true? We would then use the first instead
+ // of the last note matching the current beat if notes overlap. But notes
+ // should not overlap at all.
+ // if (NoteAvailable) then
+ // Break;
+ end;
+
+ CurrentPlayer := @Player[PlayerIndex];
+ CurrentSound := AudioInputProcessor.Sound[PlayerIndex];
+
+ // at the beginning of the song there is no previous note
+ if (Length(CurrentPlayer.Note) > 0) then
+ LastPlayerNote := @CurrentPlayer.Note[CurrentPlayer.HighNote]
+ else
+ LastPlayerNote := nil;
+
+ // analyze buffer
+ CurrentSound.AnalyzeBuffer;
+
+ // add some noise
+ // TODO: do we need this?
+ //LyricsState.Tone := LyricsState.Tone + Round(Random(3)) - 1;
+
+ // add note if possible
+ if (CurrentSound.ToneValid and NoteAvailable) then
+ begin
+ Line := @Lines[0].Line[SentenceDetected];
+ // process until last note
+ for LineFragmentIndex := 0 to Line.HighNote do
+ begin
+ CurrentLineFragment := @Line.Note[LineFragmentIndex];
+ if (CurrentLineFragment.Start <= ActualBeat) and
+ (CurrentLineFragment.Start + CurrentLineFragment.Length > ActualBeat) then
+ begin
+ // compare notes (from song-file and from player)
+
+ // move players tone to proper octave
+ while (CurrentSound.Tone - CurrentLineFragment.Tone > 6) do
+ CurrentSound.Tone := CurrentSound.Tone - 12;
+
+ while (CurrentSound.Tone - CurrentLineFragment.Tone < -6) do
+ CurrentSound.Tone := CurrentSound.Tone + 12;
+
+ // half size notes patch
+ NoteHit := false;
+ ActualTone := CurrentSound.Tone;
+ Range := 2 - Ini.Difficulty;
+
+ // check if the player hit the correct tone within the tolerated range
+ if (Abs(CurrentLineFragment.Tone - CurrentSound.Tone) <= Range) then
+ begin
+ // adjust the players tone to the correct one
+ // TODO: do we need to do this?
+ // Philipp: I think we do, at least when we draw the notes.
+ // Otherwise the notehit thing would be shifted to the
+ // correct unhit note. I think this will look kind of strange.
+ ActualTone := CurrentLineFragment.Tone;
+
+ // half size notes patch
+ NoteHit := true;
+
+ if (Ini.LineBonus > 0) then
+ MaxSongPoints := MAX_SONG_SCORE - MAX_SONG_LINE_BONUS
+ else
+ MaxSongPoints := MAX_SONG_SCORE;
+
+ // Note: ScoreValue is the sum of all note values of the song
+ // (MaxSongPoints / ScoreValue) is the points that a player
+ // gets for a hit of one beat of a normal note
+ // CurNotePoints is the amount of points that is meassured
+ // for a hit of the note per full beat
+ CurNotePoints := (MaxSongPoints / Lines[0].ScoreValue) * ScoreFactor[CurrentLineFragment.NoteType];
+
+ case CurrentLineFragment.NoteType of
+ ntNormal: CurrentPlayer.Score := CurrentPlayer.Score + CurNotePoints;
+ ntGolden: CurrentPlayer.ScoreGolden := CurrentPlayer.ScoreGolden + CurNotePoints;
+ end;
+
+ // a problem if we use floor instead of round is that a score of
+ // 10000 points is only possible if the last digit of the total points
+ // for golden and normal notes is 0.
+ // if we use round, the max score is 10000 for most songs
+ // but a score of 10010 is possible if the last digit of the total
+ // points for golden and normal notes is 5
+ // the best solution is to use round for one of these scores
+ // and round the other score in the opposite direction
+ // so we assure that the highest possible score is 10000 in every case.
+ CurrentPlayer.ScoreInt := round(CurrentPlayer.Score / 10) * 10;
+
+ if (CurrentPlayer.ScoreInt < CurrentPlayer.Score) then
+ //normal score is floored so we have to ceil golden notes score
+ CurrentPlayer.ScoreGoldenInt := ceil(CurrentPlayer.ScoreGolden / 10) * 10
+ else
+ //normal score is ceiled so we have to floor golden notes score
+ CurrentPlayer.ScoreGoldenInt := floor(CurrentPlayer.ScoreGolden / 10) * 10;
+
+
+ CurrentPlayer.ScoreTotalInt := CurrentPlayer.ScoreInt +
+ CurrentPlayer.ScoreGoldenInt +
+ CurrentPlayer.ScoreLineInt;
+ end;
+
+ end; // operation
+ end; // for
+
+ // check if we have to add a new note or extend the note's length
+ if (SentenceDetected = SentenceMax) then
+ begin
+ // we will add a new note
+ NewNote := true;
+
+ // if previous note (if any) was the same, extend previous note
+ if ((CurrentPlayer.LengthNote > 0) and
+ (LastPlayerNote <> nil) and
+ (LastPlayerNote.Tone = ActualTone) and
+ ((LastPlayerNote.Start + LastPlayerNote.Length) = ActualBeat)) then
+ begin
+ NewNote := false;
+ end;
+
+ // if is not as new note to control
+ for LineFragmentIndex := 0 to Line.HighNote do
+ begin
+ if (Line.Note[LineFragmentIndex].Start = ActualBeat) then
+ NewNote := true;
+ end;
+
+ // add new note
+ if NewNote then
+ begin
+ // new note
+ Inc(CurrentPlayer.LengthNote);
+ Inc(CurrentPlayer.HighNote);
+ SetLength(CurrentPlayer.Note, CurrentPlayer.LengthNote);
+
+ // update player's last note
+ LastPlayerNote := @CurrentPlayer.Note[CurrentPlayer.HighNote];
+ with LastPlayerNote^ do
+ begin
+ Start := ActualBeat;
+ Length := 1;
+ Tone := ActualTone; // Tone || ToneAbs
+ //Detect := LyricsState.MidBeat; // Not used!
+ Hit := NoteHit; // half note patch
+ end;
+ end
+ else
+ begin
+ // extend note length
+ if (LastPlayerNote <> nil) then
+ Inc(LastPlayerNote.Length);
+ end;
+
+ // check for perfect note and then light the star (on Draw)
+ for LineFragmentIndex := 0 to Line.HighNote do
+ begin
+ CurrentLineFragment := @Line.Note[LineFragmentIndex];
+ if (CurrentLineFragment.Start = LastPlayerNote.Start) and
+ (CurrentLineFragment.Length = LastPlayerNote.Length) and
+ (CurrentLineFragment.Tone = LastPlayerNote.Tone) then
+ begin
+ LastPlayerNote.Perfect := true;
+ end;
+ end;
+ end; // if SentenceDetected = SentenceMax
+
+ end; // if Detected
+ end; // for PlayerIndex
+ end; // for ActualBeat
+ //Log.LogStatus('EndBeat', 'NewBeat');
+end;
+
+end.
diff --git a/src/base/UPath.pas b/src/base/UPath.pas
index 7cb2f649..5a0b41fd 100644
--- a/src/base/UPath.pas
+++ b/src/base/UPath.pas
@@ -1,1427 +1,1427 @@
-{* UltraStar Deluxe - Karaoke Game
- *
- * UltraStar Deluxe is the legal property of its developers, whose names
- * are too numerous to list here. Please refer to the COPYRIGHT
- * file distributed with this source distribution.
- *
- * This program is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this program; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
- * Boston, MA 02110-1301, USA.
- *
- * $URL$
- * $Id$
- *}
-
-unit UPath;
-
-{$IFDEF FPC}
- {$MODE Delphi}
-{$ENDIF}
-
-{$I switches.inc}
-
-interface
-
-uses
- SysUtils,
- Classes,
- IniFiles,
- {$IFDEF MSWINDOWS}
- TntClasses,
- {$ENDIF}
- UConfig,
- UUnicodeUtils;
-
-type
- IPath = interface;
-
- {$IFDEF FPC}
- TFileHandle = THandle;
- {$ELSE}
- TFileHandle = Longint;
- {$ENDIF}
-
- {**
- * TUnicodeMemoryStream
- *}
- TUnicodeMemoryStream = class(TMemoryStream)
- public
- procedure LoadFromFile(const FileName: IPath);
- procedure SaveToFile(const FileName: IPath);
- end;
-
- {**
- * Unicode capable IniFile implementation.
- * TMemIniFile and TIniFile are not able to handle INI-files with
- * an UTF-8 BOM. This implementation checks if an UTF-8 BOM exists
- * and removes it from the internal string-list.
- * UTF8Encoded is set accordingly.
- *}
- TUnicodeMemIniFile = class(TMemIniFile)
- private
- FFilename: IPath;
- FUTF8Encoded: boolean;
- public
- constructor Create(const FileName: IPath; UTF8Encoded: boolean = false); reintroduce;
- procedure UpdateFile; override;
- property UTF8Encoded: boolean READ FUTF8Encoded WRITE FUTF8Encoded;
- end;
-
- {**
- * TBinaryFileStream (inherited from THandleStream)
- *}
- {$IFDEF MSWINDOWS}
- TBinaryFileStream = class(TTntFileStream)
- {$ELSE}
- TBinaryFileStream = class(TFileStream)
- {$ENDIF}
- public
- {**
- * @seealso TFileStream.Create for valid Mode parameters
- *}
- constructor Create(const FileName: IPath; Mode: word);
- end;
-
- {**
- * TTextFileStream
- *}
- TTextFileStream = class(TStream)
- protected
- fLineBreak: RawByteString;
- fFilename: IPath;
- fMode: word;
-
- function ReadLine(var Success: boolean): RawByteString; overload; virtual; abstract;
- public
- constructor Create(Filename: IPath; Mode: word);
-
- function ReadString(): RawByteString; virtual; abstract;
- function ReadLine(var Line: UTF8String): boolean; overload;
- function ReadLine(var Line: AnsiString): boolean; overload;
-
- procedure WriteString(const Str: RawByteString); virtual;
- procedure WriteLine(const Line: RawByteString); virtual;
-
- property LineBreak: RawByteString read fLineBreak write fLineBreak;
- property Filename: IPath read fFilename;
- end;
-
- {**
- * TMemTextStream
- *}
- TMemTextFileStream = class(TTextFileStream)
- private
- fStream: TMemoryStream;
- protected
- function GetSize: int64; override;
-
- {**
- * Copies fStream.Memory from StartPos to EndPos-1 to the result string;
- *}
- function CopyMemString(StartPos: int64; EndPos: int64): RawByteString;
- public
- constructor Create(Filename: IPath; Mode: word);
- destructor Destroy(); override;
-
- function Read(var Buffer; Count: longint): longint; override;
- function Write(const Buffer; Count: longint): longint; override;
- function Seek(Offset: longint; Origin: word): longint; override;
- function Seek(const Offset: int64; Origin: TSeekOrigin): int64; override;
-
- function ReadLine(var Success: boolean): RawByteString; override;
- function ReadString(): RawByteString; override;
- end;
-
- {**
- TUnicodeIniStream = class()
- end;
- *}
-
- {**
- * pdKeep: Keep path as is, neither remove or append a delimiter
- * pdAppend: Append a delimiter if path does not have a trailing one
- * pdRemove: Remove a trailing delimiter from the path
- *}
- TPathDelimOption = (pdKeep, pdAppend, pdRemove);
-
- IPathDynArray = array of IPath;
-
- {**
- * An IPath represents a filename, a directory or a filesystem path in general.
- * It hides some of the operating system's specifics like path delimiters
- * and encodings and provides an easy to use interface to handle them.
- * Internally all paths are stored with the same path delimiter (PathDelim)
- * and encoding (UTF-8). The transformation is already done AT THE CREATION of
- * the IPath and hence calls to e.g. IPath.Equal() will not distinguish between
- * Unix and Windows style paths.
- *
- * Create new paths with one of the Path() functions.
- * If you need a string representation use IPath.ToNative/ToUTF8/ToWide.
- * Note that due to the path-delimiter and encoding transformation the string
- * might have changed. Path('one\test/path').ToUTF8() might return 'one/test/path'.
- *
- * It is recommended to use an IPath as long as possible without a string
- * conversion (IPath.To...()). The whole Delphi (< 2009) and FPC RTL is ANSI
- * only on Windows. If you would use for example FileExists(MyPath.ToNative)
- * it would not find a file which contains characters that are not in the
- * current locale. Same applies to AssignFile(), TFileStream.Create() and
- * everything else in the RTL that expects a filename.
- * As a rule of thumb: NEVER use any of the Delphi/FPC RTL filename functions
- * if the filename parameter is not of a UTF8String or WideString type.
- *
- * If you need to open a file use TBinaryStream or TFileStream instead. Many
- * of the RTL classes offer a LoadFromStream() method so ANSI Open() methods
- * can be workaround.
- *
- * If there is only a ANSI and no IPath/UTF-8/WideString version and you cannot
- * even pass a stream instead of a filename be aware that even if you know that
- * a filename is ASCII only, subdirectories in an absolute path might contain
- * some non-ASCII characters (for example the user's name) and hence might
- * fail (if the characters are not in the current locale).
- * It is rare but it happens.
- *
- * IMPORTANT:
- * This interface needs the cwstring unit on Unix (Max OS X / Linux) systems.
- * Cwstring functions (WideUpperCase, ...) cannot be used by external threads
- * as FPC uses Thread-Local-Storage for the implementation. As a result do not
- * call IPath stuff by external threads (e.g. in C callbacks or by SDL-threads).
- *}
- IPath = interface
- ['{686BF103-CE43-4598-B85D-A2C3AF950897}']
- {**
- * Returns the path as an UTF8 encoded string.
- * If UseNativeDelim is set to true, the native path delimiter ('\' on win32)
- * is used. If it is set to false the (more) portable '/' delimiter will used.
- *}
- function ToUTF8(UseNativeDelim: boolean = true): UTF8String;
-
- {**
- * Returns the path as an UTF-16 encoded string.
- * If UseNativeDelim is set to true, the native path delimiter ('\' on win32)
- * is used. If it is set to false the delimiter will be '/'.
- *}
- function ToWide(UseNativeDelim: boolean = true): WideString;
-
- {**
- * Returns the path with the system's native encoding and path delimiter.
- * Win32: ANSI (use the UTF-16 version IPath.ToWide() whenever possible)
- * Mac: UTF8
- * Unix: UTF8 or ANSI according to LC_CTYPE
- *}
- function ToNative(): RawByteString;
-
- {**
- * Note: File must be closed with FileClose(Handle) after usage
- * @seealso SysUtils.FileOpen()
- *}
- function Open(Mode: longword): TFileHandle;
-
- {** @seealso SysUtils.ExtractFileDrive() *}
- function GetDrive(): IPath;
-
- {** @seealso SysUtils.ExtractFilePath() *}
- function GetPath(): IPath;
-
- {** @seealso SysUtils.ExtractFileDir() *}
- function GetDir(): IPath;
-
- {** @seealso SysUtils.ExtractFileName() *}
- function GetName(): IPath;
-
- {** @seealso SysUtils.ExtractFileExtension() *}
- function GetExtension(): IPath;
-
- {**
- * Returns a copy of the path with the extension changed to Extension.
- * The file itself is not changed, use Rename() for this task.
- * @seealso SysUtils.ChangeFileExt()
- *}
- function SetExtension(const Extension: IPath): IPath; overload;
- function SetExtension(const Extension: RawByteString): IPath; overload;
- function SetExtension(const Extension: WideString): IPath; overload;
-
- {**
- * Returns the representation of the path relative to Basename.
- * Note that the basename must be terminated with a path delimiter
- * otherwise the last path component will be ignored.
- * @seealso SysUtils.ExtractRelativePath()
- *}
- function GetRelativePath(const BaseName: IPath): IPath;
-
- {** @seealso SysUtils.ExpandFileName() *}
- function GetAbsolutePath(): IPath;
-
- {**
- * Returns the concatenation of this path with Child. If this path does not
- * end with a path delimiter one is inserted in front of the Child path.
- * Example: Path('parent').Append(Path('child')) -> Path('parent/child')
- *}
- function Append(const Child: IPath; DelimOption: TPathDelimOption = pdKeep): IPath; overload;
- function Append(const Child: RawByteString; DelimOption: TPathDelimOption = pdKeep): IPath; overload;
- function Append(const Child: WideString; DelimOption: TPathDelimOption = pdKeep): IPath; overload;
-
- {**
- * Splits the path into its components. Path delimiters are not removed from
- * components.
- * Example: C:\test\my\dir -> ['C:\', 'test\', 'my\', 'dir']
- *}
- function SplitDirs(): IPathDynArray;
-
- {**
- * Returns the parent directory or PATH_NONE if none exists.
- *}
- function GetParent(): IPath;
-
- {**
- * Checks if this path is a subdir of or file inside Parent.
- * If Direct is true this path must be a direct child.
- * Example: C:\test\file is a direct child of C:\test and a child of C:\
- *}
- function IsChildOf(const Parent: IPath; Direct: boolean): boolean;
-
- {**
- * Adjusts the case of the path on case senstitive filesystems.
- * If the path does not exist or the filesystem is case insensitive
- * the original path will be returned. Otherwise a corrected copy.
- *}
- function AdjustCase(AdjustAllLevels: boolean): IPath;
-
- {** @seealso SysUtils.IncludeTrailingPathDelimiter() *}
- function AppendPathDelim(): IPath;
-
- {** @seealso SysUtils.ExcludeTrailingPathDelimiter() *}
- function RemovePathDelim(): IPath;
-
- function Exists(): boolean;
- function IsFile(): boolean;
- function IsDirectory(): boolean;
- function IsAbsolute(): boolean;
- function GetFileAge(): integer; overload;
- function GetFileAge(out FileDateTime: TDateTime): boolean; overload;
- function GetAttr(): cardinal;
- function SetAttr(Attr: Integer): boolean;
- function IsReadOnly(): boolean;
- function SetReadOnly(ReadOnly: boolean): boolean;
-
- {**
- * Checks if this path points to nothing, that means the path consists of
- * the empty string '' and hence equals PATH_NONE.
- * This is a shortcut for IPath.Equals('') or IPath.Equals(PATH_NONE).
- * If IsUnset() returns true this path and PATH_NONE are equal but they must
- * not be identical as the references might point to different objects.
- *
- * Example:
- * Path('').Equals(PATH_EMPTY) -> true
- * Path('') = PATH_EMPTY -> false
- *}
- function IsUnset(): boolean;
- function IsSet(): boolean;
-
- {**
- * Compares this path with Other and returns true if both paths are
- * equal. Both paths are expanded and trailing slashes excluded before
- * comparison. If IgnoreCase is true, the case will be ignored on
- * case-sensitive filesystems.
- *}
- function Equals(const Other: IPath; IgnoreCase: boolean = false): boolean; overload;
- function Equals(const Other: RawByteString; IgnoreCase: boolean = false): boolean; overload;
- function Equals(const Other: WideString; IgnoreCase: boolean = false): boolean; overload;
-
- {**
- * Searches for a file in DirList. The Result is nil if the file was
- * not found. Use IFileSystem.FileFind() instead if you want to use
- * wildcards.
- * @seealso SysUtils.FileSearch()
- *}
- function FileSearch(const DirList: IPath): IPath;
-
- {**
- * File must be closed with FileClose(Handle) after usage
- *}
- function CreateFile(): TFileHandle;
- function DeleteFile(): boolean;
- function CreateDirectory(Force: boolean = false): boolean;
- function DeleteEmptyDir(): boolean;
- function Rename(const NewName: IPath): boolean;
- function CopyFile(const Target: IPath; FailIfExists: boolean): boolean;
-
- // TODO: Dirwatch stuff
- // AddFileChangeListener(Listener: TFileChangeListener);
-
- {**
- * Internal string representation. For debugging only.
- *}
- function GetIntern: UTF8String;
- property Intern: UTF8String READ GetIntern;
- end;
-
-{**
- * Creates a new path with the given pathname. PathName can be either in UTF8
- * or the local encoding.
- * Notes:
- * - On Apple only UTF8 is supported
- * - Same applies to Unix with LC_CTYPE set to UTF8 encoding (default on newer systems)
- *}
-function Path(const PathName: RawByteString; DelimOption: TPathDelimOption = pdKeep): IPath; overload;
-function Path(PathName: PChar; DelimOption: TPathDelimOption = pdKeep): IPath; overload;
-
-{**
- * Creates a new path with the given UTF-16 pathname.
- *}
-function Path(const PathName: WideString; DelimOption: TPathDelimOption = pdKeep): IPath; overload;
-
-{**
- * Returns a singleton for Path('').
- *}
-function PATH_NONE(): IPath;
-
-implementation
-
-uses
- RTLConsts,
- UTextEncoding,
- UFilesystem;
-
-{*
- * Due to a compiler bug in FPC <= 2.2.4 reference counting does not work
- * properly with interfaces (see http://bugs.freepascal.org/view.php?id=14019).
- *
- * There are two (probably more) scenarios causes a program to crash:
- *
- * 1. Assume we execute Path('fail').GetParent().ToUTF8(). The compiler will
- * internally create a temporary variable to hold the result of Path('fail').
- * This temporary var is then passed as Self to GetParent(). Unfortunately FPC
- * does already decrement the ref-count of the temporary var at the end of the
- * call to Path('fail') and the ref-count drops to zero and the temp object
- * is destroyed as FPC erroneously assumes that the temp is not used anymore.
- * As a result the Self variable in GetParent() will be invalid, the same
- * applies to TPathImpl.fName which reference count dropped to zero when the
- * temp was destroyed. Hence GetParent() will likely crash.
- * If it does not, ToUTF8() will either return some random string
- * (e.g. '' or stupid stuff like 'fhwkjehdk') or crash.
- * Either way the result of ToUTF8() is messed up.
- * This scenario applies whenever a function (or method) is called that returns
- * an interfaced object (e.g. an IPath) and the result is used without storing
- * a reference to it in a (temporary) variable first.
- *
- * Tmp := Path('fail'); Tmp2 := Tmp.GetParent(); Tmp2.ToUTF8();
- *
- * will not crash but is very impractical and error-prone. Note that Tmp2 cannot
- * be replaced with Tmp (see scenario 2).
- *
- * 2. Another situation this bug will ruin our lives is when a variable to an
- * interfaced object is used at the left and right side of an assignment as in:
- * MyPath := MyPath.GetParent()
- *
- * Although the bug is already fixed in the FPC development version 2.3.1
- * it will take quite some time till the next FPC release (> 2.2.4) in which
- * this issue is fixed.
- *
- * To workaround this bug we use some very simple and stupid kind of garbage
- * collection. New IPaths are stored in an IInterfaceList (call it GarbaegeList)
- * to artificially increase the ref-count of the newly created object.
- * This keeps the object alive when FPC's temporary variable comes to the end
- * of its lifetime and the object's ref-count is decremented
- * (and is now 1 instead of 0).
- * Later on, the object is either garbage or referenced by another variable.
- *
- * Look at
- * MyPath := Path('SomeDir/SubDir').GetParent()
- *
- * (1) The result of Path('SomeDir/SubDir') is garbage as it is not used anymore.
- * (2) The result of GetParent() is referenced by MyPath
- * Object (1) has a reference count of 1 (as it is only referenced by the
- * GarbageList). Object (2) is referenced twice (MyPath + GarbageList).
- * When the reference to (2) is finally stored in MyPath we can safely remove
- * (1) and (2) from the GarbageList so (1) will be freed and the ref-count of
- * (2) will be decremented to 1.
- *
- * As we do not know when it is safe to remove an object from the GarbageList
- * we assume that there are max. GarbageMaxCount IPath elements created until
- * the execution of the expression is performed and a reference to the resulting
- * object is assigned to a variable so all temps can be safely deleted.
- *
- * Worst-case scenarios are recursive calls or calls with large call stacks with
- * functions that return an IPath. Also keep in mind that multiple threads might
- * be executing such functions at the same time.
- * A reasonable count might be a max. of 20.000 elements. With an average length
- * of 40 UTF8 chars (maybe 60 byte with class info, pointer etc.) per IPath
- * this will consume ~1.2MB.
- *}
-{$IFDEF FPC}
-{$IF FPC_VERSION_INT <= 002002004} // <= 2.2.4
- {$DEFINE HAVE_REFCNTBUG}
-{$IFEND}
-{$ENDIF}
-
-{$IFDEF HAVE_REFCNTBUG}
-const
- // when GarbageList.Count reaches GarbageMaxCount the oldest references in
- // GarbageList will be deleted until GarbageList.Count equals GarbageAfterCleanCount.
- GarbageMaxCount = 20000;
- GarbageAfterCleanCount = GarbageMaxCount-1000;
-
-var
- GarbageList: IInterfaceList;
-{$ENDIF}
-
-type
- TPathImpl = class(TInterfacedObject, IPath)
- private
- fName: UTF8String; //<** internal filename string, always UTF8 with PathDelim
-
- {**
- * Unifies the filename. Path-delimiters are replaced by '/'.
- *}
- procedure Unify(DelimOption: TPathDelimOption);
-
- {**
- * Returns a copy of fName with path delimiters changed to '/'.
- *}
- function GetPortableString(): UTF8String;
-
- procedure AssertRefCount; {$IFDEF HasInline}inline;{$ENDIF}
-
- public
- constructor Create(const Name: UTF8String; DelimOption: TPathDelimOption);
- destructor Destroy(); override;
-
- function ToUTF8(UseNativeDelim: boolean): UTF8String;
- function ToWide(UseNativeDelim: boolean): WideString;
- function ToNative(): RawByteString;
-
- function Open(Mode: longword): TFileHandle;
-
- function GetDrive(): IPath;
- function GetPath(): IPath;
- function GetDir(): IPath;
- function GetName(): IPath;
- function GetExtension(): IPath;
-
- function SetExtension(const Extension: IPath): IPath; overload;
- function SetExtension(const Extension: RawByteString): IPath; overload;
- function SetExtension(const Extension: WideString): IPath; overload;
-
- function GetRelativePath(const BaseName: IPath): IPath;
- function GetAbsolutePath(): IPath;
- function GetParent(): IPath;
- function SplitDirs(): IPathDynArray;
-
- function Append(const Child: IPath; DelimOption: TPathDelimOption): IPath; overload;
- function Append(const Child: RawByteString; DelimOption: TPathDelimOption): IPath; overload;
- function Append(const Child: WideString; DelimOption: TPathDelimOption): IPath; overload;
-
- function Equals(const Other: IPath; IgnoreCase: boolean): boolean; overload;
- function Equals(const Other: RawByteString; IgnoreCase: boolean): boolean; overload;
- function Equals(const Other: WideString; IgnoreCase: boolean): boolean; overload;
-
- function IsChildOf(const Parent: IPath; Direct: boolean): boolean;
-
- function AdjustCase(AdjustAllLevels: boolean): IPath;
-
- function AppendPathDelim(): IPath;
- function RemovePathDelim(): IPath;
-
- function GetFileAge(): integer; overload;
- function GetFileAge(out FileDateTime: TDateTime): boolean; overload;
- function Exists(): boolean;
- function IsFile(): boolean;
- function IsDirectory(): boolean;
- function IsAbsolute(): boolean;
- function GetAttr(): cardinal;
- function SetAttr(Attr: Integer): boolean;
- function IsReadOnly(): boolean;
- function SetReadOnly(ReadOnly: boolean): boolean;
-
- function IsUnset(): boolean;
- function IsSet(): boolean;
-
- function FileSearch(const DirList: IPath): IPath;
-
- function CreateFile(): TFileHandle;
- function DeleteFile(): boolean;
- function CreateDirectory(Force: boolean): boolean;
- function DeleteEmptyDir(): boolean;
- function Rename(const NewName: IPath): boolean;
- function CopyFile(const Target: IPath; FailIfExists: boolean): boolean;
-
- function GetIntern(): UTF8String;
- end;
-
-function Path(const PathName: RawByteString; DelimOption: TPathDelimOption): IPath;
-begin
- if (IsUTF8String(PathName)) then
- Result := TPathImpl.Create(PathName, DelimOption)
- else if (IsNativeUTF8()) then
- Result := PATH_NONE
- else
- Result := TPathImpl.Create(AnsiToUtf8(PathName), DelimOption);
-end;
-
-function Path(PathName: PChar; DelimOption: TPathDelimOption): IPath;
-begin
- Result := Path(RawByteString(PathName));
-end;
-
-function Path(const PathName: WideString; DelimOption: TPathDelimOption): IPath;
-begin
- Result := TPathImpl.Create(UTF8Encode(PathName), DelimOption);
-end;
-
-
-
-procedure TPathImpl.AssertRefCount;
-begin
- {$IFDEF HAVE_REFCNTBUG}
- if (FRefCount <= 0) then
- raise Exception.Create('RefCount error: ' + IntToStr(FRefCount));
- {$ENDIF}
-end;
-
-constructor TPathImpl.Create(const Name: UTF8String; DelimOption: TPathDelimOption);
-begin
- inherited Create();
- fName := Name;
- Unify(DelimOption);
- {$IFDEF HAVE_REFCNTBUG}
- GarbageList.Lock;
- if (GarbageList.Count >= GarbageMaxCount) then
- begin
- while (GarbageList.Count > GarbageAfterCleanCount) do
- GarbageList.Delete(0);
- end;
- GarbageList.Add(Self);
- GarbageList.Unlock;
- {$ENDIF}
-end;
-
-destructor TPathImpl.Destroy();
-begin
- inherited;
-end;
-
-procedure TPathImpl.Unify(DelimOption: TPathDelimOption);
-var
- I: integer;
-begin
- // convert all path delimiters to native ones
- for I := 1 to Length(fName) do
- begin
- if (fName[I] in ['\', '/']) and (fName[I] <> PathDelim) then
- fName[I] := PathDelim;
- end;
-
- // Include/ExcludeTrailingPathDelimiter need PathDelim as path delimiter
- case DelimOption of
- pdAppend: fName := IncludeTrailingPathDelimiter(fName);
- pdRemove: fName := ExcludeTrailingPathDelimiter(fName);
- end;
-end;
-
-function TPathImpl.GetPortableString(): UTF8String;
-var
- I: integer;
-begin
- Result := fName;
- if (PathDelim = '/') then
- Exit;
-
- for I := 1 to Length(Result) do
- begin
- if (Result[I] = PathDelim) then
- Result[I] := '/';
- end;
-end;
-
-function TPathImpl.ToUTF8(UseNativeDelim: boolean): UTF8String;
-begin
- AssertRefCount;
-
- if (UseNativeDelim) then
- Result := fName
- else
- Result := GetPortableString();
-end;
-
-function TPathImpl.ToWide(UseNativeDelim: boolean): WideString;
-begin
- if (UseNativeDelim) then
- Result := UTF8Decode(fName)
- else
- Result := UTF8Decode(GetPortableString());
-end;
-
-function TPathImpl.ToNative(): RawByteString;
-begin
- if (IsNativeUTF8()) then
- Result := fName
- else
- Result := Utf8ToAnsi(fName);
-end;
-
-function TPathImpl.GetDrive(): IPath;
-begin
- AssertRefCount;
- Result := FileSystem.ExtractFileDrive(Self);
-end;
-
-function TPathImpl.GetPath(): IPath;
-begin
- AssertRefCount;
- Result := FileSystem.ExtractFilePath(Self);
-end;
-
-function TPathImpl.GetDir(): IPath;
-begin
- AssertRefCount;
- Result := FileSystem.ExtractFileDir(Self);
-end;
-
-function TPathImpl.GetName(): IPath;
-begin
- AssertRefCount;
- Result := FileSystem.ExtractFileName(Self);
-end;
-
-function TPathImpl.GetExtension(): IPath;
-begin
- AssertRefCount;
- Result := FileSystem.ExtractFileExt(Self);
-end;
-
-function TPathImpl.SetExtension(const Extension: IPath): IPath;
-begin
- AssertRefCount;
- Result := FileSystem.ChangeFileExt(Self, Extension);
-end;
-
-function TPathImpl.SetExtension(const Extension: RawByteString): IPath;
-begin
- Result := SetExtension(Path(Extension));
-end;
-
-function TPathImpl.SetExtension(const Extension: WideString): IPath;
-begin
- Result := SetExtension(Path(Extension));
-end;
-
-function TPathImpl.GetRelativePath(const BaseName: IPath): IPath;
-begin
- AssertRefCount;
- Result := FileSystem.ExtractRelativePath(BaseName, Self);
-end;
-
-function TPathImpl.GetAbsolutePath(): IPath;
-begin
- AssertRefCount;
- Result := FileSystem.ExpandFileName(Self);
-end;
-
-function TPathImpl.GetParent(): IPath;
-var
- CurPath, ParentPath: IPath;
-begin
- AssertRefCount;
-
- Result := PATH_NONE;
-
- CurPath := Self.RemovePathDelim();
- // check if current path has a parent (no further '/')
- if (Pos(PathDelim, CurPath.ToUTF8()) = 0) then
- Exit;
-
- // set new path and check if it has changed to avoid endless loops
- // e.g. with invalid paths like '/C:' (GetPath() uses ':' as delimiter too)
- // on delphi/win32
- ParentPath := CurPath.GetPath();
- if (ParentPath.ToUTF8 = CurPath.ToUTF8) then
- Exit;
-
- Result := ParentPath;
-end;
-
-function TPathImpl.SplitDirs(): IPathDynArray;
-var
- CurPath: IPath;
- Components: array of IPath;
- CurPathStr: UTF8String;
- DelimPos: integer;
- I: integer;
-begin
- SetLength(Result, 0);
-
- if (Length(Self.ToUTF8(true)) = 0) then
- Exit;
-
- CurPath := Self;
- SetLength(Components, 0);
- repeat
- SetLength(Components, Length(Components)+1);
-
- CurPathStr := CurPath.ToUTF8();
- DelimPos := LastDelimiter(PathDelim, SysUtils.ExcludeTrailingPathDelimiter(CurPathStr));
- Components[High(Components)] := Path(Copy(CurPathStr, DelimPos+1, Length(CurPathStr)));
-
- CurPath := CurPath.GetParent();
- until (CurPath = PATH_NONE);
-
- // reverse list
- SetLength(Result, Length(Components));
- for I := 0 to High(Components) do
- Result[I] := Components[High(Components)-I];
-end;
-
-function TPathImpl.Append(const Child: IPath; DelimOption: TPathDelimOption): IPath;
-var
- TmpResult: IPath;
-begin
- AssertRefCount;
-
- if (fName = '') then
- TmpResult := Child
- else
- TmpResult := Path(Self.AppendPathDelim().ToUTF8() + Child.ToUTF8());
-
- case DelimOption of
- pdKeep: Result := TmpResult;
- pdAppend: Result := TmpResult.AppendPathDelim;
- pdRemove: Result := TmpResult.RemovePathDelim;
- end;
-end;
-
-function TPathImpl.Append(const Child: RawByteString; DelimOption: TPathDelimOption): IPath;
-begin
- AssertRefCount;
- Result := Append(Path(Child), DelimOption);
-end;
-
-function TPathImpl.Append(const Child: WideString; DelimOption: TPathDelimOption): IPath;
-begin
- AssertRefCount;
- Result := Append(Path(Child), DelimOption);
-end;
-
-function TPathImpl.Equals(const Other: IPath; IgnoreCase: boolean): boolean;
-var
- SelfPath, OtherPath: UTF8String;
-begin
- SelfPath := Self.GetAbsolutePath().RemovePathDelim().ToUTF8();
- OtherPath := Other.GetAbsolutePath().RemovePathDelim().ToUTF8();
- if (FileSystem.IsCaseSensitive() and not IgnoreCase) then
- Result := (CompareStr(SelfPath, OtherPath) = 0)
- else
- Result := (CompareText(SelfPath, OtherPath) = 0);
-end;
-
-function TPathImpl.Equals(const Other: RawByteString; IgnoreCase: boolean): boolean;
-begin
- Result := Equals(Path(Other), IgnoreCase);
-end;
-
-function TPathImpl.Equals(const Other: WideString; IgnoreCase: boolean): boolean;
-begin
- Result := Equals(Path(Other), IgnoreCase);
-end;
-
-function TPathImpl.IsChildOf(const Parent: IPath; Direct: boolean): boolean;
-var
- SelfPath, ParentPath: UTF8String;
-begin
- Result := false;
-
- if (Direct) then
- begin
- SelfPath := Self.GetParent().GetAbsolutePath().AppendPathDelim().ToUTF8();
- ParentPath := Parent.GetAbsolutePath().AppendPathDelim().ToUTF8();
-
- // simply check if this paths parent path (SelfPath) equals ParentPath
- Result := (SelfPath = ParentPath);
- end
- else
- begin
- SelfPath := Self.GetAbsolutePath().AppendPathDelim().ToUTF8();
- ParentPath := Parent.GetAbsolutePath().AppendPathDelim().ToUTF8();
-
- if (Length(SelfPath) <= Length(ParentPath)) then
- Exit;
-
- // check if ParentPath is a substring of SelfPath
- if (FileSystem.IsCaseSensitive()) then
- Result := (StrLComp(PAnsiChar(SelfPath), PAnsiChar(ParentPath), Length(ParentPath)) = 0)
- else
- Result := (StrLIComp(PAnsiChar(SelfPath), PAnsiChar(ParentPath), Length(ParentPath)) = 0)
- end;
-end;
-
-function AdjustCaseRecursive(CurPath: IPath; AdjustAllLevels: boolean): IPath;
-var
- OldParent, AdjustedParent: IPath;
- LocalName: IPath;
- PathFound: IPath;
- PathWithAdjParent: IPath;
- SearchInfo: TFileInfo;
- FileIter: IFileIterator;
- Pattern: IPath;
-begin
- // if case-sensitive path exists there is no need to adjust case
- if (CurPath.Exists()) then
- begin
- Result := CurPath;
- Exit;
- end;
-
- LocalName := CurPath.RemovePathDelim().GetName();
-
- // try to adjust parent
- OldParent := CurPath.GetParent();
- if (OldParent <> PATH_NONE) then
- begin
- if (not AdjustAllLevels) then
- begin
- AdjustedParent := OldParent;
- end
- else
- begin
- AdjustedParent := AdjustCaseRecursive(OldParent, AdjustAllLevels);
- if (AdjustedParent = nil) then
- begin
- // parent path was not found case-insensitive
- Result := nil;
- Exit;
- end;
-
- // check if the path with adjusted parent can be found now
- PathWithAdjParent := AdjustedParent.Append(LocalName);
- if (PathWithAdjParent.Exists()) then
- begin
- Result := PathWithAdjParent;
- Exit;
- end;
- end;
- Pattern := AdjustedParent.Append(Path('*'));
- end
- else // path has no parent
- begin
- // the top path can either be absolute or relative
- if (CurPath.IsAbsolute) then
- begin
- // the only absolute directory at Unix without a parent is root ('/')
- // and hence does not need to be adjusted
- Result := CurPath;
- Exit;
- end;
- // this is a relative path, search in the current working dir
- AdjustedParent := nil;
- Pattern := Path('*');
- end;
-
- // compare name with all files in the current directory case-insensitive
- FileIter := FileSystem.FileFind(Pattern, faAnyFile);
- while (FileIter.HasNext()) do
- begin
- SearchInfo := FileIter.Next();
- PathFound := SearchInfo.Name;
- if (CompareText(LocalName.ToUTF8, PathFound.ToUTF8) = 0) then
- begin
- if (AdjustedParent <> nil) then
- Result := AdjustedParent.Append(PathFound)
- else
- Result := PathFound;
- Exit;
- end;
- end;
-
- // no matching file found
- Result := nil;
-end;
-
-function TPathImpl.AdjustCase(AdjustAllLevels: boolean): IPath;
-begin
- AssertRefCount;
-
- Result := Self;
-
- if (FileSystem.IsCaseSensitive) then
- begin
- Result := AdjustCaseRecursive(Self, AdjustAllLevels);
- if (Result = nil) then
- Result := Self;
- end;
-end;
-
-function TPathImpl.AppendPathDelim(): IPath;
-begin
- AssertRefCount;
- Result := FileSystem.IncludeTrailingPathDelimiter(Self);
-end;
-
-function TPathImpl.RemovePathDelim(): IPath;
-begin
- AssertRefCount;
- Result := FileSystem.ExcludeTrailingPathDelimiter(Self);
-end;
-
-function TPathImpl.CreateFile(): TFileHandle;
-begin
- Result := FileSystem.FileCreate(Self);
-end;
-
-function TPathImpl.CreateDirectory(Force: boolean): boolean;
-begin
- if (Force) then
- Result := FileSystem.ForceDirectories(Self)
- else
- Result := FileSystem.DirectoryCreate(Self);
-end;
-
-function TPathImpl.Open(Mode: longword): TFileHandle;
-begin
- Result := FileSystem.FileOpen(Self, Mode);
-end;
-
-function TPathImpl.GetFileAge(): integer;
-begin
- Result := FileSystem.FileAge(Self);
-end;
-
-function TPathImpl.GetFileAge(out FileDateTime: TDateTime): boolean;
-begin
- Result := FileSystem.FileAge(Self, FileDateTime);
-end;
-
-function TPathImpl.Exists(): boolean;
-begin
- // note the different specifications of FileExists() on Win32 <> Unix
- {$IFDEF MSWINDOWS}
- Result := IsFile() or IsDirectory();
- {$ELSE}
- Result := FileSystem.FileExists(Self);
- {$ENDIF}
-end;
-
-function TPathImpl.IsFile(): boolean;
-begin
- // note the different specifications of FileExists() on Win32 <> Unix
- {$IFDEF MSWINDOWS}
- Result := FileSystem.FileExists(Self);
- {$ELSE}
- Result := Exists() and not IsDirectory();
- {$ENDIF}
-end;
-
-function TPathImpl.IsDirectory(): boolean;
-begin
- Result := FileSystem.DirectoryExists(Self);
-end;
-
-function TPathImpl.IsAbsolute(): boolean;
-begin
- AssertRefCount;
- Result := FileSystem.FileIsAbsolute(Self);
-end;
-
-function TPathImpl.GetAttr(): cardinal;
-begin
- Result := FileSystem.FileGetAttr(Self);
-end;
-
-function TPathImpl.SetAttr(Attr: Integer): boolean;
-begin
- Result := FileSystem.FileSetAttr(Self, Attr);
-end;
-
-function TPathImpl.IsReadOnly(): boolean;
-begin
- Result := FileSystem.FileIsReadOnly(Self);
-end;
-
-function TPathImpl.SetReadOnly(ReadOnly: boolean): boolean;
-begin
- Result := FileSystem.FileSetReadOnly(Self, ReadOnly);
-end;
-
-function TPathImpl.IsUnset(): boolean;
-begin
- Result := (fName = '');
-end;
-
-function TPathImpl.IsSet(): boolean;
-begin
- Result := (fName <> '');
-end;
-
-function TPathImpl.FileSearch(const DirList: IPath): IPath;
-begin
- AssertRefCount;
- Result := FileSystem.FileSearch(Self, DirList);
-end;
-
-function TPathImpl.Rename(const NewName: IPath): boolean;
-begin
- Result := FileSystem.RenameFile(Self, NewName);
-end;
-
-function TPathImpl.DeleteFile(): boolean;
-begin
- Result := FileSystem.DeleteFile(Self);
-end;
-
-function TPathImpl.DeleteEmptyDir(): boolean;
-begin
- Result := FileSystem.RemoveDir(Self);
-end;
-
-function TPathImpl.CopyFile(const Target: IPath; FailIfExists: boolean): boolean;
-begin
- Result := FileSystem.CopyFile(Self, Target, FailIfExists);
-end;
-
-function TPathImpl.GetIntern(): UTF8String;
-begin
- Result := fName;
-end;
-
-
-{ TBinaryFileStream }
-
-constructor TBinaryFileStream.Create(const FileName: IPath; Mode: word);
-begin
-{$IFDEF MSWINDOWS}
- inherited Create(FileName.ToWide(), Mode);
-{$ELSE}
- inherited Create(FileName.ToNative(), Mode);
-{$ENDIF}
-end;
-
-{ TTextStream }
-
-constructor TTextFileStream.Create(Filename: IPath; Mode: word);
-begin
- inherited Create();
- fMode := Mode;
- fFilename := Filename;
- fLineBreak := sLineBreak;
-end;
-
-function TTextFileStream.ReadLine(var Line: UTF8String): boolean;
-begin
- Line := ReadLine(Result);
-end;
-
-function TTextFileStream.ReadLine(var Line: AnsiString): boolean;
-begin
- Line := ReadLine(Result);
-end;
-
-procedure TTextFileStream.WriteString(const Str: RawByteString);
-begin
- WriteBuffer(Str[1], Length(Str));
-end;
-
-procedure TTextFileStream.WriteLine(const Line: RawByteString);
-begin
- WriteBuffer(Line[1], Length(Line));
- WriteBuffer(fLineBreak[1], Length(fLineBreak));
-end;
-
-{ TMemTextStream }
-
-constructor TMemTextFileStream.Create(Filename: IPath; Mode: word);
-var
- FileStream: TBinaryFileStream;
-begin
- inherited Create(Filename, Mode);
-
- fStream := TMemoryStream.Create();
-
- // load data to memory in read mode
- if ((Mode and 3) in [fmOpenRead, fmOpenReadWrite]) then
- begin
- FileStream := TBinaryFileStream.Create(Filename, fmOpenRead);
- try
- fStream.LoadFromStream(FileStream);
- finally
- FileStream.Free;
- end;
- end
- // check if file exists for write-mode
- else if ((Mode and 3) = fmOpenWrite) and (not Filename.IsFile) then
- begin
- raise EFOpenError.CreateResFmt(@SFOpenError,
- [FileName.GetAbsolutePath.ToNative]);
- end;
-end;
-
-destructor TMemTextFileStream.Destroy();
-var
- FileStream: TBinaryFileStream;
- SaveMode: word;
-begin
- // save changes in write mode (= not read-only mode)
- if ((fMode and 3) <> fmOpenRead) then
- begin
- if (fMode = fmCreate) then
- SaveMode := fmCreate
- else
- SaveMode := fmOpenWrite;
- FileStream := TBinaryFileStream.Create(fFilename, SaveMode);
- try
- fStream.SaveToStream(FileStream);
- finally
- FileStream.Free;
- end;
- end;
-
- fStream.Free;
- inherited;
-end;
-
-function TMemTextFileStream.GetSize: int64;
-begin
- Result := fStream.Size;
-end;
-
-function TMemTextFileStream.Read(var Buffer; Count: longint): longint;
-begin
- Result := fStream.Read(Buffer, Count);
-end;
-
-function TMemTextFileStream.Write(const Buffer; Count: longint): longint;
-begin
- Result := fStream.Write(Buffer, Count);
-end;
-
-function TMemTextFileStream.Seek(Offset: longint; Origin: word): longint;
-begin
- Result := fStream.Seek(Offset, Origin);
-end;
-
-function TMemTextFileStream.Seek(const Offset: int64; Origin: TSeekOrigin): int64;
-begin
- Result := fStream.Seek(Offset, Origin);
-end;
-
-function TMemTextFileStream.CopyMemString(StartPos: int64; EndPos: int64): RawByteString;
-var
- LineLength: cardinal;
- Temp: RawByteString;
-begin
- LineLength := EndPos - StartPos;
- if (LineLength > 0) then
- begin
- // set string length to line-length (+ zero-terminator)
- SetLength(Temp, LineLength);
- StrLCopy(PAnsiChar(Temp),
- @PAnsiChar(fStream.Memory)[StartPos],
- LineLength);
- Result := Temp;
- end
- else
- begin
- Result := '';
- end;
-end;
-
-function TMemTextFileStream.ReadString(): RawByteString;
-var
- TextPtr: PAnsiChar;
- CurPos, StartPos, FileSize: int64;
-begin
- TextPtr := PAnsiChar(fStream.Memory);
- CurPos := Position;
- FileSize := Size;
- StartPos := -1;
-
- while (CurPos < FileSize) do
- begin
- // check for whitespace (tab, lf, cr, space)
- if (TextPtr[CurPos] in [#9, #10, #13, ' ']) then
- begin
- // check if we are at the end of a string
- if (StartPos > -1) then
- Break;
- end
- else if (StartPos = -1) then // start of string found
- begin
- StartPos := CurPos;
- end;
- Inc(CurPos);
- end;
-
- if (StartPos = -1) then
- Result := ''
- else
- begin
- Result := CopyMemString(StartPos, CurPos);
- fStream.Position := CurPos;
- end;
-end;
-
-{*
- * Implementation of ReadLine(). We need separate versions for UTF8String
- * and AnsiString as "var" parameter types have to fit exactly.
- * To avoid a var-parameter here, the internal version the Line parameter is
- * used as return value.
- *}
-function TMemTextFileStream.ReadLine(var Success: boolean): RawByteString;
-var
- TextPtr: PAnsiChar;
- CurPos, FileSize: int64;
-begin
- TextPtr := PAnsiChar(fStream.Memory);
- CurPos := fStream.Position;
- FileSize := Size;
-
- // check for EOF
- if (CurPos >= FileSize) then
- begin
- Result := '';
- Success := false;
- Exit;
- end;
-
- Success := true;
-
- while (CurPos < FileSize) do
- begin
- if (TextPtr[CurPos] in [#10, #13]) then
- begin
- // copy text line
- Result := CopyMemString(fStream.Position, CurPos);
-
- // handle windows style #13#10 (\r\n) newlines
- if (TextPtr[CurPos] = #13) and
- (CurPos+1 < FileSize) and
- (TextPtr[CurPos+1] = #10) then
- begin
- Inc(CurPos);
- end;
-
- // update stream pos
- fStream.Position := CurPos+1;
-
- Exit;
- end;
- Inc(CurPos);
- end;
-
- Result := CopyMemString(fStream.Position, CurPos);
- fStream.Position := FileSize;
-end;
-
-{ TUnicodeMemoryStream }
-
-procedure TUnicodeMemoryStream.LoadFromFile(const FileName: IPath);
-var
- Stream: TStream;
-begin
- Stream := TBinaryFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
- try
- LoadFromStream(Stream);
- finally
- Stream.Free;
- end;
-end;
-
-procedure TUnicodeMemoryStream.SaveToFile(const FileName: IPath);
-var
- Stream: TStream;
-begin
- Stream := TBinaryFileStream.Create(FileName, fmCreate);
- try
- SaveToStream(Stream);
- finally
- Stream.Free;
- end;
-end;
-
-{ TUnicodeMemIniFile }
-
-constructor TUnicodeMemIniFile.Create(const FileName: IPath; UTF8Encoded: boolean);
-var
- List: TStringList;
- Stream: TBinaryFileStream;
- BOMBuf: array[0..2] of AnsiChar;
-begin
- inherited Create('');
- FFilename := FileName;
- FUTF8Encoded := UTF8Encoded;
-
- if FileName.Exists() then
- begin
- List := nil;
- Stream := nil;
- try
- List := TStringList.Create;
- Stream := TBinaryFileStream.Create(FileName, fmOpenRead);
- if (Stream.Read(BOMBuf[0], SizeOf(BOMBuf)) = 3) and
- (CompareMem(PChar(UTF8_BOM), @BomBuf, Length(UTF8_BOM))) then
- begin
- // truncate BOM
- FUTF8Encoded := true;
- end
- else
- begin
- // rewind file
- Stream.Seek(0, soBeginning);
- end;
- List.LoadFromStream(Stream);
- SetStrings(List);
- finally
- Stream.Free;
- List.Free;
- end;
- end;
-end;
-
-procedure TUnicodeMemIniFile.UpdateFile;
-var
- List: TStringList;
- Stream: TBinaryFileStream;
-begin
- List := nil;
- Stream := nil;
- try
- List := TStringList.Create;
- GetStrings(List);
- Stream := TBinaryFileStream.Create(FFileName, fmCreate);
- if UTF8Encoded then
- Stream.Write(UTF8_BOM, Length(UTF8_BOM));
- List.SaveToStream(Stream);
- finally
- List.Free;
- Stream.Free;
- end;
-end;
-
-
-var
- PATH_NONE_Singelton: IPath;
-
-function PATH_NONE(): IPath;
-begin
- Result := PATH_NONE_Singelton;
-end;
-
-initialization
- {$IFDEF HAVE_REFCNTBUG}
- GarbageList := TInterfaceList.Create();
- GarbageList.Capacity := GarbageMaxCount;
- {$ENDIF}
- PATH_NONE_Singelton := Path('');
-
-finalization
- PATH_NONE_Singelton := nil;
-
-end.
+{* UltraStar Deluxe - Karaoke Game
+ *
+ * UltraStar Deluxe is the legal property of its developers, whose names
+ * are too numerous to list here. Please refer to the COPYRIGHT
+ * file distributed with this source distribution.
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301, USA.
+ *
+ * $URL$
+ * $Id$
+ *}
+
+unit UPath;
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+{$ENDIF}
+
+{$I switches.inc}
+
+interface
+
+uses
+ SysUtils,
+ Classes,
+ IniFiles,
+ {$IFDEF MSWINDOWS}
+ TntClasses,
+ {$ENDIF}
+ UConfig,
+ UUnicodeUtils;
+
+type
+ IPath = interface;
+
+ {$IFDEF FPC}
+ TFileHandle = THandle;
+ {$ELSE}
+ TFileHandle = Longint;
+ {$ENDIF}
+
+ {**
+ * TUnicodeMemoryStream
+ *}
+ TUnicodeMemoryStream = class(TMemoryStream)
+ public
+ procedure LoadFromFile(const FileName: IPath);
+ procedure SaveToFile(const FileName: IPath);
+ end;
+
+ {**
+ * Unicode capable IniFile implementation.
+ * TMemIniFile and TIniFile are not able to handle INI-files with
+ * an UTF-8 BOM. This implementation checks if an UTF-8 BOM exists
+ * and removes it from the internal string-list.
+ * UTF8Encoded is set accordingly.
+ *}
+ TUnicodeMemIniFile = class(TMemIniFile)
+ private
+ FFilename: IPath;
+ FUTF8Encoded: boolean;
+ public
+ constructor Create(const FileName: IPath; UTF8Encoded: boolean = false); reintroduce;
+ procedure UpdateFile; override;
+ property UTF8Encoded: boolean READ FUTF8Encoded WRITE FUTF8Encoded;
+ end;
+
+ {**
+ * TBinaryFileStream (inherited from THandleStream)
+ *}
+ {$IFDEF MSWINDOWS}
+ TBinaryFileStream = class(TTntFileStream)
+ {$ELSE}
+ TBinaryFileStream = class(TFileStream)
+ {$ENDIF}
+ public
+ {**
+ * @seealso TFileStream.Create for valid Mode parameters
+ *}
+ constructor Create(const FileName: IPath; Mode: word);
+ end;
+
+ {**
+ * TTextFileStream
+ *}
+ TTextFileStream = class(TStream)
+ protected
+ fLineBreak: RawByteString;
+ fFilename: IPath;
+ fMode: word;
+
+ function ReadLine(var Success: boolean): RawByteString; overload; virtual; abstract;
+ public
+ constructor Create(Filename: IPath; Mode: word);
+
+ function ReadString(): RawByteString; virtual; abstract;
+ function ReadLine(var Line: UTF8String): boolean; overload;
+ function ReadLine(var Line: AnsiString): boolean; overload;
+
+ procedure WriteString(const Str: RawByteString); virtual;
+ procedure WriteLine(const Line: RawByteString); virtual;
+
+ property LineBreak: RawByteString read fLineBreak write fLineBreak;
+ property Filename: IPath read fFilename;
+ end;
+
+ {**
+ * TMemTextStream
+ *}
+ TMemTextFileStream = class(TTextFileStream)
+ private
+ fStream: TMemoryStream;
+ protected
+ function GetSize: int64; override;
+
+ {**
+ * Copies fStream.Memory from StartPos to EndPos-1 to the result string;
+ *}
+ function CopyMemString(StartPos: int64; EndPos: int64): RawByteString;
+ public
+ constructor Create(Filename: IPath; Mode: word);
+ destructor Destroy(); override;
+
+ function Read(var Buffer; Count: longint): longint; override;
+ function Write(const Buffer; Count: longint): longint; override;
+ function Seek(Offset: longint; Origin: word): longint; override;
+ function Seek(const Offset: int64; Origin: TSeekOrigin): int64; override;
+
+ function ReadLine(var Success: boolean): RawByteString; override;
+ function ReadString(): RawByteString; override;
+ end;
+
+ {**
+ TUnicodeIniStream = class()
+ end;
+ *}
+
+ {**
+ * pdKeep: Keep path as is, neither remove or append a delimiter
+ * pdAppend: Append a delimiter if path does not have a trailing one
+ * pdRemove: Remove a trailing delimiter from the path
+ *}
+ TPathDelimOption = (pdKeep, pdAppend, pdRemove);
+
+ IPathDynArray = array of IPath;
+
+ {**
+ * An IPath represents a filename, a directory or a filesystem path in general.
+ * It hides some of the operating system's specifics like path delimiters
+ * and encodings and provides an easy to use interface to handle them.
+ * Internally all paths are stored with the same path delimiter (PathDelim)
+ * and encoding (UTF-8). The transformation is already done AT THE CREATION of
+ * the IPath and hence calls to e.g. IPath.Equal() will not distinguish between
+ * Unix and Windows style paths.
+ *
+ * Create new paths with one of the Path() functions.
+ * If you need a string representation use IPath.ToNative/ToUTF8/ToWide.
+ * Note that due to the path-delimiter and encoding transformation the string
+ * might have changed. Path('one\test/path').ToUTF8() might return 'one/test/path'.
+ *
+ * It is recommended to use an IPath as long as possible without a string
+ * conversion (IPath.To...()). The whole Delphi (< 2009) and FPC RTL is ANSI
+ * only on Windows. If you would use for example FileExists(MyPath.ToNative)
+ * it would not find a file which contains characters that are not in the
+ * current locale. Same applies to AssignFile(), TFileStream.Create() and
+ * everything else in the RTL that expects a filename.
+ * As a rule of thumb: NEVER use any of the Delphi/FPC RTL filename functions
+ * if the filename parameter is not of a UTF8String or WideString type.
+ *
+ * If you need to open a file use TBinaryStream or TFileStream instead. Many
+ * of the RTL classes offer a LoadFromStream() method so ANSI Open() methods
+ * can be workaround.
+ *
+ * If there is only a ANSI and no IPath/UTF-8/WideString version and you cannot
+ * even pass a stream instead of a filename be aware that even if you know that
+ * a filename is ASCII only, subdirectories in an absolute path might contain
+ * some non-ASCII characters (for example the user's name) and hence might
+ * fail (if the characters are not in the current locale).
+ * It is rare but it happens.
+ *
+ * IMPORTANT:
+ * This interface needs the cwstring unit on Unix (Max OS X / Linux) systems.
+ * Cwstring functions (WideUpperCase, ...) cannot be used by external threads
+ * as FPC uses Thread-Local-Storage for the implementation. As a result do not
+ * call IPath stuff by external threads (e.g. in C callbacks or by SDL-threads).
+ *}
+ IPath = interface
+ ['{686BF103-CE43-4598-B85D-A2C3AF950897}']
+ {**
+ * Returns the path as an UTF8 encoded string.
+ * If UseNativeDelim is set to true, the native path delimiter ('\' on win32)
+ * is used. If it is set to false the (more) portable '/' delimiter will used.
+ *}
+ function ToUTF8(UseNativeDelim: boolean = true): UTF8String;
+
+ {**
+ * Returns the path as an UTF-16 encoded string.
+ * If UseNativeDelim is set to true, the native path delimiter ('\' on win32)
+ * is used. If it is set to false the delimiter will be '/'.
+ *}
+ function ToWide(UseNativeDelim: boolean = true): WideString;
+
+ {**
+ * Returns the path with the system's native encoding and path delimiter.
+ * Win32: ANSI (use the UTF-16 version IPath.ToWide() whenever possible)
+ * Mac: UTF8
+ * Unix: UTF8 or ANSI according to LC_CTYPE
+ *}
+ function ToNative(): RawByteString;
+
+ {**
+ * Note: File must be closed with FileClose(Handle) after usage
+ * @seealso SysUtils.FileOpen()
+ *}
+ function Open(Mode: longword): TFileHandle;
+
+ {** @seealso SysUtils.ExtractFileDrive() *}
+ function GetDrive(): IPath;
+
+ {** @seealso SysUtils.ExtractFilePath() *}
+ function GetPath(): IPath;
+
+ {** @seealso SysUtils.ExtractFileDir() *}
+ function GetDir(): IPath;
+
+ {** @seealso SysUtils.ExtractFileName() *}
+ function GetName(): IPath;
+
+ {** @seealso SysUtils.ExtractFileExtension() *}
+ function GetExtension(): IPath;
+
+ {**
+ * Returns a copy of the path with the extension changed to Extension.
+ * The file itself is not changed, use Rename() for this task.
+ * @seealso SysUtils.ChangeFileExt()
+ *}
+ function SetExtension(const Extension: IPath): IPath; overload;
+ function SetExtension(const Extension: RawByteString): IPath; overload;
+ function SetExtension(const Extension: WideString): IPath; overload;
+
+ {**
+ * Returns the representation of the path relative to Basename.
+ * Note that the basename must be terminated with a path delimiter
+ * otherwise the last path component will be ignored.
+ * @seealso SysUtils.ExtractRelativePath()
+ *}
+ function GetRelativePath(const BaseName: IPath): IPath;
+
+ {** @seealso SysUtils.ExpandFileName() *}
+ function GetAbsolutePath(): IPath;
+
+ {**
+ * Returns the concatenation of this path with Child. If this path does not
+ * end with a path delimiter one is inserted in front of the Child path.
+ * Example: Path('parent').Append(Path('child')) -> Path('parent/child')
+ *}
+ function Append(const Child: IPath; DelimOption: TPathDelimOption = pdKeep): IPath; overload;
+ function Append(const Child: RawByteString; DelimOption: TPathDelimOption = pdKeep): IPath; overload;
+ function Append(const Child: WideString; DelimOption: TPathDelimOption = pdKeep): IPath; overload;
+
+ {**
+ * Splits the path into its components. Path delimiters are not removed from
+ * components.
+ * Example: C:\test\my\dir -> ['C:\', 'test\', 'my\', 'dir']
+ *}
+ function SplitDirs(): IPathDynArray;
+
+ {**
+ * Returns the parent directory or PATH_NONE if none exists.
+ *}
+ function GetParent(): IPath;
+
+ {**
+ * Checks if this path is a subdir of or file inside Parent.
+ * If Direct is true this path must be a direct child.
+ * Example: C:\test\file is a direct child of C:\test and a child of C:\
+ *}
+ function IsChildOf(const Parent: IPath; Direct: boolean): boolean;
+
+ {**
+ * Adjusts the case of the path on case senstitive filesystems.
+ * If the path does not exist or the filesystem is case insensitive
+ * the original path will be returned. Otherwise a corrected copy.
+ *}
+ function AdjustCase(AdjustAllLevels: boolean): IPath;
+
+ {** @seealso SysUtils.IncludeTrailingPathDelimiter() *}
+ function AppendPathDelim(): IPath;
+
+ {** @seealso SysUtils.ExcludeTrailingPathDelimiter() *}
+ function RemovePathDelim(): IPath;
+
+ function Exists(): boolean;
+ function IsFile(): boolean;
+ function IsDirectory(): boolean;
+ function IsAbsolute(): boolean;
+ function GetFileAge(): integer; overload;
+ function GetFileAge(out FileDateTime: TDateTime): boolean; overload;
+ function GetAttr(): cardinal;
+ function SetAttr(Attr: Integer): boolean;
+ function IsReadOnly(): boolean;
+ function SetReadOnly(ReadOnly: boolean): boolean;
+
+ {**
+ * Checks if this path points to nothing, that means the path consists of
+ * the empty string '' and hence equals PATH_NONE.
+ * This is a shortcut for IPath.Equals('') or IPath.Equals(PATH_NONE).
+ * If IsUnset() returns true this path and PATH_NONE are equal but they must
+ * not be identical as the references might point to different objects.
+ *
+ * Example:
+ * Path('').Equals(PATH_EMPTY) -> true
+ * Path('') = PATH_EMPTY -> false
+ *}
+ function IsUnset(): boolean;
+ function IsSet(): boolean;
+
+ {**
+ * Compares this path with Other and returns true if both paths are
+ * equal. Both paths are expanded and trailing slashes excluded before
+ * comparison. If IgnoreCase is true, the case will be ignored on
+ * case-sensitive filesystems.
+ *}
+ function Equals(const Other: IPath; IgnoreCase: boolean = false): boolean; overload;
+ function Equals(const Other: RawByteString; IgnoreCase: boolean = false): boolean; overload;
+ function Equals(const Other: WideString; IgnoreCase: boolean = false): boolean; overload;
+
+ {**
+ * Searches for a file in DirList. The Result is nil if the file was
+ * not found. Use IFileSystem.FileFind() instead if you want to use
+ * wildcards.
+ * @seealso SysUtils.FileSearch()
+ *}
+ function FileSearch(const DirList: IPath): IPath;
+
+ {**
+ * File must be closed with FileClose(Handle) after usage
+ *}
+ function CreateFile(): TFileHandle;
+ function DeleteFile(): boolean;
+ function CreateDirectory(Force: boolean = false): boolean;
+ function DeleteEmptyDir(): boolean;
+ function Rename(const NewName: IPath): boolean;
+ function CopyFile(const Target: IPath; FailIfExists: boolean): boolean;
+
+ // TODO: Dirwatch stuff
+ // AddFileChangeListener(Listener: TFileChangeListener);
+
+ {**
+ * Internal string representation. For debugging only.
+ *}
+ function GetIntern: UTF8String;
+ property Intern: UTF8String READ GetIntern;
+ end;
+
+{**
+ * Creates a new path with the given pathname. PathName can be either in UTF8
+ * or the local encoding.
+ * Notes:
+ * - On Apple only UTF8 is supported
+ * - Same applies to Unix with LC_CTYPE set to UTF8 encoding (default on newer systems)
+ *}
+function Path(const PathName: RawByteString; DelimOption: TPathDelimOption = pdKeep): IPath; overload;
+function Path(PathName: PChar; DelimOption: TPathDelimOption = pdKeep): IPath; overload;
+
+{**
+ * Creates a new path with the given UTF-16 pathname.
+ *}
+function Path(const PathName: WideString; DelimOption: TPathDelimOption = pdKeep): IPath; overload;
+
+{**
+ * Returns a singleton for Path('').
+ *}
+function PATH_NONE(): IPath;
+
+implementation
+
+uses
+ RTLConsts,
+ UTextEncoding,
+ UFilesystem;
+
+{*
+ * Due to a compiler bug in FPC <= 2.2.4 reference counting does not work
+ * properly with interfaces (see http://bugs.freepascal.org/view.php?id=14019).
+ *
+ * There are two (probably more) scenarios causes a program to crash:
+ *
+ * 1. Assume we execute Path('fail').GetParent().ToUTF8(). The compiler will
+ * internally create a temporary variable to hold the result of Path('fail').
+ * This temporary var is then passed as Self to GetParent(). Unfortunately FPC
+ * does already decrement the ref-count of the temporary var at the end of the
+ * call to Path('fail') and the ref-count drops to zero and the temp object
+ * is destroyed as FPC erroneously assumes that the temp is not used anymore.
+ * As a result the Self variable in GetParent() will be invalid, the same
+ * applies to TPathImpl.fName which reference count dropped to zero when the
+ * temp was destroyed. Hence GetParent() will likely crash.
+ * If it does not, ToUTF8() will either return some random string
+ * (e.g. '' or stupid stuff like 'fhwkjehdk') or crash.
+ * Either way the result of ToUTF8() is messed up.
+ * This scenario applies whenever a function (or method) is called that returns
+ * an interfaced object (e.g. an IPath) and the result is used without storing
+ * a reference to it in a (temporary) variable first.
+ *
+ * Tmp := Path('fail'); Tmp2 := Tmp.GetParent(); Tmp2.ToUTF8();
+ *
+ * will not crash but is very impractical and error-prone. Note that Tmp2 cannot
+ * be replaced with Tmp (see scenario 2).
+ *
+ * 2. Another situation this bug will ruin our lives is when a variable to an
+ * interfaced object is used at the left and right side of an assignment as in:
+ * MyPath := MyPath.GetParent()
+ *
+ * Although the bug is already fixed in the FPC development version 2.3.1
+ * it will take quite some time till the next FPC release (> 2.2.4) in which
+ * this issue is fixed.
+ *
+ * To workaround this bug we use some very simple and stupid kind of garbage
+ * collection. New IPaths are stored in an IInterfaceList (call it GarbaegeList)
+ * to artificially increase the ref-count of the newly created object.
+ * This keeps the object alive when FPC's temporary variable comes to the end
+ * of its lifetime and the object's ref-count is decremented
+ * (and is now 1 instead of 0).
+ * Later on, the object is either garbage or referenced by another variable.
+ *
+ * Look at
+ * MyPath := Path('SomeDir/SubDir').GetParent()
+ *
+ * (1) The result of Path('SomeDir/SubDir') is garbage as it is not used anymore.
+ * (2) The result of GetParent() is referenced by MyPath
+ * Object (1) has a reference count of 1 (as it is only referenced by the
+ * GarbageList). Object (2) is referenced twice (MyPath + GarbageList).
+ * When the reference to (2) is finally stored in MyPath we can safely remove
+ * (1) and (2) from the GarbageList so (1) will be freed and the ref-count of
+ * (2) will be decremented to 1.
+ *
+ * As we do not know when it is safe to remove an object from the GarbageList
+ * we assume that there are max. GarbageMaxCount IPath elements created until
+ * the execution of the expression is performed and a reference to the resulting
+ * object is assigned to a variable so all temps can be safely deleted.
+ *
+ * Worst-case scenarios are recursive calls or calls with large call stacks with
+ * functions that return an IPath. Also keep in mind that multiple threads might
+ * be executing such functions at the same time.
+ * A reasonable count might be a max. of 20.000 elements. With an average length
+ * of 40 UTF8 chars (maybe 60 byte with class info, pointer etc.) per IPath
+ * this will consume ~1.2MB.
+ *}
+{$IFDEF FPC}
+{$IF FPC_VERSION_INT <= 002002004} // <= 2.2.4
+ {$DEFINE HAVE_REFCNTBUG}
+{$IFEND}
+{$ENDIF}
+
+{$IFDEF HAVE_REFCNTBUG}
+const
+ // when GarbageList.Count reaches GarbageMaxCount the oldest references in
+ // GarbageList will be deleted until GarbageList.Count equals GarbageAfterCleanCount.
+ GarbageMaxCount = 20000;
+ GarbageAfterCleanCount = GarbageMaxCount-1000;
+
+var
+ GarbageList: IInterfaceList;
+{$ENDIF}
+
+type
+ TPathImpl = class(TInterfacedObject, IPath)
+ private
+ fName: UTF8String; //<** internal filename string, always UTF8 with PathDelim
+
+ {**
+ * Unifies the filename. Path-delimiters are replaced by '/'.
+ *}
+ procedure Unify(DelimOption: TPathDelimOption);
+
+ {**
+ * Returns a copy of fName with path delimiters changed to '/'.
+ *}
+ function GetPortableString(): UTF8String;
+
+ procedure AssertRefCount; {$IFDEF HasInline}inline;{$ENDIF}
+
+ public
+ constructor Create(const Name: UTF8String; DelimOption: TPathDelimOption);
+ destructor Destroy(); override;
+
+ function ToUTF8(UseNativeDelim: boolean): UTF8String;
+ function ToWide(UseNativeDelim: boolean): WideString;
+ function ToNative(): RawByteString;
+
+ function Open(Mode: longword): TFileHandle;
+
+ function GetDrive(): IPath;
+ function GetPath(): IPath;
+ function GetDir(): IPath;
+ function GetName(): IPath;
+ function GetExtension(): IPath;
+
+ function SetExtension(const Extension: IPath): IPath; overload;
+ function SetExtension(const Extension: RawByteString): IPath; overload;
+ function SetExtension(const Extension: WideString): IPath; overload;
+
+ function GetRelativePath(const BaseName: IPath): IPath;
+ function GetAbsolutePath(): IPath;
+ function GetParent(): IPath;
+ function SplitDirs(): IPathDynArray;
+
+ function Append(const Child: IPath; DelimOption: TPathDelimOption): IPath; overload;
+ function Append(const Child: RawByteString; DelimOption: TPathDelimOption): IPath; overload;
+ function Append(const Child: WideString; DelimOption: TPathDelimOption): IPath; overload;
+
+ function Equals(const Other: IPath; IgnoreCase: boolean): boolean; overload;
+ function Equals(const Other: RawByteString; IgnoreCase: boolean): boolean; overload;
+ function Equals(const Other: WideString; IgnoreCase: boolean): boolean; overload;
+
+ function IsChildOf(const Parent: IPath; Direct: boolean): boolean;
+
+ function AdjustCase(AdjustAllLevels: boolean): IPath;
+
+ function AppendPathDelim(): IPath;
+ function RemovePathDelim(): IPath;
+
+ function GetFileAge(): integer; overload;
+ function GetFileAge(out FileDateTime: TDateTime): boolean; overload;
+ function Exists(): boolean;
+ function IsFile(): boolean;
+ function IsDirectory(): boolean;
+ function IsAbsolute(): boolean;
+ function GetAttr(): cardinal;
+ function SetAttr(Attr: Integer): boolean;
+ function IsReadOnly(): boolean;
+ function SetReadOnly(ReadOnly: boolean): boolean;
+
+ function IsUnset(): boolean;
+ function IsSet(): boolean;
+
+ function FileSearch(const DirList: IPath): IPath;
+
+ function CreateFile(): TFileHandle;
+ function DeleteFile(): boolean;
+ function CreateDirectory(Force: boolean): boolean;
+ function DeleteEmptyDir(): boolean;
+ function Rename(const NewName: IPath): boolean;
+ function CopyFile(const Target: IPath; FailIfExists: boolean): boolean;
+
+ function GetIntern(): UTF8String;
+ end;
+
+function Path(const PathName: RawByteString; DelimOption: TPathDelimOption): IPath;
+begin
+ if (IsUTF8String(PathName)) then
+ Result := TPathImpl.Create(PathName, DelimOption)
+ else if (IsNativeUTF8()) then
+ Result := PATH_NONE
+ else
+ Result := TPathImpl.Create(AnsiToUtf8(PathName), DelimOption);
+end;
+
+function Path(PathName: PChar; DelimOption: TPathDelimOption): IPath;
+begin
+ Result := Path(RawByteString(PathName));
+end;
+
+function Path(const PathName: WideString; DelimOption: TPathDelimOption): IPath;
+begin
+ Result := TPathImpl.Create(UTF8Encode(PathName), DelimOption);
+end;
+
+
+
+procedure TPathImpl.AssertRefCount;
+begin
+ {$IFDEF HAVE_REFCNTBUG}
+ if (FRefCount <= 0) then
+ raise Exception.Create('RefCount error: ' + IntToStr(FRefCount));
+ {$ENDIF}
+end;
+
+constructor TPathImpl.Create(const Name: UTF8String; DelimOption: TPathDelimOption);
+begin
+ inherited Create();
+ fName := Name;
+ Unify(DelimOption);
+ {$IFDEF HAVE_REFCNTBUG}
+ GarbageList.Lock;
+ if (GarbageList.Count >= GarbageMaxCount) then
+ begin
+ while (GarbageList.Count > GarbageAfterCleanCount) do
+ GarbageList.Delete(0);
+ end;
+ GarbageList.Add(Self);
+ GarbageList.Unlock;
+ {$ENDIF}
+end;
+
+destructor TPathImpl.Destroy();
+begin
+ inherited;
+end;
+
+procedure TPathImpl.Unify(DelimOption: TPathDelimOption);
+var
+ I: integer;
+begin
+ // convert all path delimiters to native ones
+ for I := 1 to Length(fName) do
+ begin
+ if (fName[I] in ['\', '/']) and (fName[I] <> PathDelim) then
+ fName[I] := PathDelim;
+ end;
+
+ // Include/ExcludeTrailingPathDelimiter need PathDelim as path delimiter
+ case DelimOption of
+ pdAppend: fName := IncludeTrailingPathDelimiter(fName);
+ pdRemove: fName := ExcludeTrailingPathDelimiter(fName);
+ end;
+end;
+
+function TPathImpl.GetPortableString(): UTF8String;
+var
+ I: integer;
+begin
+ Result := fName;
+ if (PathDelim = '/') then
+ Exit;
+
+ for I := 1 to Length(Result) do
+ begin
+ if (Result[I] = PathDelim) then
+ Result[I] := '/';
+ end;
+end;
+
+function TPathImpl.ToUTF8(UseNativeDelim: boolean): UTF8String;
+begin
+ AssertRefCount;
+
+ if (UseNativeDelim) then
+ Result := fName
+ else
+ Result := GetPortableString();
+end;
+
+function TPathImpl.ToWide(UseNativeDelim: boolean): WideString;
+begin
+ if (UseNativeDelim) then
+ Result := UTF8Decode(fName)
+ else
+ Result := UTF8Decode(GetPortableString());
+end;
+
+function TPathImpl.ToNative(): RawByteString;
+begin
+ if (IsNativeUTF8()) then
+ Result := fName
+ else
+ Result := Utf8ToAnsi(fName);
+end;
+
+function TPathImpl.GetDrive(): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.ExtractFileDrive(Self);
+end;
+
+function TPathImpl.GetPath(): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.ExtractFilePath(Self);
+end;
+
+function TPathImpl.GetDir(): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.ExtractFileDir(Self);
+end;
+
+function TPathImpl.GetName(): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.ExtractFileName(Self);
+end;
+
+function TPathImpl.GetExtension(): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.ExtractFileExt(Self);
+end;
+
+function TPathImpl.SetExtension(const Extension: IPath): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.ChangeFileExt(Self, Extension);
+end;
+
+function TPathImpl.SetExtension(const Extension: RawByteString): IPath;
+begin
+ Result := SetExtension(Path(Extension));
+end;
+
+function TPathImpl.SetExtension(const Extension: WideString): IPath;
+begin
+ Result := SetExtension(Path(Extension));
+end;
+
+function TPathImpl.GetRelativePath(const BaseName: IPath): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.ExtractRelativePath(BaseName, Self);
+end;
+
+function TPathImpl.GetAbsolutePath(): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.ExpandFileName(Self);
+end;
+
+function TPathImpl.GetParent(): IPath;
+var
+ CurPath, ParentPath: IPath;
+begin
+ AssertRefCount;
+
+ Result := PATH_NONE;
+
+ CurPath := Self.RemovePathDelim();
+ // check if current path has a parent (no further '/')
+ if (Pos(PathDelim, CurPath.ToUTF8()) = 0) then
+ Exit;
+
+ // set new path and check if it has changed to avoid endless loops
+ // e.g. with invalid paths like '/C:' (GetPath() uses ':' as delimiter too)
+ // on delphi/win32
+ ParentPath := CurPath.GetPath();
+ if (ParentPath.ToUTF8 = CurPath.ToUTF8) then
+ Exit;
+
+ Result := ParentPath;
+end;
+
+function TPathImpl.SplitDirs(): IPathDynArray;
+var
+ CurPath: IPath;
+ Components: array of IPath;
+ CurPathStr: UTF8String;
+ DelimPos: integer;
+ I: integer;
+begin
+ SetLength(Result, 0);
+
+ if (Length(Self.ToUTF8(true)) = 0) then
+ Exit;
+
+ CurPath := Self;
+ SetLength(Components, 0);
+ repeat
+ SetLength(Components, Length(Components)+1);
+
+ CurPathStr := CurPath.ToUTF8();
+ DelimPos := LastDelimiter(PathDelim, SysUtils.ExcludeTrailingPathDelimiter(CurPathStr));
+ Components[High(Components)] := Path(Copy(CurPathStr, DelimPos+1, Length(CurPathStr)));
+
+ CurPath := CurPath.GetParent();
+ until (CurPath = PATH_NONE);
+
+ // reverse list
+ SetLength(Result, Length(Components));
+ for I := 0 to High(Components) do
+ Result[I] := Components[High(Components)-I];
+end;
+
+function TPathImpl.Append(const Child: IPath; DelimOption: TPathDelimOption): IPath;
+var
+ TmpResult: IPath;
+begin
+ AssertRefCount;
+
+ if (fName = '') then
+ TmpResult := Child
+ else
+ TmpResult := Path(Self.AppendPathDelim().ToUTF8() + Child.ToUTF8());
+
+ case DelimOption of
+ pdKeep: Result := TmpResult;
+ pdAppend: Result := TmpResult.AppendPathDelim;
+ pdRemove: Result := TmpResult.RemovePathDelim;
+ end;
+end;
+
+function TPathImpl.Append(const Child: RawByteString; DelimOption: TPathDelimOption): IPath;
+begin
+ AssertRefCount;
+ Result := Append(Path(Child), DelimOption);
+end;
+
+function TPathImpl.Append(const Child: WideString; DelimOption: TPathDelimOption): IPath;
+begin
+ AssertRefCount;
+ Result := Append(Path(Child), DelimOption);
+end;
+
+function TPathImpl.Equals(const Other: IPath; IgnoreCase: boolean): boolean;
+var
+ SelfPath, OtherPath: UTF8String;
+begin
+ SelfPath := Self.GetAbsolutePath().RemovePathDelim().ToUTF8();
+ OtherPath := Other.GetAbsolutePath().RemovePathDelim().ToUTF8();
+ if (FileSystem.IsCaseSensitive() and not IgnoreCase) then
+ Result := (CompareStr(SelfPath, OtherPath) = 0)
+ else
+ Result := (CompareText(SelfPath, OtherPath) = 0);
+end;
+
+function TPathImpl.Equals(const Other: RawByteString; IgnoreCase: boolean): boolean;
+begin
+ Result := Equals(Path(Other), IgnoreCase);
+end;
+
+function TPathImpl.Equals(const Other: WideString; IgnoreCase: boolean): boolean;
+begin
+ Result := Equals(Path(Other), IgnoreCase);
+end;
+
+function TPathImpl.IsChildOf(const Parent: IPath; Direct: boolean): boolean;
+var
+ SelfPath, ParentPath: UTF8String;
+begin
+ Result := false;
+
+ if (Direct) then
+ begin
+ SelfPath := Self.GetParent().GetAbsolutePath().AppendPathDelim().ToUTF8();
+ ParentPath := Parent.GetAbsolutePath().AppendPathDelim().ToUTF8();
+
+ // simply check if this paths parent path (SelfPath) equals ParentPath
+ Result := (SelfPath = ParentPath);
+ end
+ else
+ begin
+ SelfPath := Self.GetAbsolutePath().AppendPathDelim().ToUTF8();
+ ParentPath := Parent.GetAbsolutePath().AppendPathDelim().ToUTF8();
+
+ if (Length(SelfPath) <= Length(ParentPath)) then
+ Exit;
+
+ // check if ParentPath is a substring of SelfPath
+ if (FileSystem.IsCaseSensitive()) then
+ Result := (StrLComp(PAnsiChar(SelfPath), PAnsiChar(ParentPath), Length(ParentPath)) = 0)
+ else
+ Result := (StrLIComp(PAnsiChar(SelfPath), PAnsiChar(ParentPath), Length(ParentPath)) = 0)
+ end;
+end;
+
+function AdjustCaseRecursive(CurPath: IPath; AdjustAllLevels: boolean): IPath;
+var
+ OldParent, AdjustedParent: IPath;
+ LocalName: IPath;
+ PathFound: IPath;
+ PathWithAdjParent: IPath;
+ SearchInfo: TFileInfo;
+ FileIter: IFileIterator;
+ Pattern: IPath;
+begin
+ // if case-sensitive path exists there is no need to adjust case
+ if (CurPath.Exists()) then
+ begin
+ Result := CurPath;
+ Exit;
+ end;
+
+ LocalName := CurPath.RemovePathDelim().GetName();
+
+ // try to adjust parent
+ OldParent := CurPath.GetParent();
+ if (OldParent <> PATH_NONE) then
+ begin
+ if (not AdjustAllLevels) then
+ begin
+ AdjustedParent := OldParent;
+ end
+ else
+ begin
+ AdjustedParent := AdjustCaseRecursive(OldParent, AdjustAllLevels);
+ if (AdjustedParent = nil) then
+ begin
+ // parent path was not found case-insensitive
+ Result := nil;
+ Exit;
+ end;
+
+ // check if the path with adjusted parent can be found now
+ PathWithAdjParent := AdjustedParent.Append(LocalName);
+ if (PathWithAdjParent.Exists()) then
+ begin
+ Result := PathWithAdjParent;
+ Exit;
+ end;
+ end;
+ Pattern := AdjustedParent.Append(Path('*'));
+ end
+ else // path has no parent
+ begin
+ // the top path can either be absolute or relative
+ if (CurPath.IsAbsolute) then
+ begin
+ // the only absolute directory at Unix without a parent is root ('/')
+ // and hence does not need to be adjusted
+ Result := CurPath;
+ Exit;
+ end;
+ // this is a relative path, search in the current working dir
+ AdjustedParent := nil;
+ Pattern := Path('*');
+ end;
+
+ // compare name with all files in the current directory case-insensitive
+ FileIter := FileSystem.FileFind(Pattern, faAnyFile);
+ while (FileIter.HasNext()) do
+ begin
+ SearchInfo := FileIter.Next();
+ PathFound := SearchInfo.Name;
+ if (CompareText(LocalName.ToUTF8, PathFound.ToUTF8) = 0) then
+ begin
+ if (AdjustedParent <> nil) then
+ Result := AdjustedParent.Append(PathFound)
+ else
+ Result := PathFound;
+ Exit;
+ end;
+ end;
+
+ // no matching file found
+ Result := nil;
+end;
+
+function TPathImpl.AdjustCase(AdjustAllLevels: boolean): IPath;
+begin
+ AssertRefCount;
+
+ Result := Self;
+
+ if (FileSystem.IsCaseSensitive) then
+ begin
+ Result := AdjustCaseRecursive(Self, AdjustAllLevels);
+ if (Result = nil) then
+ Result := Self;
+ end;
+end;
+
+function TPathImpl.AppendPathDelim(): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.IncludeTrailingPathDelimiter(Self);
+end;
+
+function TPathImpl.RemovePathDelim(): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.ExcludeTrailingPathDelimiter(Self);
+end;
+
+function TPathImpl.CreateFile(): TFileHandle;
+begin
+ Result := FileSystem.FileCreate(Self);
+end;
+
+function TPathImpl.CreateDirectory(Force: boolean): boolean;
+begin
+ if (Force) then
+ Result := FileSystem.ForceDirectories(Self)
+ else
+ Result := FileSystem.DirectoryCreate(Self);
+end;
+
+function TPathImpl.Open(Mode: longword): TFileHandle;
+begin
+ Result := FileSystem.FileOpen(Self, Mode);
+end;
+
+function TPathImpl.GetFileAge(): integer;
+begin
+ Result := FileSystem.FileAge(Self);
+end;
+
+function TPathImpl.GetFileAge(out FileDateTime: TDateTime): boolean;
+begin
+ Result := FileSystem.FileAge(Self, FileDateTime);
+end;
+
+function TPathImpl.Exists(): boolean;
+begin
+ // note the different specifications of FileExists() on Win32 <> Unix
+ {$IFDEF MSWINDOWS}
+ Result := IsFile() or IsDirectory();
+ {$ELSE}
+ Result := FileSystem.FileExists(Self);
+ {$ENDIF}
+end;
+
+function TPathImpl.IsFile(): boolean;
+begin
+ // note the different specifications of FileExists() on Win32 <> Unix
+ {$IFDEF MSWINDOWS}
+ Result := FileSystem.FileExists(Self);
+ {$ELSE}
+ Result := Exists() and not IsDirectory();
+ {$ENDIF}
+end;
+
+function TPathImpl.IsDirectory(): boolean;
+begin
+ Result := FileSystem.DirectoryExists(Self);
+end;
+
+function TPathImpl.IsAbsolute(): boolean;
+begin
+ AssertRefCount;
+ Result := FileSystem.FileIsAbsolute(Self);
+end;
+
+function TPathImpl.GetAttr(): cardinal;
+begin
+ Result := FileSystem.FileGetAttr(Self);
+end;
+
+function TPathImpl.SetAttr(Attr: Integer): boolean;
+begin
+ Result := FileSystem.FileSetAttr(Self, Attr);
+end;
+
+function TPathImpl.IsReadOnly(): boolean;
+begin
+ Result := FileSystem.FileIsReadOnly(Self);
+end;
+
+function TPathImpl.SetReadOnly(ReadOnly: boolean): boolean;
+begin
+ Result := FileSystem.FileSetReadOnly(Self, ReadOnly);
+end;
+
+function TPathImpl.IsUnset(): boolean;
+begin
+ Result := (fName = '');
+end;
+
+function TPathImpl.IsSet(): boolean;
+begin
+ Result := (fName <> '');
+end;
+
+function TPathImpl.FileSearch(const DirList: IPath): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.FileSearch(Self, DirList);
+end;
+
+function TPathImpl.Rename(const NewName: IPath): boolean;
+begin
+ Result := FileSystem.RenameFile(Self, NewName);
+end;
+
+function TPathImpl.DeleteFile(): boolean;
+begin
+ Result := FileSystem.DeleteFile(Self);
+end;
+
+function TPathImpl.DeleteEmptyDir(): boolean;
+begin
+ Result := FileSystem.RemoveDir(Self);
+end;
+
+function TPathImpl.CopyFile(const Target: IPath; FailIfExists: boolean): boolean;
+begin
+ Result := FileSystem.CopyFile(Self, Target, FailIfExists);
+end;
+
+function TPathImpl.GetIntern(): UTF8String;
+begin
+ Result := fName;
+end;
+
+
+{ TBinaryFileStream }
+
+constructor TBinaryFileStream.Create(const FileName: IPath; Mode: word);
+begin
+{$IFDEF MSWINDOWS}
+ inherited Create(FileName.ToWide(), Mode);
+{$ELSE}
+ inherited Create(FileName.ToNative(), Mode);
+{$ENDIF}
+end;
+
+{ TTextStream }
+
+constructor TTextFileStream.Create(Filename: IPath; Mode: word);
+begin
+ inherited Create();
+ fMode := Mode;
+ fFilename := Filename;
+ fLineBreak := sLineBreak;
+end;
+
+function TTextFileStream.ReadLine(var Line: UTF8String): boolean;
+begin
+ Line := ReadLine(Result);
+end;
+
+function TTextFileStream.ReadLine(var Line: AnsiString): boolean;
+begin
+ Line := ReadLine(Result);
+end;
+
+procedure TTextFileStream.WriteString(const Str: RawByteString);
+begin
+ WriteBuffer(Str[1], Length(Str));
+end;
+
+procedure TTextFileStream.WriteLine(const Line: RawByteString);
+begin
+ WriteBuffer(Line[1], Length(Line));
+ WriteBuffer(fLineBreak[1], Length(fLineBreak));
+end;
+
+{ TMemTextStream }
+
+constructor TMemTextFileStream.Create(Filename: IPath; Mode: word);
+var
+ FileStream: TBinaryFileStream;
+begin
+ inherited Create(Filename, Mode);
+
+ fStream := TMemoryStream.Create();
+
+ // load data to memory in read mode
+ if ((Mode and 3) in [fmOpenRead, fmOpenReadWrite]) then
+ begin
+ FileStream := TBinaryFileStream.Create(Filename, fmOpenRead);
+ try
+ fStream.LoadFromStream(FileStream);
+ finally
+ FileStream.Free;
+ end;
+ end
+ // check if file exists for write-mode
+ else if ((Mode and 3) = fmOpenWrite) and (not Filename.IsFile) then
+ begin
+ raise EFOpenError.CreateResFmt(@SFOpenError,
+ [FileName.GetAbsolutePath.ToNative]);
+ end;
+end;
+
+destructor TMemTextFileStream.Destroy();
+var
+ FileStream: TBinaryFileStream;
+ SaveMode: word;
+begin
+ // save changes in write mode (= not read-only mode)
+ if ((fMode and 3) <> fmOpenRead) then
+ begin
+ if (fMode = fmCreate) then
+ SaveMode := fmCreate
+ else
+ SaveMode := fmOpenWrite;
+ FileStream := TBinaryFileStream.Create(fFilename, SaveMode);
+ try
+ fStream.SaveToStream(FileStream);
+ finally
+ FileStream.Free;
+ end;
+ end;
+
+ fStream.Free;
+ inherited;
+end;
+
+function TMemTextFileStream.GetSize: int64;
+begin
+ Result := fStream.Size;
+end;
+
+function TMemTextFileStream.Read(var Buffer; Count: longint): longint;
+begin
+ Result := fStream.Read(Buffer, Count);
+end;
+
+function TMemTextFileStream.Write(const Buffer; Count: longint): longint;
+begin
+ Result := fStream.Write(Buffer, Count);
+end;
+
+function TMemTextFileStream.Seek(Offset: longint; Origin: word): longint;
+begin
+ Result := fStream.Seek(Offset, Origin);
+end;
+
+function TMemTextFileStream.Seek(const Offset: int64; Origin: TSeekOrigin): int64;
+begin
+ Result := fStream.Seek(Offset, Origin);
+end;
+
+function TMemTextFileStream.CopyMemString(StartPos: int64; EndPos: int64): RawByteString;
+var
+ LineLength: cardinal;
+ Temp: RawByteString;
+begin
+ LineLength := EndPos - StartPos;
+ if (LineLength > 0) then
+ begin
+ // set string length to line-length (+ zero-terminator)
+ SetLength(Temp, LineLength);
+ StrLCopy(PAnsiChar(Temp),
+ @PAnsiChar(fStream.Memory)[StartPos],
+ LineLength);
+ Result := Temp;
+ end
+ else
+ begin
+ Result := '';
+ end;
+end;
+
+function TMemTextFileStream.ReadString(): RawByteString;
+var
+ TextPtr: PAnsiChar;
+ CurPos, StartPos, FileSize: int64;
+begin
+ TextPtr := PAnsiChar(fStream.Memory);
+ CurPos := Position;
+ FileSize := Size;
+ StartPos := -1;
+
+ while (CurPos < FileSize) do
+ begin
+ // check for whitespace (tab, lf, cr, space)
+ if (TextPtr[CurPos] in [#9, #10, #13, ' ']) then
+ begin
+ // check if we are at the end of a string
+ if (StartPos > -1) then
+ Break;
+ end
+ else if (StartPos = -1) then // start of string found
+ begin
+ StartPos := CurPos;
+ end;
+ Inc(CurPos);
+ end;
+
+ if (StartPos = -1) then
+ Result := ''
+ else
+ begin
+ Result := CopyMemString(StartPos, CurPos);
+ fStream.Position := CurPos;
+ end;
+end;
+
+{*
+ * Implementation of ReadLine(). We need separate versions for UTF8String
+ * and AnsiString as "var" parameter types have to fit exactly.
+ * To avoid a var-parameter here, the internal version the Line parameter is
+ * used as return value.
+ *}
+function TMemTextFileStream.ReadLine(var Success: boolean): RawByteString;
+var
+ TextPtr: PAnsiChar;
+ CurPos, FileSize: int64;
+begin
+ TextPtr := PAnsiChar(fStream.Memory);
+ CurPos := fStream.Position;
+ FileSize := Size;
+
+ // check for EOF
+ if (CurPos >= FileSize) then
+ begin
+ Result := '';
+ Success := false;
+ Exit;
+ end;
+
+ Success := true;
+
+ while (CurPos < FileSize) do
+ begin
+ if (TextPtr[CurPos] in [#10, #13]) then
+ begin
+ // copy text line
+ Result := CopyMemString(fStream.Position, CurPos);
+
+ // handle windows style #13#10 (\r\n) newlines
+ if (TextPtr[CurPos] = #13) and
+ (CurPos+1 < FileSize) and
+ (TextPtr[CurPos+1] = #10) then
+ begin
+ Inc(CurPos);
+ end;
+
+ // update stream pos
+ fStream.Position := CurPos+1;
+
+ Exit;
+ end;
+ Inc(CurPos);
+ end;
+
+ Result := CopyMemString(fStream.Position, CurPos);
+ fStream.Position := FileSize;
+end;
+
+{ TUnicodeMemoryStream }
+
+procedure TUnicodeMemoryStream.LoadFromFile(const FileName: IPath);
+var
+ Stream: TStream;
+begin
+ Stream := TBinaryFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
+ try
+ LoadFromStream(Stream);
+ finally
+ Stream.Free;
+ end;
+end;
+
+procedure TUnicodeMemoryStream.SaveToFile(const FileName: IPath);
+var
+ Stream: TStream;
+begin
+ Stream := TBinaryFileStream.Create(FileName, fmCreate);
+ try
+ SaveToStream(Stream);
+ finally
+ Stream.Free;
+ end;
+end;
+
+{ TUnicodeMemIniFile }
+
+constructor TUnicodeMemIniFile.Create(const FileName: IPath; UTF8Encoded: boolean);
+var
+ List: TStringList;
+ Stream: TBinaryFileStream;
+ BOMBuf: array[0..2] of AnsiChar;
+begin
+ inherited Create('');
+ FFilename := FileName;
+ FUTF8Encoded := UTF8Encoded;
+
+ if FileName.Exists() then
+ begin
+ List := nil;
+ Stream := nil;
+ try
+ List := TStringList.Create;
+ Stream := TBinaryFileStream.Create(FileName, fmOpenRead);
+ if (Stream.Read(BOMBuf[0], SizeOf(BOMBuf)) = 3) and
+ (CompareMem(PChar(UTF8_BOM), @BomBuf, Length(UTF8_BOM))) then
+ begin
+ // truncate BOM
+ FUTF8Encoded := true;
+ end
+ else
+ begin
+ // rewind file
+ Stream.Seek(0, soBeginning);
+ end;
+ List.LoadFromStream(Stream);
+ SetStrings(List);
+ finally
+ Stream.Free;
+ List.Free;
+ end;
+ end;
+end;
+
+procedure TUnicodeMemIniFile.UpdateFile;
+var
+ List: TStringList;
+ Stream: TBinaryFileStream;
+begin
+ List := nil;
+ Stream := nil;
+ try
+ List := TStringList.Create;
+ GetStrings(List);
+ Stream := TBinaryFileStream.Create(FFileName, fmCreate);
+ if UTF8Encoded then
+ Stream.Write(UTF8_BOM, Length(UTF8_BOM));
+ List.SaveToStream(Stream);
+ finally
+ List.Free;
+ Stream.Free;
+ end;
+end;
+
+
+var
+ PATH_NONE_Singelton: IPath;
+
+function PATH_NONE(): IPath;
+begin
+ Result := PATH_NONE_Singelton;
+end;
+
+initialization
+ {$IFDEF HAVE_REFCNTBUG}
+ GarbageList := TInterfaceList.Create();
+ GarbageList.Capacity := GarbageMaxCount;
+ {$ENDIF}
+ PATH_NONE_Singelton := Path('');
+
+finalization
+ PATH_NONE_Singelton := nil;
+
+end.
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 04:32:43 +0000